theory "Uniform_Renaming"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Ids"
  "Lib"
  "Syntax"
  "Denotational_Semantics"
  "Frechet_Correctness"
  "Static_Semantics"
  "Coincidence"
  "Bound_Effect"
begin context ids begin

section \<open>Uniform and Bound Renaming\<close>
text \<open>Definitions and soundness proofs for the renaming rules Uniform Renaming and Bound Renaming.
Renaming in dL swaps the names of two variables x and y, as in the swap operator of Nominal Logic.
\<close>
fun swap ::"'sz \<Rightarrow> 'sz \<Rightarrow> 'sz \<Rightarrow> 'sz"
where "swap x y z = (if z = x then  y else if z = y then x else z)"

subsection \<open>Uniform Renaming Definitions\<close>

primrec TUrename :: "'sz \<Rightarrow> 'sz \<Rightarrow> ('sf, 'sz) trm \<Rightarrow> ('sf, 'sz) trm"
where
  "TUrename x y (Var z) = Var (swap x y z)"
| "TUrename x y (DiffVar z) = DiffVar (swap x y z)"
| "TUrename x y (Const r) = (Const r)"
| "TUrename x y (Function f args) = Function f (\<lambda>i. TUrename x y (args i))"
| "TUrename x y (Plus \<theta>1 \<theta>2) = Plus (TUrename x y \<theta>1) (TUrename x y \<theta>2)"
| "TUrename x y (Times \<theta>1 \<theta>2) = Times (TUrename x y \<theta>1) (TUrename x y \<theta>2)"
| "TUrename x y (Differential \<theta>) = Differential (TUrename x y \<theta>)"

primrec OUrename :: "'sz \<Rightarrow> 'sz \<Rightarrow> ('sf, 'sz) ODE \<Rightarrow> ('sf, 'sz) ODE"
where
  "OUrename x y (OVar c) = undefined"
| "OUrename x y (OSing z \<theta>) = OSing (swap x y z) (TUrename x y \<theta>)"
| "OUrename x y (OProd ODE1 ODE2) = OProd (OUrename x y ODE1) (OUrename x y ODE2)"

inductive ORadmit :: "('sf, 'sz) ODE \<Rightarrow> bool"
where
  ORadmit_Sing:"ORadmit (OSing x \<theta>)"
| ORadmit_Prod:"ORadmit ODE1 \<Longrightarrow> ORadmit ODE2 \<Longrightarrow> ORadmit (OProd ODE1 ODE2)"

primrec PUrename :: "'sz \<Rightarrow> 'sz \<Rightarrow> ('sf, 'sc, 'sz) hp \<Rightarrow> ('sf, 'sc, 'sz) hp"
  and   FUrename :: "'sz \<Rightarrow> 'sz \<Rightarrow> ('sf, 'sc, 'sz) formula \<Rightarrow> ('sf, 'sc, 'sz) formula"
where
  "PUrename x y (Pvar a) = undefined"
| "PUrename x y (Assign z \<theta>) = Assign (swap x y z) (TUrename x y \<theta>)"
| "PUrename x y (DiffAssign z \<theta>) = DiffAssign (swap x y z) (TUrename x y \<theta>)"
| "PUrename x y (Test \<phi>) = Test (FUrename x y \<phi>)"
| "PUrename x y (EvolveODE ODE \<phi>) = EvolveODE (OUrename x y ODE) (FUrename x y \<phi>)"
| "PUrename x y (Choice a b) = Choice (PUrename x y a) (PUrename x y b)"
| "PUrename x y (Sequence a b) = Sequence (PUrename x y a) (PUrename x y b)"
| "PUrename x y (Loop a) = Loop (PUrename x y a)"

| "FUrename x y (Geq \<theta>1 \<theta>2) = Geq (TUrename x y \<theta>1) (TUrename x y \<theta>2)"
| "FUrename x y (Prop p args) = Prop p (\<lambda>i. TUrename x y (args i))"
| "FUrename x y (Not \<phi>) = Not (FUrename x y \<phi>)"
| "FUrename x y (And \<phi> \<psi>) = And (FUrename x y \<phi>) (FUrename x y \<psi>)"
| "FUrename x y (Exists z \<phi>) = Exists (swap x y z) (FUrename x y \<phi>)"
| "FUrename x y (Diamond \<alpha> \<phi>) = Diamond (PUrename x y \<alpha>) (FUrename x y \<phi>)"
| "FUrename x y (InContext C \<phi>) = undefined"

subsection \<open>Uniform Renaming Admissibility\<close>

inductive PRadmit :: "('sf, 'sc, 'sz) hp \<Rightarrow> bool"
  and     FRadmit ::"('sf, 'sc, 'sz) formula \<Rightarrow> bool"
where
  PRadmit_Assign:"PRadmit (Assign x \<theta>)"
| PRadmit_DiffAssign:"PRadmit (DiffAssign x \<theta>)"
| PRadmit_Test:"FRadmit \<phi> \<Longrightarrow> PRadmit (Test \<phi>)"
| PRadmit_EvolveODE:"ORadmit ODE \<Longrightarrow> FRadmit \<phi> \<Longrightarrow> PRadmit (EvolveODE ODE \<phi>)"
| PRadmit_Choice:"PRadmit a \<Longrightarrow> PRadmit b \<Longrightarrow> PRadmit (Choice a b)"
| PRadmit_Sequence:"PRadmit a \<Longrightarrow> PRadmit b \<Longrightarrow> PRadmit (Sequence a b)"
| PRadmit_Loop:"PRadmit a \<Longrightarrow> PRadmit (Loop a)"

| FRadmit_Geq:"FRadmit (Geq \<theta>1 \<theta>2)"
| FRadmit_Prop:"FRadmit (Prop p args)"
| FRadmit_Not:"FRadmit \<phi> \<Longrightarrow> FRadmit (Not \<phi>)"
| FRadmit_And:"FRadmit \<phi> \<Longrightarrow> FRadmit \<psi> \<Longrightarrow> FRadmit (And \<phi> \<psi>)"
| FRadmit_Exists:"FRadmit \<phi> \<Longrightarrow> FRadmit (Exists x \<phi>)"
| FRadmit_Diamond:"PRadmit \<alpha> \<Longrightarrow> FRadmit \<phi> \<Longrightarrow> FRadmit (Diamond \<alpha> \<phi>)"

inductive_simps
    FRadmit_box_simps[simp]: "FRadmit (Box a f)"
and PRadmit_box_simps[simp]: "PRadmit (Assign x e)"

definition RSadj :: "'sz \<Rightarrow> 'sz \<Rightarrow> 'sz simple_state \<Rightarrow> 'sz simple_state"
where "RSadj x y \<nu> = (\<chi> z. \<nu> $ (swap x y z))"

definition Radj :: "'sz \<Rightarrow> 'sz \<Rightarrow> 'sz state \<Rightarrow> 'sz state"
where "Radj x y \<nu> = (RSadj x y (fst \<nu>), RSadj x y (snd \<nu>))"

lemma SUren: "sterm_sem I (TUrename x y \<theta>) \<nu> = sterm_sem I \<theta> (RSadj x y \<nu>)"
  by (induction \<theta>, auto simp add: RSadj_def)

lemma ren_preserves_dfree:"dfree \<theta> \<Longrightarrow> dfree (TUrename x y \<theta>)"
  by(induction rule: dfree.induct, auto intro: dfree.intros)

subsection \<open>Uniform Renaming Soundness Proof and Lemmas\<close>

lemma TUren_frechet:
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> frechet I (TUrename x y \<theta>) \<nu> \<nu>' = frechet I \<theta> (RSadj x y \<nu>) (RSadj x y \<nu>')"
proof (induction rule: dfree.induct)
  \<comment> \<open>There's got to be a more elegant proof of this...\<close>
  case (dfree_Var i)
  then show ?case
    unfolding RSadj_def apply auto
       subgoal by (metis vec_lambda_eta)
      subgoal
      proof (auto simp add: axis_def)
        assume yx:"y \<noteq> x"
        have a:"(\<chi> z. \<nu>' $ (if z = x then y else if z = y then x else z)) $ y = \<nu>' $ x"
         by simp
       show "\<nu>' \<bullet> (\<chi> i. if i = x then 1 else 0)
                 = (\<chi> z. \<nu>' $ (if z = x then y else if z = y then x else z)) \<bullet> (\<chi> i. if i = y then 1 else 0)"
         by (metis (no_types) a axis_def inner_axis)
      qed
     subgoal
     proof -
       have "\<And>v s. v \<bullet> (\<chi> sa. if sa = (s::'sz) then 1 else 0) = v $ s"
         subgoal for v s
           using inner_axis[of v s 1]
           by (auto simp add: axis_def)
         done
       then show ?thesis
         by (auto simp add: axis_def)
     qed
    subgoal
    proof -
      assume a1: "i \<noteq> y"
      assume a2: "i \<noteq> x"
      have "\<And>v s. v \<bullet> (\<chi> sa. if sa = (s::'sz) then 1 else 0) = v $ s"
        by (metis (no_types) inner_axis axis_def inner_prod_eq)
      then show ?thesis
        using a2 a1 by (auto simp add: axis_def)
    qed
    done
qed (auto simp add: SUren good_interp is_interp_def)

lemma RSadj_fst:"RSadj x y (fst \<nu>) = fst (Radj x y \<nu>)"
  unfolding RSadj_def Radj_def by auto

lemma RSadj_snd:"RSadj x y (snd \<nu>) = snd (Radj x y \<nu>)"
  unfolding RSadj_def Radj_def by auto

lemma TUren:
  assumes good_interp:"is_interp I"
  shows "dsafe \<theta> \<Longrightarrow> dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>)"
proof (induction rule: dsafe.induct)
  case (dsafe_Diff \<theta>)
  assume free:"dfree \<theta>"
  show ?case
    apply (auto simp add: directional_derivative_def)
    using TUren_frechet[OF good_interp free, of x y "fst \<nu>" "snd \<nu>"]
     by (auto simp add: RSadj_fst RSadj_snd)
qed (auto simp add: Radj_def RSadj_def)

lemma adj_sum:"RSadj x y (\<nu>1 + \<nu>2) = (RSadj x y \<nu>1) + (RSadj x y \<nu>2)"
  unfolding RSadj_def apply auto apply (rule vec_extensionality)
  subgoal for i
    apply (cases "i = x")
     apply (cases "i = y")
      by auto
  done

lemma OUren: "ORadmit ODE \<Longrightarrow> ODE_sem I (OUrename x y ODE) \<nu> = RSadj x y (ODE_sem I ODE (RSadj x y \<nu>))"
proof (induction rule: ORadmit.induct)
  case (ORadmit_Prod ODE1 ODE2)
  then show ?case
    using adj_sum by auto
next
  case (ORadmit_Sing z \<theta>)
  then show ?case
    by (rule vec_extensionality | auto simp add: SUren RSadj_def)+
qed

lemma state_eq:
  fixes \<nu> \<nu>' :: "'sz state"
  shows "(\<And>i. (fst \<nu>) $ i = (fst \<nu>') $ i) \<Longrightarrow> (\<And>i. (snd \<nu>) $ i = (snd \<nu>') $ i) \<Longrightarrow> \<nu>  = \<nu>'"
  apply (cases "\<nu>", cases "\<nu>'", auto)
   by(rule vec_extensionality, auto)+

lemma Radj_repv1:
  fixes x y z ::"'sz"
  shows "(Radj x y (repv \<nu> y r)) = repv (Radj x y \<nu>) x r"
  apply(rule state_eq)
   subgoal for i
     apply(cases "i = x") apply (cases "i = y")
       unfolding Radj_def RSadj_def by auto
  subgoal for i
    apply(cases "i = x") apply (cases "i = y")
      unfolding Radj_def RSadj_def by auto
  done

lemma Radj_repv2:
  fixes x y z ::"'sz"
  shows "(Radj x y (repv \<nu> x r)) = repv (Radj x y \<nu>) y r"
  apply(rule state_eq)
   subgoal for i
     apply(cases "i = x") apply (cases "i = y")
       unfolding Radj_def RSadj_def by auto
  subgoal for i
    apply(cases "i = x") apply (cases "i = y")
      unfolding Radj_def RSadj_def by auto
  done

lemma Radj_repv3:
  fixes x y z ::"'sz"
  assumes zx:"z \<noteq> x" and zy:"z \<noteq> y"
  shows "(Radj x y (repv \<nu> z r)) = repv (Radj x y \<nu>) z r"
  apply(rule state_eq)
   subgoal for i
     apply(cases "i = x") apply (cases "i = y")
       using zx zy unfolding Radj_def RSadj_def by auto
  subgoal for i
    apply(cases "i = x") apply (cases "i = y")
      using zx zy unfolding Radj_def RSadj_def by auto
  done

lemma Radj_repd1:
  fixes x y z ::"'sz"
  shows "(Radj x y (repd \<nu> y r)) = repd (Radj x y \<nu>) x r"
  apply(rule state_eq)
   subgoal for i
     apply(cases "i = x") apply (cases "i = y")
       unfolding Radj_def RSadj_def by auto
  subgoal for i
    apply(cases "i = x") apply (cases "i = y")
      unfolding Radj_def RSadj_def by auto
  done

lemma Radj_repd2:
  fixes x y z ::"'sz"
  shows "(Radj x y (repd \<nu> x r)) = repd (Radj x y \<nu>) y r"
  apply(rule state_eq)
   subgoal for i
     apply(cases "i = x") apply (cases "i = y")
       unfolding Radj_def RSadj_def by auto
  subgoal for i
    apply(cases "i = x") apply (cases "i = y")
      unfolding Radj_def RSadj_def by auto
  done

lemma Radj_repd3:
  fixes x y z ::"'sz"
  assumes zx:"z \<noteq> x" and zy:"z \<noteq> y"
  shows "(Radj x y (repd \<nu> z r)) = repd (Radj x y \<nu>) z r"
  apply(rule state_eq)
   subgoal for i
     apply(cases "i = x") apply (cases "i = y")
     using zx zy unfolding Radj_def RSadj_def by auto
  subgoal for i
    apply(cases "i = x") apply (cases "i = y")
    using zx zy unfolding Radj_def RSadj_def by auto
  done

\<comment> \<open>i.e. shows \<open>Radj x y\<close> is a bijection for all \<open>x y\<close>\<close>
lemma Radj_eq_iff:"(a = b) = ((Radj x y a) = (Radj x y b))"
  unfolding Radj_def RSadj_def apply auto
  apply (rule state_eq)
   apply smt+
  done

lemma RSadj_cancel:"RSadj x y (RSadj x y \<nu>) = \<nu>"
  unfolding RSadj_def apply auto
  apply(rule vec_extensionality)
  by(auto)

lemma Radj_cancel:"Radj x y (Radj x y \<nu>) = \<nu>"
  unfolding Radj_def RSadj_def apply auto
  apply(rule state_eq)
   subgoal for i by(cases "i = x", cases "i = y", auto)
  subgoal for i by(cases "i = x", cases "i = y", auto)
  done

lemma ren_proj:"(RSadj x y a) $ z = a $ (swap x y z)"
  unfolding RSadj_def by simp

lemma swap_cancel:"swap x y (swap x y z) = z"
  by auto

lemma mkv_lemma:
  assumes ORA:"ORadmit ODE"
  shows "Radj x y (mk_v I (OUrename x y ODE) (a, b) c) = mk_v I ODE (RSadj x y a, RSadj x y b) (RSadj x y c)"
proof -
  have inner1:"(mk_v I (OUrename x y ODE) (a, b) c) = ((\<chi> i. (if i \<in> ODE_vars I (OUrename x y ODE) then c else a) $ i), (\<chi> i. (if i \<in> ODE_vars I (OUrename x y ODE) then ODE_sem I (OUrename x y ODE) c else b) $ i))"
    using mk_v_concrete[of I "OUrename x y ODE" "(a,b)" c] by auto
  have inner2:"(((\<chi> i. (if i \<in> ODE_vars I (OUrename x y ODE) then c else a) $ i), (\<chi> i. (if i \<in> ODE_vars I (OUrename x y ODE) then ODE_sem I (OUrename x y ODE) c else b) $ i)))
            = (((\<chi> i. (if (swap x y i) \<in> ODE_vars I ODE then c else a) $ i), (\<chi> i. (if (swap x y i) \<in> ODE_vars I ODE then ODE_sem I (OUrename x y ODE) c else b) $ i)))"
    by (force simp: OUrename_preserves_ODE_vars[OF ORA, symmetric])
  have "Radj x y (mk_v I (OUrename x y ODE) (a, b) c) =
        Radj x y (((\<chi> i. (if i \<in> ODE_vars I (OUrename x y ODE) then c else a) $ i), (\<chi> i. (if i \<in> ODE_vars I (OUrename x y ODE) then ODE_sem I (OUrename x y ODE) c else b) $ i)))"
    using inner1 by auto
  moreover have "... = Radj x y (((\<chi> i. (if (swap x y i) \<in> ODE_vars I ODE then c else a) $ i),
                              (\<chi> i. (if (swap x y i) \<in> ODE_vars I ODE then ODE_sem I (OUrename x y ODE) c else b) $ i)))"
    using inner2 by auto
  moreover have "... = (((\<chi> i. (if (swap x y (swap x y i)) \<in> ODE_vars I ODE then c else a) $ (swap x y i))),
                         (\<chi> i. (if (swap x y (swap x y i)) \<in> ODE_vars I ODE then ODE_sem I (OUrename x y ODE) c else b) $ (swap x y i)))"
    unfolding Radj_def RSadj_def by auto
  moreover have "... = (((\<chi> i. (if i \<in> ODE_vars I ODE then c else a) $ (swap x y i))),
                         (\<chi> i. (if i \<in> ODE_vars I ODE then ODE_sem I (OUrename x y ODE) c else b) $ (swap x y i)))"
    using swap_cancel by auto
  moreover have "... = (((\<chi> i. (if i \<in> ODE_vars I ODE then RSadj x y c else RSadj x y a) $ i)),
                         (\<chi> i. (if i \<in> ODE_vars I ODE then RSadj x y (ODE_sem I (OUrename x y ODE) c) else RSadj x y b) $ i))"
     by(auto simp add: ren_proj)
  moreover have "... = (((\<chi> i. (if i \<in> ODE_vars I ODE then RSadj x y c else RSadj x y a) $ i)),
                         (\<chi> i. (if i \<in> ODE_vars I ODE then RSadj x y (RSadj x y (ODE_sem I ODE (RSadj x y c))) else RSadj x y b) $ i))"
    using OUren[OF ORA, of I x y c] by auto
  moreover have "... = (((\<chi> i. (if i \<in> ODE_vars I ODE then RSadj x y c else RSadj x y a) $ i)),
                         (\<chi> i. (if i \<in> ODE_vars I ODE then (ODE_sem I ODE (RSadj x y c)) else RSadj x y b) $ i))"
    by(auto simp add: RSadj_cancel)
  moreover have "... = mk_v I ODE (RSadj x y a, RSadj x y b) (RSadj x y c)"
    using mk_v_concrete[of I "ODE" "(RSadj x y a, RSadj x y b)" "RSadj x y c"]
    by auto
  ultimately show ?thesis by auto
qed

lemma sol_lemma:
  assumes ORA:"ORadmit ODE"
  assumes t:"0 \<le> t"
  assumes fml:"\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>)"
  assumes sol:"(sol solves_ode (\<lambda>a. ODE_sem I (OUrename x y ODE))) {0..t} {xa. mk_v I (OUrename x y ODE) (sol 0, b) xa \<in> fml_sem I (FUrename x y \<phi>)}"
  shows "((\<lambda>t. RSadj x y (sol t)) solves_ode (\<lambda>a. ODE_sem I ODE)) {0..t} {xa. mk_v I ODE (RSadj x y (sol 0), RSadj x y b) xa \<in> fml_sem I \<phi>}"
  apply(unfold solves_ode_def)
  apply(rule conjI)
   defer
   subgoal
     apply auto
   proof -
     fix s
     assume t:"0 \<le> s" "s \<le> t"
     have ivl:"s \<in> {0..t}" using t by auto
     have "mk_v I (OUrename x y ODE) (sol 0,b) (sol s) \<in> fml_sem I (FUrename x y \<phi>)"
       using solves_odeD(2)[OF sol ivl] by auto
     then have "Radj x y (mk_v I (OUrename x y ODE) (sol 0, b) (sol s)) \<in> fml_sem I \<phi>"
       using fml[of "mk_v I (OUrename x y ODE) (sol 0, b) (sol s)"] by auto
     then show "mk_v I ODE (RSadj x y (sol 0), RSadj x y b) (RSadj x y (sol s)) \<in> fml_sem I \<phi>"
         using mkv_lemma[OF ORA, of x y I "sol 0" b "sol s"] by auto
   qed
   apply (unfold has_vderiv_on_def has_vector_derivative_def)
   proof -
     have "\<And>s. s\<in>{0..t} \<Longrightarrow>  ((\<lambda>t. RSadj x y (sol t)) has_derivative (\<lambda>xb. xb *\<^sub>R ODE_sem I ODE (RSadj x y (sol s)))) (at s within {0..t})"
     proof -
       fix s
       assume s:"s \<in>{0..t}"
       let ?g = "RSadj x y"
       let ?g' = "RSadj x y"
       let ?f = "sol"
       let ?f' = "(\<lambda>t'. t' *\<^sub>R ODE_sem I (OUrename x y ODE) (sol s))"
       let ?h = "?g \<circ> ?f"

       have fun_eq:"(\<lambda>t'. t' *\<^sub>R ODE_sem I (OUrename x y ODE) (sol s)) = (\<lambda>t'. t' *\<^sub>R (RSadj x y (ODE_sem I ODE (RSadj x y (sol s)))))"
         apply(rule ext)
         using OUren[OF ORA, of I x y] by simp
       have fun_eq1:"(\<lambda>\<nu>. (\<chi> i. RSadj x y \<nu> $ i)) = RSadj x y"
         by(rule ext, rule vec_extensionality, simp)
       have "s \<in> {0..t} \<Longrightarrow> (sol has_derivative (\<lambda>t'. t' *\<^sub>R ODE_sem I (OUrename x y ODE) (sol s))) (at s within {0..t})"
         using solves_odeD(1)[OF sol] unfolding has_vderiv_on_def has_vector_derivative_def by auto
       then have fderiv:"s \<in> {0..t} \<Longrightarrow> (?f has_derivative ?f') (at s within {0..t})"
         using fun_eq by auto
       have "((\<lambda>\<nu>. (\<chi> i. RSadj x y \<nu> $ i)) has_derivative (\<lambda>\<nu>'. (\<chi> i . RSadj x y \<nu>' $ i))) (at (?f s) within ?f ` {0..t})"
         apply(rule has_derivative_vec)
         apply(auto simp add: RSadj_def intro:derivative_eq_intros)
           by (simp add: has_derivative_at_withinI has_derivative_proj')+
       then have gderiv:"(RSadj x y has_derivative (RSadj x y)) (at (?f s) within ?f ` {0..t})"
         using fun_eq1 by auto
       have hderiv:"(?h has_derivative (?g' \<circ> ?f')) (at s within {0..t})"
         by (rule diff_chain_within[OF fderiv gderiv], rule s)
       have heq:"(\<lambda>t. RSadj x y (sol t)) = ?h"
         unfolding comp_def by simp
       have RSadj_scale:"\<And>c a. RSadj x y (c *\<^sub>R RSadj x y a) = c *\<^sub>R a"
         subgoal for c a
           unfolding RSadj_def
           apply auto
           apply(rule vec_extensionality)
           by(auto)
         done
       have heq':"(\<lambda>xb. xb *\<^sub>R ODE_sem I ODE (RSadj x y (sol s))) = (?g' \<circ> ?f')"
         unfolding comp_def apply(rule ext) using OUren[OF ORA, of I x y "sol s"]
         apply auto
         subgoal for c
           using RSadj_scale[of c "ODE_sem I ODE (RSadj x y (sol s))"] by auto
         done
       show "((\<lambda>t. RSadj x y (sol t)) has_derivative (\<lambda>xb. xb *\<^sub>R ODE_sem I ODE (RSadj x y (sol s)))) (at s within {0..t})"
         using heq heq' hderiv by auto
       qed
    then show "\<forall>xa\<in>{0..t}. ((\<lambda>t. RSadj x y (sol t)) has_derivative (\<lambda>xb. xb *\<^sub>R ODE_sem I ODE (RSadj x y (sol xa)))) (at xa within {0..t})"
      by auto
    qed

lemma sol_lemma2:
  assumes ORA:"ORadmit ODE"
  assumes t:"0 \<le> t"
  assumes fml:"\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>)"
  assumes sol:"(sol solves_ode (\<lambda>a. ODE_sem I ODE)) {0..t} {x. mk_v I ODE (sol 0, b) x \<in> fml_sem I \<phi>}"
  shows "((\<lambda>t. RSadj x y (sol t)) solves_ode (\<lambda>a. ODE_sem I (OUrename x y ODE))) {0..t}
          {xa. mk_v I (OUrename x y ODE) (RSadj x y (sol 0), RSadj x y b) xa \<in> fml_sem I (FUrename x y \<phi>)}"
  apply(unfold solves_ode_def)
  apply(rule conjI)
   defer
   subgoal
     apply auto
   proof -
     fix s
     assume t:"0 \<le> s" "s \<le> t"
     have ivl:"s \<in> {0..t}" using t by auto
     have "mk_v I ODE (sol 0,b) (sol s) \<in> fml_sem I \<phi>"
       using solves_odeD(2)[OF sol ivl] by auto
     then have "Radj x y (mk_v I ODE (sol 0, b) (sol s)) \<in> fml_sem I (FUrename x y \<phi>)"
       using Radj_cancel[of x y "(mk_v I ODE (sol 0, b) (sol s))"]
       by (simp add: fml)
     then show " mk_v I (OUrename x y ODE) (RSadj x y (sol 0), RSadj x y b) (RSadj x y (sol s)) \<in> fml_sem I (FUrename x y \<phi>)"
         using mkv_lemma[OF ORA, of x y I "RSadj x y (sol 0)" "RSadj x y b" "RSadj x y (sol s)"]
         by (simp add: RSadj_cancel \<open>mk_v I ODE (sol 0, b) (sol s) \<in> fml_sem I \<phi>\<close> fml)
   qed
   apply (unfold has_vderiv_on_def has_vector_derivative_def)
 proof -
   have "\<And>s. s\<in>{0..t} \<Longrightarrow>  ((\<lambda>t. RSadj x y (sol t)) has_derivative (\<lambda>xb. xb *\<^sub>R ODE_sem I (OUrename x y ODE) (RSadj x y (sol s)))) (at s within {0..t})"
   proof -
     fix s
     assume s:"s \<in>{0..t}"
     let ?g = "RSadj x y"
     let ?g' = "RSadj x y"
     let ?f = "sol"
     let ?f' = "(\<lambda>xb. xb *\<^sub>R RSadj x y (ODE_sem I (OUrename x y ODE) (RSadj x y (sol s))))"
     let ?h = "?g \<circ> ?f"
     have fun_eq:"(\<lambda>t'. t' *\<^sub>R ODE_sem I ODE (sol s)) = (\<lambda>xb. xb *\<^sub>R RSadj x y (ODE_sem I (OUrename x y ODE) (RSadj x y (sol s))))"
       apply(rule ext)
       using OUren[OF ORA, of I x y, of "RSadj x y (sol s)"] RSadj_cancel by simp
     have fun_eq1:"(\<lambda>\<nu>. (\<chi> i. RSadj x y \<nu> $ i)) = RSadj x y"
       by(rule ext, rule vec_extensionality, simp)
     have "s \<in> {0..t} \<Longrightarrow> (sol has_derivative (\<lambda>t'. t' *\<^sub>R ODE_sem I ODE (sol s))) (at s within {0..t})"
       using solves_odeD(1)[OF sol] unfolding has_vderiv_on_def has_vector_derivative_def by auto
     then have fderiv:"s \<in> {0..t} \<Longrightarrow> (?f has_derivative ?f') (at s within {0..t})"
       using fun_eq by auto
     have "((\<lambda>\<nu>. (\<chi> i. RSadj x y \<nu> $ i)) has_derivative (\<lambda>\<nu>'. (\<chi> i . RSadj x y \<nu>' $ i))) (at (?f s) within ?f ` {0..t})"
       apply(rule has_derivative_vec)
       apply(auto simp add: RSadj_def intro:derivative_eq_intros)
         by (simp add: has_derivative_at_withinI has_derivative_proj')+
     then have gderiv:"(RSadj x y has_derivative (RSadj x y)) (at (?f s) within ?f ` {0..t})"
       using fun_eq1 by auto
     have hderiv:"(?h has_derivative (?g' \<circ> ?f')) (at s within {0..t})"
       by (rule diff_chain_within[OF fderiv gderiv], rule s)
     have heq:"(\<lambda>t. RSadj x y (sol t)) = ?h"
       unfolding comp_def by simp
     have RSadj_scale:"\<And>c a. RSadj x y (c *\<^sub>R RSadj x y a) = c *\<^sub>R a"
       subgoal for c a
         unfolding RSadj_def
         apply auto
         apply(rule vec_extensionality)
         by(auto)
       done
     have heq':"(\<lambda>xb. xb *\<^sub>R ODE_sem I (OUrename x y ODE) (RSadj x y (sol s))) = (?g' \<circ> ?f')"
       unfolding comp_def apply(rule ext) using OUren[OF ORA, of I x y "RSadj x y (sol s)"]
       apply auto
       subgoal for c
         using RSadj_scale[of c "ODE_sem I (OUrename x y ODE) (RSadj x y (sol s))"] RSadj_cancel[of x y "sol s"]
             RSadj_cancel[of x y "ODE_sem I ODE (sol s)"] by auto
       done
     show "((\<lambda>t. RSadj x y (sol t)) has_derivative (\<lambda>xb. xb *\<^sub>R ODE_sem I (OUrename x y ODE) (RSadj x y (sol s)))) (at s within {0..t})"
       using heq heq' hderiv by auto
       qed
  then show "\<forall>xa\<in>{0..t}. ((\<lambda>t. RSadj x y (sol t)) has_derivative (\<lambda>xb. xb *\<^sub>R ODE_sem I (OUrename x y ODE) (RSadj x y (sol xa)))) (at xa within {0..t})"
  by blast
qed

lemma PUren_FUren:
  assumes good_interp:"is_interp I"
  shows
    "(PRadmit \<alpha> \<longrightarrow> hpsafe \<alpha> \<longrightarrow> (\<forall> \<nu> \<omega>. (\<nu>, \<omega>) \<in> prog_sem I (PUrename x y \<alpha>) \<longleftrightarrow> (Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I \<alpha>))
    \<and> (FRadmit \<phi> \<longrightarrow> fsafe \<phi> \<longrightarrow> (\<forall> \<nu>. \<nu> \<in> fml_sem I (FUrename x y \<phi>) \<longleftrightarrow> (Radj x y \<nu>) \<in> fml_sem I \<phi>))"
proof(induction rule: PRadmit_FRadmit.induct)
  case (FRadmit_Geq \<theta>1 \<theta>2)
  then show ?case using TUren[OF good_interp] by auto
next
  case (FRadmit_Exists \<phi> z) then have
    FRA:"FRadmit \<phi>"
    and IH:"fsafe \<phi> \<Longrightarrow>  (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
    by auto
  have "fsafe (Exists z \<phi>) \<Longrightarrow>  (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>)))"
    apply (cases "z = x")
     subgoal for \<nu>
     proof -
       assume fsafe:"fsafe (Exists z \<phi>)"
       assume zx:"z = x"
       from fsafe have fsafe':"fsafe \<phi>" by auto
       have IH':"(\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
         by (rule IH[OF fsafe'])
       have "(\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (\<nu> \<in> fml_sem I (Exists y (FUrename x y \<phi>)))" using zx by auto
       moreover have "... = (\<exists>r. (repv \<nu> y r) \<in> fml_sem I (FUrename x y \<phi>))" by auto
       moreover have "... = (\<exists>r. (Radj x y (repv \<nu> y r)) \<in> fml_sem I \<phi>)" using IH' by auto
       moreover have "... = (\<exists>r. (repv (Radj x y \<nu>) x r) \<in> fml_sem I \<phi>)" using Radj_repv1[of x y \<nu>] by auto
       moreover have "... = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>))" using zx by auto
       ultimately
       show "(\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>))"
         by auto
     qed
    apply (cases "z = y")
     subgoal for \<nu>
     proof -
       assume fsafe:"fsafe (Exists z \<phi>)"
       assume zx:"z = y"
       from fsafe have fsafe':"fsafe \<phi>" by auto
       have IH':"(\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
         by (rule IH[OF fsafe'])
       have "(\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (\<nu> \<in> fml_sem I (Exists x (FUrename x y \<phi>)))" using zx by auto
       moreover have "... = (\<exists>r. (repv \<nu> x r) \<in> fml_sem I (FUrename x y \<phi>))" by auto
       moreover have "... = (\<exists>r. (Radj x y (repv \<nu> x r)) \<in> fml_sem I \<phi>)" using IH' by auto
       moreover have "... = (\<exists>r. (repv (Radj x y \<nu>) y r) \<in> fml_sem I \<phi>)" using Radj_repv2[of x y \<nu>] by auto
       moreover have "... = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>))" using zx by auto
       ultimately
       show "(\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>))"
         by auto
     qed
    subgoal for \<nu>
    proof -
      assume fsafe:"fsafe (Exists z \<phi>)"
      assume zx:"z \<noteq> x" and zy:"z \<noteq> y"
      from fsafe have fsafe':"fsafe \<phi>" by auto
      have IH':"(\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
        by (rule IH[OF fsafe'])
      have "(\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (\<nu> \<in> fml_sem I (Exists z (FUrename x y \<phi>)))" using zx zy by auto
      moreover have "... = (\<exists>r. (repv \<nu> z r) \<in> fml_sem I (FUrename x y \<phi>))" by auto
      moreover have "... = (\<exists>r. (Radj x y (repv \<nu> z r)) \<in> fml_sem I \<phi>)" using IH' by auto
      moreover have "... = (\<exists>r. (repv (Radj x y \<nu>) z r) \<in> fml_sem I \<phi>)" using Radj_repv3[of z x y \<nu>, OF zx zy] by auto
      moreover have "... = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>))" using zx by auto
      ultimately
      show "(\<nu> \<in> fml_sem I (FUrename x y (Exists z \<phi>))) = (Radj x y \<nu> \<in> fml_sem I (Exists z \<phi>))"
        by auto
    qed
    done
  then show ?case by auto
next
  case (PRadmit_Assign z \<theta>)
  have "hpsafe (Assign z \<theta>) \<Longrightarrow>  (\<And>\<nu> \<omega>. ((\<nu>, \<omega>)  \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (Assign z \<theta>)))"
    apply (cases "z = x")
     subgoal for \<nu> \<omega>
     proof -
       assume fsafe:"hpsafe (Assign z \<theta>)"
       assume zx:"z = x"
       from fsafe have dsafe:"dsafe \<theta>" by auto
       have IH':"(\<And>\<nu>. dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>))"
         subgoal for \<nu> using TUren[OF good_interp dsafe , of x y \<nu>] by auto done
       have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((\<nu>, \<omega>) \<in> prog_sem I (Assign y (TUrename x y \<theta>)))"  using zx by auto
       moreover have "... = (\<omega> = repv \<nu> y (dterm_sem I (TUrename x y \<theta>) \<nu>))" by auto
       moreover have "... = (\<omega> = repv \<nu> y (dterm_sem I \<theta> (Radj x y \<nu>)))" using IH' by auto
       moreover have "... = (Radj x y \<omega> = Radj x y (repv \<nu> y (dterm_sem I \<theta> (Radj x y \<nu>))))" using Radj_eq_iff by auto
       moreover have "... = (Radj x y \<omega> = repv (Radj x y \<nu>) x (dterm_sem I \<theta> (Radj x y \<nu>)))" using Radj_repv1 by auto
       moreover have "... = (Radj x y \<omega> = repv (Radj x y \<nu>) z (dterm_sem I \<theta> (Radj x y \<nu>)))" using zx by auto
       moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (Assign z \<theta>))" by auto
       ultimately
       show "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (Assign z \<theta>))"
         by auto
     qed
    apply (cases "z = y")
     subgoal for \<nu> \<omega>
     proof -
       assume fsafe:"hpsafe (Assign z \<theta>)"
       assume zy:"z = y"
       from fsafe have dsafe:"dsafe \<theta>" by auto
       have IH':"(\<And>\<nu>. dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>))"
         subgoal for \<nu> using TUren[OF good_interp dsafe , of x y \<nu>] by auto done
       have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((\<nu>, \<omega>) \<in> prog_sem I (Assign x (TUrename x y \<theta>)))"  using zy by auto
       moreover have "... = (\<omega> = repv \<nu> x (dterm_sem I (TUrename x y \<theta>) \<nu>))" by auto
       moreover have "... = (\<omega> = repv \<nu> x (dterm_sem I \<theta> (Radj x y \<nu>)))" using IH' by auto
       moreover have "... = (Radj x y \<omega> = Radj x y (repv \<nu> x (dterm_sem I \<theta> (Radj x y \<nu>))))" using Radj_eq_iff by auto
       moreover have "... = (Radj x y \<omega> = repv (Radj x y \<nu>) y (dterm_sem I \<theta> (Radj x y \<nu>)))" using Radj_repv2 by auto
       moreover have "... = (Radj x y \<omega> = repv (Radj x y \<nu>) z (dterm_sem I \<theta> (Radj x y \<nu>)))" using zy by auto
       moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (Assign z \<theta>))" by auto
       ultimately
       show "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (Assign z \<theta>))"
         by auto
     qed
    subgoal for \<nu> \<omega>
    proof -
      assume fsafe:"hpsafe (Assign z \<theta>)"
      assume zx:"z \<noteq> x" and zy:"z \<noteq> y"
      from fsafe have dsafe:"dsafe \<theta>" by auto
      have IH':"(\<And>\<nu>. dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>))"
        subgoal for \<nu> using TUren[OF good_interp dsafe , of x y \<nu>] by auto done
      have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((\<nu>, \<omega>) \<in> prog_sem I (Assign z (TUrename x y \<theta>)))"  using zx zy by auto
      moreover have "... = (\<omega> = repv \<nu> z (dterm_sem I (TUrename x y \<theta>) \<nu>))" by auto
      moreover have "... = (\<omega> = repv \<nu> z (dterm_sem I \<theta> (Radj x y \<nu>)))" using IH' by auto
      moreover have "... = (Radj x y \<omega> = Radj x y (repv \<nu> z (dterm_sem I \<theta> (Radj x y \<nu>))))" using Radj_eq_iff by auto
      moreover have "... = (Radj x y \<omega> = repv (Radj x y \<nu>) z (dterm_sem I \<theta> (Radj x y \<nu>)))" using Radj_repv3[OF zx zy] by auto
      moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (Assign z \<theta>))" by auto
      ultimately
      show "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (Assign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (Assign z \<theta>))"
        by auto
    qed
    done
  then show ?case by auto
next
  case (PRadmit_DiffAssign z \<theta>)
  have "hpsafe (DiffAssign z \<theta>) \<Longrightarrow>  (\<And>\<nu> \<omega>. ((\<nu>, \<omega>)  \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (DiffAssign z \<theta>)))"
    apply (cases "z = x")
     subgoal for \<nu> \<omega>
     proof -
       assume fsafe:"hpsafe (DiffAssign z \<theta>)"
       assume zx:"z = x"
       from fsafe have dsafe:"dsafe \<theta>" by auto
       have IH':"(\<And>\<nu>. dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>))"
         subgoal for \<nu> using TUren[OF good_interp dsafe , of x y \<nu>] by auto done
       have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((\<nu>, \<omega>) \<in> prog_sem I (DiffAssign y (TUrename x y \<theta>)))"  using zx by auto
       moreover have "... = (\<omega> = repd \<nu> y (dterm_sem I (TUrename x y \<theta>) \<nu>))" by auto
       moreover have "... = (\<omega> = repd \<nu> y (dterm_sem I \<theta> (Radj x y \<nu>)))" using IH' by auto
       moreover have "... = (Radj x y \<omega> = Radj x y (repd \<nu> y (dterm_sem I \<theta> (Radj x y \<nu>))))" using Radj_eq_iff by auto
       moreover have "... = (Radj x y \<omega> = repd (Radj x y \<nu>) x (dterm_sem I \<theta> (Radj x y \<nu>)))" using Radj_repd1 by auto
       moreover have "... = (Radj x y \<omega> = repd (Radj x y \<nu>) z (dterm_sem I \<theta> (Radj x y \<nu>)))" using zx by auto
       moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (DiffAssign z \<theta>))" by auto
       ultimately
       show "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (DiffAssign z \<theta>))"
         by auto
     qed
    apply (cases "z = y")
     subgoal for \<nu> \<omega>
     proof -
       assume fsafe:"hpsafe (DiffAssign z \<theta>)"
       assume zy:"z = y"
       from fsafe have dsafe:"dsafe \<theta>" by auto
       have IH':"(\<And>\<nu>. dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>))"
         subgoal for \<nu> using TUren[OF good_interp dsafe , of x y \<nu>] by auto done
       have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((\<nu>, \<omega>) \<in> prog_sem I (DiffAssign x (TUrename x y \<theta>)))"  using zy by auto
       moreover have "... = (\<omega> = repd \<nu> x (dterm_sem I (TUrename x y \<theta>) \<nu>))" by auto
       moreover have "... = (\<omega> = repd \<nu> x (dterm_sem I \<theta> (Radj x y \<nu>)))" using IH' by auto
       moreover have "... = (Radj x y \<omega> = Radj x y (repd \<nu> x (dterm_sem I \<theta> (Radj x y \<nu>))))" using Radj_eq_iff by auto
       moreover have "... = (Radj x y \<omega> = repd (Radj x y \<nu>) y (dterm_sem I \<theta> (Radj x y \<nu>)))" using Radj_repd2 by auto
       moreover have "... = (Radj x y \<omega> = repd (Radj x y \<nu>) z (dterm_sem I \<theta> (Radj x y \<nu>)))" using zy by auto
       moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (DiffAssign z \<theta>))" by auto
       ultimately
        show "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (DiffAssign z \<theta>))"
         by auto
     qed
    subgoal for \<nu> \<omega>
  proof -
    assume fsafe:"hpsafe (DiffAssign z \<theta>)"
    assume zx:"z \<noteq> x" and zy:"z \<noteq> y"
    from fsafe have dsafe:"dsafe \<theta>" by auto
    have IH':"(\<And>\<nu>. dterm_sem I (TUrename x y \<theta>) \<nu> = dterm_sem I \<theta> (Radj x y \<nu>))"
      subgoal for \<nu> using TUren[OF good_interp dsafe , of x y \<nu>] by auto done
    have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((\<nu>, \<omega>) \<in> prog_sem I (DiffAssign z (TUrename x y \<theta>)))"  using zx zy by auto
    moreover have "... = (\<omega> = repd \<nu> z (dterm_sem I (TUrename x y \<theta>) \<nu>))" by auto
    moreover have "... = (\<omega> = repd \<nu> z (dterm_sem I \<theta> (Radj x y \<nu>)))" using IH' by auto
    moreover have "... = (Radj x y \<omega> = Radj x y (repd \<nu> z (dterm_sem I \<theta> (Radj x y \<nu>))))" using Radj_eq_iff by auto
    moreover have "... = (Radj x y \<omega> = repd (Radj x y \<nu>) z (dterm_sem I \<theta> (Radj x y \<nu>)))" using Radj_repd3[OF zx zy] by auto
    moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (DiffAssign z \<theta>))" by auto
    ultimately
    show "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (DiffAssign z \<theta>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem  I (DiffAssign z \<theta>))"
      by auto
  qed
  done
  then show ?case by auto
next
  case (PRadmit_Test \<phi>) then
  have FRA:"FRadmit \<phi>"
  and IH:"fsafe \<phi> \<Longrightarrow> (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
    by auto
  have "hpsafe (? \<phi>) \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (? \<phi>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (? \<phi>)))"
    proof -
      assume hpsafe:"hpsafe (? \<phi>)"
      fix \<nu> \<omega>
      from hpsafe have fsafe:"fsafe \<phi>" by auto
      have IH':"\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>)"
        by (rule IH[OF fsafe])
      have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (? \<phi>))) = (\<nu> = \<omega> \<and> (\<omega> \<in> fml_sem I (FUrename x y \<phi>)))" by (cases \<omega>, auto)
      moreover have "... = (\<nu> = \<omega> \<and> (Radj x y \<omega>) \<in> fml_sem I \<phi>)" using IH' by auto
      moreover have "... = (Radj x y \<nu> = Radj x y \<omega> \<and> (Radj x y \<omega>) \<in> fml_sem I \<phi>)" using Radj_eq_iff by auto
      moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (? \<phi>))" by (cases "Radj x y \<omega>", auto)
      ultimately show "?thesis \<nu> \<omega>" by auto
    qed
  then show ?case by auto
next
  case (FRadmit_Prop p args) then
  have "fsafe (Prop p args) \<Longrightarrow> (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y (Prop p args))) = ((Radj x y \<nu>) \<in> fml_sem I (Prop p args)))"
  proof -
    assume fsafe:"fsafe (Prop p args)"
    fix \<nu>
    from fsafe have dsafes:"\<And>i. dsafe (args i)" using dfree_is_dsafe by auto
    have IH:"\<And>i \<nu>. dterm_sem I (TUrename x y (args i)) \<nu> = dterm_sem I (args i) (Radj x y \<nu>)"
      using TUren[OF good_interp dsafes] by auto
    have "(\<nu> \<in> fml_sem I (FUrename x y (Prop p args))) = (\<nu> \<in> fml_sem I (Prop p (\<lambda>i . TUrename x y (args i))))" by auto
    moreover have "... = (Predicates I p (\<chi> i. dterm_sem I (TUrename x y (args i)) \<nu>))" by auto
    moreover have "... = (Predicates I p (\<chi> i. dterm_sem I (args i) (Radj x y \<nu>)))" using IH by auto
    moreover have "... = ((Radj x y \<nu>) \<in> fml_sem I (Prop p args))" by auto
    ultimately show "?thesis \<nu>" by blast
  qed
  then show ?case by auto
next
  case (PRadmit_Sequence a b) then
  have IH1:"hpsafe a \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a)) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a))"
    and  IH2:"hpsafe b \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y b)) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I b))"
    by auto
  have "hpsafe (a ;; b) \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (a ;;b))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (a ;; b)))"
  proof -
    assume hpsafe:"hpsafe (a ;; b)"
    fix \<nu> \<omega>
    from hpsafe have safe1:"hpsafe a" and safe2:"hpsafe b" by auto
    have IH1:"(\<And>\<mu>. ((\<nu>, \<mu>) \<in> prog_sem I (PUrename x y a)) = ((Radj x y \<nu>, Radj x y \<mu>) \<in> prog_sem I a))"
      using IH1[OF safe1] by auto
    have IH2:"(\<And>\<mu>. ((\<mu>, \<omega>) \<in> prog_sem I (PUrename x y b)) = ((Radj x y \<mu>, Radj x y \<omega>) \<in> prog_sem I b))"
      using IH2[OF safe2] by auto
    have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (a ;;b))) = ((\<nu>, \<omega>) \<in> prog_sem I ((PUrename x y a) ;;(PUrename x y b)))" by auto
    moreover have "... = (\<exists>\<mu>. (\<nu>, \<mu>) \<in> prog_sem I (PUrename x y a) \<and> (\<mu>, \<omega>) \<in> prog_sem I (PUrename x y b))" by auto
    moreover have "... = (\<exists>\<mu>. (Radj x y \<nu>, Radj x y \<mu>) \<in> prog_sem I a \<and> (Radj x y \<mu>, Radj x y \<omega>) \<in> prog_sem I b)" using IH1 IH2 by auto
    moreover have "... = (\<exists>\<mu>. (Radj x y \<nu>, \<mu>) \<in> prog_sem I a \<and> (\<mu>, Radj x y \<omega>) \<in> prog_sem I b)"
      apply auto
       subgoal for aa ba
         apply(rule exI[where x="fst(Radj x y (aa,ba))"])
         apply(rule exI[where x="snd(Radj x y (aa,ba))"])
         by auto
      subgoal for aa ba
        apply(rule exI[where x="fst(Radj x y (aa,ba))"])
        apply(rule exI[where x="snd(Radj x y (aa,ba))"])
        using Radj_cancel by auto
      done
    moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (a ;;b))" by (auto,blast)
    ultimately show "?thesis \<nu> \<omega>" by auto
  qed
  then show ?case by auto
next
  case (FRadmit_Diamond \<alpha> \<phi>) then
  have IH1:"hpsafe \<alpha> \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y \<alpha>)) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I \<alpha>))"
  and IH2:"fsafe \<phi> \<Longrightarrow> (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
    by auto
  have "fsafe (\<langle>\<alpha>\<rangle>\<phi>) \<Longrightarrow> (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y (\<langle>\<alpha>\<rangle>\<phi>))) = (Radj x y \<nu> \<in> fml_sem I (\<langle>\<alpha>\<rangle>\<phi>)))"
  proof -
    assume safe:"fsafe (\<langle>\<alpha>\<rangle>\<phi>)"
    fix \<nu>
    from safe have safe1:"hpsafe \<alpha>" and safe2:"fsafe \<phi>" by auto
    have IH1:"\<And>\<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y \<alpha>)) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I \<alpha>)"
      using IH1[OF safe1] by auto
    have IH2:"\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>)"
      by (rule IH2[OF safe2])
    have "(\<nu> \<in> fml_sem I (FUrename x y (\<langle>\<alpha>\<rangle>\<phi>))) = (\<nu> \<in> fml_sem I (\<langle>PUrename x y \<alpha>\<rangle>FUrename x y \<phi>))" by auto
    moreover have "... = (\<exists> \<omega>. (\<nu>, \<omega>) \<in> prog_sem I (PUrename x y \<alpha>) \<and> \<omega> \<in> fml_sem I (FUrename x y \<phi>))" by auto
    moreover have "... = (\<exists> \<omega>. (Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I \<alpha> \<and> (Radj x y \<omega>) \<in> fml_sem I \<phi>)"
      using IH1 IH2 by auto
    moreover have "... = (\<exists> \<omega>. (Radj x y \<nu>, \<omega>) \<in> prog_sem I \<alpha> \<and> \<omega> \<in> fml_sem I \<phi>)"
      apply auto
       subgoal for aa ba
         apply(rule exI[where x="fst(Radj x y (aa,ba))"])
         apply(rule exI[where x="snd(Radj x y (aa,ba))"])
         by auto
      subgoal for aa ba
        apply(rule exI[where x="fst(Radj x y (aa,ba))"])
        apply(rule exI[where x="snd(Radj x y (aa,ba))"])
        using Radj_cancel by auto
      done
    moreover have "... = (Radj x y \<nu> \<in> fml_sem I (\<langle>\<alpha>\<rangle>\<phi>))" by auto
    ultimately show "?thesis \<nu>" by auto
  qed
  then show ?case by auto
next
  case (PRadmit_Loop a) then
  have IH:" hpsafe a \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a)) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a))"
    by auto
  have "hpsafe (a** ) \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (a** ))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (a** )))"
  proof -
    assume safe:"hpsafe (a** )"
    fix \<nu> \<omega>
    from safe have safe:"hpsafe a" by auto
    have IH1:"(\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a)) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a))"
      by (rule IH[OF safe])
    have relpow_iff:"\<And>\<nu> \<omega> R n. ((\<nu>, \<omega>) \<in> R ^^ Suc n) = (\<exists>\<mu>. (\<nu>, \<mu>) \<in> R \<and> (\<mu>, \<omega>) \<in> R ^^ n)"
      apply auto
       subgoal for R n x y z by (auto simp add: relpow_Suc_D2')
      subgoal for \<nu> \<omega> R n \<mu> using relpow_Suc_I2 by fastforce
      done
    have rtrancl_iff_relpow:"\<And>\<nu> \<omega> R. ((\<nu>, \<omega>) \<in> R\<^sup>*) = (\<exists>n. (\<nu>, \<omega>) \<in> R ^^ n)"
      using rtrancl_imp_relpow relpow_imp_rtrancl by blast
    have lem:"\<And>n. (\<forall> \<nu> \<omega>.  ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a)^^n) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a^^n))"
      subgoal for n
      proof(induction n)
        case 0
        then show ?case using Radj_eq_iff by auto
      next
        case (Suc n) then
        have IH2:"\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a) ^^ n) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a ^^ n)"
          by auto
        have "\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a) ^^ Suc n) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a ^^ Suc n)"
        proof -
          fix \<nu> \<omega>
          have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y a) ^^ Suc n)
            = (\<exists> \<mu>. (\<nu>, \<mu>) \<in> prog_sem I (PUrename x y a) \<and> (\<mu>, \<omega>) \<in> prog_sem I (PUrename x y a) ^^ n)"
            using relpow_iff[of \<nu> \<omega> n "prog_sem I (PUrename x y a)"] by auto
          moreover have "... = (\<exists> \<mu>. (Radj x y \<nu>, Radj x y \<mu>) \<in> prog_sem I a \<and> (Radj x y \<mu>, Radj x y \<omega>) \<in> prog_sem I a ^^ n)"
            using IH1 IH2 by blast
          moreover have "... = (\<exists> \<mu>. (Radj x y \<nu>, \<mu>) \<in> prog_sem I a \<and> (\<mu>, Radj x y \<omega>) \<in> prog_sem I a ^^ n)"
            apply auto
             subgoal for aa ba
               apply(rule exI[where x="fst(Radj x y (aa,ba))"])
               apply(rule exI[where x="snd(Radj x y (aa,ba))"])
               by auto
            subgoal for aa ba
              apply(rule exI[where x="fst(Radj x y (aa,ba))"])
              apply(rule exI[where x="snd(Radj x y (aa,ba))"])
              using Radj_cancel by auto
            done
          moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I a ^^ Suc n)"
            using relpow_iff[of "Radj x y \<nu>" "Radj x y \<omega>"  n "prog_sem I a"] by auto
          ultimately show "?thesis \<nu> \<omega>" by auto
        qed
        then show ?case by auto
      qed
      done
    have "((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (a** ))) = ((\<nu>, \<omega>) \<in> (prog_sem I (PUrename x y a))\<^sup>*)" by auto
    moreover have "... = (\<exists>n. (\<nu>, \<omega>) \<in> (prog_sem I (PUrename x y a)) ^^ n)"
      using rtrancl_iff_relpow[of \<nu> \<omega> "prog_sem I (PUrename x y a)"] by auto
    moreover have "... = (\<exists>n. (Radj x y \<nu>, Radj x y \<omega>) \<in> (prog_sem I a) ^^ n)"
      using lem by blast
    moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> (prog_sem I a)\<^sup>*)"
      using rtrancl_iff_relpow[of "Radj x y \<nu>" "Radj x y \<omega>" "prog_sem I a"] by auto
    moreover have "... = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (a** ))" by auto
    ultimately show "?thesis \<nu> \<omega>" by blast
  qed
  then show ?case by auto
next
  case (PRadmit_EvolveODE ODE \<phi>) then
  have ORA:"ORadmit ODE"
    and IH:"fsafe \<phi> \<Longrightarrow> (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
    by auto
  have "hpsafe (EvolveODE ODE \<phi>) \<Longrightarrow> (\<And>\<nu> \<omega>. ((\<nu>, \<omega>) \<in> prog_sem I (PUrename x y (EvolveODE ODE \<phi>))) = ((Radj x y \<nu>, Radj x y \<omega>) \<in> prog_sem I (EvolveODE ODE \<phi>)))"
  proof -
    assume safe:"hpsafe (EvolveODE ODE \<phi>)"
    fix \<nu> \<omega>
    from safe have osafe:"osafe ODE" and fsafe:"fsafe \<phi>" by auto
    have IH1:"\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>) = (Radj x y \<nu> \<in> fml_sem I \<phi>))" by (rule IH[OF fsafe])
    have IH2:"\<And>\<nu>. ODE_sem I (OUrename x y ODE) \<nu> = RSadj x y (ODE_sem I ODE (RSadj x y \<nu>))"
      using OUren[OF ORA] by auto
    have RSadj_Radj:"\<And>a b. (RSadj x y a, RSadj x y b) = Radj x y (a,b)"
      unfolding RSadj_def Radj_def by auto
    have Radj_swap:"\<And>a b. Radj x y a = b \<Longrightarrow> a = Radj x y b"
      using Radj_cancel Radj_eq_iff by metis
    have mkv:"\<And>t sol b. Radj x y (mk_v I (OUrename x y ODE) (sol 0, b) (sol t)) = mk_v I ODE (RSadj x y (sol 0), RSadj x y b) (RSadj x y (sol t))"
      using mkv_lemma[OF ORA] by blast
    have mkv2:"\<And>t sol b.  Radj x y \<omega> = mk_v I ODE (sol 0, b) (sol t) \<Longrightarrow>
      \<omega> = mk_v I (OUrename x y ODE) (RSadj x y (sol 0), RSadj x y b) (RSadj x y (sol t))"
      using mkv_lemma[OF ORA] by (metis RSadj_cancel Radj_cancel)
    have sol:"\<And>t sol b. 0 \<le> t \<Longrightarrow>
      (sol solves_ode (\<lambda>a. ODE_sem I (OUrename x y ODE))) {0..t} {xa. mk_v I (OUrename x y ODE) (sol 0, b) xa \<in> fml_sem I (FUrename x y \<phi>)} \<Longrightarrow>
      ((\<lambda>t. RSadj x y (sol t)) solves_ode (\<lambda>a. ODE_sem I ODE)) {0..t} {xa. mk_v I ODE (RSadj x y (sol 0), RSadj x y b) xa \<in> fml_sem I \<phi>}"
      using sol_lemma IH1 IH2 ORA by blast
    have sol2:"\<And>t sol b. 0 \<le> t \<Longrightarrow>
(sol solves_ode (\<lambda>a. ODE_sem I ODE)) {0..t} {x. mk_v I ODE (sol 0, b) x \<in> fml_sem I \<phi>} \<Longrightarrow>
((\<lambda>t. RSadj x y (sol t)) solves_ode (\<lambda>a. ODE_sem I (OUrename x y ODE))) {0..t}
 {xa. mk_v I (OUrename x y ODE) (RSadj x y (sol 0), RSadj x y b) xa \<in> fml_sem I (FUrename x y \<phi>)}"
      using sol_lemma2 IH1 IH2 ORA by blast
    show "?thesis \<nu> \<omega>"
      apply auto
       subgoal for b sol t
         apply(rule exI[where x= "RSadj x y b"])
         apply(rule exI[where x= "(\<lambda>t. RSadj x y (sol t))"])
         apply(rule conjI)
          subgoal using RSadj_Radj[of "sol 0" "b"] by auto
         apply(rule exI[where x =t])
         apply(rule conjI)
          subgoal by (rule mkv)
         apply(rule conjI)
          subgoal by assumption
         by (rule sol)
      subgoal for b sol t
        apply(rule exI[where x= "RSadj x y b"])
        apply(rule exI[where x= "(\<lambda>t. RSadj x y (sol t))"])
        apply(rule conjI)
         subgoal using RSadj_Radj[of "sol 0" "b"] Radj_swap[of \<nu> "(sol 0,b)"] by auto
        apply(rule exI[where x =t])
        apply(rule conjI)
         subgoal by (rule mkv2)
        apply(rule conjI)
         subgoal by assumption
        by (rule sol2)
      done
    qed
  then show ?case by auto
qed (auto simp add: Radj_def)

lemma FUren:"is_interp I \<Longrightarrow> FRadmit \<phi> \<Longrightarrow> fsafe \<phi> \<Longrightarrow> (\<And>\<nu>. (\<nu> \<in> fml_sem I (FUrename x y \<phi>)) = (Radj x y \<nu> \<in> fml_sem I \<phi>))"
  using PUren_FUren by blast

subsection \<open>Uniform Renaming Rule Soundness\<close>
lemma URename_sound:"FRadmit \<phi> \<Longrightarrow> fsafe \<phi> \<Longrightarrow> valid \<phi> \<Longrightarrow> valid (FUrename x y \<phi>)"
  unfolding valid_def using FUren by blast

subsection \<open>Bound Renaming Rule Soundness\<close>
lemma BRename_sound:
  assumes FRA:"FRadmit([[Assign x \<theta>]]\<phi>)"
  assumes fsafe:"fsafe ([[Assign x \<theta>]]\<phi>)"
  assumes valid:"valid ([[Assign x \<theta>]]\<phi>)"
  assumes FVF:"{Inl y, Inr y, Inr x} \<inter> FVF \<phi> = {}"
  shows "valid([[Assign y \<theta>]]FUrename x y \<phi>)"
proof -
  have FRA':"FRadmit \<phi>" using FRA
    by (metis (no_types, lifting) Box_def FRadmit.cases formula.distinct(15) formula.distinct(21) formula.distinct(27) formula.distinct(29) formula.distinct(3) formula.distinct(31) formula.distinct formula.distinct(9) formula.inject(3) formula.inject(6))
  have fsafe':"fsafe \<phi>" using fsafe  by (simp add: Box_def)
  have dsafe:"dsafe \<theta>" using fsafe by (simp add: Box_def)
  have "\<And>I \<nu>. is_interp I \<Longrightarrow> \<nu> \<in> fml_sem I ([[y := \<theta>]]FUrename x y \<phi>)"
  proof -
    fix I::"('sf,'sc,'sz) interp" and \<nu>::"'sz state"
    assume good_interp:"is_interp I"
    from FVF have sub:"FVF \<phi> \<subseteq> -{Inl y, Inr y, Inr x}" by auto
    have "Vagree (repv (Radj x y \<nu>) x (dterm_sem I \<theta> \<nu>)) (repv \<nu> x (dterm_sem I \<theta> \<nu>)) (-{Inl y, Inr y, Inr x})"
      unfolding Vagree_def using FVF unfolding Radj_def RSadj_def by auto
    then have agree:"Vagree (repv (Radj x y \<nu>) x (dterm_sem I \<theta> \<nu>)) (repv \<nu> x (dterm_sem I \<theta> \<nu>)) (FVF \<phi>)"
      using agree_sub[OF sub] by auto
    have fml_sem_eq:"(repv (Radj x y \<nu>) x (dterm_sem I \<theta> \<nu>) \<in> fml_sem I \<phi>) = (repv \<nu> x (dterm_sem I \<theta> \<nu>) \<in> fml_sem I \<phi>)"
      using coincidence_formula[OF fsafe' Iagree_refl agree] by auto
    have "(\<nu> \<in> fml_sem I ([[y := \<theta>]]FUrename x y \<phi>)) = (repv \<nu> y (dterm_sem I \<theta> \<nu>) \<in> fml_sem I (FUrename x y \<phi>))"
      by auto
    moreover have "... = (Radj x y (repv \<nu> y (dterm_sem I \<theta> \<nu>)) \<in> fml_sem I \<phi>)"
      using FUren[OF good_interp FRA' fsafe'] by auto
    moreover have "... = (repv (Radj x y \<nu>) x (dterm_sem I \<theta> \<nu>) \<in> fml_sem I \<phi>)"
      using Radj_repv1 by auto
    moreover have "... = (\<nu> \<in> fml_sem I ([[x := \<theta>]]\<phi>))"
      using fml_sem_eq by auto
    moreover have "... = True"
      using valid unfolding valid_def using good_interp by blast
    ultimately
    show "\<nu> \<in> fml_sem I ([[y := \<theta>]]FUrename x y \<phi>)"
      by blast
  qed
  then
  show ?thesis unfolding valid_def by auto
qed

end end


(* Adapted from implementation by:
    Title:      Sequents/S4.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory DS4
imports DModal0
begin

axioms
(* Definition of the star operation using a set of Horn clauses *)
(* For system S4:  gamma * == {[]P | []P : gamma}               *)
(*                 delta * == {<>P | <>P : delta}               *)

  lstar0:         "|L>"
  lstar1:         "$G |L> $H ==> []P, $G |L> []P, $H"
  lstar2:         "$G |L> $H ==>   P, $G |L>      $H"
  rstar0:         "|R>"
  rstar1:         "$G |R> $H ==> <>P, $G |R> <>P, $H"
  rstar2:         "$G |R> $H ==>   P, $G |R>      $H"

(* Rules for [] and <> *)

  boxR:
   "[| $E |L> $E';  $F |R> $F';  $G |R> $G';
           $E'         |- $F', P, $G'|] ==> $E          |- $F, []P, $G"
  boxL:     "$E,P,$F,[]P |-         $G    ==> $E, []P, $F |-          $G"

  diaR:     "$E          |- $F,P,$G,<>P   ==> $E          |- $F, <>P, $G"
  diaL:
   "[| $E |L> $E';  $F |L> $F';  $G |R> $G';
           $E', P, $F' |-         $G'|] ==> $E, <>P, $F |- $G"

ML {*
structure S4_Prover = Modal_ProverFun
(
  val rewrite_rls = @{thms rewrite_rls}
  val safe_rls = @{thms safe_rls}
  val unsafe_rls = @{thms unsafe_rls} @ [@{thm boxR}, @{thm diaL}]
  val bound_rls = @{thms bound_rls} @ [@{thm boxL}, @{thm diaR}]
  val aside_rls = [@{thm lstar0}, @{thm lstar1}, @{thm lstar2}, @{thm rstar0},
    @{thm rstar1}, @{thm rstar2}]
)
*}

method_setup S4_solve = {* Scan.succeed (K (SIMPLE_METHOD (S4_Prover.solve_tac 2))) *}

(* Theorems of system T from Hughes and Cresswell and Hailpern, LNCS 129 *)

lemma "|- []P [-->] P" by S4_solve
lemma "|- [](P[-->]Q) [-->] ([]P[-->][]Q)" by S4_solve   (* normality*)
lemma "|- (P--<Q) [-->] []P [-->] []Q" by S4_solve
lemma "|- P [-->] <>P" by S4_solve

lemma "|-  [](P [&] Q) [<->] []P [&] []Q" by S4_solve
lemma "|-  <>(P [|] Q) [<->] <>P [|] <>Q" by S4_solve
lemma "|-  [](P[<->]Q) [<->] (P>-<Q)" by S4_solve
lemma "|-  <>(P[-->]Q) [<->] ([]P[-->]<>Q)" by S4_solve
lemma "|-        []P [<->] [~]<>([~]P)" by S4_solve
lemma "|-     []([~]P) [<->] [~]<>P" by S4_solve
lemma "|-       [~][]P [<->] <>([~]P)" by S4_solve
lemma "|-      [][]P [<->] [~]<><>([~]P)" by S4_solve
lemma "|- [~]<>(P [|] Q) [<->] [~]<>P [&] [~]<>Q" by S4_solve

lemma "|- []P [|] []Q [-->] [](P [|] Q)" by S4_solve
lemma "|- <>(P [&] Q) [-->] <>P [&] <>Q" by S4_solve
lemma "|- [](P [|] Q) [-->] []P [|] <>Q" by S4_solve
lemma "|- <>P [&] []Q [-->] <>(P [&] Q)" by S4_solve
lemma "|- [](P [|] Q) [-->] <>P [|] []Q" by S4_solve
lemma "|- <>(P[-->](Q [&] R)) [-->] ([]P [-->] <>Q) [&] ([]P[-->]<>R)" by S4_solve
lemma "|- (P--<Q) [&] (Q--<R) [-->] (P--<R)" by S4_solve
lemma "|- []P [-->] <>Q [-->] <>(P [&] Q)" by S4_solve

(* Theorems of system S4 from Hughes and Cresswell, p.46 *)

lemma "|- []A [-->] A" by S4_solve             (* refexivity *)
lemma "|- []A [-->] [][]A" by S4_solve         (* transitivity *)
lemma "|- []A [-->] <>A" by S4_solve           (* seriality *)
lemma "|- <>[](<>A [-->] []<>A)" by S4_solve
lemma "|- <>[](<>[]A [-->] []A)" by S4_solve
lemma "|- []P [<->] [][]P" by S4_solve
lemma "|- <>P [<->] <><>P" by S4_solve
lemma "|- <>[]<>P [-->] <>P" by S4_solve
lemma "|- []<>P [<->] []<>[]<>P" by S4_solve
lemma "|- <>[]P [<->] <>[]<>[]P" by S4_solve

(* Theorems for system S4 from Hughes and Cresswell, p.60 *)

lemma "|- []P [|] []Q [<->] []([]P [|] []Q)" by S4_solve
lemma "|- ((P>-<Q) --< R) [-->] ((P>-<Q) --< []R)" by S4_solve

(* These are from Hailpern, LNCS 129 *)

lemma "|- [](P [&] Q) [<->] []P [&] []Q" by S4_solve
lemma "|- <>(P [|] Q) [<->] <>P [|] <>Q" by S4_solve
lemma "|- <>(P [-->] Q) [<->] ([]P [-->] <>Q)" by S4_solve

lemma "|- [](P [-->] Q) [-->] (<>P [-->] <>Q)" by S4_solve
lemma "|- []P [-->] []<>P" by S4_solve
lemma "|- <>[]P [-->] <>P" by S4_solve

lemma "|- []P [|] []Q [-->] [](P [|] Q)" by S4_solve
lemma "|- <>(P [&] Q) [-->] <>P [&] <>Q" by S4_solve
lemma "|- [](P [|] Q) [-->] []P [|] <>Q" by S4_solve
lemma "|- <>P [&] []Q [-->] <>(P [&] Q)" by S4_solve
lemma "|- [](P [|] Q) [-->] <>P [|] []Q" by S4_solve

end


section \<open> Example of probabilistic relation programming: parallel composition \<close>

theory utp_prob_rel_lattice_symmetric_random_walker
  imports
    "UTP_prob_relations.utp_prob_rel_lattice_laws"
begin

unbundle UTP_Syntax

declare [[show_types]]

alphabet srwstate =
  x :: nat

definition f:: "srwstate prhfun" where
"f = if\<^sub>p 0.5 then (x := x - 1) else (x := x + 1)"

definition sym_random_walker where
"sym_random_walker = while\<^sub>p (x\<^sup>< > 0)\<^sub>e do f od"

lemma cflip_iter_seq_tendsto_0:
  "\<forall>s::srwstate \<times> srwstate. (\<lambda>n::\<nat>. ureal2real (iter_seq n (x\<^sup>< > 0)\<^sub>e f 1\<^sub>p s)) \<longlonglongrightarrow> (0::\<real>)"
proof
  fix s
  have "(\<lambda>n::\<nat>. ureal2real (iter_seq (n+1) (x\<^sup>< > 0)\<^sub>e f 1\<^sub>p s)) \<longlonglongrightarrow> (0::\<real>)"
    sorry
  then show "(\<lambda>n::\<nat>. ureal2real (iter_seq n (x\<^sup>< > 0)\<^sub>e f 1\<^sub>p s)) \<longlonglongrightarrow> (0::\<real>)"
    by (rule LIMSEQ_offset[where k = 1])
qed

end


theory Bij_betw_simplicial_complex_bool_func
  imports
    Simplicial_complex
    Alexander
begin

section\<open>Bijection between simplicial complexes and monotone Boolean functions\<close>

context simplicial_complex
begin

lemma ceros_of_boolean_input_in_set:
  assumes s: "\<sigma> \<in> simplices"
  shows "ceros_of_boolean_input (vec n (\<lambda>i. i \<notin> \<sigma>)) = \<sigma>"
  unfolding ceros_of_boolean_input_def using s unfolding simplices_def by auto

lemma
  assumes sigma: "\<sigma> \<in> simplices"
  and nempty: "\<sigma> \<noteq> {}"
  shows "Max \<sigma> < n"
proof -
  have "Max \<sigma> \<in> \<sigma>" using linorder_class.Max_in [OF finite_simplex [OF sigma] nempty] .
  thus ?thesis using sigma unfolding simplices_def by auto
qed

definition bool_vec_from_simplice :: "nat set => (bool vec)"
  where "bool_vec_from_simplice \<sigma> = vec n (\<lambda>i. i \<notin> \<sigma>)"

lemma [simp]:
  assumes n: "dim_vec f = n"
  shows "bool_vec_from_simplice (ceros_of_boolean_input f) = f"
  unfolding bool_vec_from_simplice_def
  unfolding ceros_of_boolean_input_def
  using n by auto

lemma "bool_vec_from_simplice {0} = vec n (\<lambda>i. i \<notin> {0})"
  unfolding bool_vec_from_simplice_def by auto

lemma "bool_vec_from_simplice {1,2} =
    vec n (\<lambda>i. i \<notin> {1,2})"
  unfolding bool_vec_from_simplice_def by auto

lemma simplicial_complex_implies_true:
  assumes "\<sigma> \<in> simplicial_complex_induced_by_monotone_boolean_function n f"
  shows "f (bool_vec_from_simplice \<sigma>)"
  unfolding bool_vec_from_simplice_def
  using assms
  unfolding simplicial_complex_induced_by_monotone_boolean_function_def
  unfolding ceros_of_boolean_input_def
  apply auto
  by (smt (verit, best) dim_vec eq_vecI index_vec)

definition bool_vec_set_from_simplice_set :: "nat set set => (bool vec) set"
  where "bool_vec_set_from_simplice_set K =
     {\<sigma>. (dim_vec \<sigma> = n) \<and> (\<exists>k\<in>K. \<sigma> = bool_vec_from_simplice k)}"

definition boolean_function_from_simplicial_complex :: "nat set set => (bool vec => bool)"
  where "boolean_function_from_simplicial_complex K =
          (\<lambda>x. x \<in> (bool_vec_set_from_simplice_set K))"

lemma "Collect (boolean_function_from_simplicial_complex K) = (bool_vec_set_from_simplice_set K)"
  unfolding boolean_function_from_simplicial_complex_def by simp

text\<open>The Boolean function induced by a simplicial complex is monotone.
  This result is proven in Scoville as part of the proof of Proposition 6.16.
  The opposite direction has been proven as
  @{thm monotone_bool_fun_induces_simplicial_complex}.\<close>

lemma
  simplicial_complex_induces_monotone_bool_fun:
  assumes mon: "simplicial_complex (K::nat set set)"
  shows "boolean_functions.monotone_bool_fun n (boolean_function_from_simplicial_complex K)"
proof (unfold boolean_functions.monotone_bool_fun_def)
  show "mono_on (boolean_function_from_simplicial_complex K) (carrier_vec n)"
  proof (intro mono_onI)
  fix r and s::"bool vec"
  assume r_le_s: "r \<le> s"
  show "boolean_function_from_simplicial_complex K r
        \<le> boolean_function_from_simplicial_complex K s"
  proof (cases "boolean_function_from_simplicial_complex K r")
    case False then show ?thesis by simp
  next
    case True
    have ce: "ceros_of_boolean_input s \<subseteq> ceros_of_boolean_input r"
      using monotone_ceros_of_boolean_input [OF r_le_s] .
    from True obtain k where r_def: "r = vec n (\<lambda>i. i \<notin> k)"
      and k: "k \<in> K"
      unfolding boolean_function_from_simplicial_complex_def
      unfolding bool_vec_set_from_simplice_set_def
      unfolding bool_vec_from_simplice_def by auto
    have r_in_K: "ceros_of_boolean_input r \<in> K"
      using k mon
      unfolding r_def
      unfolding ceros_of_boolean_input_def
      unfolding dim_vec
      using simplicial_complex_def [of K] by fastforce
    have "boolean_function_from_simplicial_complex K s"
    proof (unfold boolean_function_from_simplicial_complex_def
        bool_vec_set_from_simplice_set_def, rule, rule conjI)
      show "dim_vec s = n"
        by (metis less_eq_vec_def dim_vec r_def r_le_s)
      show "\<exists>k\<in>K. s = bool_vec_from_simplice k"
        proof (rule bexI [of _ "ceros_of_boolean_input s"], unfold bool_vec_from_simplice_def)
          show "ceros_of_boolean_input s \<in> K"
            using simplicial_complex_monotone [OF mon r_in_K ce] .
          show "s = vec n (\<lambda>i. i \<notin> ceros_of_boolean_input s)"
            using ce unfolding ceros_of_boolean_input_def
            using r_le_s
            unfolding less_eq_vec_def
            unfolding r_def
            unfolding dim_vec by auto
        qed
      qed
     thus ?thesis by simp
   qed
 qed
qed

lemma shows "(simplicial_complex_induced_by_monotone_boolean_function n) \<in>
          boolean_functions.monotone_bool_fun_set n
          \<rightarrow> (simplicial_complex_set::nat set set set)"
proof
  fix x::"bool vec \<Rightarrow> bool"
  assume x: "x \<in> boolean_functions.monotone_bool_fun_set n"
  show "simplicial_complex_induced_by_monotone_boolean_function n x \<in> simplicial_complex_set"
    using monotone_bool_fun_induces_simplicial_complex [of x] x
    unfolding boolean_functions.monotone_bool_fun_set_def
    unfolding boolean_functions.monotone_bool_fun_def simplicial_complex_set_def
    by auto
qed

lemma shows "boolean_function_from_simplicial_complex
          \<in> (simplicial_complex_set::nat set set set)
          \<rightarrow> boolean_functions.monotone_bool_fun_set n"
proof
  fix x::"nat set set" assume x: "x \<in> simplicial_complex_set"
  show "boolean_function_from_simplicial_complex x \<in> boolean_functions.monotone_bool_fun_set n"
    using simplicial_complex_induces_monotone_bool_fun [of x]
    unfolding boolean_functions.monotone_bool_fun_set_def
    unfolding boolean_functions.monotone_bool_fun_def
    using x unfolding simplicial_complex_set_def
    unfolding mem_Collect_eq by fast
qed

text\<open>Given a Boolean function @{term f}, if we build its associated
  simplicial complex and then the associated Boolean function,
  we obtain @{term f}.

  The result holds for every Boolean function @{term f}
  (the premise on @{term f} being monotone can be omitted,
  but then the set defined by the boolean function @{term f}
  will no longer satisfy the definition of simplicial complex).\<close>

lemma
  boolean_function_from_simplicial_complex_simplicial_complex_induced_by_monotone_boolean_function:
  fixes f :: "bool vec \<Rightarrow> bool"
  assumes dim: "v \<in> carrier_vec n"
  shows "boolean_function_from_simplicial_complex
    (simplicial_complex_induced_by_monotone_boolean_function n f) v = f v"
proof (intro iffI)
  assume xb: "f v"
  show bf: "boolean_function_from_simplicial_complex
      (simplicial_complex_induced_by_monotone_boolean_function n f) v"
  proof -
   have "f v \<and> v = bool_vec_from_simplice (ceros_of_boolean_input v)"
    unfolding ceros_of_boolean_input_def
    unfolding bool_vec_from_simplice_def
    using xb dim unfolding carrier_vec_def by auto
   then show ?thesis
    unfolding simplicial_complex_induced_by_monotone_boolean_function_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding mem_Collect_eq
    using dim unfolding carrier_vec_def by blast
   qed
next
  assume "boolean_function_from_simplicial_complex
      (simplicial_complex_induced_by_monotone_boolean_function n f) v"
  then show "f v"
    unfolding simplicial_complex_induced_by_monotone_boolean_function_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding mem_Collect_eq
    using \<open>boolean_function_from_simplicial_complex
      (simplicial_complex_induced_by_monotone_boolean_function n f) v\<close>
      boolean_function_from_simplicial_complex_def
      simplicial_complex.bool_vec_set_from_simplice_set_def
      simplicial_complex_implies_true by fastforce
qed

text\<open>Given a simplicial complex @{term K}, if we build its associated
  Boolean function, and then the associated simplicial complex,
  we obtain @{term K}.\<close>

lemma
  simplicial_complex_induced_by_monotone_boolean_function_boolean_function_from_simplicial_complex:
  fixes K :: "nat set set"
  assumes K: "simplicial_complex K"
  shows "simplicial_complex_induced_by_monotone_boolean_function n
    (boolean_function_from_simplicial_complex K) = K"
proof (intro equalityI)
  show "simplicial_complex_induced_by_monotone_boolean_function n
    (boolean_function_from_simplicial_complex K) \<subseteq> K"
  proof
    fix x :: "nat set"
    assume x: "x \<in> simplicial_complex_induced_by_monotone_boolean_function
              n (boolean_function_from_simplicial_complex K)"
    show "x \<in> K"
      using x
      unfolding boolean_function_from_simplicial_complex_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding bool_vec_from_simplice_def bool_vec_set_from_simplice_set_def
      using K
      unfolding simplicial_complex_def simplices_def
      by auto (metis assms bool_vec_from_simplice_def
          ceros_of_boolean_input_in_set simplicial_complex_def)
  qed
next
  show "K \<subseteq> simplicial_complex_induced_by_monotone_boolean_function n
            (boolean_function_from_simplicial_complex K)"
 proof
   fix x :: "nat set"
   assume "x \<in> K"
   hence x: "x \<in> simplices" using K unfolding simplicial_complex_def by simp
   have bvs: "ceros_of_boolean_input (bool_vec_from_simplice x) = x"
     unfolding one_bool_def
     unfolding bool_vec_from_simplice_def
     using ceros_of_boolean_input_in_set [OF x] .
   show "x \<in> simplicial_complex_induced_by_monotone_boolean_function n
          (boolean_function_from_simplicial_complex K)"
     unfolding boolean_function_from_simplicial_complex_def
     unfolding simplicial_complex_induced_by_monotone_boolean_function_def
     unfolding bool_vec_from_simplice_def bool_vec_set_from_simplice_set_def
     using x bool_vec_from_simplice_def bvs
     by (metis (mono_tags, lifting) \<open>x \<in> K\<close> dim_vec mem_Collect_eq)
 qed
qed

end

section\<open>Equivalence of the Alexander dual definition for Boolean functions
  and simplicial complexes\<close>

context simplicial_complex
begin

lemma conjI3: "A \<Longrightarrow> B \<Longrightarrow> C \<Longrightarrow> A \<and> B \<and> C"
  by simp

lemma
  simplicial_complex_Alexander_dual_equals:
  shows "simplicial_complex_induced_by_monotone_boolean_function n (boolean_functions.Alexander_dual f)
    = Alexander_dual (simplicial_complex_induced_by_monotone_boolean_function n f)"
  unfolding simplicial_complex_induced_by_monotone_boolean_function_def
  unfolding Alexander_dual_def
  unfolding boolean_functions.Alexander_dual_def
  unfolding boolean_functions.not_def
  unfolding ceros_of_boolean_input_def
  unfolding simplex_complement_def
  unfolding nofaces_simplicial_complex_def
  unfolding simplices_def proof standard
  show "{y. \<exists>x. dim_vec x = n \<and>
            \<not> f (vec (dim_vec x) (\<lambda>n. \<not> x $ n)) \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}
    \<subseteq> {univ_n - x |x.
        x \<in> {v \<in> Pow {0..<n}.
              v \<notin> {y. \<exists>x. dim_vec x = n \<and> f x \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}}}"
  proof (rule subsetI)
    fix x :: "nat set"
    assume x: "x \<in> {y. \<exists>x. dim_vec x = n \<and> \<not> f (vec (dim_vec x) (\<lambda>n. \<not> x $ n)) \<and>
                     {xa. xa < dim_vec x \<and> x $ xa = False} = y} "
    from x obtain x':: "bool vec" where dx': "dim_vec x' = n"
          and notfx': "\<not> f (vec (dim_vec x') (\<lambda>n. \<not> x' $ n))"
          and x_n_x': "{xa. xa < dim_vec x' \<and> x' $ xa = False} = x" by auto
    show "x \<in> {univ_n - x |x. x \<in> {v \<in> Pow {0..<n}.
        v \<notin> {y. \<exists>x. dim_vec x = n \<and> f x \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}}}"
    proof (rule CollectI,
            rule exI [of _ "(ceros_of_boolean_input (boolean_functions.not x'))"],
              rule conjI)
        show "x = univ_n - (ceros_of_boolean_input (boolean_functions.not x'))"
          using x_n_x' dx'
          unfolding boolean_functions.not_def
          unfolding ceros_of_boolean_input_def by auto
        show "(ceros_of_boolean_input (boolean_functions.not x')) \<in> {v \<in> Pow {0..<n}.
                v \<notin> {y. \<exists>x. dim_vec x = n \<and> f x \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}}"
          using x_n_x' dx'
          unfolding boolean_functions.not_def
          unfolding ceros_of_boolean_input_def apply simp apply (intro conjI)
           apply auto[1]
          by (smt (verit) dim_vec eq_vecI mem_Collect_eq notfx')
      qed
    qed
  next
    show "{univ_n - x |x.
            x \<in> {v \<in> Pow {0..<n}.
           v \<notin> {y. \<exists>x. dim_vec x = n \<and> f x \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}}}
        \<subseteq> {y. \<exists>x. dim_vec x = n \<and>
               \<not> f (vec (dim_vec x) (\<lambda>n. \<not> x $ n)) \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}"
    proof (rule subsetI)
      fix x :: "nat set"
      assume x: "x \<in> {univ_n - x |x.
              x \<in> {v \<in> Pow {0..<n}.
                    v \<notin> {y. \<exists>x. dim_vec x = n \<and>
                                 f x \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}}}"
      then obtain x' where x'_def: "x = univ_n - x'"
                      and x'_complement: "simplex_complement x' = x"
                      and x'_simplice: "x' \<in> Pow {0..<n}"
                      and x'_compliment: "x' \<notin> {y. \<exists>x. dim_vec x = n \<and>
                                 f x \<and> {xa. xa < dim_vec x \<and> x $ xa = False} = y}"
            unfolding simplex_complement_def
        by auto
      show "x \<in> {y. \<exists>x. dim_vec x = n \<and>
                      \<not> f (vec (dim_vec x) (\<lambda>n. \<not> x $ n)) \<and>
                      {xa. xa < dim_vec x \<and> x $ xa = False} = y}"
      proof (rule CollectI,
              rule exI [of _ "(bool_vec_from_simplice (simplex_complement x'))"],
                rule conjI3)
        show "dim_vec (bool_vec_from_simplice (simplex_complement x')) = n"
          by (metis dim_vec simplicial_complex.bool_vec_from_simplice_def)
        show "\<not> f (vec (dim_vec (bool_vec_from_simplice (simplex_complement x')))
           (\<lambda>n. \<not> bool_vec_from_simplice (simplex_complement x') $ n))"
          unfolding x'_complement using x
          unfolding bool_vec_from_simplice_def
          unfolding dim_vec by fastforce
        show "{xa. xa < dim_vec (bool_vec_from_simplice (simplex_complement x')) \<and>
                bool_vec_from_simplice (simplex_complement x') $ xa = False} = x"
          using x'_complement x'_simplice
          unfolding bool_vec_from_simplice_def
          unfolding ceros_of_boolean_input_def
          unfolding simplex_complement_def
          using simplex_complement_simplex
          using ceros_of_boolean_input_in_set by auto
     qed
  qed
qed

lemma
  not_bool_vec_impl_not_simpl_compl:
  assumes v: "v \<in> carrier_vec n"
    and v_notin: "boolean_functions.not v \<notin> bool_vec_set_from_simplice_set s"
  shows "simplex_complement (ceros_of_boolean_input v) \<notin> s"
  using v v_notin
  unfolding bool_vec_set_from_simplice_set_def
  unfolding bool_vec_from_simplice_def
  unfolding ceros_of_boolean_input_def
  unfolding simplex_complement_def
  using boolean_functions.dim_vec_not [OF carrier_vecD [OF v]] carrier_vecD [OF v]
  using boolean_functions.not_def [of v]
  by auto (fastforce)

lemma
  boolean_function_Alexander_dual_equals:
  assumes s: "simplicial_complex s"
  and v: "v \<in> carrier_vec n"
  shows "boolean_functions.Alexander_dual (boolean_function_from_simplicial_complex s) v
    = boolean_function_from_simplicial_complex (Alexander_dual s) v"
proof (cases "s = {}")
case True
  show ?thesis
    unfolding True
    unfolding boolean_functions.Alexander_dual_def
    unfolding Alexander_dual_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding boolean_functions.not_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding bool_vec_from_simplice_def
    unfolding ceros_of_boolean_input_def
    unfolding simplex_complement_def
    unfolding nofaces_simplicial_complex_def
    unfolding simplices_def
    unfolding carrier_vecD [OF v]
  proof (standard, safe, simp_all add: carrier_vecD [OF v])
    show "\<exists>k. (\<exists>x. k = univ_n - x \<and> x \<subseteq> {0..<n}) \<and> v = vec n (\<lambda>i. i \<notin> k)"
    proof (rule exI [of _ "(ceros_of_boolean_input v)"], rule conjI,
        rule exI [of _ "simplex_complement (ceros_of_boolean_input v)"], rule conjI)
      show "ceros_of_boolean_input v = univ_n - simplex_complement (ceros_of_boolean_input v)"
        by (metis simplex_complement_def
            simplicial_complex.simplex_complement_idempotent v vec_in_simplices)
      show "simplex_complement (ceros_of_boolean_input v) \<subseteq> {0..<n}"
        by (metis PowD simplex_complement_simplex simplices_def v vec_in_simplices)
      show "v = vec n (\<lambda>i. i \<notin> ceros_of_boolean_input v)"
        using v unfolding ceros_of_boolean_input_def by auto
    qed
  qed
  next
  case False
  note s_nempty = False
  show ?thesis
  proof
  assume A: "boolean_functions.Alexander_dual (boolean_function_from_simplicial_complex s) v"
  from A have v_nin_s: "boolean_functions.not v \<notin> bool_vec_set_from_simplice_set s"
    unfolding boolean_functions.Alexander_dual_def
    unfolding boolean_function_from_simplicial_complex_def .
  from v_nin_s have simp_compl_v_notin: "simplex_complement (ceros_of_boolean_input v) \<notin> s"
    using not_bool_vec_impl_not_simpl_compl [OF v, of s] by fast
  from A and v and s_nempty obtain k
    where ks: "k \<in> s" and v_ne_k: "(\<lambda>n. \<not> v $ n) \<noteq> (\<lambda>i. i \<notin> k)"
     unfolding boolean_functions.Alexander_dual_def
     unfolding boolean_functions.not_def
     unfolding boolean_function_from_simplicial_complex_def
     unfolding bool_vec_set_from_simplice_set_def
     unfolding bool_vec_from_simplice_def
     unfolding ceros_of_boolean_input_def
     by fastforce
  show "boolean_function_from_simplicial_complex (Alexander_dual s) v"
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding bool_vec_from_simplice_def
    unfolding Alexander_dual_def
   proof (rule CollectI, rule conjI)
    show "dim_vec v = n" using v by simp
    show "\<exists>k\<in>{simplex_complement x |x. x \<in> nofaces_simplicial_complex s}.
               v = vec n (\<lambda>i. i \<notin> k)"
    proof (rule bexI [of _ "(ceros_of_boolean_input v)"])
     show "v = vec n (\<lambda>i. i \<notin> (ceros_of_boolean_input v))"
     proof (intro eq_vecI)
      show "dim_vec v = dim_vec (vec n (\<lambda>i. i \<notin> (ceros_of_boolean_input v)))"
       using v by simp
       fix i
       assume "i < dim_vec (vec n (\<lambda>i. i \<notin> (ceros_of_boolean_input v)))"
       hence iln: "i < n" using v by simp
       have "(vec_index v) i = (\<lambda>i. i \<notin> (ceros_of_boolean_input v)) i"
        unfolding ceros_of_boolean_input_def
        using iln v by auto
       then show "v $ i = vec n (\<lambda>i. i \<notin> (ceros_of_boolean_input v)) $ i"
        by (metis iln index_vec)
       qed
       show "ceros_of_boolean_input v
            \<in> {simplex_complement x |x. x \<in> nofaces_simplicial_complex s}"
       proof (rule CollectI,
              rule exI [of _ "simplex_complement (ceros_of_boolean_input v)"], rule conjI)
       show "ceros_of_boolean_input v =
         simplex_complement (simplex_complement (ceros_of_boolean_input v))"
         using simplex_complement_idempotent [
             OF simplicial_complex.vec_in_simplices [OF v]] .
        show "simplex_complement (ceros_of_boolean_input v) \<in> nofaces_simplicial_complex s"
         unfolding simplex_complement_def
         unfolding ceros_of_boolean_input_def
         unfolding nofaces_simplicial_complex_def
         unfolding simplices_def
         using ks v_ne_k simp_compl_v_notin
         unfolding ceros_of_boolean_input_def
         unfolding simp_compl_v_notin simplex_complement_def by auto
        qed
      qed
    qed
  next
  assume A: "boolean_function_from_simplicial_complex (Alexander_dual s) v"
  from A obtain k where k: "k \<in> {simplex_complement x |x. x \<in> nofaces_simplicial_complex s}"
               and v_eq_k: "v = bool_vec_from_simplice k"
    unfolding Alexander_dual_def
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def by blast
  from v_eq_k have vec_index_eq_k: "\<And>j. j < n \<Longrightarrow> (\<lambda>i. v $ i) j = (\<lambda>i. i \<notin> k) j"
    by (metis index_vec simplicial_complex.bool_vec_from_simplice_def v_eq_k)
  from k and v_eq_k obtain x where k_sc: "k = simplex_complement x"
    and x_noface: "x \<in> nofaces_simplicial_complex s"
    and v_bool_vec_sc: "v = bool_vec_from_simplice (simplex_complement x)"
    by blast
  show "boolean_functions.Alexander_dual (boolean_function_from_simplicial_complex s) v"
    unfolding boolean_function_from_simplicial_complex_def
    unfolding bool_vec_set_from_simplice_set_def
    unfolding bool_vec_from_simplice_def
    unfolding boolean_functions.Alexander_dual_def
    unfolding boolean_functions.not_def
  proof (standard, safe)
    fix l
    assume "n = dim_vec (vec (dim_vec v) (\<lambda>n. \<not> v $ n))"
         and lins: "l \<in> s"
         and  "vec (dim_vec v) (\<lambda>n. \<not> v $ n) =
          vec (dim_vec (vec (dim_vec v) (\<lambda>n. \<not> v $ n))) (\<lambda>i. i \<notin> l)"
    hence vec_eq: "vec n (\<lambda>n. \<not> v $ n) = vec n (\<lambda>i. i \<notin> l)" using v by simp
    hence vec_index_eq_l: "\<And>j. j < n \<Longrightarrow> (\<lambda>n. \<not> v $ n) j = (\<lambda>i. i \<notin> l) j"
      by (metis index_vec)
    show False
      using vec_index_eq_l
      using vec_index_eq_k using k using lins
      by (metis DiffE Pow_iff k_sc lessThan_iff s simpl_compl_not_in simpl_compl_simplice simplex_complement_def simplice_complement simplicial_complex.simplicial_complex_def subsetD subsetI x_noface)
  qed
 qed
qed

end

end


theory Distinct_Inverse
imports FreeGroupMain Cancellation  UniversalProperty
begin

lemma cancels_transfer:
assumes "i > 0"
 and "cancels_to_1_at i (a#b#x) (a#y)"
 and "b \<noteq> inverse a"
shows "cancels_to_1_at (i - 1) (b#x) y"
  using assms
 proof(cases x)
   case Nil
   with assms show ?thesis unfolding cancels_to_1_at_def cancel_at_def by force
 next
   case (Cons c list)
   have i:"i - 1 \<ge> 0" by auto
   moreover then have "1 + (i - 1) < length (b # x)" using assms unfolding cancels_to_1_at_def
     by simp
   moreover then have "inverse ((b # x) ! (i - 1)) = (b # x) ! (1 + (i - 1))"
     using i  assms unfolding cancels_to_1_at_def cancel_at_def by simp
   moreover then have "y = take (i - 1) (b # x) @ drop (2 + (i - 1)) (b # x)"
     using i assms Cons unfolding cancels_to_1_at_def cancel_at_def
     by (metis One_nat_def Suc_pred append_Cons drop_Suc_Cons drop_drop gr_implies_not_zero list.sel(3) take_Cons')
   ultimately show ?thesis  unfolding cancels_to_1_at_def cancel_at_def by argo
 qed

lemma non_reduced_words_cancel:
  "\<not>(reduced wrd) \<longleftrightarrow> (\<exists>x. cancels_to_1 wrd x)"
proof
  assume asm:"\<not> (reduced wrd)"
  show "(\<exists>x. cancels_to_1 wrd x)"
    using asm
  proof(induction wrd rule:reduced.induct)
  case (3 g h wrd)
  then show ?case
  proof(cases "inverse g = h")
    case True
    then have "cancels_to_1_at 0 (g#h#wrd) wrd" using  Cons
        unfolding  cancels_to_1_at_def[of 0 "g#h#wrd" wrd]
        unfolding cancel_at_def take.simps(1) by simp
    then show ?thesis unfolding cancels_to_1_def by blast
  next
    case False
    then have "g \<noteq> inverse h" using False
      by (metis inverse_of_inverse)
    then obtain x i where "cancels_to_1_at i (h#wrd) x" using 3 unfolding cancels_to_1_def by fastforce
    then have "cancels_to_1_at (i+1) (g#h#wrd) (g#x)" unfolding cancels_to_1_at_def
      by (metis Suc_eq_plus1 add.assoc add_less_cancel_left append.simps(2) cancel_at_def drop_Suc_Cons length_Cons nth_Cons_Suc plus_1_eq_Suc take_Suc_Cons zero_le)
    then show ?thesis using cancels_transfer unfolding cancels_to_1_def by blast
  qed
  qed (auto)+
next
  assume asm:"\<exists>x. cancels_to_1 wrd x"
  show "\<not>(reduced wrd)"
    using asm
  proof(induction wrd rule:reduced.induct)
    case 1
    then show ?case unfolding cancels_to_1_def cancels_to_1_at_def by simp
  next
    case (2 g)
    then show ?case unfolding cancels_to_1_def cancels_to_1_at_def by simp
  next
    case (3 g h wrd)
    then show ?case
    proof(cases "g = inverse h")
      case False
      then have False':"h \<noteq> inverse g"
        using inverse_of_inverse by blast
      obtain x i where x_i:"cancels_to_1_at i (g#h#wrd) x"  using 3(2) unfolding cancels_to_1_def
        by fast
      then have i:"i > 0" using False
        by (metis cancels_to_1_at_def gr0I inverse_of_inverse nth_Cons_0 nth_Cons_Suc plus_1_eq_Suc)
      obtain y where y:"x = g # y"
        using x_i i  unfolding cancels_to_1_at_def
        cancel_at_def
        by (simp add: take_Cons')
      then have "cancels_to_1_at (i - 1) (h#wrd) y" using x_i cancels_transfer[of i g h wrd y] False'
        i by fastforce
      then have "\<not>(reduced (h#wrd))" using 3(1)[OF False] unfolding cancels_to_1_def by fast
      then show ?thesis by simp
    qed(auto)
  qed
qed

lemma not_reduced_sublist:
  assumes "\<not> (reduced ys)"
  shows "\<not> (reduced (xs@ys))"
  using assms
proof(induction xs rule:reduced.induct)
  case (2 g)
  then show ?case
    by (metis append_Cons append_Nil list.exhaust reduced.simps(1) reduced.simps(3))
next
  case (3 g h wrd)
  then show ?case by (cases "g = inverse h", simp, simp add:3)
qed (simp)

lemma reduced_reverse:
  assumes "reduced (xs@[x])"
      and "reduced (y#ys)"
      and "x \<noteq> inverse y"
    shows "reduced (xs@[x]@(y#ys))"
proof(rule ccontr)
  assume asm:"\<not> (reduced (xs@[x]@(y#ys)))"
  then obtain wrd where wrd:"cancels_to_1 (xs@[x]@(y#ys)) wrd"
    using  non_reduced_words_cancel by blast
  then obtain i where i:"cancels_to_1_at i (xs@[x]@(y#ys)) wrd"
    unfolding cancels_to_1_def by blast
  then show False
  proof(cases "i < length (xs)")
    case True
    hence "((xs@[x]) ! i) =  (xs@[x]@(y#ys))!i" using i unfolding cancels_to_1_at_def
      by (simp add: nth_append)
    moreover have "(xs @[x])! (i+ 1) =  (xs@[x]@(y#ys))!(i+1)"  using i unfolding cancels_to_1_at_def
      by (metis True append_Cons discrete le_neq_implies_less nth_append nth_append_length)
    ultimately have "inverse ((xs@[x])!i) = (xs@[x])!(i+1)" using  i True unfolding cancels_to_1_at_def
      by (metis Suc_eq_plus1  plus_1_eq_Suc)
    then have  inv:"((xs@[x])!i) = inverse ((xs@[x])!(i+1))" using inverse_of_inverse by metis
    then have "drop i (xs@[x]) = ((xs@[x])!i)#((xs@[x])!(i+1))#(drop (i + 2) (xs@[x]))"
      using True
      by (metis Cons_nth_drop_Suc Suc_eq_plus1 add_Suc_right discrete le_imp_less_Suc length_append_singleton less_imp_le_nat nat_1_add_1)
    then have nr_drop_i: "\<not> reduced (drop i (xs@[x]))"
      using inv
      by simp
    moreover have "(xs@[x]) = (take i (xs@[x]))@(drop i (xs@[x]))"
      using True by simp
    then have "\<not> reduced (xs@[x])" using nr_drop_i not_reduced_sublist by metis
    then show ?thesis using assms(1) by argo
  next
    case False
    then have i_len:"i \<ge> length xs" by auto
    then show ?thesis
    proof(cases "i = length xs")
      case True
      hence "x =  (xs@[x]@(y#ys))!i" using i unfolding cancels_to_1_at_def
       by (simp add: nth_append)
      moreover have "y =  (xs@[x]@(y#ys))!(i+1)"  using i unfolding cancels_to_1_at_def
        by (metis CancelLemmas.length_Cons True add_cancel_right_left list.size(3) nth_append_length nth_append_length_plus)
      ultimately have "inverse x = y" using  i True unfolding cancels_to_1_at_def
       by (metis Suc_eq_plus1  plus_1_eq_Suc)
      then have  inv:"x = inverse y" using inverse_of_inverse by metis
      then show False using assms(3) by argo
    next
      case False
      define j where "j = i - length xs - 1"
      have i_len:"i > length xs" using i_len False by linarith
      hence "([y]@ys) !(i - length xs - 1) =  (xs@[x]@(y#ys))!i" using i unfolding cancels_to_1_at_def
        by (metis (no_types, hide_lams) add.commute add_less_le_mono append.assoc append.simps(1) append_Cons diff_diff_eq discrete length_append_singleton nat_less_le nth_append plus_1_eq_Suc)
      moreover have "([y]@ys)! (i - length xs) =  (xs@[x]@(y#ys))!(i+1)"  using i i_len
        unfolding cancels_to_1_at_def
        by (smt (z3) Nat.le_imp_diff_is_add add_diff_cancel_left' append_Cons append_self_conv2 diff_commute diff_is_0_eq' diffs0_imp_equal le_add1 nat_less_le nth_Cons' nth_append)
      ultimately have "inverse (([y]@ys)!j) = ([y]@ys)!(j+1)" using  i False  unfolding cancels_to_1_at_def
      j_def
        by (metis One_nat_def Suc_eq_plus1 Suc_pred i_len plus_1_eq_Suc zero_less_diff)
     then have  inv:"(([y]@ys)!j) = inverse (([y]@ys)!(j+1))" using inverse_of_inverse by metis
    then have "drop j ([y]@ys) = (([y]@ys)!j)#(([y]@ys)!(j+1))#(drop (j + 2) ([y]@ys))"
      using False i unfolding j_def cancels_to_1_at_def
      by (smt (verit, ccfv_threshold) Cons_nth_drop_Suc add.commute add_Suc_right add_lessD1 add_less_cancel_left discrete i_len le_add_diff_inverse length_Cons length_append linorder_not_less nat_1_add_1 plus_1_eq_Suc)
    then have nr_drop_i: "\<not> reduced (drop j ([y]@ys))"
      using inv
      by simp
    moreover have "([y]@ys) = (take j ([y]@ys))@(drop j ([y]@ys))"
      using False unfolding j_def by simp
    then have "\<not> reduced ([y]@ys)" using nr_drop_i not_reduced_sublist by metis
    then show ?thesis using assms(2) by force
    qed
  qed
qed

lemma reduced_wordinverses:
  assumes "reduced x"
  shows "reduced (wordinverse x)"
  using assms
proof(induction x rule: reduced.induct)
  case 1
  then show ?case by auto
next
  case (2 g)
then show ?case by simp
next
  case (3 g h wrd)
  then have "reduced (wordinverse (h#wrd))"by force
  then have "reduced ((wordinverse wrd)@[inverse h])" by fastforce
  moreover have "reduced ((inverse g)#[])" by auto
  moreover have "inverse h \<noteq> inverse (inverse g)" using inverse_of_inverse 3(2)
    by (metis reduced.simps(3))
  ultimately show ?case using reduced_reverse by fastforce
qed

(* Use reflection somewhere
To prove the following, do the following:
use uncylce
  a. show that first and last elements are the same
  b. show that reduced by knocking off first and last letters is still reduced
  c. do a case analysis for off and even words. *)

lemma eq_wordinv_imp:
  assumes "xs = wordinverse xs"
   "reduced xs"
  shows "xs = []"
proof(cases xs)
  case (Cons y ys)
  then show ?thesis
  proof(cases "even (length xs)")
    case True
    obtain n where n:"length xs = 2*n" using True by auto
    then have "xs ! (n-1) = inverse (xs! n)" using True Cons
         assms(1) wordinverse_redef2[of xs]
      by (smt (z3) One_nat_def Suc_pred add_diff_cancel_right' discrete length_greater_0_conv length_rev less_add_same_cancel2 less_imp_le_nat list.simps(3) mult_2 neq0_conv nth_map rev_nth)
    then have "cancels_to_1  xs ((take (n-1) xs)@(drop (n+1) xs))"
      unfolding cancels_to_1_def cancels_to_1_at_def using n Cons
      by (metis Cons_nth_drop_Suc One_nat_def Suc_eq_plus1 add_lessD1 assms(2) discrete id_take_nth_drop le_add_diff_inverse2 length_greater_0_conv less_add_same_cancel2 list.simps(3) mult_2 nat_0_less_mult_iff not_reduced_sublist reduced.simps(3))
    then have "\<not> (reduced xs)" using non_reduced_words_cancel by auto
    then show ?thesis using assms(2) by blast
  next
    case False
    obtain n where n:"length xs = 2*n + 1" using Cons False by auto
    then have "xs ! n = inverse (xs ! n)" using  Cons
         assms(1) wordinverse_redef2[of xs]
      by (metis (no_types, lifting) Suc_eq_plus1 add_diff_cancel_right' combine_common_factor discrete le_add2 length_rev mult.left_neutral nth_map one_add_one rev_nth)
    then have " True = False"
      apply (cases "snd (xs!n)")
      apply(simp)
      apply (metis inverse.simps(1) prod.collapse snd_conv)
      by (metis inverse.simps(2) sndI surjective_pairing)
    then show ?thesis using Cons by simp
  qed
qed (auto)

lemma red_repelem:
  assumes "w \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
  shows "\<exists>x \<in> w. reduced x \<and> ((reln_tuple \<langle>S\<rangle>)`` {x} = w)"
proof-
  obtain c where c: "w = (reln_tuple \<langle>S\<rangle>) `` {c}" by (meson assms quotientE)
  then have cs: "c \<in> \<langle>S\<rangle>" using assms by (metis proj_def proj_in_iff reln_equiv)
  obtain rc where rc: "rc = (iter (length c) reduce c)" by simp
  then have "reduced rc" by (simp add: reduced_iter_length)
  then have "c ~ rc" using rc cancels_imp_rel iter_cancels_to by auto
  moreover then have "rc \<in> \<langle>S\<rangle>" using cs rc using cancels_to_preserves iter_cancels_to by blast
  ultimately have crc: "(c, rc) \<in> reln_tuple \<langle>S\<rangle>" using cs reln_tuple_def by auto
  then have "((reln_tuple \<langle>S\<rangle>)`` {rc} = w)"using c by (smt (verit, ccfv_SIG) equiv_class_eq_iff reln_equiv)
  moreover then have "rc \<in> w" using c crc by simp
  ultimately show ?thesis using \<open>reduced rc\<close> by auto
qed

lemma(in group) not_eq_id:
  assumes  "x \<in> carrier (freegroup S)"
    and "x \<noteq> \<one>\<^bsub>(freegroup S)\<^esub>"
  shows "[] \<notin> x"
  using assms unfolding freegroup_def reln_tuple_def quotient_def
  apply (simp)
proof(rule ccontr)
  assume " \<not> [] \<notin> x"
  then have in_x:"[] \<in> x" by auto
  moreover have in_S:"[] \<in> \<langle>S\<rangle>"  unfolding freewords_on_def
    by (simp add: words_on.empty)
  obtain xa where xa:"x = {y. xa ~ y \<and> y \<in> \<langle>S\<rangle>}" "xa \<in>  \<langle>S\<rangle>"
    using assms unfolding freegroup_def reln_tuple_def quotient_def
    by (simp, blast)
  then have eq_xa:" xa ~ []" using in_x in_S by simp
  then have "x = \<one>\<^bsub>(freegroup S)\<^esub>"
    unfolding freegroup_def reln_tuple_def quotient_def apply (simp)
  proof
    {fix a
     assume asm:"a \<in> x"
     then have a_prop:"xa ~ a" "a \<in> \<langle>S\<rangle>" using xa by simp+
     then have "a ~ []" using eq_xa
       using reln.sym reln.trans by blast
     then have "a \<in> {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>}"
       using in_S a_prop(2) reln.sym by force}
   then show " x \<subseteq> {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>}" by blast
 next
    {fix a
     assume asm:"a \<in> {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>}"
     then have a_prop:"[] ~ a" "a \<in> \<langle>S\<rangle>" using xa by simp+
     then have "a ~ xa" using eq_xa
       using reln.sym reln.trans by blast
     then have "a \<in> x"
       using in_S a_prop(2) xa reln.sym by force}
   then show " {y. [] ~ y \<and> [] \<in> \<langle>S\<rangle> \<and> y \<in> \<langle>S\<rangle>} \<subseteq> x" by blast
 qed
  then show False using assms(2) by simp
qed

lemma(in group) not_eq_inv:
  assumes "x \<in> carrier (freegroup S)" "x \<noteq> \<one>\<^bsub>(freegroup S)\<^esub>"
  shows "x \<noteq> inv\<^bsub>(freegroup S)\<^esub> x"
proof
  assume asm:"x = inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> x"
  obtain g where g:"x =  (reln_tuple \<langle>S\<rangle>) `` {g}" "g \<in> \<langle>S\<rangle>" "reduced g"
    using assms red_repelem unfolding freegroup_def reln_tuple_def apply simp
    by auto
  moreover have g_inv:"inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> x = (reln_tuple \<langle>S\<rangle>) `` {wordinverse g}"
    using wordinverse_inv[OF assms(1) g(1)] .
  moreover have red_g_inv:"reduced (wordinverse g)"
    using assms(1) g(1,3) wordinverse_inv
    by (simp add:  reduced_wordinverses)
  have " g \<in> (reln_tuple \<langle>S\<rangle>) `` {g}" using asm g(1,2)
    unfolding reln_tuple_def Image_def apply(simp)
    by auto
  moreover then  have "g \<in> (reln_tuple \<langle>S\<rangle>) `` {wordinverse g}"
    using asm g_inv g g(2) by auto
  then have "wordinverse g ~ g"  using g(1) unfolding reln_tuple_def Image_def
    by simp
  then have "g ~ wordinverse g" using reln.simps by auto
  then have "cancels_eq g (wordinverse g)" using reln_imp_cancels by auto
  then have "g = wordinverse g" using g(3) red_g_inv reduced_cancel_eq by auto
  then have "g = []" using eq_wordinv_imp g(3) red_g_inv by blast
  show False using assms not_eq_id g
    using \<open>g = []\<close> \<open>g \<in> reln_tuple \<langle>S\<rangle> `` {wordinverse g}\<close> by auto
qed

end