section "A Typed Language"

theory Types imports Star Complex_Main begin

text \<open>We build on \<^theory>\<open>Complex_Main\<close> instead of \<^theory>\<open>Main\<close> to access
the real numbers.\<close>

subsection "Arithmetic Expressions"

datatype val = Iv int | Rv real

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{aexptDef}{0}{2}{%\<close>
datatype aexp =  Ic int | Rc real | V vname | Plus aexp aexp
text_raw\<open>}%endsnip\<close>

inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"taval (Ic i) s (Iv i)" |
"taval (Rc r) s (Rv r)" |
"taval (V x) s (s x)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2)
 \<Longrightarrow> taval (Plus a1 a2) s (Iv(i1+i2))" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2)
 \<Longrightarrow> taval (Plus a1 a2) s (Rv(r1+r2))"

inductive_cases [elim!]:
  "taval (Ic i) s v"  "taval (Rc i) s v"
  "taval (V x) s v"
  "taval (Plus a1 a2) s v"

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
"tbval (Bc v) s v" |
"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 & bv2)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2) \<Longrightarrow> tbval (Less a1 a2) s (i1 < i2)" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2) \<Longrightarrow> tbval (Less a1 a2) s (r1 < r2)"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Rty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
Rc_ty: "\<Gamma> \<turnstile> Rc r : Rty" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

declare atyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

text\<open>Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity.\<close>

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50)
where
B_ty: "\<Gamma> \<turnstile> Bc v" |
Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
Less_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"

declare btyping.intros [intro!]
inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: atyping.induct)
apply (fastforce simp: styping_def)+
done

lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
proof(induction rule: atyping.induct)
  case (Plus_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2" by blast
  show ?case
  proof (cases v1)
    case Iv
    with Plus_ty v show ?thesis
      by(fastforce intro: taval.intros(4) dest!: apreservation)
  next
    case Rv
    with Plus_ty v show ?thesis
      by(fastforce intro: taval.intros(5) dest!: apreservation)
  qed
qed (auto intro: taval.intros)

lemma bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
proof(induction rule: btyping.induct)
  case (Less_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
    by (metis aprogress)
  show ?case
  proof (cases v1)
    case Iv
    with Less_ty v show ?thesis
      by (fastforce intro!: tbval.intros(4) dest!:apreservation)
  next
    case Rv
    with Less_ty v show ?thesis
      by (fastforce intro!: tbval.intros(5) dest!:apreservation)
  qed
qed (auto intro: tbval.intros)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign aprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where "tbval b s bv" by (metis bprogress)
  show ?case
  proof(cases bv)
    assume "bv"
    with \<open>tbval b s bv\<close> show ?case by simp (metis IfTrue)
  next
    assume "\<not>bv"
    with \<open>tbval b s bv\<close> show ?case by simp (metis IfFalse)
  qed
next
  case While_ty show ?case by (metis While)
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
by (metis styping_preservation ctyping_preservation)

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section \<open>The Polynomial Factorization Algorithm\<close>

subsection \<open>Factoring Square-Free Integer Polynomials\<close>

text \<open>We combine all previous results, i.e., Berlekamp's algorithm, Hensel-lifting, the reconstruction
  of Zassenhaus, Mignotte-bounds, etc., to eventually assemble the factorization algorithm for
  integer polynomials.\<close>

theory Berlekamp_Zassenhaus
imports
  Berlekamp_Hensel
  Polynomial_Factorization.Gauss_Lemma
  Polynomial_Factorization.Dvd_Int_Poly
  Reconstruction
  Suitable_Prime
  Degree_Bound
  Code_Abort_Gcd
begin

context
begin
private partial_function (tailrec) find_exponent_main :: "int \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> nat" where
  [code]: "find_exponent_main p pm m bnd = (if pm > bnd then m
    else find_exponent_main p (pm * p) (Suc m) bnd)"

definition find_exponent :: "int \<Rightarrow> int \<Rightarrow> nat" where
  "find_exponent p bnd = find_exponent_main p p 1 bnd"

lemma find_exponent: assumes p: "p > 1"
  shows "p ^ find_exponent p bnd > bnd" "find_exponent p bnd \<noteq> 0"
proof -
  {
    fix m and n
    assume "n = nat (1 + bnd - p^m)" and "m \<ge> 1"
    hence "bnd < p ^ find_exponent_main p (p^m) m bnd \<and> find_exponent_main p (p^m) m bnd \<ge> 1"
    proof (induct n arbitrary: m rule: less_induct)
      case (less n m)
      note simp = find_exponent_main.simps[of p "p^m"]
      show ?case
      proof (cases "bnd < p ^ m")
        case True
        thus ?thesis using less unfolding simp by simp
      next
        case False
        hence id: "find_exponent_main p (p ^ m) m bnd = find_exponent_main p (p ^ Suc m) (Suc m) bnd"
          unfolding simp by (simp add: ac_simps)
        show ?thesis unfolding id
          by (rule less(1)[OF _ refl], unfold less(2), insert False p, auto)
      qed
    qed
  }
  from this[OF refl, of 1]
  show "p ^ find_exponent p bnd > bnd" "find_exponent p bnd \<noteq> 0"
    unfolding find_exponent_def by auto
qed

end

definition berlekamp_zassenhaus_factorization :: "int poly \<Rightarrow> int poly list" where
  "berlekamp_zassenhaus_factorization f = (let
     \<comment> \<open>find suitable prime\<close>
     p = suitable_prime_bz f;
     \<comment> \<open>compute finite field factorization\<close>
     (_, fs) = finite_field_factorization_int p f;
     \<comment> \<open>determine maximal degree that we can build by multiplying at most half of the factors\<close>
     max_deg = degree_bound fs;
     \<comment> \<open>determine a number large enough to represent all coefficients of every\<close>
     \<comment> \<open>factor of \<open>lc * f\<close> that has at most degree most \<open>max_deg\<close>\<close>
     bnd = 2 * \<bar>lead_coeff f\<bar> * factor_bound f max_deg;
     \<comment> \<open>determine \<open>k\<close> such that \<open>p^k > bnd\<close>\<close>
     k = find_exponent p bnd;
     \<comment> \<open>perform hensel lifting to lift factorization to mod \<open>p^k\<close>\<close>
     vs = hensel_lifting p k f fs
     \<comment> \<open>reconstruct integer factors\<close>
   in zassenhaus_reconstruction vs p k f)"

theorem berlekamp_zassenhaus_factorization_irreducible\<^sub>d:
  assumes res: "berlekamp_zassenhaus_factorization f = fs"
  and sf: "square_free f"
  and deg: "degree f > 0"
  shows "f = prod_list fs \<and> (\<forall> fi \<in> set fs. irreducible\<^sub>d fi)"
proof -
  let ?lc = "lead_coeff f"
  define p where "p \<equiv> suitable_prime_bz f"
  obtain c gs where berl: "finite_field_factorization_int p f = (c,gs)" by force
  let ?degs = "map degree gs"
  note res = res[unfolded berlekamp_zassenhaus_factorization_def Let_def, folded p_def,
    unfolded berl split, folded]
  from suitable_prime_bz[OF sf refl]
  have prime: "prime p" and cop: "coprime ?lc p" and sf: "poly_mod.square_free_m p f"
    unfolding p_def by auto
  from prime interpret poly_mod_prime p by unfold_locales
  define n where "n = find_exponent p (2 * abs ?lc * factor_bound f (degree_bound gs))"
  note n = find_exponent[OF m1, of "2 * abs ?lc * factor_bound f (degree_bound gs)",
    folded n_def]
  note bh = berlekamp_and_hensel_separated[OF cop sf refl berl n(2)]
  have db: "degree_bound (berlekamp_hensel p n f) = degree_bound gs" unfolding bh
    degree_bound_def max_factor_degree_def by simp
  note res = res[folded n_def bh(1)]
  show ?thesis
    by (rule zassenhaus_reconstruction_irreducible\<^sub>d[OF prime cop sf deg refl _ res], insert n db, auto)
qed

corollary berlekamp_zassenhaus_factorization_irreducible:
  assumes res: "berlekamp_zassenhaus_factorization f = fs"
    and sf: "square_free f"
    and pr: "primitive f"
    and deg: "degree f > 0"
  shows "f = prod_list fs \<and> (\<forall> fi \<in> set fs. irreducible fi)"
  using pr irreducible_primitive_connect[OF primitive_prod_list]
    berlekamp_zassenhaus_factorization_irreducible\<^sub>d[OF res sf deg] by auto

end


chapter\<open>Formalizing Provability\<close>

theory Pf_Predicates
imports Coding_Predicates
begin

section \<open>Section 4 Predicates (Leading up to Pf)\<close>

subsection \<open>The predicate \<open>SentP\<close>, for the Sentiential (Boolean) Axioms\<close>

definition Sent_axioms :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool" where
 "Sent_axioms x y z w \<equiv>
             x = q_Imp y y \<or>
             x = q_Imp y (q_Disj y z) \<or>
             x = q_Imp (q_Disj y y) y \<or>
             x = q_Imp (q_Disj y (q_Disj z w)) (q_Disj (q_Disj y z) w) \<or>
             x = q_Imp (q_Disj y z) (q_Imp (q_Disj (q_Neg y) w) (q_Disj z w))"

definition Sent :: "hf set" where
 "Sent \<equiv> {x. \<exists>y z w. Form y \<and> Form z \<and> Form w \<and> Sent_axioms x y z w}"

nominal_function SentP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom y \<sharp> (z,w,x); atom z \<sharp> (w,x); atom w \<sharp> x\<rbrakk> \<Longrightarrow>
    SentP x = Ex y (Ex z (Ex w (FormP (Var y) AND FormP (Var z) AND FormP (Var w) AND
               ( (x EQ Q_Imp (Var y) (Var y)) OR
                 (x EQ Q_Imp (Var y) (Q_Disj (Var y) (Var z)) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Var y)) (Var y)) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Q_Disj (Var z) (Var w)))
                             (Q_Disj (Q_Disj (Var y) (Var z)) (Var w))) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Var z))
                             (Q_Imp (Q_Disj (Q_Neg (Var y)) (Var w)) (Q_Disj (Var z) (Var w)))))))))"
  by (auto simp: eqvt_def SentP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SentP_fresh_iff [simp]: "a \<sharp> SentP x \<longleftrightarrow> a \<sharp> x"                  (is ?thesis1)
   and eval_fm_SentP [simp]:   "eval_fm e (SentP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> Sent"    (is ?thesis2)
   and SentP_sf [iff]:         "Sigma_fm (SentP x)"                     (is ?thsf)
proof -
  obtain y::name and z::name and w::name  where "atom y \<sharp> (z,w,x)" "atom z \<sharp> (w,x)" "atom w \<sharp> x"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: Sent_def Sent_axioms_def q_defs)
qed

subsection \<open>The predicate \<open>Equality_axP\<close>, for the Equality Axioms\<close>

definition Equality_ax :: "hf set" where
 "Equality_ax \<equiv> { \<lbrakk>\<guillemotleft>refl_ax\<guillemotright>\<rbrakk>e0, \<lbrakk>\<guillemotleft>eq_cong_ax\<guillemotright>\<rbrakk>e0, \<lbrakk>\<guillemotleft>mem_cong_ax\<guillemotright>\<rbrakk>e0, \<lbrakk>\<guillemotleft>eats_cong_ax\<guillemotright>\<rbrakk>e0 }"

function Equality_axP :: "tm \<Rightarrow> fm"
  where "Equality_axP x =
    x EQ \<guillemotleft>refl_ax\<guillemotright> OR x EQ \<guillemotleft>eq_cong_ax\<guillemotright> OR x EQ \<guillemotleft>mem_cong_ax\<guillemotright> OR x EQ \<guillemotleft>eats_cong_ax\<guillemotright>"
by auto

termination
  by lexicographic_order

lemma eval_fm_Equality_axP [simp]: "eval_fm e (Equality_axP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> Equality_ax"
  by (auto simp: Equality_ax_def intro: eval_quot_fm_ignore)

subsection \<open>The predicate \<open>HF_axP\<close>, for the HF Axioms\<close>

definition HF_ax :: "hf set" where
  "HF_ax \<equiv> {\<lbrakk>\<guillemotleft>HF1\<guillemotright>\<rbrakk>e0, \<lbrakk>\<guillemotleft>HF2\<guillemotright>\<rbrakk>e0}"

function HF_axP :: "tm \<Rightarrow> fm"
  where "HF_axP x = x EQ \<guillemotleft>HF1\<guillemotright> OR x EQ \<guillemotleft>HF2\<guillemotright>"
by auto

termination
  by lexicographic_order

lemma eval_fm_HF_axP [simp]: "eval_fm e (HF_axP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> HF_ax"
  by (auto simp: HF_ax_def intro: eval_quot_fm_ignore)

lemma HF_axP_sf [iff]: "Sigma_fm (HF_axP t)"
  by auto

subsection \<open>The specialisation axioms\<close>

inductive_set Special_ax :: "hf set" where
  I: "\<lbrakk>AbstForm v 0 x ax; SubstForm v y x sx; Form x; is_Var v; Term y\<rbrakk>
      \<Longrightarrow> q_Imp sx (q_Ex ax) \<in> Special_ax"

subsubsection \<open>Defining the syntax\<close>

nominal_function Special_axP :: "tm \<Rightarrow> fm" where
  "\<lbrakk>atom v \<sharp> (p,sx,y,ax,x); atom x \<sharp> (p,sx,y,ax);
    atom ax \<sharp> (p,sx,y); atom y \<sharp> (p,sx); atom sx \<sharp> p\<rbrakk> \<Longrightarrow>
  Special_axP p = Ex v (Ex x (Ex ax (Ex y (Ex sx
                   (FormP (Var x) AND VarP (Var v) AND TermP (Var y) AND
                    AbstFormP (Var v) Zero (Var x) (Var ax) AND
                    SubstFormP (Var v) (Var y) (Var x) (Var sx) AND
                    p EQ Q_Imp (Var sx) (Q_Ex (Var ax)))))))"
  by (auto simp: eqvt_def Special_axP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows Special_axP_fresh_iff [simp]: "a \<sharp> Special_axP p \<longleftrightarrow> a \<sharp> p" (is ?thesis1)
   and eval_fm_Special_axP [simp]: "eval_fm e (Special_axP p) \<longleftrightarrow> \<lbrakk>p\<rbrakk>e \<in> Special_ax" (is ?thesis2)
   and Special_axP_sf [iff]:       "Sigma_fm (Special_axP p)" (is ?thesis3)
proof -
  obtain v::name and x::name and ax::name and y::name and sx::name
    where "atom v \<sharp> (p,sx,y,ax,x)" "atom x \<sharp> (p,sx,y,ax)"
          "atom ax \<sharp> (p,sx,y)" "atom y \<sharp> (p,sx)" "atom sx \<sharp> p"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    apply auto
    apply (metis q_Disj_def q_Ex_def q_Imp_def q_Neg_def Special_ax.intros)
    apply (metis q_Disj_def q_Ex_def q_Imp_def q_Neg_def Special_ax.cases)
    done
qed

subsubsection \<open>Correctness (or, correspondence)\<close>

lemma Special_ax_imp_special_axioms:
  assumes "x \<in> Special_ax" shows "\<exists>A. x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> A \<in> special_axioms"
using assms
proof (induction rule: Special_ax.induct)
  case (I v x ax y sx)
  obtain fm::fm and u::tm where fm: "x = \<lbrakk>\<guillemotleft>fm\<guillemotright>\<rbrakk>e" and  u: "y = \<lbrakk>\<guillemotleft>u\<guillemotright>\<rbrakk>e"
    using I  by (auto elim!: Form_imp_is_fm Term_imp_is_tm)
  obtain B where x: "x  = \<lbrakk>quot_dbfm B\<rbrakk>e"
            and ax: "ax = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0 B)\<rbrakk>e"
    using I AbstForm_imp_abst_dbfm  by force
  obtain B' where x': "x = \<lbrakk>quot_dbfm B'\<rbrakk>e"
             and sx: "sx = \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] u) (decode_Var v) B')\<rbrakk>e"
    using I  by (metis u SubstForm_imp_subst_dbfm_lemma quot_tm_def)
  have eq: "B'=B"
    by (metis quot_dbfm_inject_lemma x x')
  have "fm(decode_Var v::=u) IMP SyntaxN.Ex (decode_Var v) fm \<in> special_axioms"
    by (metis special_axioms.intros)
  thus ?case using eq
    apply (auto simp: quot_simps q_defs
                intro!: exI [where x = "fm((decode_Var v)::=u) IMP (Ex (decode_Var v) fm)"])
    apply (metis fm quot_dbfm_inject_lemma quot_fm_def subst_fm_trans_commute sx x')
    apply (metis abst_trans_fm ax fm quot_dbfm_inject_lemma quot_fm_def x)
    done
qed

lemma special_axioms_into_Special_ax: "A \<in> special_axioms \<Longrightarrow> \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<in> Special_ax"
proof (induct rule: special_axioms.induct)
  case (I A i t)
  have "\<lbrakk>\<guillemotleft>A(i::=t) IMP SyntaxN.Ex i A\<guillemotright>\<rbrakk>e =
        q_Imp \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] t) i (trans_fm [] A))\<rbrakk>e
              (q_Ex \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e)"
    by (simp add: quot_fm_def q_defs)
  also have "... \<in> Special_ax"
    apply (rule Special_ax.intros [OF AbstForm_trans_fm])
    apply (auto simp: quot_fm_def [symmetric] intro: SubstForm_quot [unfolded eval_Var_q])
    done
  finally show ?case .
qed

text\<open>We have precisely captured the codes of the specialisation axioms.\<close>
corollary Special_ax_eq_special_axioms: "Special_ax = (\<Union>A \<in> special_axioms. { \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e })"
  by (force dest: special_axioms_into_Special_ax Special_ax_imp_special_axioms)

subsection \<open>The induction axioms\<close>

inductive_set Induction_ax :: "hf set" where
  I: "\<lbrakk>SubstForm v 0 x x0;
       SubstForm v w x xw;
       SubstForm v (q_Eats v w) x xevw;
       AbstForm w 0 (q_Imp x (q_Imp xw xevw)) allw;
       AbstForm v 0 (q_All allw) allvw;
       AbstForm v 0 x ax;
       v \<noteq> w; VarNonOccForm w x\<rbrakk>
      \<Longrightarrow> q_Imp x0 (q_Imp (q_All allvw) (q_All ax)) \<in> Induction_ax"

subsubsection \<open>Defining the syntax\<close>

nominal_function Induction_axP :: "tm \<Rightarrow> fm" where
  "\<lbrakk>atom ax \<sharp> (p,v,w,x,x0,xw,xevw,allw,allvw);
    atom allvw \<sharp> (p,v,w,x,x0,xw,xevw,allw); atom allw \<sharp> (p,v,w,x,x0,xw,xevw);
    atom xevw \<sharp> (p,v,w,x,x0,xw); atom xw \<sharp> (p,v,w,x,x0);
    atom x0 \<sharp> (p,v,w,x); atom x \<sharp> (p,v,w);
    atom w \<sharp> (p,v); atom v \<sharp> p\<rbrakk> \<Longrightarrow>
  Induction_axP p = Ex v (Ex w (Ex x (Ex x0 (Ex xw (Ex xevw (Ex allw (Ex allvw (Ex ax
               ((Var v NEQ Var w) AND VarNonOccFormP (Var w) (Var x) AND
                SubstFormP (Var v) Zero (Var x) (Var x0) AND
                SubstFormP (Var v) (Var w) (Var x) (Var xw) AND
                SubstFormP (Var v) (Q_Eats (Var v) (Var w)) (Var x) (Var xevw) AND
                AbstFormP (Var w) Zero (Q_Imp (Var x) (Q_Imp (Var xw) (Var xevw))) (Var allw) AND
                AbstFormP (Var v) Zero (Q_All (Var allw)) (Var allvw) AND
                AbstFormP (Var v) Zero (Var x) (Var ax) AND
                p EQ Q_Imp (Var x0) (Q_Imp (Q_All (Var allvw)) (Q_All (Var ax))))))))))))"
  by (auto simp: eqvt_def Induction_axP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows Induction_axP_fresh_iff [simp]: "a \<sharp> Induction_axP p \<longleftrightarrow> a \<sharp> p" (is ?thesis1)
   and eval_fm_Induction_axP [simp]:
      "eval_fm e (Induction_axP p) \<longleftrightarrow> \<lbrakk>p\<rbrakk>e \<in> Induction_ax"    (is ?thesis2)
   and Induction_axP_sf [iff]: "Sigma_fm (Induction_axP p)" (is ?thesis3)
proof -
  obtain v::name and w::name and x::name and x0::name and xw::name and xevw::name
                 and allw::name and allvw::name and ax::name
    where atoms: "atom ax \<sharp> (p,v,w,x,x0,xw,xevw,allw,allvw)"
                 "atom allvw \<sharp> (p,v,w,x,x0,xw,xevw,allw)" "atom allw \<sharp> (p,v,w,x,x0,xw,xevw)"
                 "atom xevw \<sharp> (p,v,w,x,x0,xw)" "atom xw \<sharp> (p,v,w,x,x0)" "atom x0 \<sharp> (p,v,w,x)"
                 "atom x \<sharp> (p,v,w)" "atom w \<sharp> (p,v)" "atom v \<sharp> p"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis3
    by auto
  show ?thesis2
    proof
      assume "eval_fm e (Induction_axP p)"
      thus "\<lbrakk>p\<rbrakk>e \<in> Induction_ax" using atoms
        by (auto intro!: Induction_ax.I [unfolded q_defs])
    next
      assume "\<lbrakk>p\<rbrakk>e \<in> Induction_ax"
      thus "eval_fm e (Induction_axP p)"
        apply (rule Induction_ax.cases) using atoms
        apply (force simp: q_defs htuple_minus_1 intro!: AbstForm_imp_Ord)
        done
    qed
qed

subsubsection \<open>Correctness (or, correspondence)\<close>

lemma Induction_ax_imp_induction_axioms:
  assumes "x \<in> Induction_ax" shows "\<exists>A. x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> A \<in> induction_axioms"
using assms
proof (induction rule: Induction_ax.induct)
  case (I v x x0 w xw xevw allw allvw ax)
  then have v: "is_Var v" and w: "is_Var w"
        and dvw [simp]: "decode_Var v \<noteq> decode_Var w"  "atom (decode_Var w) \<sharp> [decode_Var v]"
    by (auto simp: AbstForm_def fresh_Cons)
  obtain A::fm where A: "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e" and wfresh: "atom (decode_Var w) \<sharp> A"
    using I VarNonOccForm_imp_fresh  by blast
  then obtain A' A'' where A': "q_Imp (\<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e) (q_Imp xw xevw) = \<lbrakk>quot_dbfm A'\<rbrakk>e"
                       and A'': "q_All allw = \<lbrakk>quot_dbfm A''\<rbrakk>e"
    using I VarNonOccForm_imp_fresh by (auto dest!: AbstForm_imp_abst_dbfm)
  define Aw where "Aw = A(decode_Var v::=Var (decode_Var w))"
  define Ae where "Ae = A(decode_Var v::= Eats (Var (decode_Var v)) (Var (decode_Var w)))"
  have x0: "x0 = \<lbrakk>\<guillemotleft>A(decode_Var v::=Zero)\<guillemotright>\<rbrakk>e"  using I SubstForm_imp_subst_fm
    by (metis A Form_quot_fm eval_fm_inject eval_tm.simps(1) quot_Zero)
  have xw: "xw = \<lbrakk>\<guillemotleft>Aw\<guillemotright>\<rbrakk>e"  using I SubstForm_imp_subst_fm
    by (metis A Form_quot_fm eval_fm_inject is_Var_imp_decode_Var w Aw_def)
  have "SubstForm v (\<lbrakk>\<guillemotleft>Eats (Var (decode_Var v)) (Var (decode_Var w))\<guillemotright>\<rbrakk>e) x xevw"
    using I  by (simp add: quot_simps q_defs) (metis is_Var_iff v w)
  hence xevw: "xevw = \<lbrakk>\<guillemotleft>Ae\<guillemotright>\<rbrakk>e"
    by (metis A Ae_def Form_quot_fm SubstForm_imp_subst_fm eval_fm_inject)
  have ax: "ax = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0 (trans_fm [] A))\<rbrakk>e"
    using I  by (metis A AbstForm_imp_abst_dbfm nat_of_ord_0 quot_dbfm_inject_lemma quot_fm_def)
  have evw: "q_Imp x (q_Imp xw xevw) =
             \<lbrakk>quot_dbfm (trans_fm [] (A IMP (Aw IMP Ae)))\<rbrakk>e"
    using A xw xevw  by (auto simp: quot_simps q_defs quot_fm_def)
  hence allw: "allw = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var w) 0
                                    (trans_fm [] (A IMP (Aw IMP Ae))))\<rbrakk>e"
    using I  by (metis AbstForm_imp_abst_dbfm nat_of_ord_0 quot_dbfm_inject_lemma)
  then have evw: "q_All allw = \<lbrakk>quot_dbfm (trans_fm [] (All (decode_Var w) (A IMP (Aw IMP Ae))))\<rbrakk>e"
    by (auto simp: q_defs abst_trans_fm)
  hence allvw: "allvw = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0
                                     (trans_fm [] (All (decode_Var w) (A IMP (Aw IMP Ae)))))\<rbrakk>e"
    using I  by (metis AbstForm_imp_abst_dbfm nat_of_ord_0 quot_dbfm_inject_lemma)
  define ind_ax
    where "ind_ax =
        A(decode_Var v::=Zero) IMP
        ((All (decode_Var v) (All (decode_Var w) (A IMP (Aw IMP Ae)))) IMP
        (All (decode_Var v) A))"
  have "atom (decode_Var w) \<sharp> (decode_Var v, A)" using I wfresh v w
    by (metis atom_eq_iff decode_Var_inject fresh_Pair fresh_ineq_at_base)
  hence "ind_ax \<in> induction_axioms"
    by (auto simp: ind_ax_def Aw_def Ae_def induction_axioms.intros)
  thus ?case
    by (force simp: quot_simps q_defs ind_ax_def allvw ax x0 abst_trans_fm2 abst_trans_fm)
qed

lemma induction_axioms_into_Induction_ax:
  "A \<in> induction_axioms \<Longrightarrow> \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<in> Induction_ax"
proof (induct rule: induction_axioms.induct)
  case (ind j i A)
  hence eq: "\<lbrakk>\<guillemotleft>A(i::=Zero) IMP All i (All j (A IMP A(i::=Var j) IMP A(i::=Eats (Var i) (Var j)))) IMP All i A\<guillemotright>\<rbrakk>e =
            q_Imp \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] Zero) i (trans_fm [] A))\<rbrakk>e
            (q_Imp (q_All (q_All
                  (q_Imp \<lbrakk>quot_dbfm (trans_fm [j, i] A)\<rbrakk>e
                    (q_Imp
                      \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Var j)))\<rbrakk>e
                      \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Eats (Var i) (Var j))))\<rbrakk>e))))
              (q_All \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e))"
    by (simp add: quot_simps q_defs quot_subst_eq fresh_Cons fresh_Pair)
  have [simp]: "atom j \<sharp> [i]" using ind
    by (metis fresh_Cons fresh_Nil fresh_Pair)
  show ?case
  proof (simp only: eq, rule Induction_ax.intros [where v = "q_Var i" and w = "q_Var j"])
    show "SubstForm (q_Var i) 0 \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e
           \<lbrakk>quot_dbfm (subst_dbfm (trans_tm [] Zero) i (trans_fm [] A))\<rbrakk>e"
     by (metis SubstForm_subst_dbfm_eq Term_quot_tm eval_tm.simps(1) quot_Zero quot_fm_def quot_tm_def)
  next
    show "SubstForm (q_Var i) (q_Var j) \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<lbrakk>quot_dbfm (subst_dbfm (DBVar j) i (trans_fm [] A))\<rbrakk>e"
      by (auto simp: quot_fm_def intro!: SubstForm_subst_dbfm_eq Term_Var)
         (metis q_Var_def)
  next
    show "SubstForm (q_Var i) (q_Eats (q_Var i) (q_Var j)) \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e
              \<lbrakk>quot_dbfm (subst_dbfm (DBEats (DBVar i) (DBVar j)) i (trans_fm [] A))\<rbrakk>e"
      unfolding quot_fm_def
        by (auto intro!: SubstForm_subst_dbfm_eq Term_Eats Term_Var) (simp add: q_defs)
  next
    show "AbstForm (q_Var j) 0
           (q_Imp \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e
              (q_Imp \<lbrakk>quot_dbfm (subst_dbfm (DBVar j) i (trans_fm [] A))\<rbrakk>e
                     \<lbrakk>quot_dbfm (subst_dbfm (DBEats (DBVar i) (DBVar j)) i (trans_fm [] A))\<rbrakk>e))
           \<lbrakk>quot_dbfm (trans_fm [j] (A IMP (A(i::= Var j) IMP A(i::= Eats(Var i)(Var j)))))\<rbrakk>e"
      by (rule AbstForm_trans_fm_eq [where A = "(A IMP A(i::= Var j) IMP A(i::= Eats(Var i)(Var j)))"])
         (auto simp: quot_simps q_defs quot_fm_def subst_fm_trans_commute_eq)
  next
    show "AbstForm (q_Var i) 0
     (q_All \<lbrakk>quot_dbfm (trans_fm [j] (A IMP A(i::=Var j) IMP A(i::=Eats (Var i) (Var j))))\<rbrakk>e)
     (q_All
       (q_Imp \<lbrakk>quot_dbfm (trans_fm [j, i] A)\<rbrakk>e
         (q_Imp \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Var j)))\<rbrakk>e
                \<lbrakk>quot_dbfm (trans_fm [j, i] (A(i::=Eats (Var i) (Var j))))\<rbrakk>e)))"
      apply (rule AbstForm_trans_fm_eq
               [where A = "All j (A IMP (A(i::= Var j) IMP A(i::= Eats(Var i)(Var j))))"])
      apply (auto simp: q_defs quot_fm_def)
      done
  next
    show "AbstForm (q_Var i) 0 (\<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e) \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e"
      by (metis AbstForm_trans_fm)
  next
    show "q_Var i \<noteq> q_Var j" using ind
      by (simp add: q_Var_def)
  next
    show "VarNonOccForm (q_Var j) (\<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e)"
      by (metis fresh_Pair fresh_imp_VarNonOccForm ind)
  qed
qed

text\<open>We have captured the codes of the induction axioms.\<close>
corollary Induction_ax_eq_induction_axioms:
  "Induction_ax = (\<Union>A \<in> induction_axioms. {\<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e})"
  by (force dest: induction_axioms_into_Induction_ax Induction_ax_imp_induction_axioms)

subsection \<open>The predicate \<open>AxiomP\<close>, for any Axioms\<close>

definition Extra_ax :: "hf set" where
 "Extra_ax \<equiv> {\<lbrakk>\<guillemotleft>extra_axiom\<guillemotright>\<rbrakk>e0}"

definition Axiom :: "hf set" where
  "Axiom \<equiv> Extra_ax \<union> Sent \<union> Equality_ax \<union> HF_ax \<union> Special_ax \<union> Induction_ax"

definition AxiomP :: "tm \<Rightarrow> fm"
  where "AxiomP x \<equiv> x EQ \<guillemotleft>extra_axiom\<guillemotright> OR SentP x OR Equality_axP x OR
                    HF_axP x OR Special_axP x OR Induction_axP x"

lemma AxiomP_eqvt [eqvt]: "(p \<bullet> AxiomP x) = AxiomP (p \<bullet> x)"
  by (simp add: AxiomP_def)

lemma AxiomP_fresh_iff [simp]: "a \<sharp> AxiomP x \<longleftrightarrow> a \<sharp> x"
  by (auto simp: AxiomP_def)

lemma eval_fm_AxiomP [simp]: "eval_fm e (AxiomP x) \<longleftrightarrow> \<lbrakk>x\<rbrakk>e \<in> Axiom"
  unfolding AxiomP_def Axiom_def Extra_ax_def
  by (auto simp del: Equality_axP.simps HF_axP.simps intro: eval_quot_fm_ignore)

lemma AxiomP_sf [iff]: "Sigma_fm (AxiomP t)"
  by (auto simp: AxiomP_def)

subsection \<open>The predicate \<open>ModPonP\<close>, for the inference rule Modus Ponens\<close>

definition ModPon :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool" where
  "ModPon x y z \<equiv> (y = q_Imp x z)"

definition ModPonP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "ModPonP x y z = (y EQ Q_Imp x z)"

lemma ModPonP_eqvt [eqvt]: "(p \<bullet> ModPonP x y z) = ModPonP (p \<bullet> x) (p \<bullet> y) (p \<bullet> z)"
  by (simp add: ModPonP_def)

lemma ModPonP_fresh_iff [simp]: "a \<sharp> ModPonP x y z \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y \<and> a \<sharp> z"
  by (auto simp: ModPonP_def)

lemma eval_fm_ModPonP [simp]: "eval_fm e (ModPonP x y z) \<longleftrightarrow> ModPon \<lbrakk>x\<rbrakk>e \<lbrakk>y\<rbrakk>e \<lbrakk>z\<rbrakk>e"
  by (auto simp: ModPon_def ModPonP_def q_defs)

lemma ModPonP_sf [iff]: "Sigma_fm (ModPonP t u v)"
  by (auto simp: ModPonP_def)

lemma ModPonP_subst [simp]:
  "(ModPonP t u v)(i::=w) = ModPonP (subst i w t) (subst i w u) (subst i w v)"
  by (auto simp: ModPonP_def)

subsection \<open>The predicate \<open>ExistsP\<close>, for the existential rule\<close>
subsubsection \<open>Definition\<close>

(*  "\<turnstile> A IMP B \<Longrightarrow> atom i \<sharp> B \<Longrightarrow>  \<turnstile> (Ex i A) IMP B" *)
definition Exists :: "hf \<Rightarrow> hf \<Rightarrow> bool" where
 "Exists p q \<equiv> (\<exists>x x' y v. Form x \<and> VarNonOccForm v y \<and> AbstForm v 0 x x' \<and>
                p = q_Imp x y \<and> q = q_Imp (q_Ex x') y)"

nominal_function ExistsP :: "tm \<Rightarrow> tm \<Rightarrow> fm" where
  "\<lbrakk>atom x \<sharp> (p,q,v,y,x'); atom x' \<sharp> (p,q,v,y);
    atom y \<sharp> (p,q,v); atom v \<sharp> (p,q)\<rbrakk> \<Longrightarrow>
  ExistsP p q = Ex x (Ex x' (Ex y (Ex v (FormP (Var x) AND
                    VarNonOccFormP (Var v) (Var y) AND
                    AbstFormP (Var v) Zero (Var x) (Var x') AND
                    p EQ Q_Imp (Var x) (Var y) AND
                    q EQ Q_Imp (Q_Ex (Var x')) (Var y)))))"
  by (auto simp: eqvt_def ExistsP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows ExistsP_fresh_iff [simp]: "a \<sharp> ExistsP p q \<longleftrightarrow> a \<sharp> p \<and> a \<sharp> q"    (is ?thesis1)
   and eval_fm_ExistsP [simp]: "eval_fm e (ExistsP p q) \<longleftrightarrow> Exists \<lbrakk>p\<rbrakk>e \<lbrakk>q\<rbrakk>e"  (is ?thesis2)
   and ExistsP_sf [iff]:       "Sigma_fm (ExistsP p q)"   (is ?thesis3)
proof -
  obtain x::name and x'::name and y::name and v::name
    where "atom x \<sharp> (p,q,v,y,x')"  "atom x' \<sharp> (p,q,v,y)" "atom y \<sharp> (p,q,v)"  "atom v \<sharp> (p,q)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    by (auto simp: Exists_def q_defs)
qed

lemma ExistsP_subst [simp]: "(ExistsP p q)(j::=w) = ExistsP (subst j w p) (subst j w q)"
proof -
  obtain x::name and x'::name and y::name and v::name
    where "atom x \<sharp> (j,w,p,q,v,y,x')"   "atom x' \<sharp> (j,w,p,q,v,y)"
          "atom y \<sharp> (j,w,p,q,v)"   "atom v \<sharp> (j,w,p,q)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: ExistsP.simps [of x _ _ x' y v])
qed

subsubsection \<open>Correctness\<close>

lemma Exists_imp_exists:
  assumes "Exists p q"
  shows "\<exists>A B i. p = \<lbrakk>\<guillemotleft>A IMP B\<guillemotright>\<rbrakk>e \<and> q = \<lbrakk>\<guillemotleft>(Ex i A) IMP B\<guillemotright>\<rbrakk>e \<and> atom i \<sharp> B"
proof -
  obtain x ax y v
    where x:    "Form x"
      and noc:  "VarNonOccForm v y"
      and abst: "AbstForm v 0 x ax"
      and p: "p = q_Imp x y"
      and q: "q = q_Imp (q_Ex ax) y"
    using assms  by (auto simp: Exists_def)
  then obtain B::fm where B: "y = \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk>e" and vfresh: "atom (decode_Var v) \<sharp> B"
   by (metis VarNonOccForm_imp_fresh)
  obtain A::fm where A: "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e"
    by (metis Form_imp_is_fm x)
  with AbstForm_imp_abst_dbfm [OF abst, of e]
  have ax: "ax = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) 0 (trans_fm [] A))\<rbrakk>e"
           "p = \<lbrakk>\<guillemotleft>A IMP B\<guillemotright>\<rbrakk>e" using p A B
    by (auto simp: quot_simps quot_fm_def q_defs)
  have "q = \<lbrakk>\<guillemotleft>(Ex (decode_Var v) A) IMP B\<guillemotright>\<rbrakk>e" using q A B ax
    by (auto simp: abst_trans_fm quot_simps q_defs)
  then show ?thesis using vfresh ax
    by blast
qed

lemma Exists_intro: "atom i \<sharp> B \<Longrightarrow> Exists (\<lbrakk>\<guillemotleft>A IMP B\<guillemotright>\<rbrakk>e) \<lbrakk>\<guillemotleft>(Ex i A) IMP B\<guillemotright>\<rbrakk>e"
  by (simp add: Exists_def quot_simps q_defs)
     (metis AbstForm_trans_fm Form_quot_fm fresh_imp_VarNonOccForm)

text\<open>Thus, we have precisely captured the codes of the specialisation axioms.\<close>
corollary Exists_iff_exists:
  "Exists p q \<longleftrightarrow> (\<exists>A B i. p = \<lbrakk>\<guillemotleft>A IMP B\<guillemotright>\<rbrakk>e \<and> q = \<lbrakk>\<guillemotleft>(Ex i A) IMP B\<guillemotright>\<rbrakk>e \<and> atom i \<sharp> B)"
  by (force dest: Exists_imp_exists Exists_intro)

subsection \<open>The predicate \<open>SubstP\<close>, for the substitution rule\<close>

text\<open>Although the substitution rule is derivable in the calculus, the derivation is
too complicated to reproduce within the proof function. It is much easier to
provide it as an immediate inference step, justifying its soundness in terms
of other inference rules.\<close>

subsubsection \<open>Definition\<close>

text\<open>This is the inference \<open>H \<turnstile> A \<Longrightarrow> H \<turnstile> A (i::=x)\<close>\<close>
definition Subst :: "hf \<Rightarrow> hf \<Rightarrow> bool" where
  "Subst p q \<equiv> (\<exists>v u. SubstForm v u p q)"

nominal_function SubstP :: "tm \<Rightarrow> tm \<Rightarrow> fm" where
  "\<lbrakk>atom u \<sharp> (p,q,v); atom v \<sharp> (p,q)\<rbrakk> \<Longrightarrow>
   SubstP p q = Ex v (Ex u (SubstFormP (Var v) (Var u) p q))"
  by (auto simp: eqvt_def SubstP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SubstP_fresh_iff [simp]: "a \<sharp> SubstP p q \<longleftrightarrow> a \<sharp> p \<and> a \<sharp> q"        (is ?thesis1)
   and eval_fm_SubstP [simp]: "eval_fm e (SubstP p q) \<longleftrightarrow> Subst \<lbrakk>p\<rbrakk>e \<lbrakk>q\<rbrakk>e" (is ?thesis2)
   and SubstP_sf [iff]: "Sigma_fm (SubstP p q)"                           (is ?thesis3)
proof -
  obtain u::name and v::name  where "atom u \<sharp> (p,q,v)" "atom v \<sharp> (p,q)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    by (auto simp: Subst_def q_defs)
qed

lemma SubstP_subst [simp]: "(SubstP p q)(j::=w) = SubstP (subst j w p) (subst j w q)"
proof -
  obtain u::name and v::name  where "atom u \<sharp> (j,w,p,q,v)"  "atom v \<sharp> (j,w,p,q)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstP.simps [of u _ _ v])
qed

subsubsection \<open>Correctness\<close>

lemma Subst_imp_subst:
  assumes "Subst p q" "Form p"
  shows "\<exists>A::fm. \<exists>i t. p = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> q = \<lbrakk>\<guillemotleft>A(i::=t)\<guillemotright>\<rbrakk>e"
proof -
  obtain v u where subst: "SubstForm v u p q" using assms
    by (auto simp: Subst_def)
  then obtain t::tm where substt: "SubstForm v \<lbrakk>\<guillemotleft>t\<guillemotright>\<rbrakk>e p q"
    by (metis SubstForm_def Term_imp_is_tm)
  with SubstForm_imp_subst_fm [OF substt] assms
  obtain A where "p = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e"  "q = \<lbrakk>\<guillemotleft>A(decode_Var v::=t)\<guillemotright>\<rbrakk>e"
    by auto
  thus ?thesis
    by blast
qed

subsection \<open>The predicate \<open>PrfP\<close>\<close>

(*Prf(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>n\<in>k)[Sent (s n) \<or> (\<exists>m,l\<in>n)[ModPon (s m) (s l) (s n)]]*)
definition Prf :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "Prf s k y \<equiv> BuildSeq (\<lambda>x. x \<in> Axiom) (\<lambda>u v w. ModPon v w u \<or> Exists v u \<or> Subst v u) s k y"

nominal_function PrfP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,sl,m,n,sm,sn); atom sl \<sharp> (s,m,n,sm,sn);
          atom m \<sharp> (s,n,sm,sn); atom n \<sharp> (s,k,sm,sn);
          atom sm \<sharp> (s,sn); atom sn \<sharp> (s)\<rbrakk> \<Longrightarrow>
    PrfP s k t =
      LstSeqP s k t AND
      All2 n (SUCC k) (Ex sn (HPair (Var n) (Var sn) IN s AND (AxiomP (Var sn) OR
                Ex m (Ex l (Ex sm (Ex sl (Var m IN Var n AND Var l IN Var n AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var l) (Var sl) IN s AND
                       (ModPonP (Var sm) (Var sl) (Var sn) OR
                        ExistsP (Var sm) (Var sn) OR
                        SubstP (Var sm) (Var sn)))))))))"
  by (auto simp: eqvt_def PrfP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows PrfP_fresh_iff [simp]: "a \<sharp> PrfP s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t"      (is ?thesis1)
  and eval_fm_PrfP [simp]:     "eval_fm e (PrfP s k t) \<longleftrightarrow> Prf \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e \<lbrakk>t\<rbrakk>e"  (is ?thesis2)
  and PrfP_imp_OrdP [simp]:    "{PrfP s k t} \<turnstile> OrdP k"         (is ?thord)
  and PrfP_imp_LstSeqP [simp]: "{PrfP s k t} \<turnstile> LstSeqP s k t"  (is ?thlstseq)
  and PrfP_sf [iff]:           "Sigma_fm (PrfP s k t)"         (is ?thsf)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,m,n,sm,sn)"
        "atom m \<sharp> (s,n,sm,sn)"   "atom n \<sharp> (s,k,sm,sn)"
        "atom sm \<sharp> (s,sn)"   "atom sn \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thord ?thlstseq ?thsf
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    by simp
       (simp cong: conj_cong add: LstSeq_imp_Ord Prf_def BuildSeq_def Builds_def
             ModPon_def Exists_def HBall_def HBex_def
             Seq_iff_app [OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"])
qed

lemma PrfP_subst [simp]:
     "(PrfP t u v)(j::=w) = PrfP (subst j w t) (subst j w u) (subst j w v)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (t,u,v,j,w,sl,m,n,sm,sn)"   "atom sl \<sharp> (t,u,v,j,w,m,n,sm,sn)"
          "atom m \<sharp> (t,u,v,j,w,n,sm,sn)"   "atom n \<sharp> (t,u,v,j,w,sm,sn)"
          "atom sm \<sharp> (t,u,v,j,w,sn)"   "atom sn \<sharp> (t,u,v,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: PrfP.simps [of l _ sl m n sm sn])
qed

subsection \<open>The predicate \<open>PfP\<close>\<close>

definition Pf :: "hf \<Rightarrow> bool"
  where "Pf y \<equiv> (\<exists>s k. Prf s k y)"

nominal_function PfP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,y); atom s \<sharp> y\<rbrakk> \<Longrightarrow>
    PfP y = Ex k (Ex s (PrfP (Var s) (Var k) y))"
  by (auto simp: eqvt_def PfP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows PfP_fresh_iff [simp]: "a \<sharp> PfP y \<longleftrightarrow> a \<sharp> y"           (is ?thesis1)
   and eval_fm_PfP [simp]:  "eval_fm e (PfP y) \<longleftrightarrow> Pf \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
   and PfP_sf [iff]: "Sigma_fm (PfP y)"                      (is ?thsf)
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,y)" "atom s \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: Pf_def)
qed

lemma PfP_subst [simp]: "(PfP t)(j::=w) = PfP (subst j w t)"
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,t,j,w)" "atom s \<sharp> (t,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: PfP.simps [of k s])
qed

lemma ground_PfP [simp]: "ground_fm (PfP y) = ground y"
  by (simp add: ground_aux_def ground_fm_aux_def supp_conv_fresh)

section\<open>Proposition 4.4\<close>

subsection\<open>Left-to-Right Proof\<close>

lemma extra_axiom_imp_Pf: "Pf \<lbrakk>\<guillemotleft>extra_axiom\<guillemotright>\<rbrakk>e"
proof -
  have "\<lbrakk>\<guillemotleft>extra_axiom\<guillemotright>\<rbrakk>e \<in> Extra_ax"
    by (simp add: Extra_ax_def) (rule eval_quot_fm_ignore)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma boolean_axioms_imp_Pf:
  assumes "\<alpha> \<in> boolean_axioms" shows "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e"
proof -
  have "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e \<in> Sent" using assms
    by (rule boolean_axioms.cases)
       (auto simp: Sent_def Sent_axioms_def quot_Disj quot_Neg q_defs)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma equality_axioms_imp_Pf:
  assumes "\<alpha> \<in> equality_axioms" shows "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e"
proof -
  have "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e \<in> Equality_ax" using assms [unfolded equality_axioms_def]
    by (auto simp: Equality_ax_def eval_quot_fm_ignore)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma HF_axioms_imp_Pf:
  assumes "\<alpha> \<in> HF_axioms" shows "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e"
proof -
  have "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e \<in> HF_ax" using assms [unfolded HF_axioms_def]
    by (auto simp: HF_ax_def eval_quot_fm_ignore)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma special_axioms_imp_Pf:
  assumes "\<alpha> \<in> special_axioms" shows "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e"
proof -
  have "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e \<in> Special_ax"
    by (metis special_axioms_into_Special_ax assms)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma induction_axioms_imp_Pf:
  assumes "\<alpha> \<in> induction_axioms" shows "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e"
proof -
  have "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e \<in> Induction_ax"
    by (metis induction_axioms_into_Induction_ax assms)
  thus ?thesis
    by (force simp add: Pf_def Prf_def Axiom_def intro: BuildSeq_exI)
qed

lemma ModPon_imp_Pf: "\<lbrakk>Pf \<lbrakk>Q_Imp x y\<rbrakk>e; Pf \<lbrakk>x\<rbrakk>e\<rbrakk> \<Longrightarrow> Pf \<lbrakk>y\<rbrakk>e"
  by (auto simp: Pf_def Prf_def ModPon_def q_defs intro: BuildSeq_combine)

lemma quot_ModPon_imp_Pf: "\<lbrakk>Pf \<lbrakk>\<guillemotleft>\<alpha> IMP \<beta>\<guillemotright>\<rbrakk>e; Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e\<rbrakk> \<Longrightarrow> Pf \<lbrakk>\<guillemotleft>\<beta>\<guillemotright>\<rbrakk>e"
  by (simp add: ModPon_imp_Pf quot_fm_def quot_simps q_defs)

lemma quot_Exists_imp_Pf: "\<lbrakk>Pf \<lbrakk>\<guillemotleft>\<alpha> IMP \<beta>\<guillemotright>\<rbrakk>e; atom i \<sharp> \<beta>\<rbrakk> \<Longrightarrow> Pf \<lbrakk>\<guillemotleft>Ex i \<alpha> IMP \<beta>\<guillemotright>\<rbrakk>e"
  by (force simp: Pf_def Prf_def Exists_def quot_simps q_defs
            intro: BuildSeq_combine AbstForm_trans_fm_eq fresh_imp_VarNonOccForm)

lemma proved_imp_Pf: assumes "H \<turnstile> \<alpha>" "H={}" shows "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e"
using assms
proof (induct)
  case (Hyp A H) thus ?case
    by auto
next
  case (Extra H) thus ?case
    by (metis extra_axiom_imp_Pf)
next
  case (Bool A H) thus ?case
    by (metis boolean_axioms_imp_Pf)
next
  case (Eq A H) thus ?case
    by (metis equality_axioms_imp_Pf)
next
  case (HF A H) thus ?case
    by (metis HF_axioms_imp_Pf)
next
  case (Spec A H) thus ?case
    by (metis special_axioms_imp_Pf)
next
  case (Ind A H) thus ?case
    by (metis induction_axioms_imp_Pf)
next
  case (MP H A B H') thus ?case
    by (metis quot_ModPon_imp_Pf Un_empty)
next
  case (Exists H A B i) thus ?case
    by (metis quot_Exists_imp_Pf)
qed

corollary proved_imp_proved_PfP: "{} \<turnstile> \<alpha> \<Longrightarrow> {} \<turnstile> PfP \<guillemotleft>\<alpha>\<guillemotright>"
  by (rule Sigma_fm_imp_thm [OF PfP_sf])
     (auto simp: ground_aux_def supp_conv_fresh proved_imp_Pf)

subsection\<open>Right-to-Left Proof\<close>

lemma Sent_imp_hfthm:
  assumes "x \<in> Sent" shows "\<exists>A. x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
proof -
  obtain y z w where "Form y" "Form z" "Form w" and axs: "Sent_axioms x y z w"
    using assms  by (auto simp: Sent_def)
  then obtain A::fm and B::fm and C::fm
         where A: "y = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e" and B: "z = \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk>e" and C: "w = \<lbrakk>\<guillemotleft>C\<guillemotright>\<rbrakk>e"
    by (metis Form_imp_is_fm)
  have "\<exists>A. q_Imp y y = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force simp add: A quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp y (q_Disj y z) = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="A IMP (A OR B)"]
                simp add: A B quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp (q_Disj y y) y = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="(A OR A) IMP A"]
                simp add: A quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp (q_Disj y (q_Disj z w)) (q_Disj (q_Disj y z) w) = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="(A OR (B OR C)) IMP ((A OR B) OR C)"]
                simp add: A B C quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  moreover have "\<exists>A. q_Imp (q_Disj y z) (q_Imp (q_Disj (q_Neg y) w) (q_Disj z w)) = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
      by (force intro!: exI [where x="(A OR B) IMP ((Neg A OR C) IMP (B OR C))"]
                simp add: A B C quot_Disj quot_Neg q_defs hfthm.Bool boolean_axioms.intros)
  ultimately show ?thesis using axs [unfolded Sent_axioms_def]
    by blast
qed

lemma Extra_ax_imp_hfthm:
  assumes "x \<in> Extra_ax" obtains A where "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
  using assms unfolding Extra_ax_def
  by (auto intro: eval_quot_fm_ignore hfthm.Extra)

lemma Equality_ax_imp_hfthm:
  assumes "x \<in> Equality_ax" obtains A where "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
  using assms unfolding Equality_ax_def
  by (auto intro: eval_quot_fm_ignore hfthm.Eq [unfolded equality_axioms_def])

lemma HF_ax_imp_hfthm:
  assumes "x \<in> HF_ax" obtains A where "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
  using assms unfolding HF_ax_def
  by (auto intro: eval_quot_fm_ignore hfthm.HF [unfolded HF_axioms_def])

lemma Special_ax_imp_hfthm:
  assumes "x \<in> Special_ax" obtains A where "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e" "{} \<turnstile> A"
  by (metis Spec Special_ax_imp_special_axioms assms)

lemma Induction_ax_imp_hfthm:
  assumes "x \<in> Induction_ax" obtains A where "x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e" "{} \<turnstile> A"
  by (metis Induction_ax_imp_induction_axioms assms hfthm.Ind)

lemma Exists_imp_hfthm: "\<lbrakk>Exists \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e y; {} \<turnstile> A\<rbrakk> \<Longrightarrow> \<exists>B. y = \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> B"
  by (drule Exists_imp_exists [where e=e]) (auto intro: anti_deduction)

lemma Subst_imp_hfthm:  "\<lbrakk>Subst \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e y; {} \<turnstile> A\<rbrakk> \<Longrightarrow> \<exists>B. y = \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> B"
  by (drule Subst_imp_subst [where e=e], auto intro: Subst)

lemma eval_Neg_imp_Neg: "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e = q_Neg x \<Longrightarrow> \<exists>A. \<alpha> = Neg A \<and> \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e = x"
  by (cases \<alpha> rule: fm.exhaust) (auto simp: quot_simps q_defs htuple_minus_1)

lemma eval_Disj_imp_Disj: "\<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e = q_Disj x y \<Longrightarrow> \<exists>A B. \<alpha> = A OR B \<and> \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e = x \<and> \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk>e = y"
  by (cases \<alpha> rule: fm.exhaust) (auto simp: quot_simps q_defs htuple_minus_1)

lemma Prf_imp_proved: assumes "Prf s k x" shows "\<exists>A. x = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e \<and> {} \<turnstile> A"
using assms [unfolded Prf_def Axiom_def]
proof (induction x rule: BuildSeq_induct)
  case (B x) thus ?case
    by (auto intro: Extra_ax_imp_hfthm Sent_imp_hfthm Equality_ax_imp_hfthm HF_ax_imp_hfthm
                    Special_ax_imp_hfthm Induction_ax_imp_hfthm)
next
  case (C x y z)
  then obtain A::fm and B::fm where "y = \<lbrakk>\<guillemotleft>A\<guillemotright>\<rbrakk>e" "{} \<turnstile> A" "z = \<lbrakk>\<guillemotleft>B\<guillemotright>\<rbrakk>e" "{} \<turnstile> B"
    by blast
  thus ?case using C.hyps ModPon_def q_Imp_def
    by (auto dest!: MP_same eval_Neg_imp_Neg eval_Disj_imp_Disj Exists_imp_hfthm Subst_imp_hfthm)
qed

corollary Pf_quot_imp_is_proved: "Pf \<lbrakk>\<guillemotleft>\<alpha>\<guillemotright>\<rbrakk>e \<Longrightarrow> {} \<turnstile> \<alpha>"
  by (metis Pf_def Prf_imp_proved eval_fm_inject)

text\<open>Proposition 4.4!\<close>
theorem proved_iff_proved_PfP: "{} \<turnstile> \<alpha> \<longleftrightarrow> {} \<turnstile> PfP \<guillemotleft>\<alpha>\<guillemotright>"
  by (metis Pf_quot_imp_is_proved emptyE eval_fm_PfP hfthm_sound proved_imp_proved_PfP)

end


theory IHT_Mergesort
  imports "../Functional/MergeSort" IHT_Arrays
begin

section \<open>Imperative version\<close>

function mergeinto :: "nat \<Rightarrow> nat \<Rightarrow> 'a::{heap,linorder} array \<Rightarrow> 'a array \<Rightarrow> 'a array \<Rightarrow> unit Heap" where
  "mergeinto 0 0 a b c = return ()"
| "mergeinto (Suc la) 0 a b c = do {
     mergeinto la 0 a b c;
     e \<leftarrow> Array_Time.nth a la;
     Array_Time.upd la e c;
     return ()
   }"
| "mergeinto 0 (Suc lb) a b c = do {
     mergeinto 0 lb a b c;
     e \<leftarrow> Array_Time.nth b lb;
     Array_Time.upd lb e c;
     return ()
   }"
| "mergeinto (Suc la) (Suc lb) a b c = do {
     ha \<leftarrow> Array_Time.nth a la;
     hb \<leftarrow> Array_Time.nth b lb;
     if ha \<ge> hb then do {
       mergeinto la (Suc lb) a b c;
       Array_Time.upd (Suc (la+lb)) ha c;
       return ()
     }
     else do {
       mergeinto (Suc la) lb a b c;
       Array_Time.upd (Suc (la+lb)) hb c;
       return ()
     }
   }"
by pat_completeness auto
termination by (relation "Wellfounded.measure (\<lambda>(la, lb, a, b, c). la + lb)") auto

lemma mergeinto_to_fun [hoare_triple]:
  "la \<le> length as \<Longrightarrow> lb \<le> length bs \<Longrightarrow> length cs = length as + length bs \<Longrightarrow>
    <a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a bs * c \<mapsto>\<^sub>a cs * $(4 * (la + lb) + 2)>
    mergeinto la lb a b c
    <\<lambda>_. a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a bs * c \<mapsto>\<^sub>a mergeinto_fun la lb as bs cs>\<^sub>t"
@proof @fun_induct "mergeinto_fun la lb as bs cs" @with
  @subgoal "(la = Suc la, lb = Suc lb, as = as, bs = bs, cs = cs)"
    @case "bs ! lb \<le> as ! la"
  @endgoal @end
@qed

definition mergeinto_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "mergeinto_time n = 4 * n + 2"

lemma mergeinto_correct [hoare_triple]:
  "length as = la \<Longrightarrow> length bs = lb \<Longrightarrow> length cs = la + lb \<Longrightarrow>
    <a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a bs * c \<mapsto>\<^sub>a cs * $(mergeinto_time (length cs))>
    mergeinto la lb a b c
    <\<lambda>_. a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a bs * c \<mapsto>\<^sub>a MergeSort.merge_list as bs>\<^sub>t"
@proof @have "mergeinto_time (length cs) \<ge>\<^sub>t 4 * (la + lb) + 2" @qed  (* TODO: why need this? *)

lemma mergeinto_time_bound [asym_bound]: "(\<lambda>n. mergeinto_time n) \<in> \<Theta>(\<lambda>n. n)"
  by (simp only: mergeinto_time_def) auto2

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

partial_function (heap_time) merge_sort_impl :: "'a::{heap,linorder} array \<Rightarrow> unit Heap" where
  "merge_sort_impl X = do {
    n \<leftarrow> Array_Time.len X;
    if n \<le> 1 then return ()
    else do {
      A \<leftarrow> atake (n div 2) X;
      B \<leftarrow> adrop (n div 2) X;
      merge_sort_impl A;
      merge_sort_impl B;
      mergeinto (n div 2) (n - n div 2) A B X
    }
  }"

function merge_sort_time :: "nat \<Rightarrow> nat" where
  "n \<le> 1 \<Longrightarrow> merge_sort_time n = 2"
| "n > 1 \<Longrightarrow> merge_sort_time n =
    atake_time n + adrop_time n + mergeinto_time n + 1 +
    (merge_sort_time (n div 2) + merge_sort_time (n - n div 2))"
  by force simp_all
  termination by (relation "Wellfounded.measure (\<lambda>n. n)") auto
setup \<open>fold add_rewrite_rule @{thms merge_sort_time.simps}\<close>

definition merge_sort_time' :: "nat \<Rightarrow> real" where
  "merge_sort_time' n = real (merge_sort_time n)"

lemma div_2_to_rounding:
  "n - n div 2 = nat \<lceil>n / 2\<rceil>" "n div 2 = nat \<lfloor>n / 2\<rfloor>" by linarith+

lemma merge_sort_time_O:
  "(\<lambda>n. merge_sort_time n) \<in> \<Theta>(\<lambda>n. real n * ln (real n))"
  unfolding merge_sort_time'_def[symmetric]
  apply (master_theorem2 2.3 recursion: merge_sort_time.simps(2)
         rew: merge_sort_time'_def div_2_to_rounding)
  apply (auto simp: merge_sort_time'_def div_2_to_rounding)
  by auto2

lemma mergeSort_to_fun [hoare_triple]:
  "<p \<mapsto>\<^sub>a xs * $(merge_sort_time (length xs))>
   merge_sort_impl p
   <\<lambda>_. p \<mapsto>\<^sub>a merge_sort_fun xs>\<^sub>t"
@proof
  @fun_induct "merge_sort_fun xs" arbitrary p
  @unfold "merge_sort_fun xs"
@qed

lemma mergeSort_correct [hoare_triple]:
  "<p \<mapsto>\<^sub>a xs * $(merge_sort_time (length xs))>
   merge_sort_impl p
   <\<lambda>_. p \<mapsto>\<^sub>a sort xs>\<^sub>t" by auto2

end


(*  Title:       Verification components for hybrid systems
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Verification components for hybrid systems \<close>

text \<open> A light-weight version of the verification components. We define the forward box
operator to compute weakest liberal preconditions (wlps) of hybrid programs. Then we
introduce three methods for verifying correctness specifications of the continuous
dynamics of a HS. \<close>

theory HS_VC_Spartan
  imports HS_ODEs

begin

type_synonym 'a pred = "'a \<Rightarrow> bool"

no_notation Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)

notation Union ("\<mu>")
     and g_orbital ("(1x\<acute>=_ & _ on _ _ @ _)")

abbreviation "skip \<equiv> (\<lambda>s. {s})"

subsection \<open>Verification of regular programs\<close>

text \<open>First we add lemmas for computation of weakest liberal preconditions (wlps).\<close>

definition fbox :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b pred \<Rightarrow> 'a pred" ("|_] _" [61,81] 82)
  where "|F] P = (\<lambda>s. (\<forall>s'. s' \<in> F s \<longrightarrow> P s'))"

lemma fbox_iso: "P \<le> Q \<Longrightarrow> |F] P \<le> |F] Q"
  unfolding fbox_def by auto

lemma fbox_invariants:
  assumes "I \<le> |F] I" and "J \<le> |F] J"
  shows "(\<lambda>s. I s \<and> J s) \<le> |F] (\<lambda>s. I s \<and> J s)"
    and "(\<lambda>s. I s \<or> J s) \<le> |F] (\<lambda>s. I s \<or> J s)"
  using assms unfolding fbox_def by auto

text \<open>Now, we compute wlps for specific programs starting with @{text "skip"}.\<close>

lemma fbox_eta[simp]: "fbox skip P = P"
  unfolding fbox_def by simp

text \<open>Next, we introduce assignments and their wlps.\<close>

definition vec_upd :: "'a^'n \<Rightarrow> 'n \<Rightarrow> 'a \<Rightarrow> 'a^'n"
  where "vec_upd s i a = (\<chi> j. ((($) s)(i := a)) j)"

definition assign :: "'n \<Rightarrow> ('a^'n \<Rightarrow> 'a) \<Rightarrow> 'a^'n \<Rightarrow> ('a^'n) set" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})"

lemma fbox_assign[simp]: "|x ::= e] Q = (\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j))"
  unfolding vec_upd_def assign_def by (subst fbox_def) simp

text \<open>The wlp of a (kleisli) composition is just the composition of the wlps.\<close>

definition kcomp :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('b \<Rightarrow> 'c set) \<Rightarrow> ('a  \<Rightarrow> 'c set)" (infixl ";" 75) where
  "F ; G = \<mu> \<circ> \<P> G \<circ> F"

lemma kcomp_eq: "(f ; g) x = \<Union> {g y |y. y \<in> f x}"
  unfolding kcomp_def image_def by auto

lemma fbox_kcomp[simp]: "|G ; F] P = |G] |F] P"
  unfolding fbox_def kcomp_def by auto

lemma hoare_kcomp:
  assumes "P \<le> |G] R" "R \<le> |F] Q"
  shows "P \<le> |G ; F] Q"
  apply(subst fbox_kcomp)
  by (rule order.trans[OF assms(1)]) (rule fbox_iso[OF assms(2)])

text \<open>We also have an implementation of the conditional operator and its wlp.\<close>

definition ifthenelse :: "'a pred \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set)"
  ("IF _ THEN _ ELSE _" [64,64,64] 63) where
  "IF P THEN X ELSE Y \<equiv> (\<lambda>s. if P s then X s else Y s)"

lemma fbox_if_then_else[simp]:
  "|IF T THEN X ELSE Y] Q = (\<lambda>s. (T s \<longrightarrow> ( |X] Q) s) \<and> (\<not> T s \<longrightarrow> ( |Y] Q) s))"
  unfolding fbox_def ifthenelse_def by auto

lemma hoare_if_then_else:
  assumes "(\<lambda>s. P s \<and> T s) \<le> |X] Q"
    and "(\<lambda>s. P s \<and> \<not> T s) \<le> |Y] Q"
  shows "P \<le> |IF T THEN X ELSE Y] Q"
  using assms unfolding fbox_def ifthenelse_def by auto

text \<open>The final wlp we add is that of the finite iteration.\<close>

definition kpower :: "('a \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a set)"
  where "kpower f n = (\<lambda>s. ((;) f ^^ n) skip s)"

lemma kpower_base:
  shows "kpower f 0 s = {s}" and "kpower f (Suc 0) s = f s"
  unfolding kpower_def by(auto simp: kcomp_eq)

lemma kpower_simp: "kpower f (Suc n) s = (f ; kpower f n) s"
  unfolding kcomp_eq
  apply(induct n)
  unfolding kpower_base
   apply(force simp: subset_antisym)
  unfolding kpower_def kcomp_eq by simp

definition kleene_star :: "('a \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(_\<^sup>*)" [1000] 999)
  where "(f\<^sup>*) s = \<Union> {kpower f n s |n. n \<in> UNIV}"

lemma kpower_inv:
  fixes F :: "'a \<Rightarrow> 'a set"
  assumes "\<forall>s. I s \<longrightarrow> (\<forall>s'. s' \<in> F s \<longrightarrow> I s')"
  shows "\<forall>s. I s \<longrightarrow> (\<forall>s'. s' \<in> (kpower F n s) \<longrightarrow> I s')"
  apply(clarsimp, induct n)
  unfolding kpower_base kpower_simp
   apply(simp_all add: kcomp_eq, clarsimp)
  apply(subgoal_tac "I y", simp)
  using assms by blast

lemma kstar_inv: "I \<le> |F] I \<Longrightarrow> I \<le> |F\<^sup>*] I"
  unfolding kleene_star_def fbox_def
  apply clarsimp
  apply(unfold le_fun_def, subgoal_tac "\<forall>x. I x \<longrightarrow> (\<forall>s'. s' \<in> F x \<longrightarrow> I s')")
  using kpower_inv[of I F] by blast simp

lemma fbox_kstarI:
  assumes "P \<le> I" and "I \<le> Q" and "I \<le> |F] I"
  shows "P \<le> |F\<^sup>*] Q"
proof-
  have "I \<le> |F\<^sup>*] I"
    using assms(3) kstar_inv by blast
  hence "P \<le> |F\<^sup>*] I"
    using assms(1) by auto
  also have "|F\<^sup>*] I \<le> |F\<^sup>*] Q"
    by (rule fbox_iso[OF assms(2)])
  finally show ?thesis .
qed

definition loopi :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP F INV I \<equiv> (F\<^sup>*)"

lemma fbox_loopI: "P \<le> I \<Longrightarrow> I \<le> Q \<Longrightarrow> I \<le> |F] I \<Longrightarrow> P \<le> |LOOP F INV I] Q"
  unfolding loopi_def using fbox_kstarI[of "P"] by simp

subsection \<open>Verification of hybrid programs\<close>

text \<open>Verification by providing evolution\<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> 'a set \<Rightarrow> ('b \<Rightarrow> 'b set)" ("EVOL")
  where "EVOL \<phi> G T = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G T)"

lemma fbox_g_evol[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "|EVOL \<phi> G T] Q = (\<lambda>s. (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  unfolding g_evol_def g_orbit_eq fbox_def by auto

text \<open>Verification by providing solutions\<close>

lemma fbox_g_orbital: "|x\<acute>=f & G on T S @ t\<^sub>0] Q =
  (\<lambda>s. \<forall>X\<in>Sols (\<lambda>t. f) T S t\<^sub>0 s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (X \<tau>)) \<longrightarrow> Q (X t))"
  unfolding fbox_def g_orbital_eq by (auto simp: fun_eq_iff)

context local_flow
begin

lemma fbox_g_ode: "|x\<acute>=f & G on T S @ 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))" (is "_ = ?wlp")
  unfolding fbox_g_orbital
  apply(rule ext, safe, clarsimp)
    apply(erule_tac x="\<lambda>t. \<phi> t s" in ballE)
  using in_ivp_sols
     apply(force, force, force simp: init_time ivp_sols_def)
  apply(subgoal_tac "\<forall>\<tau>\<in>down T t. X \<tau> = \<phi> \<tau> s", simp_all, clarsimp)
  apply(subst eq_solution, simp_all add: ivp_sols_def)
  using init_time by auto

lemma fbox_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> |x\<acute>=f & G on {0..t} S @ 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  unfolding fbox_g_orbital
  apply(rule ext, clarsimp, safe)
    apply(erule_tac x="\<lambda>t. \<phi> t s" in ballE, force)
  using in_ivp_sols_ivl
    apply(force simp: closed_segment_eq_real_ivl)
  using in_ivp_sols_ivl
   apply(force simp: ivp_sols_def)
  apply(subgoal_tac "\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. X \<tau> = \<phi> \<tau> s)", simp, clarsimp)
  apply(subst eq_solution_ivl, simp_all add: ivp_sols_def)
     apply(rule has_vderiv_on_subset, force, force simp: closed_segment_eq_real_ivl)
    apply(force simp: closed_segment_eq_real_ivl)
  using interval_time init_time
   apply (meson is_interval_1 order_trans)
  using init_time by force

lemma fbox_orbit: "|\<gamma>\<^sup>\<phi>] Q = (\<lambda>s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s)))"
  unfolding orbit_def fbox_g_ode by simp

end

text \<open> Verification with differential invariants \<close>

definition g_ode_inv :: "(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> real set \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on T S @ t\<^sub>0 DINV I) = (x\<acute>= f & G on T S @ t\<^sub>0)"

lemma fbox_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "|x\<acute>=f & G on T S @ t\<^sub>0] Q = |x\<acute>=f & G on T S @ t\<^sub>0] H "
  unfolding fbox_g_orbital using assms by auto

lemma fbox_g_orbital_inv:
  assumes "P \<le> I" and "I \<le> |x\<acute>=f & G on T S @ t\<^sub>0] I" and "I \<le> Q"
  shows "P \<le> |x\<acute>=f & G on T S @ t\<^sub>0] Q"
  using assms(1) apply(rule order.trans)
  using assms(2) apply(rule order.trans)
  by (rule fbox_iso[OF assms(3)])

lemma fbox_diff_inv[simp]:
  "(I \<le> |x\<acute>=f & G on T S @ t\<^sub>0] I) = diff_invariant I f T S t\<^sub>0 G"
  by (auto simp: diff_invariant_def ivp_sols_def fbox_def g_orbital_eq)

lemma diff_inv_guard_ignore:
  assumes "I \<le> |x\<acute>= f & (\<lambda>s. True) on T S @ t\<^sub>0] I"
  shows "I \<le> |x\<acute>= f & G on T S @ t\<^sub>0] I"
  using assms unfolding fbox_diff_inv diff_invariant_eq image_le_pred by auto

context local_flow
begin

lemma fbox_diff_inv_eq: "diff_invariant I f T S 0 (\<lambda>s. True) =
  ((\<lambda>s. s \<in> S \<longrightarrow> I s) = |x\<acute>= f & (\<lambda>s. True) on T S @ 0] (\<lambda>s. s \<in> S \<longrightarrow> I s))"
  unfolding fbox_diff_inv[symmetric] fbox_g_orbital le_fun_def fun_eq_iff
  using init_time
  apply(clarsimp simp: subset_eq ivp_sols_def)
  apply(safe, force, force)
   apply(subst ivp(2)[symmetric], simp)
   apply(erule_tac x="\<lambda>t. \<phi> t x" in allE)
  using in_domain has_vderiv_on_domain ivp(2) init_time by auto

lemma diff_inv_eq_inv_set: "diff_invariant I f T S 0 (\<lambda>s. True) = (\<forall>s. I s \<longrightarrow> \<gamma>\<^sup>\<phi> s \<subseteq> {s. I s})"
  unfolding diff_inv_eq_inv_set orbit_def by simp

end

lemma fbox_g_odei: "P \<le> I \<Longrightarrow> I \<le> |x\<acute>= f & G on T S @ t\<^sub>0] I \<Longrightarrow> (\<lambda>s. I s \<and> G s) \<le> Q \<Longrightarrow>
  P \<le> |x\<acute>= f & G on T S @ t\<^sub>0 DINV I] Q"
  unfolding g_ode_inv_def
  apply(rule_tac b="|x\<acute>= f & G on T S @ t\<^sub>0] I" in order.trans)
   apply(rule_tac I="I" in fbox_g_orbital_inv, simp_all)
  apply(subst fbox_g_orbital_guard, simp)
  by (rule fbox_iso, force)

subsection \<open> Derivation of the rules of dL \<close>

text \<open> We derive domain specific rules of differential dynamic logic (dL). First we present a
generalised version, then we show the rules as instances of the general ones.\<close>

lemma diff_solve_axiom:
  fixes c::"'a::{heine_borel, banach}"
  assumes "0 \<in> T" and "is_interval T" "open T"
  shows "|x\<acute>=(\<lambda>s. c) & G on T UNIV @ 0] Q =
  (\<lambda>s. \<forall>t\<in>T. (\<P> (\<lambda>\<tau>. s + \<tau> *\<^sub>R c) (down T t) \<subseteq> {s. G s}) \<longrightarrow> Q (s + t *\<^sub>R c))"
  apply(subst local_flow.fbox_g_ode[of "\<lambda>s. c" _ _ "(\<lambda>t s. s + t *\<^sub>R c)"])
  using line_is_local_flow assms by auto

lemma diff_solve_rule:
  assumes "local_flow f T UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall> t\<in>T. (\<P> (\<lambda>t. \<phi> t s) (down T t) \<subseteq> {s. G s}) \<longrightarrow> Q (\<phi> t s))"
  shows "P \<le> |x\<acute>= f & G on T UNIV @ 0] Q"
  using assms by(subst local_flow.fbox_g_ode) auto

lemma diff_weak_axiom: "|x\<acute>= f & G on T S @ t\<^sub>0] Q = |x\<acute>= f & G on T S @ t\<^sub>0] (\<lambda>s. G s \<longrightarrow> Q s)"
  unfolding fbox_g_orbital image_def by force

lemma diff_weak_rule: "G \<le> Q \<Longrightarrow> P \<le> |x\<acute>= f & G on T S @ t\<^sub>0] Q"
  by(auto intro: g_orbitalD simp: le_fun_def g_orbital_eq fbox_def)

lemma fbox_g_orbital_eq_univD:
  assumes "|x\<acute>= f & G on T S @ t\<^sub>0] C = (\<lambda>s. True)"
    and "\<forall>\<tau>\<in>(down T t). x \<tau> \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
  shows "\<forall>\<tau>\<in>(down T t). C (x \<tau>)"
proof
  fix \<tau> assume "\<tau> \<in> (down T t)"
  hence "x \<tau> \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    using assms(2) by blast
  also have "\<forall>s'. s' \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s \<longrightarrow> C s'"
    using assms(1) unfolding fbox_def by meson
  ultimately show "C (x \<tau>)" by blast
qed

lemma diff_cut_axiom:
  assumes Thyp: "is_interval T" "t\<^sub>0 \<in> T"
    and "|x\<acute>= f & G on T S @ t\<^sub>0] C = (\<lambda>s. True)"
  shows "|x\<acute>= f & G on T S @ t\<^sub>0] Q = |x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0] Q"
proof(rule_tac f="\<lambda> x. |x] Q" in HOL.arg_cong, rule ext, rule subset_antisym)
  fix s
  {fix s' assume "s' \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    then obtain \<tau>::real and X where x_ivp: "X \<in> Sols (\<lambda>t. f) T S t\<^sub>0 s"
      and "X \<tau> = s'" and "\<tau> \<in> T" and guard_x:"\<P> X (down T \<tau>) \<subseteq> {s. G s}"
      using g_orbitalD[of s' "f" G T S t\<^sub>0 s]  by blast
    have "\<forall>t\<in>(down T \<tau>). \<P> X (down T t) \<subseteq> {s. G s}"
      using guard_x by (force simp: image_def)
    also have "\<forall>t\<in>(down T \<tau>). t \<in> T"
      using \<open>\<tau> \<in> T\<close> Thyp closed_segment_subset_interval by auto
    ultimately have "\<forall>t\<in>(down T \<tau>). X t \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp] by (metis (mono_tags, lifting))
    hence "\<forall>t\<in>(down T \<tau>). C (X t)"
      using assms(3) unfolding fbox_def by meson
    hence "s' \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp \<open>\<tau> \<in> T\<close>] guard_x \<open>X \<tau> = s'\<close> by fastforce}
  thus "(x\<acute>= f & G on T S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s"
    by blast
next show "\<And>s. (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    by (auto simp: g_orbital_eq)
qed

lemma diff_cut_rule:
  assumes Thyp: "is_interval T" "t\<^sub>0 \<in> T"
    and fbox_C: "P \<le> |x\<acute>= f & G on T S @ t\<^sub>0] C"
    and fbox_Q: "P \<le> |x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0] Q"
  shows "P \<le> |x\<acute>= f & G on T S @ t\<^sub>0] Q"
proof(subst fbox_def, subst g_orbital_eq, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "P s" and "t \<in> T"
    and x_ivp:"X \<in> Sols (\<lambda>t. f) T S t\<^sub>0 s"
    and guard_x:"\<forall>\<tau>. \<tau> \<in> T \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)"
  have "\<forall>\<tau>\<in>(down T t). X \<tau> \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    using g_orbitalI[OF x_ivp] guard_x unfolding image_le_pred by auto
  hence "\<forall>\<tau>\<in>(down T t). C (X \<tau>)"
    using fbox_C \<open>P s\<close> by (subst (asm) fbox_def, auto)
  hence "X t \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s"
    using guard_x \<open>t \<in> T\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "Q (X t)"
    using \<open>P s\<close> fbox_Q by (subst (asm) fbox_def) auto
qed

text \<open>The rules of dL\<close>

abbreviation g_global_orbit ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set"
  ("(1x\<acute>=_ & _)") where "(x\<acute>=f & G) \<equiv> (x\<acute>=f & G on UNIV UNIV @ 0)"

abbreviation g_global_ode_inv ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set"
  ("(1x\<acute>=_ & _ DINV _)") where "(x\<acute>=f & G DINV I) \<equiv> (x\<acute>=f & G on UNIV UNIV @ 0 DINV I)"

lemma solve:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall>t. (\<forall>\<tau>\<le>t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "P \<le> |x\<acute>= f & G] Q"
  apply(rule diff_solve_rule[OF assms(1)])
  using assms(2) unfolding image_le_pred by simp

lemma DS:
  fixes c::"'a::{heine_borel, banach}"
  shows "|x\<acute>=(\<lambda>s. c) & G] Q = (\<lambda>x. \<forall>t. (\<forall>\<tau>\<le>t. G (x + \<tau> *\<^sub>R c)) \<longrightarrow> Q (x + t *\<^sub>R c))"
  by (subst diff_solve_axiom[of UNIV]) auto

lemma DW: "|x\<acute>= f & G] Q = |x\<acute>= f & G] (\<lambda>s. G s \<longrightarrow> Q s)"
  by (rule diff_weak_axiom)

lemma DC:
  assumes "|x\<acute>= f & G] C = (\<lambda>s. True)"
  shows "|x\<acute>= f & G] Q = |x\<acute>= f & (\<lambda>s. G s \<and> C s)] Q"
  by (rule diff_cut_axiom) (auto simp: assms)

lemma dC:
  assumes "P \<le> |x\<acute>= f & G] C"
    and "P \<le> |x\<acute>= f & (\<lambda>s. G s \<and> C s)] Q"
  shows "P \<le> |x\<acute>= f & G] Q"
  apply(rule diff_cut_rule)
  using assms by auto

end


(*section {* Sliceable  *}*)
text {*\label{sec:theory-sliceable} *}

(*<*)
theory Sliceable

imports Main

begin
(*>*)

text {*
  In this section we present a class to express sub-structures for a data type, and laws over such a class.
  For example, for lists, \emph{sliceable} defines operators and theorems to obtain sublists.
*}

class sliceable =
  fixes slice :: "'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" ("(3_\<dagger>_.._)"  [80,80,80] 80)
  fixes size :: "'a \<Rightarrow> nat" ("(1#_)" 65)
  fixes empty_inter :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes disjoint :: "'a \<Rightarrow> bool"
  (*assumes disjoint_simp [simp]: "disjoint x"*)
  assumes slice_none: "x\<dagger>0..(#x) = x"
  assumes empty_seq_inter [simp]:
    "disjoint x \<Longrightarrow> c \<le> k \<Longrightarrow> empty_inter (x\<dagger>0..c) (x\<dagger>k..(#x))"
  assumes size_slice: "size (x\<dagger>i..j) = max 0 ((min j (size x))-i)"
  assumes slice_slice: "(x\<dagger>i..j)\<dagger>a..b = x\<dagger>(i+a)..(min j (i+b))"
  assumes disjoint_slice_suc:
    "disjoint x \<Longrightarrow> i\<noteq>j \<Longrightarrow> i < (#x) \<Longrightarrow> j < (#x) \<Longrightarrow>
    x\<dagger>i..(Suc i) \<noteq> x\<dagger>j..(Suc j)"
  assumes disjoint_slice[simp]: "disjoint x \<Longrightarrow> disjoint (x\<dagger>i..j)"
  assumes forall_slice_implies_eq: "(#x) = (#y) \<and> (\<forall>i j. (x\<dagger>i..j) =
    (y\<dagger>i..j)) \<longleftrightarrow> (x = y)"
  (*
  assumes forall_slice_Suc_implies_eq:
    "(#x) = (#y) \<and> (\<forall>i. x\<dagger>i..(Suc i) = y\<dagger>i..(Suc i)) \<longleftrightarrow> (x = y)"
  *)
notation (latex output) slice  ("(3_\<^bsub>[_.._]\<^esub>)" [80,80,80] 80)

text {* Teste @{term "slice x i j"}*}

definition slice_right :: "'a::sliceable \<Rightarrow> nat \<Rightarrow> 'a" ("(2_\<dagger>.._)" [80,80] 80)
where "slice_right x i = x\<dagger>0..i"

notation ("latex") slice_right  ("(2_\<^bsub>[.._]\<^esub>)" [80,80] 80)

(*text {* The notation for @{term "slice_right x i"} is @{term "x\<^bsub>[..i]\<^esub>"}  *}*)

definition slice_left :: "'a::sliceable \<Rightarrow> nat \<Rightarrow> 'a" ("(2_\<dagger>_..)" [80,80] 80)
where "x\<dagger>i.. = x\<dagger>i..(# x)"

notation ("latex") slice_left  ("(2_\<^bsub>[_..]\<^esub>)" [80,80] 80)

(*subsection {* Disjoint elements and sliceable *}*)

lemma (in sliceable) slice_right_disjoint[simp]: "disjoint xs \<Longrightarrow>
  disjoint (slice_right xs i)"
unfolding slice_right_def
by simp
text {* The notation for @{term "slice_right x i"} is @{term "x\<^bsub>[..i]\<^esub>"}  *}

lemma (in sliceable) slice_left_disjoint[simp]: "disjoint xs \<Longrightarrow>
  disjoint (xs\<dagger>i..)"
unfolding slice_left_def
by simp

(*subsection {* n-th element in a sliceable *}*)

abbreviation sliceable_nth :: "'a::sliceable \<Rightarrow> nat \<Rightarrow> 'a"
where
"sliceable_nth l i \<equiv> l\<dagger>i..(Suc i)"

(*subsection {* Theorems for sliceable *}*)

theorem (in sliceable) empty_seq_inter_eq [simp]:
  "disjoint x \<Longrightarrow> empty_inter (x\<dagger>..i) (x\<dagger>i..)"
by (simp add: slice_right_def slice_left_def)

theorem (in sliceable) empty_seq_sliced_inter [simp]:
  "disjoint x \<Longrightarrow> b \<le> i \<Longrightarrow> j \<le> a \<Longrightarrow> i \<le> j \<Longrightarrow> a \<le> size x \<Longrightarrow>
    empty_inter (x\<dagger>b..i) (x\<dagger>j..a)"
proof-
  let ?l = "x\<dagger>b..a"
  assume lt0: "i \<le> j"
  assume lt1: "j \<le> a"
  assume lt2: "b \<le> i"
  assume lt3: "a \<le> size x"
  assume lt4: "disjoint x"
  have blta: "b \<le> a" using lt0 lt1 lt2 by simp
  have ilta: "i \<le> a" using lt0 lt1 by simp
  hence 2: "empty_inter (?l\<dagger>0..(i-b)) (?l\<dagger>(j-b)..(#?l))"
    using lt0 lt4 disjoint_slice by simp
  hence "empty_inter ((x\<dagger>b..a)\<dagger>0..(i-b)) ((x\<dagger>b..a)\<dagger>(j-b)..(#?l))" by simp
  hence 3: "empty_inter (x\<dagger>b..i) ((x\<dagger>b..a)\<dagger>(j-b)..(#(x\<dagger>b..a)))" using ilta lt2
    by (simp add: slice_slice min_absorb2)
  hence 3: "empty_inter (x\<dagger>b..i) (x\<dagger>j..a)"
    using blta lt0 lt2 lt3
    by (auto simp add: size_slice slice_slice min_def)
  thus ?thesis by simp
qed

theorem distinct_slice_lte_inter_empty[simp]:
  "distinct l \<Longrightarrow> i \<le> j \<Longrightarrow>
    set (take i (drop 0 l))
    \<inter> set (take (length l-i) (drop i l)) = {}"
by (simp add: set_take_disj_set_drop_if_distinct )

lemma (in sliceable) size_slice_right_absorb: "(#(l\<dagger>..i)) = min i (#l)"
by (simp add: slice_right_def sliceable_class.size_slice)

lemma (in sliceable) size_slice_left_absorb: "(#(l\<dagger>i..)) = (#l)-i"
by (simp add: slice_left_def sliceable_class.size_slice)

corollary (in sliceable) slice_right_slice_left_absorb: "(l\<dagger>..i)\<dagger>j.. = l\<dagger>j..i"
unfolding slice_left_def slice_right_def
by (metis (mono_tags, hide_lams) add.left_neutral add.right_neutral max_0L
  min.left_idem size_slice_right_absorb slice_right_def
  sliceable_class.size_slice sliceable_class.slice_none
  sliceable_class.slice_slice)

corollary (in sliceable) slice_right_slice_left_absorb_empty:
  "i \<le> j \<Longrightarrow> (#((l\<dagger>..i)\<dagger>j..)) = 0"
by (simp add: size_slice_left_absorb size_slice_right_absorb)

corollary (in sliceable) slice_left_slice_right_absorb:
  "(l\<dagger>i..)\<dagger>..j = l\<dagger>i..(i+j)"
unfolding slice_left_def slice_right_def
proof -
  have "(l\<dagger>i..(#l))\<dagger>0..j = (l\<dagger>0..(#l))\<dagger>i..(i + j)"
    by (simp add: sliceable_class.slice_slice)
  thus "(l\<dagger>i..(#l))\<dagger>0..j = l\<dagger>i..(i + j)"
    by (simp add: sliceable_class.slice_none)
qed

corollary (in sliceable) slice_right_slice_right_absorb:
  "(l\<dagger>..i)\<dagger>..j = (l\<dagger>..(min i j))"
unfolding slice_left_def slice_right_def
by (simp add: sliceable_class.slice_slice)

corollary (in sliceable) slice_left_slice_left_absorb:
  "(l\<dagger>i..)\<dagger>j.. = l\<dagger>(i+j).."
unfolding slice_left_def slice_right_def
by (simp add: sliceable_class.slice_slice sliceable_class.size_slice
  min_absorb1)

corollary (in sliceable) slice_slice_right_absorb:
  "(l\<dagger>i..j)\<dagger>..b = l\<dagger>i..(min j (i+b))"
unfolding slice_left_def slice_right_def
by (simp add: add.commute sliceable_class.slice_slice)

corollary (in sliceable) slice_slice_left_absorb:
  "(l\<dagger>i..j)\<dagger>a.. = l\<dagger>(i+a)..j"
unfolding slice_left_def slice_right_def
by (metis (mono_tags, hide_lams) add.assoc diff_diff_left max_0L
  slice_left_def slice_left_slice_right_absorb slice_right_def
  slice_slice_right_absorb sliceable_class.size_slice
  sliceable_class.slice_none sliceable_class.slice_slice)

corollary (in sliceable) slice_left_slice_absorb:
  "(l\<dagger>i..)\<dagger>a..b = l\<dagger>(i+a)..(i+b)"
unfolding slice_left_def slice_right_def
by (metis (mono_tags, lifting) slice_left_slice_right_absorb slice_right_def
  slice_right_slice_left_absorb slice_slice_left_absorb
  sliceable_class.slice_none)

corollary (in sliceable) slice_right_slice_absorb:
  "(l\<dagger>..j)\<dagger>a..b = l\<dagger>a..(min j b)"
unfolding slice_left_def slice_right_def
by (simp add: sliceable_class.slice_slice)

lemmas (in sliceable) slice_slice_simps =
  slice_left_slice_left_absorb slice_left_slice_right_absorb
  slice_right_slice_left_absorb slice_right_slice_right_absorb slice_slice
  slice_slice_right_absorb slice_slice_left_absorb slice_left_slice_absorb
  slice_right_slice_absorb

lemmas (in sliceable) size_slice_defs =
  size_slice size_slice_left_absorb size_slice_right_absorb

lemma (in sliceable) slice_f_min_neutral:
  "(P (l\<dagger>i..(min f k)) \<and> f \<le> k) \<longleftrightarrow> (P (l\<dagger>i..f) \<and> f \<le> k)"
by linarith

lemma (in sliceable) slice_i_min_neutral:
  "(P (l\<dagger>(min i k)..f) \<and> i \<le> k) \<longleftrightarrow> (P (l\<dagger>i..f) \<and> i \<le> k)"
by linarith

lemma (in sliceable) slice_i_min_neutral_lt:
  "(P (l\<dagger>(min k i)..f) \<and> i < k) \<longleftrightarrow> (P (l\<dagger>i..f) \<and> i < k)"
by linarith

lemma (in sliceable) slice_foral_i_min_neutral:
  "(\<forall> i f . P (l\<dagger>(min i k)..f) \<and> i \<le> k) \<longleftrightarrow> (\<forall> i f . P (l\<dagger>i..f) \<and> i \<le> k)"
using not_less by auto

lemma (in sliceable) slice_f_max_neutral:
  "(P (l\<dagger>i..(max f k)) \<and> f \<ge> k) \<longleftrightarrow> (P (l\<dagger>i..f) \<and> f \<ge> k)"
by (metis max.orderE)

lemma (in sliceable) slice_i_max_neutral:
  "(P (l\<dagger>(max i k)..f) \<and> i \<ge> k) \<longleftrightarrow> (P (l\<dagger>i..f) \<and> i \<ge> k)"
by (metis max.orderE)

lemma (in sliceable) empty_slice[simp]: "i \<le> j \<Longrightarrow> (#(l\<dagger>j..i)) = 0"
using local.size_slice by auto

corollary (in sliceable) forall_disjoint_slice_suc:
  "\<forall> i j . (disjoint x \<and> i\<noteq>j \<and> i < (#x) \<and> j < (#x)) \<longrightarrow>
    (x\<dagger>i..(Suc i) \<noteq> x\<dagger>j..(Suc j))"
by (simp add: local.disjoint_slice_suc)

lemma (in sliceable) empty_slice_none:
  "(#x) = 0 \<Longrightarrow> (#(x\<dagger>i..j)) = 0"
by (simp add: size_slice)

corollary (in sliceable) empty_slice_right_none:
  "(#x) = 0 \<Longrightarrow> (#(x\<dagger>..j)) = 0"
by (simp add: slice_right_def sliceable_class.empty_slice_none)

corollary (in sliceable) empty_slice_left_none:
  "(#x) = 0 \<Longrightarrow> (#(x\<dagger>i..)) = 0"
by (simp add: slice_left_def sliceable_class.empty_slice_none)

(*<*)
end
(*>*)


(*  Title:      HOL/Hoare/Hoare_Logic_Abort.thy
    Author:     Leonor Prensa Nieto & Tobias Nipkow
    Copyright   2003 TUM

Like Hoare.thy, but with an Abort statement for modelling run time errors.
*)

theory Hoare_Logic_Abort
imports Main
begin

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
  Basic "'a \<Rightarrow> 'a"
| Abort
| Seq "'a com" "'a com"               ("(_;/ _)"      [61,60] 60)
| Cond "'a bexp" "'a com" "'a com"    ("(1IF _/ THEN _ / ELSE _/ FI)"  [0,0,0] 61)
| While "'a bexp" "'a assn" "'a com"  ("(1WHILE _/ INV {_} //DO _ /OD)"  [0,0,0] 61)

abbreviation annskip ("SKIP") where "SKIP == Basic id"

type_synonym 'a sem = "'a option => 'a option => bool"

inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) None None"
| "Sem (Basic f) (Some s) (Some (f s))"
| "Sem Abort s None"
| "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (c1;c2) s s'"
| "Sem (IF b THEN c1 ELSE c2 FI) None None"
| "s \<in> b \<Longrightarrow> Sem c1 (Some s) s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) (Some s) s'"
| "s \<notin> b \<Longrightarrow> Sem c2 (Some s) s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) (Some s) s'"
| "Sem (While b x c) None None"
| "s \<notin> b \<Longrightarrow> Sem (While b x c) (Some s) (Some s)"
| "s \<in> b \<Longrightarrow> Sem c (Some s) s'' \<Longrightarrow> Sem (While b x c) s'' s' \<Longrightarrow>
   Sem (While b x c) (Some s) s'"

inductive_cases [elim!]:
  "Sem (Basic f) s s'" "Sem (c1;c2) s s'"
  "Sem (IF b THEN c1 ELSE c2 FI) s s'"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool" where
  "Valid p c q == \<forall>s s'. Sem c s s' \<longrightarrow> s : Some ` p \<longrightarrow> s' : Some ` q"

syntax
  "_assign" :: "idt => 'b => 'a com"  ("(2_ :=/ _)" [70, 65] 61)

syntax
  "_hoare_abort_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
                 ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
syntax ("" output)
  "_hoare_abort"      :: "['a assn,'a com,'a assn] => bool"
                 ("{_} // _ // {_}" [0,55,0] 50)

ML_file "hoare_syntax.ML"
parse_translation \<open>[(@{syntax_const "_hoare_abort_vars"}, K Hoare_Syntax.hoare_vars_tr)]\<close>
print_translation
  \<open>[(@{const_syntax Valid}, K (Hoare_Syntax.spec_tr' @{syntax_const "_hoare_abort"}))]\<close>

(*** The proof rules ***)

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
by (auto simp:Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
by (auto simp:Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
by (auto simp:Valid_def)

lemma CondRule:
 "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
  \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
by (fastforce simp:Valid_def image_def)

lemma While_aux:
  assumes "Sem (WHILE b INV {i} DO c OD) s s'"
  shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> Some ` (I \<inter> b) \<longrightarrow> s' \<in> Some ` I \<Longrightarrow>
    s \<in> Some ` I \<Longrightarrow> s' \<in> Some ` (I \<inter> -b)"
  using assms
  by (induct "WHILE b INV {i} DO c OD" s s') auto

lemma WhileRule:
 "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i c) q"
apply(simp add:Valid_def)
apply(simp (no_asm) add:image_def)
apply clarify
apply(drule While_aux)
  apply assumption
 apply blast
apply blast
done

lemma AbortRule: "p \<subseteq> {s. False} \<Longrightarrow> Valid p Abort q"
by(auto simp:Valid_def)

subsection \<open>Derivation of the proof rules and, most importantly, the VCG tactic\<close>

lemma Compl_Collect: "-(Collect b) = {x. ~(b x)}"
  by blast

ML_file "hoare_tac.ML"

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

(* Special syntax for guarded statements and guarded array updates: *)

syntax
  "_guarded_com" :: "bool \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(2_ \<rightarrow>/ _)" 71)
  "_array_update" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a com"  ("(2_[_] :=/ _)" [70, 65] 61)
translations
  "P \<rightarrow> c" == "IF P THEN c ELSE CONST Abort FI"
  "a[i] := v" => "(i < CONST length a) \<rightarrow> (a := CONST list_update a i v)"
  (* reverse translation not possible because of duplicate "a" *)

text\<open>Note: there is no special syntax for guarded array access. Thus
you must write \<open>j < length a \<rightarrow> a[i] := a!j\<close>.\<close>

end