(*<*)
theory Robinson_Arithmetic
imports Nominal2.Nominal2
begin
(*>*)

section \<open>Terms and Formulas\<close>

text \<open>nat is a pure permutation type\<close>

instance nat :: pure by standard

atom_decl name

declare fresh_set_empty [simp]

lemma supp_name [simp]: fixes i::name shows "supp i = {atom i}"
  by (rule supp_at_base)

subsection \<open>The datatypes\<close>

nominal_datatype trm = zer | Var name | suc trm | pls trm trm | tms trm trm

nominal_datatype fmla =
    eql trm trm     (infixr "EQ" 150)
  | dsj fmla fmla   (infixr "OR" 130)
  | neg fmla
  | exi x::name f::fmla binds x in f

text \<open>eql are atomic formulas; dsj, neg, exi are non-atomic\<close>

declare trm.supp [simp] fmla.supp [simp]

subsection \<open>Substitution\<close>

nominal_function subst :: "name \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm"
  where
   "subst i x zer       = zer"
 | "subst i x (Var k)    = (if i=k then x else Var k)"
 | "subst i x (suc t) = suc (subst i x t)"
 | "subst i x (pls t u) = pls (subst i x t) (subst i x u)"
 | "subst i x (tms t u) = tms (subst i x t) (subst i x u)"
by (auto simp: eqvt_def subst_graph_aux_def) (metis trm.strong_exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_subst_if [simp]:
  "j \<sharp> subst i x t \<longleftrightarrow> (atom i \<sharp> t \<and> j \<sharp> t) \<or> (j \<sharp> x \<and> (j \<sharp> t \<or> j = atom i))"
  by (induct t rule: trm.induct) (auto simp: fresh_at_base)

lemma forget_subst_trm [simp]: "atom a \<sharp> trm \<Longrightarrow> subst a x trm = trm"
  by (induct trm rule: trm.induct) (simp_all add: fresh_at_base)

lemma subst_trm_id [simp]: "subst a (Var a) trm = trm"
  by (induct trm rule: trm.induct) simp_all

lemma subst_trm_commute [simp]:
  "atom j \<sharp> trm \<Longrightarrow> subst j u (subst i t trm) = subst i (subst j u t) trm"
  by (induct trm rule: trm.induct) (auto simp: fresh_Pair)

lemma subst_trm_commute2 [simp]:
  "atom j \<sharp> t \<Longrightarrow> atom i \<sharp> u \<Longrightarrow> i \<noteq> j \<Longrightarrow> subst j u (subst i t trm) = subst i t (subst j u trm)"
  by (induct trm rule: trm.induct) auto

lemma repeat_subst_trm [simp]: "subst i u (subst i t trm) = subst i (subst i u t) trm"
  by (induct trm rule: trm.induct) auto

nominal_function  subst_fmla :: "fmla \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> fmla" ("_'(_::=_')" [1000, 0, 0] 200)
  where
    eql:   "(eql t u)(i::=x)   = eql  (subst i x t) (subst i x u)"
  | dsj: "(dsj A B)(i::=x) = dsj (A(i::=x)) (B(i::=x))"
  | neg:  "(neg A)(i::=x)    = neg  (A(i::=x))"
  | exi:   "atom j \<sharp> (i, x) \<Longrightarrow> (exi j A)(i::=x) = exi j (A(i::=x))"
subgoal by (simp add: eqvt_def subst_fmla_graph_aux_def)
subgoal by auto
subgoal by (metis fmla.strong_exhaust fresh_star_insert old.prod.exhaust)
subgoal by auto
subgoal by auto
subgoal by auto
subgoal by auto
subgoal by auto
subgoal by auto
subgoal by auto
subgoal by auto
subgoal by auto
subgoal
  by (simp add: eqvt_at_def fresh_star_def fresh_Pair fresh_at_base)
     (metis flip_at_base_simps(3) flip_fresh_fresh) .

nominal_termination (eqvt)
  by lexicographic_order

lemma size_subst_fmla [simp]: "size (A(i::=x)) = size A"
  by (nominal_induct A avoiding: i x rule: fmla.strong_induct) auto

lemma forget_subst_fmla [simp]: "atom a \<sharp> A \<Longrightarrow> A(a::=x) = A"
  by (nominal_induct A avoiding: a x rule: fmla.strong_induct) (auto simp: fresh_at_base)

lemma subst_fmla_id [simp]: "A(a::=Var a) = A"
  by (nominal_induct A avoiding: a rule: fmla.strong_induct) (auto simp: fresh_at_base)

lemma subst_fmla_commute [simp]:
  "atom j \<sharp> A \<Longrightarrow> (A(i::=t))(j::=u) = A(i ::= subst j u t)"
  by (nominal_induct A avoiding: i j t u rule: fmla.strong_induct) (auto simp: fresh_at_base)

lemma repeat_subst_fmla [simp]: "(A(i::=t))(i::=u) = A(i ::= subst i u t)"
  by (nominal_induct A avoiding: i t u rule: fmla.strong_induct) auto

lemma subst_fmla_exi_with_renaming:
  "atom i' \<sharp> (A, i, j, t) \<Longrightarrow> (exi i A)(j ::= t) = exi i' (((i \<leftrightarrow> i') \<bullet> A)(j ::= t))"
  by (rule subst [of "exi i' ((i \<leftrightarrow> i') \<bullet> A)" "exi i A"])
     (auto simp: Abs1_eq_iff flip_def swap_commute)

text \<open>the simplifier cannot apply the rule above, because
it introduces a new variable at the right hand side.\<close>

lemma flip_subst_trm: "atom y \<sharp> t \<Longrightarrow> (x \<leftrightarrow> y) \<bullet> t = subst x (Var y) t"
apply(nominal_induct t avoiding: x y rule: trm.strong_induct)
by auto

lemma flip_subst_fmla: "atom y \<sharp> \<phi> \<Longrightarrow> (x \<leftrightarrow> y) \<bullet> \<phi> = \<phi>(x::=Var y)"
apply(nominal_induct \<phi> avoiding: x y rule: fmla.strong_induct)
apply (auto simp: flip_subst_trm)
using fresh_at_base(2) by blast

lemma exi_ren_subst_fresh: "atom y \<sharp> \<phi> \<Longrightarrow> exi x \<phi> = exi y (\<phi>(x::=Var y))"
  using flip_subst_fmla by auto

subsection\<open>Semantics\<close>

definition e0 :: "(name, nat) finfun"    \<comment> \<open>the null environment\<close>
  where "e0 \<equiv> finfun_const 0"

nominal_function eval_trm :: "(name, nat) finfun \<Rightarrow> trm \<Rightarrow> nat"
  where
   "eval_trm e zer = 0"
 | "eval_trm e (Var k) = finfun_apply e k"
 | "eval_trm e (suc t) = Suc (eval_trm e t)"
 | "eval_trm e (pls t u) = eval_trm e t + eval_trm e u"
 | "eval_trm e (tms t u) = eval_trm e t * eval_trm e u"
by (auto simp: eqvt_def eval_trm_graph_aux_def) (metis trm.strong_exhaust)

nominal_termination (eqvt)
  by lexicographic_order

nominal_function eval_fmla :: "(name, nat) finfun \<Rightarrow> fmla \<Rightarrow> bool"
  where
   "eval_fmla e (t EQ u) \<longleftrightarrow> eval_trm e t = eval_trm e u"
 | "eval_fmla e (A OR B) \<longleftrightarrow> eval_fmla e A \<or> eval_fmla e B"
 | "eval_fmla e (neg A) \<longleftrightarrow> (~ eval_fmla e A)"
 | "atom k \<sharp> e \<Longrightarrow> eval_fmla e (exi k A) \<longleftrightarrow> (\<exists>x. eval_fmla (finfun_update e k x) A)"
supply [[simproc del: defined_all]]
apply(simp add: eqvt_def eval_fmla_graph_aux_def)
apply(auto del: iffI) [11]
apply(rule_tac y=b and c="(a)" in fmla.strong_exhaust)
apply(auto simp: fresh_star_def)[4]
using [[simproc del: alpha_lst]] apply clarsimp
apply(erule_tac c="(ea)" in Abs_lst1_fcb2')
apply(rule pure_fresh)
apply(simp add: fresh_star_def)
apply (simp_all add: eqvt_at_def)
apply (simp_all add: perm_supp_eq)
done

nominal_termination (eqvt)
  by lexicographic_order

lemma eval_trm_rename:
  assumes "atom k' \<sharp> t"
  shows "eval_trm (finfun_update e k x) t =
         eval_trm (finfun_update e k' x) ((k' \<leftrightarrow> k) \<bullet> t)"
using assms
by (induct t rule: trm.induct) (auto simp: permute_flip_at)

lemma eval_fmla_rename:
  assumes "atom k' \<sharp> A"
  shows "eval_fmla (finfun_update e k x) A = eval_fmla (finfun_update e k' x) ((k' \<leftrightarrow> k) \<bullet> A)"
using assms
apply (nominal_induct A avoiding: e k k' x rule: fmla.strong_induct)
apply (simp_all add: eval_trm_rename[symmetric], metis)
apply (simp add: fresh_finfun_update fresh_at_base finfun_update_twist)
done

lemma better_ex_eval_fmla[simp]:
  "eval_fmla e (exi k A) \<longleftrightarrow> (\<exists>x. eval_fmla (finfun_update e k x) A)"
proof -
  obtain k'::name where k': "atom k' \<sharp> (k, e, A)"
    by (rule obtain_fresh)
  then have eq: "exi k' ((k' \<leftrightarrow> k) \<bullet> A) = exi k A"
    by (simp add: Abs1_eq_iff flip_def)
  have "eval_fmla e (exi k' ((k' \<leftrightarrow> k) \<bullet> A)) = (\<exists>x. eval_fmla (finfun_update e k' x) ((k' \<leftrightarrow> k) \<bullet> A))"
    using k' by simp
  also have "... = (\<exists>x. eval_fmla (finfun_update e k x) A)"
    by (metis eval_fmla_rename k' fresh_Pair)
  finally show ?thesis
    by (metis eq)
qed

lemma forget_eval_trm [simp]: "atom i \<sharp> t \<Longrightarrow>
    eval_trm (finfun_update e i x) t = eval_trm e t"
  by (induct t rule: trm.induct) (simp_all add: fresh_at_base)

lemma forget_eval_fmla [simp]:
   "atom k \<sharp> A \<Longrightarrow> eval_fmla (finfun_update e k x) A = eval_fmla e A"
  by (nominal_induct A avoiding: k e rule: fmla.strong_induct)
     (simp_all add: fresh_at_base finfun_update_twist)

lemma eval_subst_trm: "eval_trm e (subst i t u) =
   eval_trm (finfun_update e i (eval_trm e t)) u"
  by (induct u rule: trm.induct) (auto)

lemma eval_subst_fmla: "eval_fmla e (fmla(i::= t)) =
   eval_fmla (finfun_update e i (eval_trm e t)) fmla"
  by (nominal_induct fmla avoiding: i t e rule: fmla.strong_induct)
     (simp_all add: eval_subst_trm finfun_update_twist fresh_at_base)

subsection \<open>Derived logical connectives\<close>

abbreviation imp :: "fmla \<Rightarrow> fmla \<Rightarrow> fmla"   (infixr "IMP" 125)
  where "imp A B \<equiv> dsj (neg A) B"

abbreviation all :: "name \<Rightarrow> fmla \<Rightarrow> fmla"
  where "all i A \<equiv> neg (exi i (neg A))"

subsubsection \<open>Conjunction\<close>

definition cnj :: "fmla \<Rightarrow> fmla \<Rightarrow> fmla"   (infixr "AND" 135)
  where "cnj A B \<equiv> neg (dsj (neg A) (neg B))"

lemma cnj_eqvt [eqvt]: "p \<bullet> (A AND B) = (p \<bullet> A) AND (p \<bullet> B)"
  by (simp add: cnj_def)

lemma fresh_cnj [simp]: "a \<sharp> A AND B \<longleftrightarrow> (a \<sharp> A \<and> a \<sharp> B)"
  by (auto simp: cnj_def)

lemma supp_cnj [simp]: "supp (A AND B) = supp A \<union> supp B"
  by (auto simp: cnj_def)

lemma size_cnj [simp]: "size (A AND B) = size A + size B + 4"
  by (simp add: cnj_def)

lemma cnj_injective_iff [iff]: "(A AND B) = (A' AND B') \<longleftrightarrow> (A = A' \<and> B = B')"
  by (auto simp: cnj_def)

lemma subst_fmla_cnj [simp]: "(A AND B)(i::=x) = (A(i::=x)) AND (B(i::=x))"
  by (auto simp: cnj_def)

lemma eval_fmla_cnj [simp]: "eval_fmla e (cnj A B) \<longleftrightarrow> (eval_fmla e A \<and> eval_fmla e B)"
  by (auto simp: cnj_def)

subsubsection \<open>If and only if\<close>

definition Iff :: "fmla \<Rightarrow> fmla \<Rightarrow> fmla"   (infixr "IFF" 125)
  where "Iff A B = cnj (imp A B) (imp B A)"

lemma Iff_eqvt [eqvt]: "p \<bullet> (A IFF B) = (p \<bullet> A) IFF (p \<bullet> B)"
  by (simp add: Iff_def)

lemma fresh_Iff [simp]: "a \<sharp> A IFF B \<longleftrightarrow> (a \<sharp> A \<and> a \<sharp> B)"
  by (auto simp: cnj_def Iff_def)

lemma size_Iff [simp]: "size (A IFF B) = 2*(size A + size B) + 8"
  by (simp add: Iff_def)

lemma Iff_injective_iff [iff]: "(A IFF B) = (A' IFF B') \<longleftrightarrow> (A = A' \<and> B = B')"
  by (auto simp: Iff_def)

lemma subst_fmla_Iff [simp]: "(A IFF B)(i::=x) = (A(i::=x)) IFF (B(i::=x))"
  by (auto simp: Iff_def)

lemma eval_fmla_Iff [simp]: "eval_fmla e (Iff A B) \<longleftrightarrow> (eval_fmla e A  \<longleftrightarrow>  eval_fmla e B)"
  by (auto simp: Iff_def)

subsubsection \<open>False\<close>

definition fls  where "fls \<equiv> neg (zer EQ zer)"

lemma fls_eqvt [eqvt]: "(p \<bullet> fls) = fls"
  by (simp add: fls_def)

lemma fls_fresh [simp]: "a \<sharp> fls"
  by (simp add: fls_def)

section \<open>Axioms and Theorems\<close>

subsection \<open>Logical axioms\<close>

inductive_set boolean_axioms :: "fmla set"
  where
    Ident:     "A IMP A \<in> boolean_axioms"
  | dsjI1:    "A IMP (A OR B) \<in> boolean_axioms"
  | dsjCont:  "(A OR A) IMP A \<in> boolean_axioms"
  | dsjAssoc: "(A OR (B OR C)) IMP ((A OR B) OR C) \<in> boolean_axioms"
  | dsjcnj:  "(C OR A) IMP (((neg C) OR B) IMP (A OR B)) \<in> boolean_axioms"

lemma boolean_axioms_hold: "A \<in> boolean_axioms \<Longrightarrow> eval_fmla e A"
  by (induct rule: boolean_axioms.induct, auto)

inductive_set special_axioms :: "fmla set" where
  I: "A(i::=x) IMP (exi i A) \<in> special_axioms"

lemma special_axioms_hold: "A \<in> special_axioms \<Longrightarrow> eval_fmla e A"
  by (induct rule: special_axioms.induct, auto) (metis eval_subst_fmla)

lemma twist_forget_eval_fmla [simp]:
   "atom j \<sharp> (i, A)
    \<Longrightarrow> eval_fmla (finfun_update (finfun_update (finfun_update e i x) j y) i z) A =
        eval_fmla (finfun_update e i z) A"
  by (metis finfun_update_twice finfun_update_twist forget_eval_fmla fresh_Pair)

subsection \<open>Concrete variables\<close>

declare Abs_name_inject[simp]

abbreviation
  "X0 \<equiv> Abs_name (Atom (Sort ''Theory_Syntax_Q.name'' []) 0)"

abbreviation
  "X1 \<equiv> Abs_name (Atom (Sort ''Robinson_Arithmetic.name'' []) (Suc 0))"
   \<comment> \<open>We prefer @{term "Suc 0"} because simplification will transform 1 to that form anyway.\<close>

abbreviation
  "X2 \<equiv> Abs_name (Atom (Sort ''Robinson_Arithmetic.name'' []) 2)"

abbreviation
  "X3 \<equiv> Abs_name (Atom (Sort ''Robinson_Arithmetic.name'' []) 3)"

abbreviation
  "X4 \<equiv> Abs_name (Atom (Sort ''Robinson_Arithmetic.name'' []) 4)"

subsection \<open>Equality axioms\<close>

definition refl_ax :: fmla where
  "refl_ax = Var X1 EQ Var X1"

lemma refl_ax_holds: "eval_fmla e refl_ax"
  by (auto simp: refl_ax_def)

definition eq_cong_ax :: fmla where
  "eq_cong_ax = ((Var X1 EQ Var X2) AND (Var X3 EQ Var X4)) IMP
                ((Var X1 EQ Var X3) IMP (Var X2 EQ Var X4))"

lemma eq_cong_ax_holds: "eval_fmla e eq_cong_ax"
  by (auto simp: cnj_def eq_cong_ax_def)

definition syc_cong_ax :: fmla where
  "syc_cong_ax = ((Var X1 EQ Var X2)) IMP
                ((suc (Var X1)) EQ (suc (Var X2)))"

lemma syc_cong_ax_holds: "eval_fmla e syc_cong_ax"
  by (auto simp: cnj_def syc_cong_ax_def)

definition pls_cong_ax :: fmla where
  "pls_cong_ax = ((Var X1 EQ Var X2) AND (Var X3 EQ Var X4)) IMP
                  ((pls (Var X1) (Var X3)) EQ (pls (Var X2) (Var X4)))"

lemma pls_cong_ax_holds: "eval_fmla e pls_cong_ax"
  by (auto simp: cnj_def pls_cong_ax_def)

definition tms_cong_ax :: fmla where
  "tms_cong_ax = ((Var X1 EQ Var X2) AND (Var X3 EQ Var X4)) IMP
                  ((tms (Var X1) (Var X3)) EQ (tms (Var X2) (Var X4)))"

lemma tms_cong_ax_holds: "eval_fmla e tms_cong_ax"
  by (auto simp: cnj_def tms_cong_ax_def)

definition equality_axioms :: "fmla set" where
  "equality_axioms = {refl_ax, eq_cong_ax, syc_cong_ax, pls_cong_ax, tms_cong_ax}"

lemma equality_axioms_hold: "A \<in> equality_axioms \<Longrightarrow> eval_fmla e A"
  by (auto simp: equality_axioms_def refl_ax_holds eq_cong_ax_holds
       syc_cong_ax_holds pls_cong_ax_holds tms_cong_ax_holds)

subsection \<open>The Q (Robinson-arithmetic-specific) axioms\<close>

definition "Q_axioms \<equiv>
 {A | A X1 X2.
   X1 \<noteq> X2 \<and>
   (A = neg (zer EQ suc (Var X1)) \<or>
    A = suc (Var X1) EQ suc (Var X2) IMP Var X1 EQ Var X2 \<or>
    A = Var X2 EQ zer OR exi X1 (Var X2 EQ suc (Var X1)) \<or>
    A = pls (Var X1) zer EQ Var X1 \<or>
    A = pls (Var X1) (suc (Var X2)) EQ suc (pls (Var X1) (Var X2)) \<or>
    A = tms (Var X1) zer EQ zer \<or>
    A = tms (Var X1) (suc (Var X2)) EQ pls (tms (Var X1) (Var X2)) (Var X1))}"

subsection \<open>The proof system\<close>

inductive nprv :: "fmla set \<Rightarrow> fmla \<Rightarrow> bool" (infixl "\<turnstile>" 55)
  where
    Hyp:    "A \<in> H \<Longrightarrow> H \<turnstile> A"
  | Q:  "A \<in> Q_axioms \<Longrightarrow> H \<turnstile> A"
  | Bool:   "A \<in> boolean_axioms \<Longrightarrow> H \<turnstile> A"
  | eql:     "A \<in> equality_axioms \<Longrightarrow> H \<turnstile> A"
  | Spec:   "A \<in> special_axioms \<Longrightarrow> H \<turnstile> A"
  | MP:     "H \<turnstile> A IMP B \<Longrightarrow> H' \<turnstile> A \<Longrightarrow> H \<union> H' \<turnstile> B"
  | exiists: "H \<turnstile> A IMP B \<Longrightarrow> atom i \<sharp> B \<Longrightarrow> \<forall>C \<in> H. atom i \<sharp> C \<Longrightarrow> H \<turnstile> (exi i A) IMP B"

subsection\<open>Derived rules of inference\<close>

lemma contraction: "insert A (insert A H) \<turnstile> B \<Longrightarrow> insert A H \<turnstile> B"
  by (metis insert_absorb2)

lemma thin_Un: "H \<turnstile> A \<Longrightarrow> H \<union> H' \<turnstile> A"
  by (metis Bool MP boolean_axioms.Ident sup_commute)

lemma thin: "H \<turnstile> A \<Longrightarrow> H \<subseteq> H' \<Longrightarrow> H' \<turnstile> A"
  by (metis Un_absorb1 thin_Un)

lemma thin0: "{} \<turnstile> A \<Longrightarrow> H \<turnstile> A"
  by (metis sup_bot_left thin_Un)

lemma thin1: "H \<turnstile> B \<Longrightarrow> insert A H \<turnstile> B"
  by (metis subset_insertI thin)

lemma thin2: "insert A1 H \<turnstile> B \<Longrightarrow> insert A1 (insert A2 H) \<turnstile> B"
  by (blast intro: thin)

lemma thin4:
  "insert A1 (insert A2 (insert A3 H)) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 H))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate2: "insert A2 (insert A1 H) \<turnstile> B \<Longrightarrow> insert A1 (insert A2 H) \<turnstile> B"
  by (blast intro: thin)

lemma rotate3: "insert A3 (insert A1 (insert A2 H)) \<turnstile> B \<Longrightarrow> insert A1 (insert A2 (insert A3 H)) \<turnstile> B"
  by (blast intro: thin)

lemma rotate4:
  "insert A4 (insert A1 (insert A2 (insert A3 H))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 H))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate5:
  "insert A5 (insert A1 (insert A2 (insert A3 (insert A4 H)))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 H)))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate6:
  "insert A6 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 H))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 H))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate8:
  "insert A8 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 H))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 H))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate9:
  "insert A9 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 H)))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 H)))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate10:
  "insert A10 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 H))))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 H))))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate11:
  "insert A11 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 H)))))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 H)))))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate12:
  "insert A12 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 H))))))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 H))))))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate13:
  "insert A13 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 H)))))))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 (insert A13 H)))))))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate14:
  "insert A14 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 (insert A13 H))))))))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 (insert A13 (insert A14 H))))))))))))) \<turnstile> B"
  by (blast intro: thin)

lemma rotate15:
  "insert A15 (insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 (insert A13 (insert A14 H)))))))))))))) \<turnstile> B
   \<Longrightarrow> insert A1 (insert A2 (insert A3 (insert A4 (insert A5 (insert A6 (insert A7 (insert A8 (insert A9 (insert A10 (insert A11 (insert A12 (insert A13 (insert A14 (insert A15 H)))))))))))))) \<turnstile> B"
  by (blast intro: thin)

lemma MP_same: "H \<turnstile> A IMP B \<Longrightarrow> H \<turnstile> A \<Longrightarrow> H \<turnstile> B"
  by (metis MP Un_absorb)

lemma MP_thin: "HA \<turnstile> A IMP B \<Longrightarrow> HB \<turnstile> A \<Longrightarrow> HA \<union> HB \<subseteq> H \<Longrightarrow> H \<turnstile> B"
  by (metis MP_same le_sup_iff thin)

lemma MP_null: "{} \<turnstile> A IMP B \<Longrightarrow> H \<turnstile> A \<Longrightarrow> H \<turnstile> B"
  by (metis MP_same thin0)

lemma dsj_commute: "H \<turnstile> B OR A \<Longrightarrow> H \<turnstile> A OR B"
  using dsjcnj [of B A B] Ident [of B]
by (metis Bool MP_same)

lemma S: assumes  "H \<turnstile> A IMP (B IMP C)" "H' \<turnstile> A IMP B" shows "H \<union> H' \<turnstile> A IMP C"
proof -
  have "H' \<union> H \<turnstile> (neg A) OR (C OR (neg A))"
    by (metis Bool MP MP_same boolean_axioms.dsjcnj dsj_commute dsjAssoc assms)
  thus ?thesis
    by (metis Bool dsj_commute Un_commute MP_same dsjAssoc dsjCont dsjI1)
qed

lemma Assume: "insert A H \<turnstile> A"
  by (metis Hyp insertI1)

lemmas AssumeH = Assume Assume [THEN rotate2] Assume [THEN rotate3] Assume [THEN rotate4] Assume [THEN rotate5]
                 Assume [THEN rotate6] Assume [THEN rotate7] Assume [THEN rotate8] Assume [THEN rotate9] Assume [THEN rotate10]
                 Assume [THEN rotate11] Assume [THEN rotate12]
declare AssumeH [intro!]

lemma imp_triv_I: "H \<turnstile> B \<Longrightarrow> H \<turnstile> A IMP B"
  by (metis Bool dsj_commute MP_same boolean_axioms.dsjI1)

lemma dsjAssoc1: "H \<turnstile> A OR (B OR C) \<Longrightarrow> H \<turnstile> (A OR B) OR C"
  by (metis Bool MP_same boolean_axioms.dsjAssoc)

lemma dsjAssoc2: "H \<turnstile> (A OR B) OR C \<Longrightarrow> H \<turnstile> A OR (B OR C)"
  by (metis dsjAssoc1 dsj_commute)

lemma dsj_commute_imp: "H \<turnstile> (B OR A) IMP (A OR B)"
  using dsjcnj [of B A B] Ident [of B]
  by (metis Bool dsjAssoc2 dsj_commute MP_same)

lemma dsj_Semicong_1: "H \<turnstile> A OR C \<Longrightarrow> H \<turnstile> A IMP B \<Longrightarrow> H \<turnstile> B OR C"
  using dsjcnj [of A C B]
  by (metis Bool dsj_commute MP_same)

lemma imp_imp_commute: "H \<turnstile> B IMP (A IMP C) \<Longrightarrow> H \<turnstile> A IMP (B IMP C)"
  by (metis dsjAssoc1 dsjAssoc2 dsj_Semicong_1 dsj_commute_imp)

subsection\<open>The deduction theorem\<close>

lemma deduction_Diff: assumes "H \<turnstile> B" shows "H - {C} \<turnstile> C IMP B"
using assms
proof (induct)
  case (Hyp A H) thus ?case
    by (metis Bool imp_triv_I boolean_axioms.Ident nprv.Hyp member_remove remove_def)
next
  case (Q H) thus ?case
    by (metis imp_triv_I nprv.Q)
next
  case (Bool A H) thus ?case
    by (metis imp_triv_I nprv.Bool)
next
  case (eql A H) thus ?case
    by (metis imp_triv_I nprv.eql)
next
  case (Spec A H) thus ?case
    by (metis imp_triv_I nprv.Spec)
next
  case (MP H A B H')
  hence "(H-{C}) \<union> (H'-{C}) \<turnstile> imp C B"
    by (simp add: S)
  thus ?case
    by (metis Un_Diff)
next
  case (exiists H A B i) show ?case
  proof (cases "C \<in> H")
    case True
    hence "atom i \<sharp> C" using exiists by auto
    moreover have "H - {C} \<turnstile> A IMP C IMP B" using exiists
      by (metis imp_imp_commute)
    ultimately have "H - {C} \<turnstile> (exi i A) IMP C IMP B" using exiists
      using nprv.eql
      by (simp add: nprv.exiists)
    thus ?thesis
      by (metis imp_imp_commute)
  next
    case False
    hence "H - {C} = H" by auto
    thus ?thesis using exiists
      by (metis imp_triv_I nprv.exiists)
  qed
qed

theorem imp_I [intro!]: "insert A H \<turnstile> B \<Longrightarrow> H \<turnstile> A IMP B"
  by (metis Diff_insert_absorb imp_triv_I deduction_Diff insert_absorb)

lemma anti_deduction: "H \<turnstile> A IMP B \<Longrightarrow> insert A H \<turnstile> B"
   by (metis Assume MP_same thin1)

subsection\<open>Cut rules\<close>

lemma cut:  "H \<turnstile> A \<Longrightarrow> insert A H' \<turnstile> B \<Longrightarrow> H \<union> H' \<turnstile> B"
  by (metis MP Un_commute imp_I)

lemma cut_same: "H \<turnstile> A \<Longrightarrow> insert A H \<turnstile> B \<Longrightarrow> H \<turnstile> B"
  by (metis Un_absorb cut)

lemma cut_thin: "HA \<turnstile> A \<Longrightarrow> insert A HB \<turnstile> B \<Longrightarrow> HA \<union> HB \<subseteq> H \<Longrightarrow> H \<turnstile> B"
  by (metis thin cut)

lemma cut0: "{} \<turnstile> A \<Longrightarrow> insert A H \<turnstile> B \<Longrightarrow> H \<turnstile> B"
  by (metis cut_same thin0)

lemma cut1: "{A} \<turnstile> B \<Longrightarrow> H \<turnstile> A \<Longrightarrow> H \<turnstile> B"
  by (metis cut sup_bot_right)

lemma rcut1: "{A} \<turnstile> B \<Longrightarrow> insert B H \<turnstile> C \<Longrightarrow> insert A H \<turnstile> C"
  by (metis Assume cut1 cut_same rotate2 thin1)

lemma cut2: "\<lbrakk>{A,B} \<turnstile> C; H \<turnstile> A; H \<turnstile> B\<rbrakk> \<Longrightarrow> H \<turnstile> C"
  by (metis Un_empty_right Un_insert_right cut cut_same)

lemma rcut2: "{A,B} \<turnstile> C \<Longrightarrow> insert C H \<turnstile> D \<Longrightarrow> H \<turnstile> B \<Longrightarrow> insert A H \<turnstile> D"
  by (metis Assume cut2 cut_same insert_commute thin1)

lemma cut4: "\<lbrakk>{A,B,C,D} \<turnstile> E; H \<turnstile> A; H \<turnstile> B; H \<turnstile> C; H \<turnstile> D\<rbrakk> \<Longrightarrow> H \<turnstile> E"
  by (metis MP_same cut3 [of B C D] imp_I)

section\<open>Miscellaneous Logical Rules\<close>

lemma dsj_I1: "H \<turnstile> A \<Longrightarrow> H \<turnstile> A OR B"
  by (metis Bool MP_same boolean_axioms.dsjI1)

lemma dsj_I2: "H \<turnstile> B \<Longrightarrow> H \<turnstile> A OR B"
  by (metis dsj_commute dsj_I1)

lemma Peirce: "H \<turnstile> (neg A) IMP A \<Longrightarrow> H \<turnstile> A"
  using dsjcnj [of "neg A" A A]  dsjCont [of A]
  by (metis Bool MP_same boolean_axioms.Ident)

lemma Contra: "insert (neg A) H \<turnstile> A \<Longrightarrow> H \<turnstile> A"
  by (metis Peirce imp_I)

lemma imp_neg_I: "H \<turnstile> A IMP B \<Longrightarrow> H \<turnstile> A IMP (neg B) \<Longrightarrow> H \<turnstile> neg A"
  by (metis dsjcnj [of B "neg A" "neg A"] dsjCont Bool dsj_commute MP_same)

lemma negneg_I: "H \<turnstile> A \<Longrightarrow> H \<turnstile> neg (neg A)"
  using dsjcnj [of "neg (neg A)" "neg A" "neg (neg A)"]
  by (metis Bool Ident MP_same)

lemma negneg_D: "H \<turnstile> neg (neg A) \<Longrightarrow> H \<turnstile> A"
  by (metis dsj_I1 Peirce)

lemma neg_D: "H \<turnstile> neg A \<Longrightarrow> H \<turnstile> A \<Longrightarrow> H \<turnstile> B"
  by (metis imp_neg_I imp_triv_I negneg_D)

lemma dsj_neg_1: "H \<turnstile> A OR B \<Longrightarrow> H \<turnstile> neg B \<Longrightarrow> H \<turnstile> A"
  by (metis dsj_I1 dsj_Semicong_1 dsj_commute Peirce)

lemma dsj_neg_2: "H \<turnstile> A OR B \<Longrightarrow> H \<turnstile> neg A \<Longrightarrow> H \<turnstile> B"
  by (metis dsj_neg_1 dsj_commute)

lemma neg_dsj_I: "H \<turnstile> neg A \<Longrightarrow> H \<turnstile> neg B \<Longrightarrow> H \<turnstile> neg (A OR B)"
by (metis Bool dsj_neg_1 MP_same boolean_axioms.Ident dsjAssoc)

lemma cnj_I [intro!]: "H \<turnstile> A \<Longrightarrow> H \<turnstile> B \<Longrightarrow> H \<turnstile> A AND B"
  by (metis cnj_def negneg_I neg_dsj_I)

lemma cnj_E1: "H \<turnstile> A AND B \<Longrightarrow> H \<turnstile> A"
  by (metis cnj_def Bool dsj_neg_1 negneg_D boolean_axioms.dsjI1)

lemma cnj_E2: "H \<turnstile> A AND B \<Longrightarrow> H \<turnstile> B"
  by (metis cnj_def Bool dsj_I2 dsj_neg_2 MP_same dsjAssoc Ident)

lemma cnj_commute: "H \<turnstile> B AND A \<Longrightarrow> H \<turnstile> A AND B"
  by (metis cnj_E1 cnj_E2 cnj_I)

lemma cnj_E: assumes "insert A (insert B H) \<turnstile> C" shows "insert (A AND B) H \<turnstile> C"
apply (rule cut_same [where A=A], metis cnj_E1 Hyp insertI1)
by (metis (full_types) AssumeH(2) cnj_E2 assms cut_same [where A=B] insert_commute thin2)

lemmas cnj_EH = cnj_E cnj_E [THEN rotate2] cnj_E [THEN rotate3] cnj_E [THEN rotate4] cnj_E [THEN rotate5]
                 cnj_E [THEN rotate6] cnj_E [THEN rotate7] cnj_E [THEN rotate8] cnj_E [THEN rotate9] cnj_E [THEN rotate10]
declare cnj_EH [intro!]

lemma neg_mono: "insert A H \<turnstile> B \<Longrightarrow> insert (neg B) H \<turnstile> neg A"
  by (rule neg_I0) (metis Hyp neg_D insert_commute insertI1 thin1)

lemma cnj_mono: "insert A H \<turnstile> B \<Longrightarrow> insert C H \<turnstile> D \<Longrightarrow> insert (A AND C) H \<turnstile> B AND D"
  by (metis cnj_E1 cnj_E2 cnj_I Hyp Un_absorb2 cut insertI1 subset_insertI)

lemma dsj_mono:
  assumes "insert A H \<turnstile> B" "insert C H \<turnstile> D" shows "insert (A OR C) H \<turnstile> B OR D"
proof -
  { fix A B C H
    have "insert (A OR C) H \<turnstile> (A IMP B) IMP C OR B"
      by (metis Bool Hyp MP_same boolean_axioms.dsjcnj insertI1)
    hence "insert A H \<turnstile> B \<Longrightarrow> insert (A OR C) H \<turnstile> C OR B"
      by (metis MP_same Un_absorb Un_insert_right imp_I thin_Un)
  }
  thus ?thesis
    by (metis cut_same assms thin2)
qed

lemma dsj_E:
  assumes A: "insert A H \<turnstile> C" and B: "insert B H \<turnstile> C" shows "insert (A OR B) H \<turnstile> C"
  by (metis A B dsj_mono negneg_I Peirce)

lemmas dsj_EH = dsj_E dsj_E [THEN rotate2] dsj_E [THEN rotate3] dsj_E [THEN rotate4] dsj_E [THEN rotate5]
                 dsj_E [THEN rotate6] dsj_E [THEN rotate7] dsj_E [THEN rotate8] dsj_E [THEN rotate9] dsj_E [THEN rotate10]
declare dsj_EH [intro!]

lemma Contra': "insert A H \<turnstile> neg A \<Longrightarrow> H \<turnstile> neg A"
  by (metis Contra neg_mono)

lemma negneg_E [intro!]: "insert A H \<turnstile> B \<Longrightarrow> insert (neg (neg A)) H \<turnstile> B"
  by (metis negneg_D neg_mono)

declare negneg_E [THEN rotate2, intro!]
declare negneg_E [THEN rotate3, intro!]
declare negneg_E [THEN rotate4, intro!]
declare negneg_E [THEN rotate5, intro!]
declare negneg_E [THEN rotate6, intro!]
declare negneg_E [THEN rotate7, intro!]
declare negneg_E [THEN rotate8, intro!]

lemma imp_E:
  assumes A: "H \<turnstile> A" and B: "insert B H \<turnstile> C" shows "insert (A IMP B) H \<turnstile> C"
proof -
  have "insert (A IMP B) H \<turnstile> B"
    by (metis Hyp A thin1 MP_same insertI1)
  thus ?thesis
    by (metis cut [where B=C] Un_insert_right sup_commute sup_idem B)
qed

lemma imp_cut:
  assumes "insert C H \<turnstile> A IMP B" "{A} \<turnstile> C"
    shows "H \<turnstile> A IMP B"
  by (metis Contra dsj_I1 neg_mono assms rcut1)

lemma Iff_I [intro!]: "insert A H \<turnstile> B \<Longrightarrow> insert B H \<turnstile> A \<Longrightarrow> H \<turnstile> A IFF B"
  by (metis Iff_def cnj_I imp_I)

lemma Iff_MP_same: "H \<turnstile> A IFF B \<Longrightarrow> H \<turnstile> A \<Longrightarrow> H \<turnstile> B"
  by (metis Iff_def cnj_E1 MP_same)

lemma Iff_refl [intro!]: "H \<turnstile> A IFF A"
  by (metis Hyp Iff_I insertI1)

lemma Iff_sym: "H \<turnstile> A IFF B \<Longrightarrow> H \<turnstile> B IFF A"
  by (metis Iff_def cnj_commute)

lemma Iff_trans: "H \<turnstile> A IFF B \<Longrightarrow> H \<turnstile> B IFF C \<Longrightarrow> H \<turnstile> A IFF C"
  unfolding Iff_def
  by (metis cnj_E1 cnj_E2 cnj_I dsj_Semicong_1 dsj_commute)

lemma Iff_E:
  "insert A (insert B H) \<turnstile> C \<Longrightarrow> insert (neg A) (insert (neg B) H) \<turnstile> C \<Longrightarrow> insert (A IFF B) H \<turnstile> C"
  by (simp add: Assume Iff_def anti_deduction cnj_E dsj_EH(2) dsj_I1 insert_commute)

lemma Iff_E1:
  assumes A: "H \<turnstile> A" and B: "insert B H \<turnstile> C" shows "insert (A IFF B) H \<turnstile> C"
  by (metis Iff_def A B cnj_E imp_E insert_commute thin1)

lemma Iff_E2:
  assumes A: "H \<turnstile> A" and B: "insert B H \<turnstile> C" shows "insert (B IFF A) H \<turnstile> C"
  by (metis Iff_def A B Bool cnj_E2 cnj_mono imp_E boolean_axioms.Ident)

lemma Iff_MP_left: "H \<turnstile> A IFF B \<Longrightarrow> insert A H \<turnstile> C \<Longrightarrow> insert B H \<turnstile> C"
  by (metis Hyp Iff_E2 cut_same insertI1 insert_commute thin1)

lemma Iff_MP_left': "H \<turnstile> A IFF B \<Longrightarrow> insert B H \<turnstile> C \<Longrightarrow> insert A H \<turnstile> C"
  by (metis Iff_MP_left Iff_sym)

lemma Swap: "insert (neg B) H \<turnstile> A \<Longrightarrow> insert (neg A) H \<turnstile> B"
  by (metis negneg_D neg_mono)

lemma Cases: "insert A H \<turnstile> B \<Longrightarrow> insert (neg A) H \<turnstile> B \<Longrightarrow> H \<turnstile> B"
  by (metis Contra neg_D neg_mono)

lemma neg_cnj_E: "H \<turnstile> B \<Longrightarrow> insert (neg A) H \<turnstile> C \<Longrightarrow> insert (neg (A AND B)) H \<turnstile> C"
  by (metis cnj_I Swap thin1)

lemma dsj_CI: "insert (neg B) H \<turnstile> A \<Longrightarrow> H \<turnstile> A OR B"
  by (metis Contra dsj_I1 dsj_I2 Swap)

lemma dsj_3I: "insert (neg A) (insert (neg C) H) \<turnstile> B \<Longrightarrow> H \<turnstile> A OR B OR C"
  by (metis dsj_CI dsj_commute insert_commute)

lemma Contrapos1: "H \<turnstile> A IMP B \<Longrightarrow> H \<turnstile> neg B IMP neg A"
  by (metis Bool MP_same boolean_axioms.dsjcnj boolean_axioms.Ident)

lemma ContraAssumeN [intro]: "B \<in> H \<Longrightarrow> insert (neg B) H \<turnstile> A"
  by (metis Hyp Swap thin1)

lemma ContraAssume: "neg B \<in> H \<Longrightarrow> insert B H \<turnstile> A"
  by (metis dsj_I1 Hyp anti_deduction)

lemma ContraProve: "H \<turnstile> B \<Longrightarrow> insert (neg B) H \<turnstile> A"
  by (metis Swap thin1)

lemma dsj_IE1: "insert B H \<turnstile> C \<Longrightarrow> insert (A OR B) H \<turnstile> A OR C"
  by (metis Assume dsj_mono)

lemmas dsj_IE1H = dsj_IE1 dsj_IE1 [THEN rotate2] dsj_IE1 [THEN rotate3] dsj_IE1 [THEN rotate4] dsj_IE1 [THEN rotate5]
                 dsj_IE1 [THEN rotate6] dsj_IE1 [THEN rotate7] dsj_IE1 [THEN rotate8]
declare dsj_IE1H [intro!]

subsection\<open>Quantifier reasoning\<close>

lemma exi_I: "H \<turnstile> A(i::=x) \<Longrightarrow> H \<turnstile> exi i A"
  by (metis MP_same Spec special_axioms.intros)

lemma exi_E:
  assumes "insert A H \<turnstile> B" "atom i \<sharp> B" "\<forall>C \<in> H. atom i \<sharp> C"
  shows "insert (exi i A) H \<turnstile> B"
  by (metis exiists imp_I anti_deduction assms)

lemma exi_E_with_renaming:
  assumes "insert ((i \<leftrightarrow> i') \<bullet> A) H \<turnstile> B" "atom i' \<sharp> (A,i,B)" "\<forall>C \<in> H. atom i' \<sharp> C"
  shows "insert (exi i A) H \<turnstile> B"
proof -
  have "exi i A = exi i' ((i \<leftrightarrow> i') \<bullet> A)"
    using assms using flip_subst_fmla by auto
  thus ?thesis
    by (metis exi_E assms fresh_Pair)
qed

lemmas exi_EH = exi_E exi_E [THEN rotate2] exi_E [THEN rotate3] exi_E [THEN rotate4] exi_E [THEN rotate5]
                 exi_E [THEN rotate6] exi_E [THEN rotate7] exi_E [THEN rotate8] exi_E [THEN rotate9] exi_E [THEN rotate10]
declare exi_EH [intro!]

lemma exi_mono: "insert A H \<turnstile> B \<Longrightarrow> \<forall>C \<in> H. atom i \<sharp> C \<Longrightarrow> insert (exi i A) H \<turnstile> (exi i B)"
  by (auto simp add: intro: exi_I [where x="Var i"])

lemma all_I [intro!]: "H \<turnstile> A \<Longrightarrow> \<forall>C \<in> H. atom i \<sharp> C \<Longrightarrow> H \<turnstile> all i A"
  by (auto intro: ContraProve neg_I0)

lemma all_D: "H \<turnstile> all i A \<Longrightarrow> H \<turnstile> A(i::=x)"
  by (metis Assume exi_I negneg_D neg_mono neg cut_same)

lemma all_E: "insert (A(i::=x)) H \<turnstile> B \<Longrightarrow> insert (all i A) H \<turnstile> B"
  by (metis exi_I negneg_D neg_mono neg)

lemma all_E': "H \<turnstile> all i A \<Longrightarrow> insert (A(i::=x)) H \<turnstile> B \<Longrightarrow> H \<turnstile> B"
  by (metis all_D cut_same)

subsection\<open>Congruence rules\<close>

lemma neg_cong: "H \<turnstile> A IFF A' \<Longrightarrow> H \<turnstile> neg A IFF neg A'"
  by (metis Iff_def cnj_E1 cnj_E2 cnj_I Contrapos1)

lemma dsj_cong: "H \<turnstile> A IFF A' \<Longrightarrow> H \<turnstile> B IFF B' \<Longrightarrow> H \<turnstile> A OR B IFF A' OR B'"
  by (metis cnj_E1 cnj_E2 dsj_mono Iff_I Iff_def anti_deduction)

lemma cnj_cong: "H \<turnstile> A IFF A' \<Longrightarrow> H \<turnstile> B IFF B' \<Longrightarrow> H \<turnstile> A AND B IFF A' AND B'"
  by (metis cnj_def dsj_cong neg_cong)

lemma imp_cong: "H \<turnstile> A IFF A' \<Longrightarrow> H \<turnstile> B IFF B' \<Longrightarrow> H \<turnstile> (A IMP B) IFF (A' IMP B')"
  by (metis dsj_cong neg_cong)

lemma Iff_cong: "H \<turnstile> A IFF A' \<Longrightarrow> H \<turnstile> B IFF B' \<Longrightarrow> H \<turnstile> (A IFF B) IFF (A' IFF B')"
  by (metis Iff_def cnj_cong imp_cong)

lemma exi_cong: "H \<turnstile> A IFF A' \<Longrightarrow> \<forall>C \<in> H. atom i \<sharp> C \<Longrightarrow> H \<turnstile> (exi i A) IFF (exi i A')"
  apply (rule Iff_I)
   apply (metis exi_mono Hyp Iff_MP_same Un_absorb Un_insert_right insertI1 thin_Un)
  apply (metis exi_mono Hyp Iff_MP2_same Un_absorb Un_insert_right insertI1 thin_Un)
  done

lemma all_cong: "H \<turnstile> A IFF A' \<Longrightarrow> \<forall>C \<in> H. atom i \<sharp> C \<Longrightarrow> H \<turnstile> (all i A) IFF (all i A')"
  by (metis exi_cong neg_cong)

lemma Subst: "H \<turnstile> A \<Longrightarrow> \<forall>B \<in> H. atom i \<sharp> B \<Longrightarrow> H \<turnstile> A (i::=x)"
  by (metis all_D all_I)

section\<open>Eqluality Reasoning\<close>

subsection\<open>The congruence property for @{term eql}, and other basic properties of equality\<close>

lemma eql_cong1: "{} \<turnstile> (t EQ t' AND u EQ u') IMP (t EQ u IMP t' EQ u')"
proof -
  obtain v2::name and v3::name and v4::name
    where v2: "atom v2 \<sharp> (t,X1,X3,X4)"
      and v3: "atom v3 \<sharp> (t,t',X1,v2,X4)"
      and v4: "atom v4 \<sharp> (t,t',u,X1,v2,v3)"
    by (metis obtain_fresh)
  have "{} \<turnstile> (Var X1 EQ Var X2 AND Var X3 EQ Var X4) IMP (Var X1 EQ Var X3 IMP Var X2 EQ Var X4)"
    by (rule eql) (simp add: eq_cong_ax_def equality_axioms_def)
  hence "{} \<turnstile> (Var X1 EQ Var X2 AND Var X3 EQ Var X4) IMP (Var X1 EQ Var X3 IMP Var X2 EQ Var X4)"
    by (drule_tac i=X1 and x="Var X1" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var X3 EQ Var X4) IMP (Var X1 EQ Var X3 IMP Var v2 EQ Var X4)"
    by (drule_tac i=X2 and x="Var v2" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var v3 EQ Var X4) IMP (Var X1 EQ Var v3 IMP Var v2 EQ Var X4)"
    using v2
    by (drule_tac i=X3 and x="Var v3" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var v3 EQ Var v4) IMP (Var X1 EQ Var v3 IMP Var v2 EQ Var v4)"
    using v2 v3
    by (drule_tac i=X4 and x="Var v4" in Subst) simp_all
  hence "{} \<turnstile> (t EQ Var v2 AND Var v3 EQ Var v4) IMP (t EQ Var v3 IMP Var v2 EQ Var v4)"
    using v2 v3 v4
    by (drule_tac i=X1 and x=t in Subst) simp_all
  hence "{} \<turnstile> (t EQ t' AND Var v3 EQ Var v4) IMP (t EQ Var v3 IMP t' EQ Var v4)"
    using v2 v3 v4
    by (drule_tac i=v2 and x="t'" in Subst) simp_all
  hence "{} \<turnstile> (t EQ t' AND u EQ Var v4) IMP (t EQ u IMP t' EQ Var v4)"
    using v3 v4
    by (drule_tac i=v3 and x=u in Subst) simp_all
  thus ?thesis
    using v4
    by (drule_tac i=v4 and x="u'" in Subst) simp_all
qed

lemma Refl [iff]: "H \<turnstile> t EQ t"
proof -
  have "{} \<turnstile> Var X1 EQ Var X1"
    by (rule eql) (simp add: equality_axioms_def refl_ax_def)
  hence "{} \<turnstile> t EQ t"
    by (drule_tac i=X1 and x=t in Subst) simp_all
  thus ?thesis
    by (metis empty_subsetI thin)
qed

text\<open>Apparently necessary in order to prove the congruence property.\<close>
lemma Sym: assumes "H \<turnstile> t EQ u" shows "H \<turnstile> u EQ t"
proof -
  have "{} \<turnstile>  (t EQ u AND t EQ t) IMP (t EQ t IMP u EQ t)"
    by (rule eql_cong1)
   moreover have "{t EQ u} \<turnstile> t EQ u AND t EQ t"
    by (metis Assume cnj_I Refl)
  ultimately have "{t EQ u} \<turnstile> u EQ t"
    by (metis MP_same MP Refl sup_bot_left)
  thus "H \<turnstile> u EQ t" by (metis assms cut1)
qed

lemma Sym_L: "insert (t EQ u) H \<turnstile> A \<Longrightarrow> insert (u EQ t) H \<turnstile> A"
  by (metis Assume Sym Un_empty_left Un_insert_left cut)

lemma Trans: assumes "H \<turnstile> x EQ y" "H \<turnstile> y EQ z" shows "H \<turnstile> x EQ z"
proof -
  have "\<And>H. H \<turnstile> (x EQ x AND y EQ z) IMP (x EQ y IMP x EQ z)"
    by (metis eql_cong1 bot_least thin)
  moreover have "{x EQ y, y EQ z} \<turnstile> x EQ x AND y EQ z"
    by (metis Assume cnj_I Refl thin1)
  ultimately have "{x EQ y, y EQ z} \<turnstile> x EQ z"
    by (metis Hyp MP_same insertI1)
  thus ?thesis
    by (metis assms cut2)
qed

lemma eql_cong:
  assumes "H \<turnstile> t EQ t'" "H \<turnstile> u EQ u'" shows "H \<turnstile> t EQ u IFF t' EQ u'"
proof -
  { fix t t' u u'
    assume  "H \<turnstile> t EQ t'" "H \<turnstile> u EQ u'"
    moreover have "{t EQ t', u EQ u'} \<turnstile> t EQ u IMP t' EQ u'" using eql_cong1
      by (metis Assume cnj_I MP_null insert_commute)
    ultimately have "H \<turnstile> t EQ u IMP t' EQ u'"
      by (metis cut2)
  }
  thus ?thesis
    by (metis Iff_def cnj_I assms Sym)
qed

lemma eql_Trans_E: "H \<turnstile> x EQ u \<Longrightarrow> insert (t EQ u) H \<turnstile> A \<Longrightarrow> insert (x EQ t) H \<turnstile> A"
  by (metis Assume Sym_L Trans cut_same thin1 thin2)

subsection\<open>The congruence properties for @{term suc}, @{term pls} and @{term tms}\<close>

lemma suc_cong1: "{} \<turnstile> (t EQ t') IMP (suc t EQ suc t')"
proof -
  obtain v2::name and v3::name and v4::name
    where v2: "atom v2 \<sharp> (t,X1,X3,X4)"
      and v3: "atom v3 \<sharp> (t,t',X1,v2,X4)"
      and v4: "atom v4 \<sharp> (t,t',X1,v2,v3)"
    by (metis obtain_fresh)
  have "{} \<turnstile> (Var X1 EQ Var X2) IMP (suc (Var X1) EQ suc (Var X2))"
    by (metis syc_cong_ax_def equality_axioms_def insert_iff eql)
  hence "{} \<turnstile> (Var X1 EQ Var v2) IMP (suc (Var X1) EQ suc (Var v2))"
    by (drule_tac i=X2 and x="Var v2" in Subst) simp_all
  hence "{} \<turnstile> (t EQ Var v2) IMP (suc t EQ suc (Var v2))"
    using v2 v3 v4
    by (drule_tac i=X1 and x=t in Subst) simp_all
  hence "{} \<turnstile> (t EQ t') IMP (suc t EQ suc t')"
    using v2 v3 v4
    by (drule_tac i=v2 and x=t' in Subst) simp_all
  thus ?thesis
    using v4
    by (drule_tac i=v4 in Subst) simp_all
qed

lemma suc_cong: "\<lbrakk>H \<turnstile> t EQ t'\<rbrakk> \<Longrightarrow> H \<turnstile> suc t EQ suc t'"
  by (metis anti_deduction suc_cong1 cut1)

lemma pls_cong1: "{} \<turnstile> (t EQ t' AND u EQ u') IMP (pls t u EQ pls t' u')"
proof -
  obtain v2::name and v3::name and v4::name
    where v2: "atom v2 \<sharp> (t,X1,X3,X4)"
      and v3: "atom v3 \<sharp> (t,t',X1,v2,X4)"
      and v4: "atom v4 \<sharp> (t,t',u,X1,v2,v3)"
    by (metis obtain_fresh)
  have "{} \<turnstile> (Var X1 EQ Var X2 AND Var X3 EQ Var X4) IMP (pls (Var X1) (Var X3) EQ pls (Var X2) (Var X4))"
    by (metis pls_cong_ax_def equality_axioms_def insert_iff eql)
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var X3 EQ Var X4) IMP (pls (Var X1) (Var X3) EQ pls (Var v2) (Var X4))"
    by (drule_tac i=X2 and x="Var v2" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var v3 EQ Var X4) IMP (pls (Var X1) (Var v3) EQ pls (Var v2) (Var X4))"
    using v2
    by (drule_tac i=X3 and x="Var v3" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var v3 EQ Var v4) IMP (pls (Var X1) (Var v3) EQ pls (Var v2) (Var v4))"
    using v2 v3
    by (drule_tac i=X4 and x="Var v4" in Subst) simp_all
  hence "{} \<turnstile> (t EQ Var v2 AND Var v3 EQ Var v4) IMP (pls t (Var v3) EQ pls (Var v2) (Var v4))"
    using v2 v3 v4
    by (drule_tac i=X1 and x=t in Subst) simp_all
  hence "{} \<turnstile> (t EQ t' AND Var v3 EQ Var v4) IMP (pls t (Var v3) EQ pls t' (Var v4))"
    using v2 v3 v4
    by (drule_tac i=v2 and x=t' in Subst) simp_all
  hence "{} \<turnstile> (t EQ t' AND u EQ Var v4) IMP (pls t u EQ pls t' (Var v4))"
    using v3 v4
    by (drule_tac i=v3 and x=u in Subst) simp_all
  thus ?thesis
    using v4
    by (drule_tac i=v4 and x=u' in Subst) simp_all
qed

lemma pls_cong: "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'\<rbrakk> \<Longrightarrow> H \<turnstile> pls t u EQ pls t' u'"
  by (metis cnj_I anti_deduction pls_cong1 cut1)

lemma tms_cong1: "{} \<turnstile> (t EQ t' AND u EQ u') IMP (tms t u EQ tms t' u')"
proof -
  obtain v2::name and v3::name and v4::name
    where v2: "atom v2 \<sharp> (t,X1,X3,X4)"
      and v3: "atom v3 \<sharp> (t,t',X1,v2,X4)"
      and v4: "atom v4 \<sharp> (t,t',u,X1,v2,v3)"
    by (metis obtain_fresh)
  have "{} \<turnstile> (Var X1 EQ Var X2 AND Var X3 EQ Var X4) IMP (tms (Var X1) (Var X3) EQ tms (Var X2) (Var X4))"
    by (metis tms_cong_ax_def equality_axioms_def insert_iff eql)
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var X3 EQ Var X4) IMP (tms (Var X1) (Var X3) EQ tms (Var v2) (Var X4))"
    by (drule_tac i=X2 and x="Var v2" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var v3 EQ Var X4) IMP (tms (Var X1) (Var v3) EQ tms (Var v2) (Var X4))"
    using v2
    by (drule_tac i=X3 and x="Var v3" in Subst) simp_all
  hence "{} \<turnstile> (Var X1 EQ Var v2 AND Var v3 EQ Var v4) IMP (tms (Var X1) (Var v3) EQ tms (Var v2) (Var v4))"
    using v2 v3
    by (drule_tac i=X4 and x="Var v4" in Subst) simp_all
  hence "{} \<turnstile> (t EQ Var v2 AND Var v3 EQ Var v4) IMP (tms t (Var v3) EQ tms (Var v2) (Var v4))"
    using v2 v3 v4
    by (drule_tac i=X1 and x=t in Subst) simp_all
  hence "{} \<turnstile> (t EQ t' AND Var v3 EQ Var v4) IMP (tms t (Var v3) EQ tms t' (Var v4))"
    using v2 v3 v4
    by (drule_tac i=v2 and x=t' in Subst) simp_all
  hence "{} \<turnstile> (t EQ t' AND u EQ Var v4) IMP (tms t u EQ tms t' (Var v4))"
    using v3 v4
    by (drule_tac i=v3 and x=u in Subst) simp_all
  thus ?thesis
    using v4
    by (drule_tac i=v4 and x=u' in Subst) simp_all
qed

lemma tms_cong: "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'\<rbrakk> \<Longrightarrow> H \<turnstile> tms t u EQ tms t' u'"
  by (metis cnj_I anti_deduction tms_cong1 cut1)

subsection\<open>Substitution for eqlualities\<close>

lemma eql_subst_trm_Iff: "{t EQ u} \<turnstile> subst i t trm EQ subst i u trm"
  by (induct trm rule: trm.induct) (auto simp: suc_cong pls_cong tms_cong)

lemma eql_subst_fmla_Iff: "insert (t EQ u) H \<turnstile> A(i::=t) IFF A(i::=u)"
proof -
  have "{ t EQ u } \<turnstile> A(i::=t) IFF A(i::=u)"
    by (nominal_induct A avoiding: i t u rule: fmla.strong_induct)
       (auto simp: dsj_cong neg_cong exi_cong eql_cong eql_subst_trm_Iff)
  thus ?thesis
    by (metis Assume cut1)
qed

lemma Var_eql_subst_Iff: "insert (Var i EQ t) H \<turnstile> A(i::=t) IFF A"
  by (metis eql_subst_fmla_Iff Iff_sym subst_fmla_id)

lemma Var_eql_imp_subst_Iff: "H \<turnstile> Var i EQ t \<Longrightarrow> H \<turnstile> A(i::=t) IFF A"
  by (metis Var_eql_subst_Iff cut_same)

subsection\<open>Congruence rules for predicates\<close>

lemma P2_cong:
  fixes tms :: "trm list"
  assumes sub: "\<And>i t u x. atom i \<sharp> tms \<Longrightarrow> (P t u)(i::=x) = P (subst i x t) (subst i x u)"
      and eq:  "H \<turnstile> x EQ x'" "H \<turnstile> y EQ y'"
  shows "H \<turnstile> P x y IFF P x' y'"
proof -
  have yy': "{ y EQ y' } \<turnstile> P x' y IFF P x' y'"
    by (rule P1_cong [where tms="[y,x']@tms"]) (auto simp: fresh_Cons sub)
  have "{ x EQ x' } \<turnstile> P x y IFF P x' y"
    by (rule P1_cong [where tms="[y,x']@tms"]) (auto simp: fresh_Cons sub)
  hence "{x EQ x', y EQ y'} \<turnstile> P x y IFF P x' y'"
    by (metis Assume Iff_trans cut1 rotate2 yy')
  thus ?thesis
    by (metis cut2 eq)
 qed

lemma P3_cong:
  fixes tms :: "trm list"
  assumes sub: "\<And>i t u v x. atom i \<sharp> tms \<Longrightarrow>
                   (P t u v)(i::=x) = P (subst i x t) (subst i x u) (subst i x v)"
      and eq:  "H \<turnstile> x EQ x'" "H \<turnstile> y EQ y'" "H \<turnstile> z EQ z'"
  shows "H \<turnstile> P x y z IFF P x' y' z'"
proof -
  obtain i::name where i: "atom i \<sharp> (z,z',y,y',x,x')"
    by (metis obtain_fresh)
  have tl: "{ y EQ y', z EQ z' } \<turnstile> P x' y z IFF P x' y' z'"
    by (rule P2_cong [where tms="[z,z',y,y',x,x']@tms"]) (auto simp: fresh_Cons sub)
  have hd: "{ x EQ x' } \<turnstile> P x y z IFF P x' y z"
    by (rule P1_cong [where tms="[z,y,x']@tms"]) (auto simp: fresh_Cons sub)
  have "{x EQ x', y EQ y', z EQ z'} \<turnstile> P x y z IFF P x' y' z'"
    by (metis Assume thin1 hd [THEN cut1] tl Iff_trans)
  thus ?thesis
    by (rule cut3) (rule eq)+
qed

lemma P4_cong:
  fixes tms :: "trm list"
  assumes sub: "\<And>i t1 t2 t3 t4 x. atom i \<sharp> tms \<Longrightarrow>
                 (P t1 t2 t3 t4)(i::=x) = P (subst i x t1) (subst i x t2) (subst i x t3) (subst i x t4)"
      and eq:  "H \<turnstile> x1 EQ x1'" "H \<turnstile> x2 EQ x2'" "H \<turnstile> x3 EQ x3'" "H \<turnstile> x4 EQ x4'"
  shows "H \<turnstile> P x1 x2 x3 x4 IFF P x1' x2' x3' x4'"
proof -
  obtain i::name where i: "atom i \<sharp> (x4,x4',x3,x3',x2,x2',x1,x1')"
    by (metis obtain_fresh)
  have tl: "{ x2 EQ x2', x3 EQ x3', x4 EQ x4' } \<turnstile> P x1' x2 x3 x4 IFF P x1' x2' x3' x4'"
    by (rule P3_cong [where tms="[x4,x4',x3,x3',x2,x2',x1,x1']@tms"]) (auto simp: fresh_Cons sub)
  have hd: "{ x1 EQ x1' } \<turnstile> P x1 x2 x3 x4 IFF P x1' x2 x3 x4"
    by (auto simp: fresh_Cons sub intro!: P1_cong [where tms="[x4,x3,x2,x1']@tms"])
  have "{x1 EQ x1', x2 EQ x2', x3 EQ x3', x4 EQ x4'} \<turnstile> P x1 x2 x3 x4 IFF P x1' x2' x3' x4'"
    by (metis Assume thin1 hd [THEN cut1] tl Iff_trans)
  thus ?thesis
    by (rule cut4) (rule eq)+
qed

subsection\<open>The formula @{term fls}\<close>

lemma neg_I [intro!]: "insert A H \<turnstile> fls \<Longrightarrow> H \<turnstile> neg A"
  unfolding fls_def
  by (meson neg_D neg_I0 Refl)

lemma neg_E [intro!]: "H \<turnstile> A \<Longrightarrow> insert (neg A) H \<turnstile> fls"
  by (rule ContraProve)

declare neg_E [THEN rotate2, intro!]
declare neg_E [THEN rotate3, intro!]
declare neg_E [THEN rotate4, intro!]
declare neg_E [THEN rotate5, intro!]
declare neg_E [THEN rotate6, intro!]
declare neg_E [THEN rotate7, intro!]
declare neg_E [THEN rotate8, intro!]

lemma neg_imp_I [intro!]: "H \<turnstile> A \<Longrightarrow> insert B H \<turnstile> fls \<Longrightarrow> H \<turnstile> neg (A IMP B)"
  by (metis negneg_I neg_dsj_I neg_I)

lemma neg_imp_E [intro!]: "insert (neg B) (insert A H) \<turnstile> C \<Longrightarrow> insert (neg (A IMP B)) H \<turnstile> C"
apply (rule cut_same [where A=A])
 apply (metis Assume dsj_I1 negneg_D neg_mono)
apply (metis Swap imp_I rotate2 thin1)
done

declare neg_imp_E [THEN rotate2, intro!]
declare neg_imp_E [THEN rotate3, intro!]
declare neg_imp_E [THEN rotate4, intro!]
declare neg_imp_E [THEN rotate5, intro!]
declare neg_imp_E [THEN rotate6, intro!]
declare neg_imp_E [THEN rotate7, intro!]
declare neg_imp_E [THEN rotate8, intro!]

declare fls_E [THEN rotate2, intro!]
declare fls_E [THEN rotate3, intro!]
declare fls_E [THEN rotate4, intro!]
declare fls_E [THEN rotate5, intro!]
declare fls_E [THEN rotate6, intro!]
declare fls_E [THEN rotate7, intro!]
declare fls_E [THEN rotate8, intro!]

lemma truth_provable: "H \<turnstile> (neg fls)"
  by (metis fls_E neg_I)

lemma exFalso: "H \<turnstile> fls \<Longrightarrow> H \<turnstile> A"
  by (metis neg_D truth_provable)

text\<open>Soundness of the provability relation\<close>

theorem nprv_sound: assumes "H \<turnstile> A" shows "(\<forall>B\<in>H. eval_fmla e B) \<Longrightarrow> eval_fmla e A"
using assms
proof (induct arbitrary: e)
  case (Hyp A H) thus ?case
    by auto
next
  case (Q H) thus ?case
     unfolding Q_axioms_def
     using not0_implies_Suc by fastforce
next
  case (Bool A H) thus ?case
    by (metis boolean_axioms_hold)
next
  case (eql A H) thus ?case
    by (metis equality_axioms_hold)
next
  case (Spec A H) thus ?case
    by (metis special_axioms_hold)
next
  case (MP H A B H') thus ?case
    by auto
next
  case (exiists H A B i e) thus ?case
    by auto (metis forget_eval_fmla)
qed

(*<*)
end
(*>*)


theory perm_test
  imports  Q_State

begin
definition pex::"nat \<Rightarrow> nat"
  where "pex i = (((((id((0::nat):=0))(1:=2))(2:=3)))(3:=1)) i"

definition pex1::"nat \<Rightarrow> nat"
  where "pex1 i = (((((id((0::nat):=0))(1:=3))(2:=1)))(3:=2)) i"

definition dims :: "nat list \<Rightarrow> nat set \<Rightarrow> nat list" where
  "dims tv vs = nths tv vs"

definition encode::"nat list \<Rightarrow> nat set \<Rightarrow> nat \<Rightarrow> nat"
  where "encode tv vs i \<equiv> digit_decode (dims tv vs) (nths (digit_encode tv i) vs)"

definition list_dims::"nat set \<Rightarrow> nat list"
  where "list_dims qvars \<equiv> replicate (card qvars) 2"

definition tensor_vec :: "nat set \<Rightarrow> nat set \<Rightarrow> 'a::times vec \<Rightarrow> 'a vec \<Rightarrow> 'a vec" where
  "tensor_vec s1 s2 v1 v2 \<equiv>
    let tv = list_dims (s1 \<union> s2) in
     Matrix.vec (prod_list tv) (\<lambda>i. (v1 $ (encode tv s1 i)) * (v2 $ (encode tv (-s1) i)))"

definition tensor_vec_qp :: "nat list \<Rightarrow> nat set \<Rightarrow> 'a::times vec \<Rightarrow> 'a vec \<Rightarrow> 'a vec" where
  "tensor_vec_qp d s1 v1 v2 \<equiv>
     Matrix.vec (prod_list d) (\<lambda>i. (v1 $ (encode d s1 i)) * (v2 $ (encode d (-s1) i)))"

definition tensor_vec_vars::"nat list \<Rightarrow> nat set \<Rightarrow> nat set \<Rightarrow> 'a::times vec \<Rightarrow> 'a vec \<Rightarrow> 'a vec" where
  "tensor_vec_vars d s1 s2 v1 v2 \<equiv>
     let vars0 = s1 \<union> s2;
         s1' = (ind_in_set vars0) ` s1 in
     tensor_vec_qp (nths d vars0) s1' v1 v2"

definition plus_QState_vector::"('a::comm_ring_1) QState \<Rightarrow> 'a QState \<Rightarrow>nat set \<times> 'a list"
  where "plus_QState_vector q1 q2 \<equiv>
     let d1 = ind_in_set ((QState_vars q1) \<union> (QState_vars q2)) ` (QState_vars q1);
         d2 = ind_in_set ((QState_vars q1) \<union> (QState_vars q2)) ` (QState_vars q2);
          s = d1 \<union> d2; l1 = QState_vector q1; l2 = QState_vector q2;
          dims = list_dims s in
          ((QState_vars q1) \<union> (QState_vars q2), list_of_vec(tensor_vec_vars dims d1 d2 l1 l2))"

value "plus_QState_vector (QState({2},[1::int,2])) (QState({0,1},[1::int,2,3,4]))"

value "plus_QState_vector (QState({3},[1::int,2]))
                          (QState(plus_QState_vector (QState({2},[5::int,7])) (QState({0,1},[11::int,12,29,37]))))"

value "plus_QState_vector (QState(plus_QState_vector (QState ({3},[1::int,2])) (QState({2},[5::int,7]))))
                          (QState({0,1},[11::int,12,29,37]))"

definition tensor_mat :: "nat set \<Rightarrow> nat set \<Rightarrow> 'a::comm_ring_1 mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
  "tensor_mat s1 s2 m1 m2 \<equiv>
   let tv = list_dims (s1 \<union> s2) in
    Matrix.mat (prod_list tv) (prod_list tv)
    (\<lambda>(i,j).
       m1 $$ (encode tv s1 i, encode tv s1 j) * m2 $$ (encode tv (-s1) i, encode tv (-s1) j))"

value "(nths [2::nat,2,2,2] {0::nat,3,2})"
value "list_of_vec (tensor_vec_vars [] {} {} (vec_of_list [1::nat]) (vec_of_list [1]))"
value "list_of_vec (tensor_vec_vars [2,2,2,2] {0} {2,3,1} (vec_of_list [0::nat, 1])  (vec_of_list [0::nat, 1, 2,3,4,5,6,7]))"
value "(ind_in_set  {0::nat,1,2}) `  {0,1,2}"
value "list_of_vec (tensor_vec_vars [2,2,2,2] {0,1,2} {} (vec_of_list [0::nat, 1, 2,3,4,5,6,7]) (vCons 1 vNil))"

value "mat_to_list (mat_of_rows_list 2 [[1::nat,2],[1,1]])"
value "mat_to_list (mat_of_rows_list 2 [[1::nat,2],[2,2]])"

value "mat_to_list (tensor_mat {0,1} {2,3}
          (mat_of_rows_list 4 [[1::nat,3,4,5],[6,7,8,9],[10,11,12,13],[14,15,16,17]])
          (mat_of_rows_list 4 [[2::nat,20,21,22],[24,25,27,28],[40,41,44,45],[50,100,9,17]]))"

value "mat_to_list (tensor_mat {2,3} {0,1}
          (mat_of_rows_list 4 [[2::nat,20,21,22],[24,25,27,28],[40,41,44,45],[50,100,9,17]])
          (mat_of_rows_list 4 [[1::nat,3,4,5],[6,7,8,9],[10,11,12,13],[14,15,16,17]] ))"

value "let a = [[a0::nat,a1,a2,a3],[b1,b2,b3,b4],[c1,c2,c3,c4],[d1,d2,d3,d4]] in a"

value "(tensor_mat {0,1} {2,3}
          (mat_of_rows_list 4 [[a0::nat,a1,a2,a3],[b1,b2,b3,b4],[c1,c2,c3,c4],[d1,d2,d3,d4]])
          (mat_of_rows_list 4 [[e1::nat,e2,e3,e4],[f1,f2,f3,f4],[g1,g2,g3,g4],[h1,h2,h3,h4]]))"
value "list_of_vec (tensor_vec {0,1} {2,3} (vec_of_list [a00::nat,a01,a30,a31]) (vec_of_list [b10,b11,b20,b21])) "

value "permute_list pex [0::nat,3,1,2]"

value "list_of_vec (tensor_vec {0} {1} (vec_of_list [a0::nat,a1]) (vec_of_list [b0,b1])) "
value "list_of_vec (tensor_vec {1} {0} (vec_of_list [b0::nat,b1]) (vec_of_list [a0,a1])) "
value "list_of_vec (tensor_vec {0} {1} (vec_of_list [b0::nat,b1]) (vec_of_list [a0,a1])) "
\<comment>\<open> a * b * c \<close>
value "list_of_vec (tensor_vec {0,1} {2} (vec_of_list [(a0::nat) * b0, a1 * b0, a0 * b1, a1 * b1]) (vec_of_list [c0,c1]))"
value "[a0 * b0 * c0, a1 * b0 * c0, a0 * b1 * c0, a1 * b1 * c0, a0 * b0 * c1, a1 * b0 * c1, a0 * b1 * c1, a1 * b1 * c1].
        \<^sub>[0::nat,1,2] \<^sub>\<leadsto>\<^sub>i \<^sub>[1,0,2]"
\<comment>\<open> b * a * c\<close>
value "list_of_vec (tensor_vec {0,1} {2}
       (vec_of_list [b0 * a0, b1 * a0, b0 * a1, b1 * a1])
        (vec_of_list [c0,c1]))"

value "list_of_vec (tensor_vec {0,1} {2,3}
            (vec_of_list [a00::nat,a01,a30,a31]) (vec_of_list [b10,b11,b20,b21])) "

value "((permute_number)) 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 0"
value "permute_number 3 (get_permutation_list [0::nat,1,2][1,2,0]) 1"
value "permute_number 3 (get_permutation_list [0::nat,1,2] [1,2,0]) 2"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 3"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 4"
value "permute_number 3 (get_permutation_list [0::nat,1,2][1,2,0]) 5"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 6"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 7"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 8"
lemma "a o f = -a"

value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 0"
value "permute_number 3 (get_permutation_list [0::nat,1,2][1,2,0]) 1"
value "permute_number 3 (get_permutation_list [0::nat,1,2] [1,2,0]) 2"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 3"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 4"
value "permute_number 3 (get_permutation_list [0::nat,1,2][1,2,0]) 5"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 6"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 7"
value "permute_number 3 (get_permutation_list  [0::nat,1,2][1,2,0]) 8"

value "permute_number 3 (get_permutation_list  [1::nat,2,0][1,2,0]) 0"
value "permute_number 3 (get_permutation_list [1::nat,2,0][1,2,0]) 1"
value "permute_number 3 (get_permutation_list [1::nat,2,0] [1,2,0]) 2"
value "permute_number 3 (get_permutation_list  [1::nat,2,0][1,2,0]) 3"
value "permute_number 3 (get_permutation_list  [1::nat,2,0][1,2,0]) 4"
value "permute_number 3 (get_permutation_list [1::nat,2,0][1,2,0]) 5"
value "permute_number 3 (get_permutation_list  [1::nat,2,0][1,2,0]) 6"
value "permute_number 3 (get_permutation_list  [1::nat,2,0][1,2,0]) 7"
value "permute_number 3 (get_permutation_list  [1::nat,2,0][1,2,0]) 8"

value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 0"
value "permute_number 4 (get_permutation_list [0,3,1,2][3::nat,0,2,1]) 1"
value "permute_number 4 (get_permutation_list [0,3,1,2] [3::nat,0,2,1]) 2"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 3"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 4"
value "permute_number 4 (get_permutation_list [0,3,1,2][3::nat,0,2,1]) 5"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 6"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 7"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 8"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 9"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 10"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 11"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 12"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1] ) 13"
value "permute_number 4 (get_permutation_list  [0,3,1,2] [3::nat,0,2,1]) 14"
value "permute_number 4 (get_permutation_list [0,3,1,2] [3::nat,0,2,1]) 15"

value "get_permutation_list [0::nat, 3, 1, 2] [3,0,2,1] 0"
value "get_permutation_list [0::nat, 3, 1, 2] [3,0,2,1] 1"
value "get_permutation_list [0::nat, 3, 1, 2] [3,0,2,1] 2"
value "get_permutation_list [0::nat, 3, 1, 2] [3,0,2,1] 3"

value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 0"
value "permute_number 4 (get_permutation_list [0,3,1,2][3::nat,0,2,1]) 1"
value "permute_number 4 (get_permutation_list [0,3,1,2] [3::nat,0,2,1]) 2"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 3"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 4"
value "permute_number 4 (get_permutation_list [0,3,1,2][3::nat,0,2,1]) 5"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 6"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 7"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 8"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 9"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 10"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 11"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1]) 12"
value "permute_number 4 (get_permutation_list  [0,3,1,2][3::nat,0,2,1] ) 13"
value "permute_number 4 (get_permutation_list  [0,3,1,2] [3::nat,0,2,1]) 14"
value "permute_number 4 (get_permutation_list [0,3,1,2] [3::nat,0,2,1]) 15"

value "get_permutation_list [3::nat, 0, 2,1] [0,1,2,3] 0"
value "get_permutation_list [3::nat, 0, 2,1] [0,1,2,3] 1"
value "get_permutation_list [3::nat, 0, 2,1] [0,1,2,3] 2"
value "get_permutation_list [3::nat, 0, 2,1] [0,1,2,3] 3"

value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 0"
value "permute_number 4 (get_permutation_list [3,0,2,1][0::nat,1,2,3]) 1"
value "permute_number 4 (get_permutation_list [3,0,2,1] [0::nat,1,2,3]) 2"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 3"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 4"
value "permute_number 4 (get_permutation_list [3,0,2,1][0::nat,1,2,3]) 5"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 6"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 7"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 8"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 9"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 10"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 11"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 12"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3] ) 13"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3]) 14"
value "permute_number 4 (get_permutation_list [3,0,2,1] [0::nat,1,2,3]) 15"

value "let v = [a00::nat, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation v [0::nat,3,1,2] [3,0,2,1]
          "

value "let v = [a00::nat, a02, a01, a03, a08, a10, a09, a11, a04, a06, a05, a07, a12, a14, a13, a15] in
           change_orientation v [3::nat,0,2,1] [0,1,2,3]
          "

value "let v = [a00::nat, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation (change_orientation v [0::nat,3,1,2] [3,0,2,1] ) [3::nat,0,2,1] [0,1,2,3]
          "
value "get_permutation_list  [0::nat,3,1,2] [0,1,2,3] 0"
value "get_permutation_list  [0::nat,3,1,2] [0,1,2,3] 1"
value "get_permutation_list  [0::nat,3,1,2] [0,1,2,3] 2"
value "get_permutation_list  [0::nat,3,1,2] [0,1,2,3] 3"

value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 0"
value "permute_number 4 (get_permutation_list [3,0,2,1][0::nat,1,2,3]) 1"
value "permute_number 4 (get_permutation_list [3,0,2,1] [0::nat,1,2,3]) 2"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 3"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 4"
value "permute_number 4 (get_permutation_list [3,0,2,1][0::nat,1,2,3]) 5"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 6"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 7"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 8"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 9"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 10"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 11"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3]) 12"
value "permute_number 4 (get_permutation_list  [3,0,2,1][0::nat,1,2,3] ) 13"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3]) 14"
value "permute_number 4 (get_permutation_list [3,0,2,1] [0::nat,1,2,3]) 15"
value "let v = [a00, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation v [0::nat,3,1,2] [0,1,2,3]
          "

(* --------------------------------- *)
value "let v = [a00, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation v [0::nat,3,1,2] [3,0,2,1]
          "

value "permute_number 4 (get_permutation_list   [0::nat,3,2,1] [3,0,2,1]) 0"
value "permute_number 4 (get_permutation_list [0::nat,3,2,1] [3,0,2,1]) 1"
value "permute_number 4 (get_permutation_list [0::nat,3,2,1] [3,0,2,1]) 2"
value "permute_number 4 (get_permutation_list   [0::nat,3,2,1] [3,0,2,1]) 3"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1] ) 4"
value "permute_number 4 (get_permutation_list   [0::nat,3,2,1] [3,0,2,1]) 5"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 6"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 7"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 8"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 9"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 10"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 11"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 12"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1]  [3,0,2,1]) 13"
value "permute_number 4 (get_permutation_list     [0::nat,3,2,1] [3,0,2,1]) 14"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [3,0,2,1]) 15"

value "let v = [a00, a02, a01, a03, a08, a10, a09, a11, a04, a06, a05, a07, a12, a14, a13, a15] in
           change_orientation v [3::nat,0,2,1] [0,1,2,3]
          "
value "(get_permutation_list [0::nat,3,2,1] [0::nat,1,2,3])"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3]) 0"
value "permute_number 4 (get_permutation_list [3,0,2,1] [0::nat,1,2,3]) 1"
value "permute_number 4 (get_permutation_list [3,0,2,1]  [0::nat,1,2,3] ) 2"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3]) 3"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 4"
value "permute_number 4 (get_permutation_list [3,0,2,1] [0::nat,1,2,3] ) 5"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 6"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 7"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 8"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 9"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 10"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3] ) 11"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3]) 12"
value "permute_number 4 (get_permutation_list  [3,0,2,1] [0::nat,1,2,3]  ) 13"
value "permute_number 4 (get_permutation_list  [3,0,2,1]  [0::nat,1,2,3] ) 14"
value "permute_number 4 (get_permutation_list [3,0,2,1]  [0::nat,1,2,3] ) 15"

value "let v = [a00, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation (change_orientation v [0::nat,3,1,2] [3,0,2,1]) [3::nat,0,2,1] [0,1,2,3]
          "

value "let v = [a00, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation v [0::nat,3,1,2] [0,1,2,3]
          "

value "let v = [a00, a01, a02, a03, a04,a05, a06, a07,a08,a09,a10,a11,a12,a13,a14,a15] in
           change_orientation (change_orientation v   [3::nat,0,2,1] [0,1,2,3]) [3::nat,0,2,1] [0::nat,3,1,2]
          "

value "permute_number 4 (get_permutation_list   [0::nat,3,2,1] [0,1,2,3]) 0"
value "permute_number 4 (get_permutation_list [0::nat,3,2,1] [0,1,2,3]) 1"
value "permute_number 4 (get_permutation_list [0::nat,3,2,1] [0,1,2,3]) 2"
value "permute_number 4 (get_permutation_list   [0::nat,3,2,1] [0,1,2,3]) 3"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3] ) 4"
value "permute_number 4 (get_permutation_list   [0::nat,3,2,1] [0,1,2,3]) 5"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 6"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 7"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 8"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 9"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 10"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 11"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 12"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1]  [0,1,2,3]) 13"
value "permute_number 4 (get_permutation_list     [0::nat,3,2,1] [0,1,2,3]) 14"
value "permute_number 4 (get_permutation_list    [0::nat,3,2,1] [0,1,2,3]) 15"

value "permute_list pex1 [0::nat,3,1,2]"

value "permute_list pex [0::nat,0,0,0]"
value "permute_list pex [0::nat,0,0,1]"
value "permute_list pex [0::nat,0,1,0]"
value "permute_list pex [0::nat,0,1,1]"
value "permute_list pex [0::nat,1,0,0]"
value "permute_list pex [0::nat,1,0,1]"
value "permute_list pex [0::nat,1,1,0]"
value "permute_list pex [0::nat,1,1,1]"
value "permute_list pex [1::nat,0,0,0]"
value "permute_list pex [1::nat,0,0,1]"
value "permute_list pex [1::nat,0,1,0]"
value "permute_list pex [1::nat,0,1,1]"
value "permute_list pex [1::nat,1,0,0]"
value "permute_list pex [1::nat,1,0,1]"
value "permute_list pex [1::nat,1,1,0]"
value "permute_list pex [1::nat,1,1,1]"

value "permute_list pex1 [0::nat,0,0,0]"
value "permute_list pex1 [0::nat,0,0,1]"
value "permute_list pex1 [0::nat,0,1,0]"
value "permute_list pex1 [0::nat,0,1,1]"
value "permute_list pex1 [0::nat,1,0,0]"
value "permute_list pex1 [0::nat,1,0,1]"
value "permute_list pex1 [0::nat,1,1,0]"
value "permute_list pex1 [0::nat,1,1,1]"
value "permute_list pex1 [1::nat,0,0,0]"
value "permute_list pex1 [1::nat,0,0,1]"
value "permute_list pex1 [1::nat,0,1,0]"
value "permute_list pex1 [1::nat,0,1,1]"
value "permute_list pex1 [1::nat,1,0,0]"
value "permute_list pex1 [1::nat,1,0,1]"
value "permute_list pex1 [1::nat,1,1,0]"
value "permute_list pex1 [1::nat,1,1,1]"

value "permute_number 4 pex "

lemma "(p_inv pex) = pex1"
  unfolding pex_def pex1_def inv_def
  apply rule by auto

lemma  " (p o p') =  p_inv (p' o p)"
  unfolding inv_def apply auto apply rule apply auto nitpick
  sorry

definition p1::"nat \<Rightarrow> nat"
  where "p1 i \<equiv> ((((id((0::nat):=2))(1:=0))(2:=1))) i"

definition p'::"nat \<Rightarrow> nat"
  where "p' i \<equiv> ((((id((0::nat):=1))(1:=2))(2:=0))) i"

definition p::"nat \<Rightarrow> nat"
  where "p i \<equiv> ((((id((0::nat):=0))(1:=2))(2:=1))) i"

definition "p'' \<equiv> p o p'"

value "permute_list p [3::nat,1,2]" (* l \<rightarrow> l' *)
value "permute_list p' [3::nat,2,1]" (* l' \<rightarrow> s *)

value "(p o p') 0"
value "(p o p') 1"
value "(p o p') 2"

value "(p' o p) 0"
value "(p' o p) 1"
value "(p' o p) 2"

lemma "p_inv (p o p') = (p' o p)"
  unfolding p_def p'_def inv_def
  apply rule
  apply auto
  oops

lemma "p_inv p = p'"
  unfolding p_def p'_def inv_def
  apply rule
  apply auto
  oops

value "permute_list (p o p') [3::nat,1,2]"
value "permute_list (p' o p) [3::nat,1,2]"
value "permute_list p' (permute_list p  [3::nat,1,2])"

value "vector_permutation 3 p ([0::nat,1,2,3,4,5,6,7]) " (* v' = v.l \<rightarrow> l' *)

value "vector_permutation 3 p' [0::nat, 2, 1, 3, 4, 6, 5, 7]" (* vs = v'. l' \<rightarrow> s *)

value "vector_permutation 3 (p o p') ([0::nat,1,2,3,4,5,6,7]) " (* vs = v.l \<rightarrow> s *)

value "vector_permutation 3 (p' o p) ([0::nat,1,2,3,4,5,6,7]) " (* vs = v.l \<rightarrow> s *)

value "vector_permutation 3 p' (vector_permutation 3 p ([0::nat,1,2,3,4,5,6,7]))"

end


theory Smap_siterate
  imports Main "$HIPSTER_HOME/IsaHipster"
    Smap
    Siterate
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy
(*cohipster smap siterate*)
(* ca 30 seconds *)
lemma lemma_ac [thy_expl]: "smap y (siterate y z) = siterate y (y z)"
 by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_ad [thy_expl]: "smap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
 by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_ac)
(*cohipster smap siterate Fun.comp*)
(*ca 1 minute*)
lemma lemma_ae [thy_expl]: "smap z (siterate (y \<circ> z) x2) = siterate (z \<circ> y) (z x2)"
 by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    auto
end


section \<open>I/O Automata with Finite-Trace Semantics\<close>

theory IOA
imports Main
begin

text \<open>This theory is inspired by the IOA theory of Olaf Müller\<close>

record 'a signature =
  inputs::"'a set"
  outputs::"'a set"
  internals::"'a set"

locale IOA
begin

subsection "Signatures"

definition actions :: "'a signature \<Rightarrow> 'a set" where
  "actions asig \<equiv> inputs asig \<union> outputs asig \<union> internals asig"

definition externals :: "'a signature \<Rightarrow> 'a set" where
  "externals asig \<equiv> inputs asig \<union> outputs asig"

definition locals :: "'a signature \<Rightarrow> 'a set" where
  "locals asig \<equiv> internals asig \<union> outputs asig"

definition is_asig :: "'a signature \<Rightarrow> bool" where
  "is_asig triple \<equiv>
     inputs triple \<inter> outputs triple = {} \<and>
     outputs triple \<inter> internals triple = {} \<and>
     inputs triple \<inter> internals triple = {}"

lemma internal_inter_external:
  assumes "is_asig sig"
  shows "internals sig \<inter> externals sig = {}"
  using assms by (auto simp add:internals_def externals_def is_asig_def)

definition hide_asig where
  "hide_asig asig actns \<equiv>
    \<lparr>inputs = inputs asig - actns, outputs = outputs asig - actns,
      internals = internals asig \<union> actns\<rparr>"

end

subsection "I/O Automata"

type_synonym
  ('s,'a) transition = "'s \<times> 'a \<times> 's"

record ('s,'a) ioa =
  asig::"'a signature"
  start::"'s set"
  trans::"('s,'a)transition set"

context IOA
begin

abbreviation "act A \<equiv> actions (asig A)"
abbreviation "ext A \<equiv> externals (asig A)"
abbreviation int where "int A \<equiv> internals (asig A)"
abbreviation "inp A \<equiv> inputs (asig A)"
abbreviation "out A \<equiv> outputs (asig A)"
abbreviation "local A \<equiv> locals (asig A)"

definition is_ioa::"('s,'a) ioa \<Rightarrow> bool" where
  "is_ioa A \<equiv> is_asig (asig A)
    \<and> (\<forall> triple  \<in> trans A . (fst o snd) triple \<in> act A)"

definition hide where
  "hide A actns \<equiv> A\<lparr>asig := hide_asig (asig A) actns\<rparr>"

definition is_trans::"'s \<Rightarrow> 'a \<Rightarrow> ('s,'a)ioa \<Rightarrow> 's \<Rightarrow> bool" where
  "is_trans s1 a A s2 \<equiv> (s1,a,s2) \<in> trans A"

notation
  is_trans  ("_ \<midarrow>_\<midarrow>_\<longrightarrow> _" [81,81,81,81] 100)

definition rename_set where
  "rename_set A ren \<equiv> {b. \<exists> x \<in> A . ren b = Some x}"

definition rename where
"rename A ren \<equiv>
  \<lparr>asig = \<lparr>inputs = rename_set (inp A) ren,
    outputs = rename_set (out A) ren,
    internals = rename_set (int A) ren\<rparr>,
   start = start A,
   trans = {tr. \<exists> x . ren (fst (snd tr)) = Some x \<and> (fst tr) \<midarrow>x\<midarrow>A\<longrightarrow> (snd (snd tr))}\<rparr>"

text "Reachable states and invariants"

inductive
  reachable :: "('s,'a) ioa \<Rightarrow> 's \<Rightarrow> bool"
  for A :: "('s,'a) ioa"
  where
    reachable_0:  "s \<in> start A \<Longrightarrow> reachable A s"
  | reachable_n:  "\<lbrakk> reachable A s; s \<midarrow>a\<midarrow>A\<longrightarrow> t \<rbrakk> \<Longrightarrow> reachable A t"

definition invariant where
  "invariant A P \<equiv> (\<forall> s . reachable A s \<longrightarrow> P(s))"

theorem invariantI:
  fixes A P
  assumes c1:"\<And> s . s \<in> start A \<Longrightarrow> P s"
  and c2:"\<And> s t a . \<lbrakk>reachable A s; P s; s \<midarrow>a\<midarrow>A\<longrightarrow> t\<rbrakk> \<Longrightarrow> P t"
  shows "invariant A P"
proof -
  { fix s
    assume "reachable A s"
    hence "P s"
    proof (induct rule:reachable.induct)
      fix s
      assume "s \<in> start A"
      thus "P s" using assms(1) by simp
    next
      fix a s t
      assume "reachable A s" and "P s" and " s \<midarrow>a\<midarrow>A\<longrightarrow> t"
      thus "P t" using assms(2) by simp
    qed }
  thus ?thesis by (simp add:invariant_def)
qed

end

subsection "Composition of Families of I/O Automata"

record ('id, 'a) family =
  ids :: "'id set"
  memb :: "'id \<Rightarrow> 'a"

context IOA
begin

definition is_ioa_fam where
  "is_ioa_fam fam \<equiv> \<forall> i \<in> ids fam . is_ioa (memb fam i)"

definition compatible2  where
  "compatible2 A B \<equiv>
   out A \<inter> out B = {} \<and>
   int A \<inter> act B = {} \<and>
   int B \<inter> act A = {}"

(*  According to Lynch we just need ids to be countable instead of finite, with some restriction
    on actions occuring into infinitely many signatures. *)
definition compatible::"('id, ('s,'a)ioa) family \<Rightarrow> bool" where
  "compatible fam \<equiv> finite (ids fam) \<and>
    (\<forall> i \<in> ids fam . \<forall> j \<in> ids fam . i \<noteq> j \<longrightarrow>
      compatible2 (memb fam i) (memb fam j))"

definition asig_comp2 where
  "asig_comp2 A B \<equiv>
     \<lparr>inputs = (inputs A \<union> inputs B) - (outputs A \<union> outputs B),
      outputs = outputs A \<union> outputs B,
      internals = internals A \<union> internals B\<rparr>"

definition asig_comp::"('id, ('s,'a)ioa) family \<Rightarrow> 'a signature" where
  "asig_comp fam \<equiv>
    \<lparr> inputs = \<Union>i\<in>(ids fam). inp (memb fam i)
        - (\<Union>i\<in>(ids fam). out (memb fam i)),
      outputs = \<Union>i\<in>(ids fam). out (memb fam i),
      internals = \<Union>i\<in>(ids fam). int (memb fam i) \<rparr>"

definition par2 (infixr "\<parallel>" 10) where
  "A \<parallel> B \<equiv>
      \<lparr>asig = asig_comp2 (asig A) (asig B),
       start = {pr. fst pr \<in> start A \<and> snd pr \<in> start B},
       trans = {tr.
        let s = fst tr; a = fst (snd tr); t = snd (snd tr)
        in (a \<in> act A \<or> a \<in> act B)
           \<and> (if a \<in> act A
              then fst s \<midarrow>a\<midarrow>A\<longrightarrow> fst t
              else fst s = fst t)
           \<and> (if a \<in> act B
              then snd s \<midarrow>a\<midarrow>B\<longrightarrow> snd t
              else snd s = snd t) }\<rparr>"

definition par::"('id, ('s,'a)ioa) family \<Rightarrow> ('id \<Rightarrow> 's,'a)ioa" where
  "par fam \<equiv> let ids = ids fam; memb = memb fam in
      \<lparr> asig = asig_comp fam,
        start = {s . \<forall> i\<in>ids . s i \<in> start (memb i)},
        trans = { (s, a, s') .
          (\<exists> i\<in>ids . a \<in> act (memb i))
          \<and> (\<forall> i\<in>ids .
              if a \<in> act (memb i)
              then s i \<midarrow>a\<midarrow>(memb i)\<longrightarrow> s' i
              else s i = (s' i)) } \<rparr>"

lemmas asig_simps = hide_asig_def is_asig_def locals_def externals_def actions_def
  hide_def compatible_def asig_comp_def
lemmas ioa_simps = rename_def rename_set_def is_trans_def is_ioa_def par_def

end

subsection "Executions and Traces"

type_synonym
   ('s,'a)pairs = "('a\<times>'s) list"
type_synonym
   ('s,'a)execution = "'s \<times> ('s,'a)pairs"
type_synonym
   'a trace = "'a list"

record ('s,'a)execution_module =
  execs::"('s,'a)execution set"
  asig::"'a signature"

record 'a trace_module =
  traces::"'a trace set"
  asig::"'a signature"

context IOA
begin

fun last_state where
  "last_state (s,[]) = s"
| "last_state (s,p#ps) = snd p"

inductive is_exec_frag_of_ind::"('s,'a)ioa \<Rightarrow> ('s,'a)execution \<Rightarrow> bool"
  for A::"('s, 'a) ioa"
  where
  "is_exec_frag_of_ind A (s, [])"
| "\<lbrakk>is_exec_frag_of_ind A (s, ps); (last_state (s, ps)) \<midarrow>fst p\<midarrow>A\<longrightarrow> snd p\<rbrakk> \<Longrightarrow> is_exec_frag_of_ind A (s,p#ps)"

fun is_exec_frag_of::"('s,'a)ioa \<Rightarrow> ('s,'a)execution \<Rightarrow> bool" where
  "is_exec_frag_of A (s,p#(p'#ps)) =
    (snd p' \<midarrow>fst p\<midarrow>A\<longrightarrow> snd p \<and> is_exec_frag_of A (s, (p'#ps)))"
| "is_exec_frag_of A (s, [p]) = s \<midarrow>fst p\<midarrow>A\<longrightarrow> snd p"
| "is_exec_frag_of A (s, []) = True"

lemma "is_exec_frag_of A e = is_exec_frag_of_ind A e"
proof -
  have "is_exec_frag_of A e \<Longrightarrow> is_exec_frag_of_ind A e"
  apply (induct rule:is_exec_frag_of.induct, auto)
        apply (simp add: IOA.is_exec_frag_of_ind.intros(2))
      apply (simp add: IOA.is_exec_frag_of_ind.intros(1) IOA.is_exec_frag_of_ind.intros(2))
    apply (simp add: IOA.is_exec_frag_of_ind.intros(1))
  done
  moreover
  have "is_exec_frag_of_ind A e \<Longrightarrow> is_exec_frag_of A e"
  apply (induct rule:is_exec_frag_of_ind.induct, auto)
    apply (metis IOA.is_exec_frag_of.simps(1) IOA.is_exec_frag_of.simps(2) IOA.last_state.simps(1) IOA.last_state.simps(2) fst_conv neq_Nil_conv snd_conv)
  done
  ultimately show ?thesis by auto
qed

definition is_exec_of::"('s,'a)ioa \<Rightarrow> ('s,'a)execution \<Rightarrow> bool" where
  "is_exec_of A e \<equiv> fst e \<in> start A \<and> is_exec_frag_of A e"

definition filter_act where
  "filter_act \<equiv> map fst"

definition schedule where
  "schedule \<equiv> filter_act o snd"

definition trace where
  "trace sig \<equiv> filter (\<lambda> a . a \<in> externals sig) o schedule"

(*
definition big_step where
  "big_step s e A as s' \<equiv> is_exec_frag_of A (ps,s) \<and> s' = fst (hd ps)
    \<and> trace (ioa.asig A) (ps,s) = as"

notation
  big_step  ("_ \<Midarrow> _ \<Midarrow> _ \<Midarrow> _ \<Longrightarrow> _" [81,81,81,81] 100)
*)

definition is_schedule_of where
  "is_schedule_of A sch \<equiv>
     (\<exists> e . is_exec_of A e \<and> sch = filter_act (snd e))"

definition is_trace_of where
  "is_trace_of A tr \<equiv>
     (\<exists> sch . is_schedule_of A sch \<and> tr = filter (\<lambda> a. a \<in> ext A) sch)"

definition traces where
  "traces A \<equiv> {tr. is_trace_of A tr}"

lemma traces_alt:
  shows "traces A = {tr . \<exists> e . is_exec_of A e
    \<and> tr = trace (ioa.asig A) e}"
proof -
  { fix t
    assume a:"t \<in> traces A"
    have "\<exists> e . is_exec_of A e \<and> trace (ioa.asig A) e = t"
    proof -
      from a obtain sch where 1:"is_schedule_of A sch"
        and 2:"t = filter (\<lambda> a. a \<in> ext A) sch"
        by (auto simp add:traces_def is_trace_of_def)
      from 1 obtain e where 3:"is_exec_of A e" and 4:"sch = filter_act (snd e)"
        by (auto simp add:is_schedule_of_def)
      from 4 and 2 have "trace (ioa.asig A) e = t"
        by (simp add:trace_def schedule_def)
      with 3 show ?thesis by fast
    qed }
  moreover
  { fix e
    assume "is_exec_of A e"
    hence "trace (ioa.asig A) e \<in> traces A"
      by (auto simp add:trace_def schedule_def traces_def
          is_trace_of_def is_schedule_of_def is_exec_of_def)
      (metis prod.collapse) }
  ultimately show ?thesis by blast
qed

lemmas traces_simps = trace_def traces_def is_trace_of_def is_schedule_of_def filter_act_def is_exec_of_def schedule_def

definition proj_trace::"'a trace \<Rightarrow> ('a signature) \<Rightarrow> 'a trace" (infixr "\<bar>" 12) where
  "proj_trace t sig \<equiv> filter (\<lambda> a . a \<in> actions sig) t"

definition ioa_implements :: "('s1,'a)ioa \<Rightarrow> ('s2,'a)ioa \<Rightarrow> bool"   (infixr "=<|" 12) where
  "A =<| B \<equiv> inp A = inp B \<and> out A = out B \<and> traces A \<subseteq> traces B"

subsection "Operations on Executions"

definition cons_exec where
  "cons_exec e p \<equiv> (fst e, p#(snd e))"

definition append_exec where
  "append_exec e e' \<equiv> (fst e, (snd e')@(snd e))"

lemma last_state_reachable:
  fixes A e
  assumes "is_exec_of A e"
  shows "reachable A (last_state e)" using assms
proof -
  have "is_exec_of A e \<Longrightarrow> reachable A (last_state e)"
  proof (induction "snd e" arbitrary: e)
    case Nil
    from Nil.prems have 1:"fst e \<in> start A" by (simp add:is_exec_of_def)
    from Nil.hyps have 2:"last_state e = fst e" by (metis last_state.simps(1) surjective_pairing)
    from 1 and 2 and Nil.hyps show ?case by (metis reachable_0)
  next
    case (Cons p ps e)
    let ?e' = "(fst e, ps)"
    have ih:"reachable A (last_state ?e')"
    proof -
      from Cons.prems and Cons.hyps(2) have "is_exec_of A ?e'"
        by (simp add:is_exec_of_def) (metis is_exec_frag_of.simps(1,3) list.exhaust prod.collapse)
      with Cons.hyps(1) show ?thesis by auto
    qed
    from Cons.prems and Cons.hyps(2) have "(last_state ?e')\<midarrow>(fst p)\<midarrow>A\<longrightarrow>(snd p)"
      by (simp add:is_exec_of_def) (cases "(A,fst e,p#ps)" rule:is_exec_frag_of.cases, auto)
    with ih and Cons.hyps(2) show ?case
      by (metis last_state.simps(2) reachable.simps surjective_pairing)
  qed
  thus ?thesis using assms by fastforce
qed

lemma trans_from_last_state:
  assumes "is_exec_frag_of A e" and "(last_state e)\<midarrow>a\<midarrow>A\<longrightarrow>s'"
  shows "is_exec_frag_of A (cons_exec e  (a,s'))"
    using assms by (cases "(A, fst e, snd e)" rule:is_exec_frag_of.cases, auto simp add:cons_exec_def)

lemma exec_frag_prefix:
  fixes A p ps
  assumes "is_exec_frag_of A (cons_exec e p)"
  shows "is_exec_frag_of A e"
    using assms by (cases "(A, fst e, snd e)" rule:is_exec_frag_of.cases, auto simp add:cons_exec_def)

lemma trace_same_ext:
  fixes A B e
  assumes "ext A = ext B"
  shows "trace (ioa.asig A) e = trace (ioa.asig B) e"
  using assms by (auto simp add:trace_def)

lemma trace_append_is_append_trace:
  fixes e e' sig
  shows "trace sig (append_exec e' e) = trace sig e @ trace sig e'"
  by (simp add:append_exec_def trace_def schedule_def filter_act_def)

lemma last_state_of_append:
  fixes e e'
  assumes "fst e' = last_state e"
  shows "last_state (append_exec e e') = last_state e'"
  using assms by (cases e' rule:last_state.cases, auto simp add:append_exec_def)

subsection "Composition is monotonic with respect to the implementation relation"

theorem monotonicity_fam:
  fixes fam1 fam2
  assumes "is_ioa_fam fam1" and "is_ioa_fam fam2"
  and "compatible fam1" and "compatible fam2"
  and "\<forall> i \<in> ids fam1 . memb fam1 i =<| memb fam2 i"
  shows "(par fam1) =<| (par fam2)"
oops

end

end


(* Author: Gerwin Klein, Tobias Nipkow *)

subsection "Big-Step Semantics of Commands"

theory Big_Step imports Com begin

text \<open>
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes \<open>(c,s) \<Rightarrow> s'\<close>.
\<close>

text_raw\<open>\snip{BigStepdef}{0}{1}{%\<close>
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
Or1: "(c1, s) \<Rightarrow> t \<Longrightarrow> (c1 OR c2, s) \<Rightarrow> t" |
Or2:
"(c2, s) \<Rightarrow> t \<Longrightarrow> (c1 OR c2, s) \<Rightarrow> t" |
Assume: "bval b s \<Longrightarrow> (ASSUME b, s) \<Rightarrow> s"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{BigStepEx}{1}{2}{%\<close>
schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw\<open>}%endsnip\<close>

thm ex[simplified]

text\<open>We want to execute the big-step rules:\<close>

code_pred big_step .

text\<open>For inductive definitions we need command
       \texttt{values} instead of \texttt{value}.\<close>

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text\<open>We need to translate the result state into a list
to display it.\<close>

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text\<open>Proof automation:\<close>

text \<open>The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules.\<close>
declare big_step.intros [intro]

text\<open>The standard induction rule
@{thm [display] big_step.induct [no_vars]}\<close>

thm big_step.induct

text\<open>
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the \<open>c\<close>, \<open>s\<close>,
and \<open>s'\<close> that we are likely to encounter. Splitting
the tuple parameter fixes this:
\<close>
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text \<open>
@{thm [display] big_step_induct [no_vars]}
\<close>

subsection "Rule inversion"

text\<open>What can we deduce from \<^prop>\<open>(SKIP,s) \<Rightarrow> t\<close> ?
That \<^prop>\<open>s = t\<close>. This is how we can automatically prove it:\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text\<open>This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands:\<close>

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases OrE[elim!]: "(c1 OR c2, s) \<Rightarrow> t"
thm OrE
inductive_cases AssumeE[elim!]: "(ASSUME b, s) \<Rightarrow> t"
thm AssumeE
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text\<open>Only [elim]: [elim!] would not terminate.\<close>

text\<open>An automatic example:\<close>

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text\<open>Rule inversion by hand via the ``cases'' method:\<close>

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  \<comment> \<open>inverting assms\<close>
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text \<open>An example combining rule inversion and derivations\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  \<comment> \<open>The other direction is analogous\<close>
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text \<open>
  We call two statements \<open>c\<close> and \<open>c'\<close> equivalent wrt.\ the
  big-step semantics when \emph{\<open>c\<close> started in \<open>s\<close> terminates
  in \<open>s'\<close> iff \<open>c'\<close> started in the same \<open>s\<close> also terminates
  in the same \<open>s'\<close>}. Formally:
\<close>
text_raw\<open>\snip{BigStepEquiv}{0}{1}{%\<close>
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw\<open>}%endsnip\<close>

text \<open>
Warning: \<open>\<sim>\<close> is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
\<close>
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
      case WhileFalse
      thus ?thesis by blast
    next
      case WhileTrue
      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
      \<comment> \<open>first, the body of the True-branch:\<close>
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
    qed
  qed
  moreover
  \<comment> \<open>now the other direction:\<close>
  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
      case IfFalse
      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
      thus ?thesis using \<open>\<not>bval b s\<close> by blast
    next
      case IfTrue
      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
    qed
  qed
  ultimately
  show ?thesis by blast
qed

text \<open>Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.\<close>

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text \<open>Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically.\<close>

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

lemma "(c1 OR c2) \<sim> (c2 OR c1)"
  by auto

lemma " (IF b THEN c1 ELSE c2) \<sim> ((ASSUME b;; c1) OR (ASSUME (Not b);; c2))"
  by fastforce
end