(*  Title:      RTS/JinjaSuppl/Subcls.thy
    Author:    Susannah Mansky, UIUC 2020
    Description:  Theory for the subcls relation
*)

section "@{term subcls} theory"

theory Subcls
imports JinjaDCI.TypeRel
begin

lemma subcls_class_ex: "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* C'; C \<noteq> C' \<rbrakk>
 \<Longrightarrow> \<exists>D' fs ms. class P C = \<lfloor>(D', fs, ms)\<rfloor>"
proof(induct rule: converse_rtrancl_induct)
  case (step y z) then show ?case by(auto dest: subcls1D)
qed(simp)

lemma class_subcls1:
 "\<lbrakk> class P y = class P' y; P \<turnstile> y \<prec>\<^sup>1 z \<rbrakk> \<Longrightarrow> P' \<turnstile> y \<prec>\<^sup>1 z"
 by(auto dest!: subcls1D intro!: subcls1I intro: sym)

lemma subcls1_single_valued: "single_valued (subcls1 P)"
by (clarsimp simp: single_valued_def subcls1.simps)

lemma subcls_confluent:
  "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* C'; P \<turnstile> C \<preceq>\<^sup>* C'' \<rbrakk> \<Longrightarrow> P \<turnstile> C' \<preceq>\<^sup>* C'' \<or> P \<turnstile> C'' \<preceq>\<^sup>* C'"
 by (simp add: single_valued_confluent subcls1_single_valued)

lemma subcls1_confluent: "\<lbrakk> P \<turnstile> a \<prec>\<^sup>1 b; P \<turnstile> a \<preceq>\<^sup>* c; a \<noteq> c \<rbrakk> \<Longrightarrow> P \<turnstile> b \<preceq>\<^sup>* c"
using subcls1_single_valued
 by (auto elim!: converse_rtranclE[where x=a] simp: single_valued_def)

lemma subcls_self_superclass: "\<lbrakk> P \<turnstile> C \<prec>\<^sup>1 C; P \<turnstile> C \<preceq>\<^sup>* D \<rbrakk> \<Longrightarrow> D = C"
using subcls1_single_valued
 by (auto elim!: rtrancl_induct[where b=D] simp: single_valued_def)

lemma subcls_of_Obj_acyclic:
 "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* Object; C \<noteq> D\<rbrakk> \<Longrightarrow> \<not>(P \<turnstile> C \<preceq>\<^sup>* D \<and> P \<turnstile> D \<preceq>\<^sup>* C)"
proof(induct arbitrary: D rule: converse_rtrancl_induct)
  case base then show ?case by simp
next
  case (step y z) show ?case
  proof(cases "y=z")
    case True with step show ?thesis by simp
  next
    case False show ?thesis
    proof(cases "z = D")
      case True with False step.hyps(3)[of y] show ?thesis by clarsimp
    next
      case neq: False
      with step.hyps(3) have "\<not>(P \<turnstile> z \<preceq>\<^sup>* D \<and> P \<turnstile> D \<preceq>\<^sup>* z)" by simp
      moreover from step.hyps(1)
      have "P \<turnstile> D \<preceq>\<^sup>* y \<Longrightarrow> P \<turnstile> D \<preceq>\<^sup>* z" by(simp add: rtrancl_into_rtrancl)
      moreover from step.hyps(1) step.prems(1)
      have "P \<turnstile> y \<preceq>\<^sup>* D \<Longrightarrow> P \<turnstile> z \<preceq>\<^sup>* D" by(simp add: subcls1_confluent)
      ultimately show ?thesis by clarsimp
    qed
  qed
qed

lemma subcls_of_Obj: "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* Object; P \<turnstile> C \<preceq>\<^sup>* D \<rbrakk> \<Longrightarrow> P \<turnstile> D \<preceq>\<^sup>* Object"
 by(auto dest: subcls_confluent)

end


(*
Title: Eckmann-Hilton Collapse for 2-Catoids
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>2-Catoids with (too) strong homomorphisms\<close>

theory Two_Catoid_Collapse
  imports Two_Catoid

begin

text \<open>Here I present  variants of 2-categories where the axioms are too strong. There is an Eckmann-Hilton
style collapse of the two structures.\<close>

subsection \<open>2-st-Multimagmas with strong homomorphism laws\<close>

class two_st_multimagma_collapse = st_multimagma0 + st_multimagma1 +
  assumes comm_s0s1: "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
  and comm_t0t1: "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"
  and comm_s0t1: "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
  and commtr0s1: "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
  assumes interchange: "(w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) \<subseteq> (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)"
  and t0_hom: "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) = \<tau>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>0 y"
  and t1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) = \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y"
  and s0_hom: "Src\<^sub>0 (x \<odot>\<^sub>1 y) = \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y" (* this is too strong *)
  and s1_hom: "Src\<^sub>1 (x \<odot>\<^sub>0 y) = \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 y" (* this is too strong *)
  and s1_s0 [simp]: "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  and t1_s0 [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  and s1_t0 [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  and t1_t0 [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"

begin

text \<open>The source and target structure collapses.\<close>

lemma s0s1: "\<sigma>\<^sub>0 x = \<sigma>\<^sub>1 x"
proof-
  have "Src\<^sub>0 (\<sigma>\<^sub>1 x \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)) = \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x))"
    by (simp add: local.s0_hom)
  also have "\<dots>  = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)) \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)"
    by simp
  also have "\<dots> = {\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)}"
    using local.src1_absorb by presburger
  also have "\<dots> \<noteq> {}"
   by (metis insert_not_empty)
  finally have "Src\<^sub>0 (\<sigma>\<^sub>1 x \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x)) \<noteq> {}".
  hence "\<sigma>\<^sub>1 x \<odot>\<^sub>1 \<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) \<noteq> {}"
    by (metis image_empty)
  hence "\<tau>\<^sub>1 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x))"
    using local.Dst1 by presburger
  hence "\<sigma>\<^sub>1 x = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x))"
    by simp
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x))"
    by (simp add: local.comm_s0s1)
  also have "\<dots> = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = \<sigma>\<^sub>0 x"
    by simp
  finally show ?thesis..
qed

lemma t0t1: "\<tau>\<^sub>0 x = \<tau>\<^sub>1 x"
  using local.comm_s0t1 local.commtr0s1 local.s0s1 stmm0.ts_compat by force

lemma s0t0: "\<sigma>\<^sub>0 x = \<tau>\<^sub>0 x"
proof-
  have "\<sigma>\<^sub>0 x = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = \<sigma>\<^sub>0 (\<tau>\<^sub>1 x)"
    by (simp add: local.comm_s0t1)
  also have "\<dots> = \<sigma>\<^sub>0 (\<tau>\<^sub>0 x)"
    by (simp add: t0t1)
  also have "\<dots> = \<tau>\<^sub>0 x "
    by simp
  finally show ?thesis.
qed

lemma "\<sigma>\<^sub>0 x = x"
  nitpick
  oops

lemma s1t1: "\<sigma>\<^sub>1 x = \<tau>\<^sub>1 x"
  using local.s0s1 s0t0 t0t1 by force

lemma "x \<in> y \<odot>\<^sub>0 z \<Longrightarrow> x' \<in> y \<odot>\<^sub>0 z \<Longrightarrow> x = x'"
  nitpick
  oops

lemma "x \<in> y \<odot>\<^sub>1 z \<Longrightarrow> x' \<in> y \<odot>\<^sub>1 z \<Longrightarrow> x = x'"
  nitpick
  oops

text \<open>The two compositions are still different---but see below for 2-catoids.\<close>

end

subsection\<open>2-Catoids with (too) strong homomorphisms\<close>

class two_catoid_collapse = two_st_multimagma_collapse + catoid0 + catoid1

begin

text \<open>The two compositions are still different, and neither of them commutes.\<close>

lemma "x \<odot>\<^sub>0 y = x \<odot>\<^sub>1 y"
  nitpick
  oops

lemma "x \<odot>\<^sub>0 y = y \<odot>\<^sub>0 x"
  nitpick
  oops

lemma "x \<odot>\<^sub>1 y = y \<odot>\<^sub>1 x"
  nitpick
  oops

end

subsection\<open>Single-set 2-categories with (too) strong homomorphisms\<close>

class two_category_collapse = two_catoid_collapse + single_set_category0 + single_set_category1

begin

lemma comp_collapse: "x \<odot>\<^sub>0 y = x \<odot>\<^sub>1 y"
  by (smt (verit) local.interchange local.pm0.functionality_lem local.pm1.fun_in_sgl local.pm1.functionality_lem local.s0s1 local.src1_absorb local.ssmsg0.sts_msg.st_local local.stmsg1.sts_msg.st_local local.t0t1 local.tgt0_absorb local.tgt1_absorb multimagma.conv_atom stmsg0.tgt_comp_aux stmsg0.tgt_twisted_aux subset_singleton_iff)

lemma comp0_comm: "x \<odot>\<^sub>0 y = y \<odot>\<^sub>0 x"
  apply safe
  apply (smt (verit, best) comp_collapse empty_iff insert_eq_iff local.interchange local.pm0.fun_in_sgl local.s0t0 local.ssmsg0.sts_msg.st_local local.tgt0_absorb multimagma.conv_atom singleton_insert_inj_eq' stmsg0.src_twisted_aux stmsg0.tgt_twisted_aux)
  by (smt (verit, best) comp_collapse local.Dst0 local.interchange local.s0t0 local.stmsg0.ts_msg.src_comp_aux local.stmsg0.ts_msg.tgt_twisted_aux local.tgt0_absorb multimagma.conv_atom stmsg0.tgt_twisted_aux subsetD)

lemma comp1_comm: "x \<odot>\<^sub>1 y = y \<odot>\<^sub>1 x"
  using comp0_comm comp_collapse by auto

lemma "\<sigma>\<^sub>0 x = x"
  nitpick
  oops

lemma "\<sigma>\<^sub>0 x = \<sigma>\<^sub>0 y"
  nitpick
  oops

lemma "x \<odot>\<^sub>0 y \<noteq> {}"
  nitpick
  oops

lemma "x \<odot>\<^sub>1 y \<noteq> {}"
  nitpick
  oops

end

subsection \<open>2-lr-Multimagmas with strong interchange law\<close>

class two_lr_multimagma_bad = st_multimagma0 + st_multimagma1 +
  assumes comm_s0s1: "\<sigma>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<sigma>\<^sub>0 x)"
  and comm_t0t1: "\<tau>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<tau>\<^sub>0 x)"
  and comm_s0t1: "\<sigma>\<^sub>0 (\<tau>\<^sub>1 x) = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
  and comm_t0s1: "\<tau>\<^sub>0 (\<sigma>\<^sub>1 x) = \<sigma>\<^sub>1 (\<tau>\<^sub>0 x)"
  assumes interchange: "(w \<odot>\<^sub>1 x) *\<^sub>0 (y \<odot>\<^sub>1 z) = (w \<odot>\<^sub>0 y) *\<^sub>1 (x \<odot>\<^sub>0 z)" (* this is too strong *)
  and t0_hom: "Tgt\<^sub>0 (x \<odot>\<^sub>1 y) = \<tau>\<^sub>0 x \<odot>\<^sub>1 \<tau>\<^sub>0 y"
  and t1_hom: "Tgt\<^sub>1 (x \<odot>\<^sub>0 y) = \<tau>\<^sub>1 x \<odot>\<^sub>0 \<tau>\<^sub>1 y"
  and s0_hom: "Src\<^sub>0 (x \<odot>\<^sub>1 y) \<subseteq> \<sigma>\<^sub>0 x \<odot>\<^sub>1 \<sigma>\<^sub>0 y"
  and s1_hom: "Src\<^sub>1 (x \<odot>\<^sub>0 y) \<subseteq> \<sigma>\<^sub>1 x \<odot>\<^sub>0 \<sigma>\<^sub>1 y"
  and s1_s0 [simp]: "\<sigma>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  and t1_s0 [simp]: "\<tau>\<^sub>1 (\<sigma>\<^sub>0 x) = \<sigma>\<^sub>0 x"
  and s1_t0 [simp]: "\<sigma>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"
  and t1_t0 [simp]: "\<tau>\<^sub>1 (\<tau>\<^sub>0 x) = \<tau>\<^sub>0 x"

begin

text \<open>The source and target structure collapses.\<close>

lemma s0s1: "\<sigma>\<^sub>0 x = \<sigma>\<^sub>1 x"
  by (metis image_empty local.comm_s0s1 local.s1_s0 local.stmm0.stopp.st_fix local.stmm0.stopp.ts_compat local.t0_hom stmm1.s_absorb_var3)

lemma t0t1: "\<tau>\<^sub>0 x = \<tau>\<^sub>1 x"
  using local.comm_s0t1 local.comm_t0s1 local.s0s1 stmm0.ts_compat by auto

lemma s0t0: "\<sigma>\<^sub>0 x = \<tau>\<^sub>0 x"
proof-
  have "\<sigma>\<^sub>0 x = \<tau>\<^sub>1 (\<sigma>\<^sub>0 x)"
    by simp
  also have "\<dots> = \<sigma>\<^sub>0 (\<tau>\<^sub>1 x)"
    by (simp add: local.comm_s0t1)
  also have "\<dots> = \<sigma>\<^sub>0 (\<tau>\<^sub>0 x)"
    by (simp add: local.t0t1)
  also have "\<dots> = \<tau>\<^sub>0 x "
    by simp
  finally show ?thesis.
qed

lemma s1t1: "\<sigma>\<^sub>1 x = \<tau>\<^sub>1 x"
  using local.comm_t0s1 local.t0t1 by force

lemma comp_collapse: "x \<odot>\<^sub>0 y = x \<odot>\<^sub>1 y"
  by (metis (no_types, opaque_lifting) local.interchange local.s0s1 local.src0_absorb local.src1_absorb local.stmm0.stopp.Dst local.stmm1.stopp.Dst local.t0t1 local.tgt0_absorb local.tgt1_absorb multimagma.conv_atom)

lemma comp0_comm: "x \<odot>\<^sub>0 y = y \<odot>\<^sub>0 x"
  by (metis local.comp_collapse local.interchange local.mm0.conv_atom local.s0s1 local.s1t1 local.src0_absorb local.tgt1_absorb stmm1.t_comm)

lemma comp1_comm: "x \<odot>\<^sub>1 y = y \<odot>\<^sub>1 x"
  using local.comp0_comm local.comp_collapse by auto

lemma comp0_assoc: "{x} *\<^sub>0 (y \<odot>\<^sub>0 z) = (x \<odot>\<^sub>0 y) *\<^sub>0 {z}"
  by (smt (z3) local.comp_collapse local.interchange local.s1t1 local.src1_absorb local.stmm0.stopp.Dst local.stmm0.stopp.s_assoc local.stmm1.stopp.conv_atom local.t0t1 local.t1_t0 local.tgt1_absorb)

lemma comp1_assoc: "{x} *\<^sub>1 (y \<odot>\<^sub>1 z) = (x \<odot>\<^sub>1 y) *\<^sub>1 {z}"
  by (metis (full_types) local.comp0_assoc local.comp1_comm local.comp_collapse local.interchange local.tgt1_absorb)

lemma "\<sigma>\<^sub>0 x = x"
  nitpick
  oops

lemma "\<sigma>\<^sub>0 x = \<sigma>\<^sub>0 y"
  nitpick
  oops

lemma "x \<odot>\<^sub>0 y \<noteq> {}"
  nitpick
  oops

lemma "x \<in> y \<odot>\<^sub>0 z \<Longrightarrow> x' \<in> y \<odot>\<^sub>0 z \<Longrightarrow> x = x'"
  nitpick
  oops

lemma "x \<odot>\<^sub>1 y \<noteq> {}"
  nitpick
  oops

lemma "x \<in> y \<odot>\<^sub>1 z \<Longrightarrow> x' \<in> y \<odot>\<^sub>1 z \<Longrightarrow> x = x'"
  nitpick
  oops

end

end


theory FP32
imports
  IEEE_Floating_Point.IEEE
  Word_Lib.Word_32
begin

(*
  this file is essentially a version of FP64 with all
  bit lengths adjusted for 32 bits
*)

section \<open>Concrete encodings\<close>

text \<open>Floating point operations defined as operations on words.
  Called ''fixed precision'' (fp) word in HOL4.\<close>

type_synonym float32 = "(8,23)float"
type_synonym fp32 = "32 word"

lift_definition fp32_of_float :: "float32 \<Rightarrow> fp32" is
  "\<lambda>(s::1 word, e::8 word, f::23 word). word_cat s (word_cat e f::31 word)" .

lift_definition float_of_fp32 :: "fp32 \<Rightarrow> float32" is
  "\<lambda>x. apsnd word_split (word_split x::1 word * 31 word)" .

definition "rel_fp32 \<equiv> (\<lambda>x (y::word32). x = float_of_fp32 y)"

definition eq_fp32::"float32 \<Rightarrow> float32 \<Rightarrow> bool" where [simp]: "eq_fp32 \<equiv> (=)"

lemma float_of_fp32_inverse[simp]: "fp32_of_float (float_of_fp32 a) = a"
  by (auto
      simp: fp32_of_float_def float_of_fp32_def Abs_float_inverse apsnd_def map_prod_def word_size
      dest!: word_cat_split_alt[rotated]
      split: prod.splits)

lemma float_of_fp32_inj_iff[simp]: "fp32_of_float r = fp32_of_float s \<longleftrightarrow> r = s"
  using Rep_float_inject
  by (force simp: fp32_of_float_def word_cat_inj word_size split: prod.splits)

lemma fp32_of_float_inverse[simp]: "float_of_fp32 (fp32_of_float a) = a"
  using float_of_fp32_inj_iff float_of_fp32_inverse by blast

lemma Quotientfp: "Quotient eq_fp32 fp32_of_float float_of_fp32 rel_fp32"
  \<comment>\<open>\<^term>\<open>eq_fp32\<close> is a workaround to prevent a (failing -- TODO: why?)
      code setup in \<open>setup_lifting\<close>.\<close>
  by (force intro!: QuotientI simp: rel_fp32_def)

setup_lifting Quotientfp

lift_definition fp32_lessThan::"fp32 \<Rightarrow> fp32 \<Rightarrow> bool" is
  "flt::float32\<Rightarrow>float32\<Rightarrow>bool" by simp

lift_definition fp32_lessEqual::"fp32 \<Rightarrow> fp32 \<Rightarrow> bool" is
  "fle::float32\<Rightarrow>float32\<Rightarrow>bool" by simp

lift_definition fp32_greaterThan::"fp32 \<Rightarrow> fp32 \<Rightarrow> bool" is
  "fgt::float32\<Rightarrow>float32\<Rightarrow>bool" by simp

lift_definition fp32_greaterEqual::"fp32 \<Rightarrow> fp32 \<Rightarrow> bool" is
  "fge::float32\<Rightarrow>float32\<Rightarrow>bool" by simp

lift_definition fp32_equal::"fp32 \<Rightarrow> fp32 \<Rightarrow> bool" is
  "feq::float32\<Rightarrow>float32\<Rightarrow>bool" by simp

lift_definition fp32_abs::"fp32 \<Rightarrow> fp32" is
  "abs::float32\<Rightarrow>float32" by simp

lift_definition fp32_negate::"fp32 \<Rightarrow> fp32" is
  "uminus::float32\<Rightarrow>float32" by simp

lift_definition fp32_sqrt::"roundmode \<Rightarrow> fp32 \<Rightarrow> fp32" is
  "fsqrt::roundmode\<Rightarrow>float32\<Rightarrow>float32" by simp

lift_definition fp32_add::"roundmode \<Rightarrow> fp32 \<Rightarrow> fp32 \<Rightarrow> fp32" is
  "fadd::roundmode\<Rightarrow>float32\<Rightarrow>float32\<Rightarrow>float32" by simp

lift_definition fp32_sub::"roundmode \<Rightarrow> fp32 \<Rightarrow> fp32 \<Rightarrow> fp32" is
  "fsub::roundmode\<Rightarrow>float32\<Rightarrow>float32\<Rightarrow>float32" by simp

lift_definition fp32_mul::"roundmode \<Rightarrow> fp32 \<Rightarrow> fp32 \<Rightarrow> fp32" is
  "fmul::roundmode\<Rightarrow>float32\<Rightarrow>float32\<Rightarrow>float32" by simp

lift_definition fp32_div::"roundmode \<Rightarrow> fp32 \<Rightarrow> fp32 \<Rightarrow> fp32" is
  "fdiv::roundmode\<Rightarrow>float32\<Rightarrow>float32\<Rightarrow>float32" by simp

lift_definition fp32_mul_add::"roundmode \<Rightarrow> fp32 \<Rightarrow> fp32 \<Rightarrow> fp32 \<Rightarrow> fp32" is
  "fmul_add::roundmode\<Rightarrow>float32\<Rightarrow>float32\<Rightarrow>float32\<Rightarrow>float32" by simp

end


section\<open>Separative notions and proper extensions\<close>
theory Proper_Extension
  imports
    Names

begin

text\<open>The key ingredient to obtain a proper extension is to have
a \<^emph>\<open>separative preorder\<close>:\<close>

locale separative_notion = forcing_notion +
  assumes separative: "p\<in>P \<Longrightarrow> \<exists>q\<in>P. \<exists>r\<in>P. q \<preceq> p \<and> r \<preceq> p \<and> q \<bottom> r"
begin

text\<open>For separative preorders, the complement of every filter is
dense. Hence an $M$-generic filter can't belong to the ground model.\<close>

lemma filter_complement_dense:
  assumes "filter(G)" shows "dense(P - G)"
proof
  fix p
  assume "p\<in>P"
  show "\<exists>d\<in>P - G. d \<preceq> p"
  proof (cases "p\<in>G")
    case True
    note \<open>p\<in>P\<close> assms
    moreover
    obtain q r where "q \<preceq> p" "r \<preceq> p" "q \<bottom> r" "q\<in>P" "r\<in>P"
      using separative[OF \<open>p\<in>P\<close>]
      by force
    with \<open>filter(G)\<close>
    obtain s where "s \<preceq> p" "s \<notin> G" "s \<in> P"
      using filter_imp_compat[of G q r]
      by auto
    then
    show ?thesis by blast
  next
    case False
    with \<open>p\<in>P\<close>
    show ?thesis using leq_reflI unfolding Diff_def by auto
  qed
qed

end (* separative_notion *)

locale ctm_separative = forcing_data + separative_notion
begin

lemma generic_not_in_M: assumes "M_generic(G)"  shows "G \<notin> M"
proof
  assume "G\<in>M"
  then
  have "P - G \<in> M"
    using P_in_M Diff_closed by simp
  moreover
  have "\<not>(\<exists>q\<in>G. q \<in> P - G)" "(P - G) \<subseteq> P"
    unfolding Diff_def by auto
  moreover
  note assms
  ultimately
  show "False"
    using filter_complement_dense[of G] M_generic_denseD[of G "P-G"]
      M_generic_def by simp \<comment> \<open>need to put generic ==> filter in claset\<close>
qed

theorem proper_extension: assumes "M_generic(G)" shows "M \<noteq> M[G]"
  using assms G_in_Gen_Ext[of G] one_in_G[of G] generic_not_in_M
  by force

end (* ctm_separative *)

end


theory RepeatShallow
  imports Main
begin

section "Repeat"

fun repeatatm :: "nat \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a"
  where
"repeatatm 0 _ _ acc _ = acc" |
"repeatatm (Suc n) f g acc obsv = (if f acc obsv then acc else repeatatm n f g (g acc obsv) obsv)"

declare repeatatm.simps[simp del]

subsection "Step and early termination lemmas"

lemma repeatatm_step_stop_Suc:
  "f (repeatatm n f g a b) b
    \<Longrightarrow> repeatatm (Suc n) f g a b = repeatatm n f g a b"
  apply (induct n arbitrary: a)
   apply (simp add: repeatatm.simps)
  apply (subst repeatatm.simps)
  apply clarsimp
  apply (rule conjI, simp add: repeatatm.simps, clarsimp)
  apply (rule sym)
  apply (subst repeatatm.simps)
  apply clarsimp
  apply (rotate_tac 1, subst (asm) repeatatm.simps)
  apply clarsimp
  done

lemma repeatatm_step:
  "\<not>f (repeatatm n f g a b) b
    \<Longrightarrow> repeatatm (Suc n) f g a b = g (repeatatm n f g a b) b"
  apply (induct n arbitrary: a)
   apply (simp add: repeatatm.simps)
  apply (subst repeatatm.simps)
  apply clarsimp
  apply (rule conjI, simp add: repeatatm.simps, clarsimp, clarsimp)
  apply (rule sym)
  apply (subst repeatatm.simps)
  apply clarsimp
  apply (rotate_tac 1, subst (asm) repeatatm.simps)
  apply clarsimp
  done

lemma repeatatm_stop_Suc:
  "\<lbrakk>f (repeatatm n f g a b) b\<rbrakk> \<Longrightarrow> f (repeatatm (Suc n) f g a b) b"
  apply (induct n arbitrary: a)
   apply (simp add: repeatatm.simps)
  apply (subst repeatatm.simps)
  apply clarsimp
  apply (rotate_tac 1, subst (asm) repeatatm.simps)
  apply clarsimp
  done

lemma repeatatm_stop:
  "\<lbrakk>f (repeatatm n f g a b) b; n \<le> m\<rbrakk> \<Longrightarrow> f (repeatatm m f g a b) b"
  apply (induct m arbitrary: a n)
   apply simp
  apply (case_tac "n < Suc m")
   apply (rule_tac f = f in repeatatm_stop_Suc)
   apply clarsimp
  apply clarsimp
  done

lemma repeatatm_step_stop:
  "\<lbrakk>f (repeatatm n f g a b) b; n \<le> m\<rbrakk> \<Longrightarrow> repeatatm m f g a b = repeatatm n f g a b"
  apply (induct m arbitrary: a n)
   apply simp
  apply (case_tac "n < Suc m")
   apply (subst repeatatm_step_stop_Suc)
    apply clarsimp
   apply clarsimp
  apply clarsimp
  done

lemma repeatatm_not_stop_Suc:
  "\<not>f (repeatatm (Suc n) f g a b) b \<Longrightarrow> \<not>f (repeatatm n f g a b) b"
  apply (rule_tac Q = "f (repeatatm (Suc n) f g a b) b" in  contrapos_nn; simp)
  apply (cut_tac n = n and f = f and g = g and a = a and b = b in repeatatm_stop_Suc; simp)
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3acc_assoc2
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc (add3acc x1 x2 x3) x4 x5) =
      (add3acc x1 (add3acc x2 x3 x4) x5))"
  oops

end


theory prop_01
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun double :: "Nat => Nat" where
  "double (Z) = Z"
  | "double (S y) = S (S (double y))"
  (*hipster plus double *)

lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_aa [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

(*hipster double plus*)
  theorem x0 :
    "(double x) = (plus x x)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory L2_rec
  imports RTC
begin

section \<open>Syntax\<close>

text \<open>Lambda terms are represented by De Brujin index\<close>

type_synonym loc = nat

datatype type =
  Unit |
  Num |
  Bool |
  Fn type type (infix "\<rightarrow>" 70)

datatype type_loc = Numref

datatype binop = Plus (".+") | Geq (".\<ge>")

datatype exp =
  Skip ("skip") |
  Number int ("#_" [100] 100) |
  Boolean bool ("$_" [100] 100) |
  Binop exp binop exp ("_ _. _" [65, 1000, 65] 65) |
  Seq exp exp (infixr ";" 65) |
  Cond exp exp exp ("if _ then _ else _ fi" [50, 50, 50] 65) |
  While exp exp ("while _ do _ od" [50, 50] 65) |
  Deref loc ("!l_" [100] 100) |
  Assign loc exp ("l_ := _" [0, 65] 65) |
  Var nat ("`_" [100] 100) |
  App exp exp ("_\<^sup>._" [65, 65] 65) |
  Abs type exp ("fn _ \<Rightarrow> _" [50, 65] 65) |
  LetRec type type exp exp ("let rec _ \<Rightarrow> _  = _ in _ end" [50, 50, 65, 65] 65)

abbreviation true :: exp where "true \<equiv> $True"

abbreviation false :: exp where "false \<equiv> $False"

section \<open>Substitution\<close>

fun lift :: "exp \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> exp" ("_\<up>\<^sub>_\<^sup>_" [50, 55, 55] 50) where
  "skip\<up>\<^sub>n\<^sup>k        = skip" |
  "#m\<up>\<^sub>n\<^sup>k          = #m" |
  "$b\<up>\<^sub>n\<^sup>k          = $b" |
  "`i\<up>\<^sub>n\<^sup>k          = `(if i < k then i else i+n)" |
  "(e1 bop. e2)\<up>\<^sub>n\<^sup>k= (e1\<up>\<^sub>n\<^sup>k) bop. (e2\<up>\<^sub>n\<^sup>k)" |
  "(e1; e2)\<up>\<^sub>n\<^sup>k    = (e1\<up>\<^sub>n\<^sup>k); (e2\<up>\<^sub>n\<^sup>k)" |
  "(if e1 then e2 else e3 fi)\<up>\<^sub>n\<^sup>k =
    if e1\<up>\<^sub>n\<^sup>k then e2\<up>\<^sub>n\<^sup>k else e3\<up>\<^sub>n\<^sup>k fi" |
  "(while e1 do e2 od)\<up>\<^sub>n\<^sup>k =
    while e1\<up>\<^sub>n\<^sup>k do e2\<up>\<^sub>n\<^sup>k od" |
  "!l(i)\<up>\<^sub>n\<^sup>k       = !l(i)" |
  "(l(i):=e)\<up>\<^sub>n\<^sup>k   = l(i):=(e\<up>\<^sub>n\<^sup>k)" |
  "(e1\<^sup>.e2)\<up>\<^sub>n\<^sup>k     = (e1\<up>\<^sub>n\<^sup>k)\<^sup>.(e2\<up>\<^sub>n\<^sup>k)" |
  "(fn T \<Rightarrow> e)\<up>\<^sub>n\<^sup>k = fn T \<Rightarrow> (e\<up>\<^sub>n\<^sup>k+1)" |
  "(let rec T1 \<Rightarrow> T2 = e1 in e2 end)\<up>\<^sub>n\<^sup>k =
    let rec T1 \<Rightarrow> T2 = (e1\<up>\<^sub>n\<^sup>k+2) in (e2\<up>\<^sub>n\<^sup>k+1) end"

fun subst :: "exp \<Rightarrow> nat \<Rightarrow> exp \<Rightarrow> exp" ("_[_::=_]" [65, 50, 50] 65) where
  "skip[k::=N]        = skip" |
  "#n[k::=N]          = #n" |
  "$b[k::=N]          = $b" |
  "`i[k::=N]          = (if i < k then `i else
                        if i = k then N else
                        `(i-1))" |
  "(e1 bop. e2)[k::=N]      = (e1[k::=N]) bop. (e2[k::=N])" |
  "(e1;e2)[k::=N]      = (e1[k::=N]);(e2[k::=N])" |
  "if e1 then e2 else e3 fi [k::=N] =
    if e1[k::=N] then e2[k::=N] else e3[k::=N] fi" |
  "while e1 do e2 od [k::=N] = while e1[k::=N] do e2[k::=N] od" |
  "!l(i)[k::=N]        = !l(i)" |
  "(l(i):=e)[k::=N]   = l(i):=(e[k::=N])" |
  "(e1\<^sup>.e2)[k::=N]     = (e1[k::=N])\<^sup>.(e2[k::=N])" |
  "(fn T \<Rightarrow> e)[k::=N] = fn T \<Rightarrow> (e[k+1 ::= N\<up>\<^sub>1\<^sup>0])" |
  "(let rec T1 \<Rightarrow> T2 = e1 in e2 end)[k::=N] =
      let rec T1 \<Rightarrow> T2 = (e1[k+2 ::= N\<up>\<^sub>2\<^sup>0]) in (e2[k+1 ::= N\<up>\<^sub>1\<^sup>0]) end"

fun closed_at :: "exp \<Rightarrow> nat \<Rightarrow> bool" where
  "closed_at skip _        = True" |
  "closed_at (#_) _        = True" |
  "closed_at ($_) _        = True" |
  "closed_at (`x) n        = (x < n)" |
  "closed_at (e1 bop. e2) n= (closed_at e1 n \<and> closed_at e2 n)" |
  "closed_at (e1;e2) n     = (closed_at e1 n \<and> closed_at e2 n)" |
  "closed_at (if e1 then e2 else e3 fi) n =
      (closed_at e1 n \<and> closed_at e2 n \<and> closed_at e3 n)" |
  "closed_at (while e1 do e2 od) n = (closed_at e1 n \<and> closed_at e2 n)" |
  "closed_at (!l_) _       = True" |
  "closed_at (l(i):=e) n   = closed_at e n" |
  "closed_at (fn _ \<Rightarrow> e) n = closed_at e (n+1)" |
  "closed_at (e1\<^sup>.e2) n     = (closed_at e1 n \<and> closed_at e2 n)" |
  "closed_at (let rec T1 \<Rightarrow> T2 = e1 in e2 end) n =
      (closed_at e1 n \<and> closed_at e2 n)"

abbreviation closed :: "exp \<Rightarrow> bool" where
  "closed e \<equiv> closed_at e 0"

section \<open>Operational semantics\<close>

fun is_value :: "exp \<Rightarrow> bool" where
  "is_value skip = True" |
  "is_value (#_) = True" |
  "is_value ($_) = True" |
  "is_value (fn _ \<Rightarrow> _) = True" |
  "is_value _ = False"

type_synonym store = "loc \<Rightarrow> int option"

inductive sem :: "exp \<times> store \<Rightarrow> exp \<times> store \<Rightarrow> bool" (infix "\<Rightarrow>" 50) where
  "(skip; e2, s) \<Rightarrow> (e2, s)" |
  "(#n1 .+. #n2, s) \<Rightarrow> (#(n1 + n2), s)" |
  "(#n1 .\<ge>. #n2, s) \<Rightarrow> ($(n1 \<ge> n2), s)" |
  "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (e1 bop. e2, s) \<Rightarrow> (e1' bop. e2, s')" |
  "is_value v \<Longrightarrow> (e2, s) \<Rightarrow> (e2', s') \<Longrightarrow> (v bop. e2, s) \<Rightarrow> (v bop. e2', s')" |
  "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (e1; e2, s) \<Rightarrow> (e1'; e2, s')" |
  "(if true then e2 else e3 fi, s) \<Rightarrow> (e2, s)" |
  "(if false then e2 else e3 fi, s) \<Rightarrow> (e3, s)" |
  "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (if e1 then e2 else e3 fi, s) \<Rightarrow>
    (if e1' then e2 else e3 fi, s')" |
  "(while e1 do e2 od, s) \<Rightarrow> (if e1 then (e2; while e1 do e2 od) else skip fi, s)" |
  "i \<in> dom s \<Longrightarrow> s i = Some n \<Longrightarrow> (!li, s) \<Rightarrow> (#n, s)" |
  "i \<in> dom s \<Longrightarrow> (l(i) := #n, s) \<Rightarrow> (skip, s(i \<mapsto> n))" |
  "(e, s) \<Rightarrow> (e', s') \<Longrightarrow> (l(i) := e, s) \<Rightarrow> (l(i) := e', s')" |
  "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (e1\<^sup>.e2, s) \<Rightarrow> (e1'\<^sup>.e2, s')" |
  "is_value v \<Longrightarrow> (e2, s) \<Rightarrow> (e2', s') \<Longrightarrow> (v\<^sup>.e2, s) \<Rightarrow> (v\<^sup>.e2', s')" |
  "is_value v \<Longrightarrow> ((fn T \<Rightarrow> e)\<^sup>.v, s) \<Rightarrow> (e[0 ::= v], s)" |
  "(let rec T1 \<Rightarrow> T2 = e1 in e2 end, s) \<Rightarrow>
    (e2[0 ::= fn T1 \<Rightarrow> (let rec T1 \<Rightarrow> T2 = e1 in e2 end)], s)"

declare sem.intros[intro!]

inductive_cases sem_elims [elim!]:
  "(skip, s) \<Rightarrow> (e', s')"
  "(#x, s) \<Rightarrow> (e', s')"
  "($x, s) \<Rightarrow> (e', s')"
  "(e1 .+. e2, s) \<Rightarrow> (e', s')"
  "(e1 .\<ge>. e2, s) \<Rightarrow> (e', s')"
  "(e1 bop. e2, s) \<Rightarrow> (e', s')"
  "(`x, s) \<Rightarrow> (e', s')"
  "(e1; e2, s) \<Rightarrow> (e', s')"
  "(if e1 then e2 else e3 fi, s) \<Rightarrow> (e', s')"
  "(while e1 do e2 od, s) \<Rightarrow> (e', s')"
  "(!l(i), s) \<Rightarrow> (e', s')"
  "(l(i) := e, s) \<Rightarrow> (e', s')"
  "(fn T \<Rightarrow> e, s) \<Rightarrow> (e', s')"
  "(e1\<^sup>.e2, s) \<Rightarrow> (e', s')"
  "(let rec T1 \<Rightarrow> T2 = e1 in e2 end, s) \<Rightarrow> (e', s')"

abbreviation sem_rtc :: "exp \<times> store \<Rightarrow> exp \<times> store \<Rightarrow> bool" (infix "\<Rightarrow>\<^sup>*" 50) where
  "\<sigma> \<Rightarrow>\<^sup>* \<sigma>' \<equiv> rtc sem \<sigma> \<sigma>'"

section \<open>Type environment\<close>

definition
  shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"  ("_\<langle>_:_\<rangle>" [90, 0, 0] 91) where
  "\<Gamma>\<langle>i:a\<rangle> = (\<lambda>j. if j < i then \<Gamma> j else if j = i then a else \<Gamma> (j - 1))"

lemma shift_gt [simp]: "j < i \<Longrightarrow> (\<Gamma>\<langle>i:T\<rangle>) j = \<Gamma> j"
  by (simp add: shift_def)

lemma shift_lt [simp]: "i < j \<Longrightarrow> (\<Gamma>\<langle>i:T\<rangle>) j = \<Gamma> (j - 1)"
  by (simp add: shift_def)

lemma shift_commute [simp]: "\<Gamma>\<langle>i:U\<rangle>\<langle>0:T\<rangle> = \<Gamma>\<langle>0:T\<rangle>\<langle>Suc i:U\<rangle>"
  by (rule ext) (simp_all add: shift_def split: nat.split, force)

section \<open>Typing\<close>

type_synonym type_env = "(nat \<Rightarrow> type) \<times> (nat \<Rightarrow> type_loc option)"

inductive typing :: "(nat \<Rightarrow> type) \<Rightarrow> (nat \<Rightarrow> type_loc option) \<Rightarrow> exp \<Rightarrow> type \<Rightarrow> bool" ("_, _ \<turnstile> _ : _" [50, 50, 50] 50) where
  "\<Gamma>, \<Delta> \<turnstile> skip : Unit" |
  "\<Gamma>, \<Delta> \<turnstile> #n : Num" |
  "\<Gamma>, \<Delta> \<turnstile> $b : Bool" |
  "\<Gamma>, \<Delta> \<turnstile> e1 : Num \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e2 : Num \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e1 .+. e2 : Num" |
  "\<Gamma>, \<Delta> \<turnstile> e1 : Num \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e2 : Num \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e1 .\<ge>. e2 : Bool" |
  "\<Gamma>, \<Delta> \<turnstile> e1 : Unit \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e2 : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e1; e2 : T" |
  "\<Gamma>, \<Delta> \<turnstile> e1 : Bool \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e2 : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e3 : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> if e1 then e2 else e3 fi : T" |
  "\<Gamma>, \<Delta> \<turnstile> e1 : Bool \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e2 : Unit \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> while e1 do e2 od : Unit" |
  "\<Delta> i = Some Numref \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> !l(i) : Num" |
  "\<Delta> i = Some Numref \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e : Num \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> l(i) := e : Unit" |
  "\<Gamma> n = T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> `n : T" |
  "\<Gamma>\<langle>0:T\<rangle>, \<Delta> \<turnstile> e : T' \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> fn T \<Rightarrow> e : T \<rightarrow> T'" |
  "\<Gamma>, \<Delta> \<turnstile> e1 : T \<rightarrow> T' \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> e2 : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>e1\<^sup>.e2 : T'" |
  "\<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>\<langle>1:T1\<rangle>, \<Delta> \<turnstile> e1 : T2 \<Longrightarrow> \<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>, \<Delta> \<turnstile> e2 : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> let rec T1 \<Rightarrow> T2 = e1 in e2 end : T"

declare typing.intros[intro!]

inductive_cases typing_elims[elim!]:
  "\<Gamma>, \<Delta> \<turnstile> skip : T"
  "\<Gamma>, \<Delta> \<turnstile> #x : T"
  "\<Gamma>, \<Delta> \<turnstile> $x : T"
  "\<Gamma>, \<Delta> \<turnstile> `x : T"
  "\<Gamma>, \<Delta> \<turnstile> e1 .+. e2 : T"
  "\<Gamma>, \<Delta> \<turnstile> e1 .\<ge>. e2 : T"
  "\<Gamma>, \<Delta> \<turnstile> e1; e2 : T"
  "\<Gamma>, \<Delta> \<turnstile> if e1 then e2 else e3 fi : T"
  "\<Gamma>, \<Delta> \<turnstile> while e1 do e2 od : T"
  "\<Gamma>, \<Delta> \<turnstile> !l(i) : T"
  "\<Gamma>, \<Delta> \<turnstile> l(i) := e : T"
  "\<Gamma>, \<Delta> \<turnstile> fn T \<Rightarrow> e : T'"
  "\<Gamma>, \<Delta> \<turnstile> e1\<^sup>.e2: T"
  "\<Gamma>, \<Delta> \<turnstile> let rec T1 \<Rightarrow> T2 = e1 in e2 end: T"

section \<open>Let constructor\<close>

definition LetVal :: "type \<Rightarrow> exp \<Rightarrow> exp \<Rightarrow> exp" ("let val _ = _ in _ end" [50, 65, 65] 65)  where
  "LetVal T e1 e2 \<equiv> App (Abs T e2) e1"

lemma type_let: "\<Gamma>, \<Delta> \<turnstile> e1 : T \<Longrightarrow> \<Gamma>\<langle>0:T\<rangle>, \<Delta> \<turnstile> e2 : T' \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile> let val T = e1 in e2 end : T'"
  by (auto simp: LetVal_def)

lemma sem_let1: "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (let val T = e1 in e2 end, s) \<Rightarrow> (let val T = e1' in e2 end, s')"
  by (auto simp: LetVal_def)

lemma sem_let2: "is_value v \<Longrightarrow> (let val T = v in e end, s) \<Rightarrow> (e[0 ::= v], s)"
  by (auto simp: LetVal_def)

section \<open>Properties about L2\<close>

lemma subst_appI: "is_value v \<Longrightarrow> e2 = e[0 ::= v] \<Longrightarrow> ((fn T \<Rightarrow> e)\<^sup>.v, s) \<Rightarrow> (e2, s)"
  by auto

lemma [dest]: "is_value e \<Longrightarrow> \<forall>s. \<not> (\<exists>e' s'. (e, s) \<Rightarrow> (e', s'))"
  by (induct e, auto)

theorem determinacy:
  assumes "(e, s) \<Rightarrow> (e1, s1)" "(e, s) \<Rightarrow> (e2, s2)"
  shows "(e1, s1) = (e2, s2)"
  using assms by (induction arbitrary: e2 rule: sem.induct; (blast | clarsimp))

lemma lift_up: "e\<up>\<^sub>n\<^sup>k = e \<Longrightarrow> lift e n (Suc k) = e"
  by (induct arbitrary: n k rule: lift.induct) auto

lemma shift_lift1 [intro!]: "\<Gamma>, \<Delta> \<turnstile> e : T \<Longrightarrow> \<Gamma>\<langle>i:U\<rangle>, \<Delta> \<turnstile> e\<up>\<^sub>1\<^sup>i : T"
  by (induct arbitrary: i rule: typing.induct)  (auto, metis shift_commute)

lemma shift_lift2 [intro!]: "\<Gamma>, \<Delta> \<turnstile> e : T \<Longrightarrow> \<Gamma>\<langle>i:U\<rangle>\<langle>Suc i:S\<rangle>, \<Delta> \<turnstile> e\<up>\<^sub>2\<^sup>i : T"
  by (induct arbitrary: i rule: typing.induct) (auto, metis shift_commute)

theorem subst_lemma [intro]:
  assumes "\<Gamma>, \<Delta>  \<turnstile> e : T" "\<Gamma>', \<Delta> \<turnstile> e' : T'" "\<Gamma>  = \<Gamma>'\<langle>i:T'\<rangle>"
  shows   "\<Gamma>', \<Delta> \<turnstile> e[i ::= e'] : T"
using assms proof (induct arbitrary: \<Gamma>' i e' rule: typing.induct)
  fix \<Gamma> T1 T2 \<Delta> e1 e2 T \<Gamma>' i e'
  assume "\<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>\<langle>1:T1\<rangle>, \<Delta> \<turnstile> e1 : T2" "\<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>, \<Delta> \<turnstile> e2 : T"
         "(\<And>\<Gamma>' i e'. \<Gamma>', \<Delta> \<turnstile> e' : T' \<Longrightarrow> \<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>\<langle>1:T1\<rangle> = \<Gamma>'\<langle>i:T'\<rangle> \<Longrightarrow> \<Gamma>', \<Delta> \<turnstile> e1[i::=e'] : T2)"
         "(\<And>\<Gamma>' i e'. \<Gamma>', \<Delta> \<turnstile> e' : T' \<Longrightarrow> \<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle> = \<Gamma>'\<langle>i:T'\<rangle> \<Longrightarrow> \<Gamma>', \<Delta> \<turnstile> e2[i::=e'] : T)"
         "\<Gamma>', \<Delta> \<turnstile> e' : T'" "\<Gamma> = \<Gamma>'\<langle>i:T'\<rangle>"
  thus   "\<Gamma>', \<Delta> \<turnstile> let rec T1 \<Rightarrow> T2  = e1 in e2 end[i::=e'] : T"
    apply clarsimp
    apply (rule typing.intros, clarsimp)
    apply (metis shift_lift2 shift_commute)
    apply (metis One_nat_def shift_lift1)
  done
qed force+

lemma preserv_letrec [dest]:
  assumes "\<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>\<langle>1:T1\<rangle>, \<Delta> \<turnstile> e1 : T2" "\<Gamma>\<langle>0:T1 \<rightarrow> T2\<rangle>, \<Delta> \<turnstile> e2 : T"
          "(let rec T1 \<Rightarrow> T2 = e1 in e2 end, s) \<Rightarrow> (e', s)"
  shows   "\<Gamma>, \<Delta> \<turnstile> e' : T"
sorry

lemma preservation:
  assumes "\<Gamma>, \<Delta> \<turnstile> e : T" "(e, s) \<Rightarrow> (e', s')"
  shows   "\<Gamma>, \<Delta> \<turnstile> e' : T"
  using assms by (induction arbitrary: e' rule: typing.induct) (erule sem_elims; blast)+

lemma preserv_dom:
  assumes "\<Gamma>, \<Delta> \<turnstile> e : T" "(e, s) \<Rightarrow> (e', s')" "dom \<Delta> \<subseteq> dom s"
  shows   "dom \<Delta> \<subseteq> dom s'"
  using assms by (induction arbitrary: e' s  rule: typing.induct) ((erule sem_elims, simp) | blast)+

corollary pres_rtc:
  assumes "(e, s) \<Rightarrow>\<^sup>* (e', s')" "\<Gamma>, \<Delta> \<turnstile> e : T" "dom \<Delta> \<subseteq> dom s"
  shows   "\<Gamma>, \<Delta> \<turnstile> e' : T" "dom \<Delta> \<subseteq> dom s'"
  using assms by (induction rule: rtc_induct, simp+, (metis preservation preserv_dom)+)

lemma [dest]: "\<Gamma>, \<Delta> \<turnstile> e : Num \<Longrightarrow> is_value e \<Longrightarrow> \<exists>n. e = #n"
  by (induction e) auto

lemma [dest]: "\<Gamma>, \<Delta> \<turnstile> e : Bool \<Longrightarrow> is_value e \<Longrightarrow> \<exists>n. e = Boolean n"
  by (induction e) auto

lemma [dest]: "\<Gamma>, \<Delta> \<turnstile> e : Unit \<Longrightarrow> is_value e \<Longrightarrow> e = skip"
  by (induction e) auto

lemma [dest]: "\<Gamma>, \<Delta> \<turnstile> e : T \<rightarrow> T' \<Longrightarrow> is_value e \<Longrightarrow> \<exists>e'. e = fn T \<Rightarrow> e'"
  by (induct e, auto)

lemma [dest]: "\<Gamma>, \<Delta> \<turnstile> e1 : Bool \<Longrightarrow> is_value e1 \<Longrightarrow> \<exists>e' s'. (if e1 then e2 else e3 fi, s) \<Rightarrow> (e', s')"
  by (induct e1, auto) (case_tac x, auto)

lemma progress:
  assumes "\<Gamma>, \<Delta> \<turnstile> e : T" "closed e" "dom \<Delta> \<subseteq> dom s"
  shows   "is_value e \<or> (\<exists>e' s'. (e, s) \<Rightarrow> (e', s'))"
  using assms by (induction arbitrary: T rule: typing.induct) (blast | simp)+

corollary safety:
  assumes "\<Gamma>, \<Delta> \<turnstile> e : T" "(e, s) \<Rightarrow>\<^sup>* (e', s')"
          "closed e'" "dom \<Delta> \<subseteq> dom s"
  shows   "is_value e' \<or> (\<exists>e'' s''. (e', s') \<Rightarrow> (e'', s''))"
  by (metis assms pres_rtc progress)

theorem uniqueness:
  assumes "\<Gamma>, \<Delta> \<turnstile> e : T" "\<Gamma>, \<Delta> \<turnstile> e : T'"
  shows   "T = T'"
  using assms by (induction arbitrary: T' rule: typing.induct; blast)

end


section \<open>Completeness\<close>

theory Completeness
  imports Countermodel EPathHintikka
begin

text \<open>In this theory, we prove that the prover is complete with regards to the SeCaV proof system
  using the abstract completeness framework.\<close>

text \<open>We start out by specializing the abstract completeness theorem to our prover.
  It is necessary to reproduce the final theorem here so we can alter it to state that our prover
  produces a proof tree instead of simply stating that a proof tree exists.\<close>
theorem epath_prover_completeness:
  fixes A :: \<open>tm list\<close> and z :: \<open>fm list\<close>
  defines \<open>t \<equiv> secavProver (A, z)\<close>
  shows \<open>(fst (root t) = (A, z) \<and> wf t \<and> tfinite t) \<or>
    (\<exists> steps. fst (shd steps) = (A, z) \<and> epath steps \<and> Saturated steps)\<close>
    (is \<open>?A \<or> ?B\<close>)
proof -
  { assume \<open>\<not> ?A\<close>
    with assms have \<open>\<not> tfinite (mkTree rules (A, z))\<close>
      unfolding secavProver_def using wf_mkTree fair_rules by simp
    then obtain steps where \<open>ipath (mkTree rules (A, z)) steps\<close> using Konig by blast
    with assms have \<open>fst (shd steps) = (A, z) \<and> epath steps \<and> Saturated steps\<close>
      by (metis UNIV_I fair_rules ipath.cases ipath_mkTree_Saturated mkTree.simps(1) prod.sel(1)
          wf_ipath_epath wf_mkTree)
    then have ?B by blast
  }
  then show ?thesis by blast
qed

text \<open>This is an abbreviation for validity under our bounded semantics
  (for well-formed interpretations).\<close>
abbreviation
  \<open>uvalid z \<equiv> \<forall>u (e :: nat \<Rightarrow> tm) f g. is_env u e \<longrightarrow> is_fdenot u f \<longrightarrow>
    (\<exists>p \<in> set z. usemantics u e f g p)\<close>

text \<open>The sequent in the first state of a saturated escape path is not valid.
  This follows from our results in the theories EPathHintikka and Countermodel.\<close>
lemma epath_countermodel:
  assumes \<open>fst (shd steps) = (A, z)\<close> and \<open>epath steps\<close> and \<open>Saturated steps\<close>
  shows \<open>\<not> uvalid z\<close>
proof
  assume \<open>uvalid z\<close>
  moreover have \<open>Hintikka (tree_fms steps)\<close> (is \<open>Hintikka ?S\<close>)
    using assms escape_path_Hintikka assms by simp
  moreover have \<open>\<forall>p \<in> set z. p \<in> tree_fms steps\<close>
    using assms shd_sset by (metis Pair_inject prod.collapse pseq_def pseq_in_tree_fms)
  then have \<open>\<exists>g. \<forall>p \<in> set z. \<not> usemantics (terms ?S) (E ?S) (F ?S) g p\<close>
    using calculation(2) Hintikka_counter_model assms by blast
  moreover have \<open>is_env (terms ?S) (E ?S)\<close> \<open>is_fdenot (terms ?S) (F ?S)\<close>
    using is_env_E is_fdenot_F by blast+
  ultimately show False
    by blast
qed

text \<open>Combining the results above, we can prove completeness with regards to our bounded
  semantics: if a sequent is valid under our bounded semantics, the prover will produce a finite,
  well-formed proof tree with the sequent at its root.\<close>
theorem prover_completeness_usemantics:
  fixes A :: \<open>tm list\<close>
  assumes \<open>uvalid z\<close>
  defines \<open>t \<equiv> secavProver (A, z)\<close>
  shows \<open>fst (root t) = (A, z) \<and> wf t \<and> tfinite t\<close>
  using assms epath_prover_completeness epath_countermodel by blast

text \<open>Since our bounded semantics are sound, we can derive our main completeness theorem as
  a corollary: if a sequent is provable in the SeCaV proof system, the prover will produce a finite,
  well-formed proof tree with the sequent at its root.\<close>
corollary prover_completeness_SeCaV:
  fixes A :: \<open>tm list\<close>
  assumes \<open>\<tturnstile> z\<close>
  defines \<open>t \<equiv> secavProver (A, z)\<close>
  shows \<open>fst (root t) = (A, z) \<and> wf t \<and> tfinite t\<close>
proof -
  have \<open>uvalid z\<close>
    using assms sound_usemantics by blast
  then show ?thesis
    using assms prover_completeness_usemantics by blast
qed

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Kruskal's Tree Theorem\<close>

theory Kruskal
imports Well_Quasi_Orders
begin

locale kruskal_tree =
  fixes F :: "('b \<times> nat) set"
    and mk :: "'b \<Rightarrow> 'a list \<Rightarrow> ('a::size)"
    and root :: "'a \<Rightarrow> 'b \<times> nat"
    and args :: "'a \<Rightarrow> 'a list"
    and trees :: "'a set"
  assumes size_arg: "t \<in> trees \<Longrightarrow> s \<in> set (args t) \<Longrightarrow> size s < size t"
    and root_mk: "(f, length ts) \<in> F \<Longrightarrow> root (mk f ts) = (f, length ts)"
    and args_mk: "(f, length ts) \<in> F \<Longrightarrow> args (mk f ts) = ts"
    and mk_root_args: "t \<in> trees \<Longrightarrow> mk (fst (root t)) (args t) = t"
    and trees_root: "t \<in> trees \<Longrightarrow> root t \<in> F"
    and trees_arity: "t \<in> trees \<Longrightarrow> length (args t) = snd (root t)"
    and trees_args: "\<And>s. t \<in> trees \<Longrightarrow> s \<in> set (args t) \<Longrightarrow> s \<in> trees"
begin

lemma mk_inject [iff]:
  assumes "(f, length ss) \<in> F" and "(g, length ts) \<in> F"
  shows "mk f ss = mk g ts \<longleftrightarrow> f = g \<and> ss = ts"
proof -
  { assume "mk f ss = mk g ts"
    then have "root (mk f ss) = root (mk g ts)"
      and "args (mk f ss) = args (mk g ts)" by auto }
  show ?thesis
    using root_mk [OF assms(1)] and root_mk [OF assms(2)]
      and args_mk [OF assms(1)] and args_mk [OF assms(2)] by auto
qed

inductive emb for P
where
  arg: "\<lbrakk>(f, m) \<in> F; length ts = m; \<forall>t\<in>set ts. t \<in> trees;
    t \<in> set ts; emb P s t\<rbrakk> \<Longrightarrow> emb P s (mk f ts)" |
  list_emb: "\<lbrakk>(f, m) \<in> F; (g, n) \<in> F; length ss = m; length ts = n;
    \<forall>s \<in> set ss. s \<in> trees; \<forall>t \<in> set ts. t \<in> trees;
    P (f, m) (g, n); list_emb (emb P) ss ts\<rbrakk> \<Longrightarrow> emb P (mk f ss) (mk g ts)"
  monos list_emb_mono

lemma almost_full_on_trees:
  assumes "almost_full_on P F"
  shows "almost_full_on (emb P) trees" (is "almost_full_on ?P ?A")
proof (rule ccontr)
  interpret mbs ?A .
  assume "\<not> ?thesis"
  from mbs' [OF this] obtain m
    where bad: "m \<in> BAD ?P"
    and min: "\<forall>g. (m, g) \<in> gseq \<longrightarrow> good ?P g" ..
  then have trees: "\<And>i. m i \<in> trees" by auto

  define r where "r i = root (m i)" for i
  define a where "a i = args (m i)" for i
  define S where "S = \<Union>{set (a i) | i. True}"

  have m: "\<And>i. m i = mk (fst (r i)) (a i)"
   by (simp add: r_def a_def mk_root_args [OF trees])
  have lists: "\<forall>i. a i \<in> lists S" by (auto simp: a_def S_def)
  have arity: "\<And>i. length (a i) = snd (r i)"
    using trees_arity [OF trees] by (auto simp: r_def a_def)
  then have sig: "\<And>i. (fst (r i), length (a i)) \<in> F"
    using trees_root [OF trees] by (auto simp: a_def r_def)
  have a_trees: "\<And>i. \<forall>t \<in> set (a i). t \<in> trees" by (auto simp: a_def trees_args [OF trees])

  have "almost_full_on ?P S"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then obtain s :: "nat \<Rightarrow> 'a"
      where S: "\<And>i. s i \<in> S" and bad_s: "bad ?P s" by (auto simp: almost_full_on_def)

    define n where "n = (LEAST n. \<exists>k. s k \<in> set (a n))"
    have "\<exists>n. \<exists>k. s k \<in> set (a n)" using S by (force simp: S_def)
    from LeastI_ex [OF this] obtain k
      where sk: "s k \<in> set (a n)" by (auto simp: n_def)
    have args: "\<And>k. \<exists>m \<ge> n. s k \<in> set (a m)"
      using S by (auto simp: S_def) (metis Least_le n_def)

    define m' where "m' i = (if i < n then m i else s (k + (i - n)))" for i

    have m'_less: "\<And>i. i < n \<Longrightarrow> m' i = m i" by (simp add: m'_def)
    have m'_geq: "\<And>i. i \<ge> n \<Longrightarrow> m' i = s (k + (i - n))" by (simp add: m'_def)

    have "bad ?P m'"
    proof
      assume "good ?P m'"
      then obtain i j where "i < j" and emb: "?P (m' i) (m' j)" by auto
      { assume "j < n"
        with \<open>i < j\<close> and emb have "?P (m i) (m j)" by (auto simp: m'_less)
        with \<open>i < j\<close> and bad have False by blast }
      moreover
      { assume "n \<le> i"
        with \<open>i < j\<close> and emb have "?P (s (k + (i - n))) (s (k + (j - n)))"
          and "k + (i - n) < k + (j - n)" by (auto simp: m'_geq)
        with bad_s have False by auto }
      moreover
      { assume "i < n" and "n \<le> j"
        with \<open>i < j\<close> and emb have *: "?P (m i) (s (k + (j - n)))" by (auto simp: m'_less m'_geq)
        with args obtain l where "l \<ge> n" and **: "s (k + (j - n)) \<in> set (a l)" by blast
        from emb.arg [OF sig [of l] _ a_trees [of l] ** *]
          have "?P (m i) (m l)" by (simp add: m)
        moreover have "i < l" using \<open>i < n\<close> and \<open>n \<le> l\<close> by auto
        ultimately have False using bad by blast }
      ultimately show False using \<open>i < j\<close> by arith
    qed
    moreover have "(m, m') \<in> gseq"
    proof -
      have "m \<in> SEQ ?A" using trees by auto
      moreover have "m' \<in> SEQ ?A"
        using trees and S and trees_args [OF trees] by (auto simp: m'_def a_def S_def)
      moreover have "\<forall>i < n. m i = m' i" by (auto simp: m'_less)
      moreover have "size (m' n) < size (m n)"
        using sk and size_arg [OF trees, unfolded m]
        by (auto simp: m m'_geq root_mk [OF sig] args_mk [OF sig])
      ultimately show ?thesis by (auto simp: gseq_def)
    qed
    ultimately show False using min by blast
  qed
  from almost_full_on_lists [OF this, THEN almost_full_on_imp_homogeneous_subseq, OF lists]
    obtain \<phi> :: "nat \<Rightarrow> nat"
    where less: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
      and lemb: "\<And>i j. i < j \<Longrightarrow> list_emb ?P (a (\<phi> i)) (a (\<phi> j))" by blast
  have roots: "\<And>i. r (\<phi> i) \<in> F" using trees [THEN trees_root] by (auto simp: r_def)
  then have "r \<circ> \<phi> \<in> SEQ F" by auto
  with assms have "good P (r \<circ> \<phi>)" by (auto simp: almost_full_on_def)
  then obtain i j
    where "i < j" and "P (r (\<phi> i)) (r (\<phi> j))" by auto
  with lemb [OF \<open>i < j\<close>] have "?P (m (\<phi> i)) (m (\<phi> j))"
    using sig and arity and a_trees by (auto simp: m intro!: emb.list_emb)
  with less [OF \<open>i < j\<close>] and bad show False by blast
qed

inductive_cases
  emb_mk2 [consumes 1, case_names arg list_emb]: "emb P s (mk g ts)"

inductive_cases
  list_emb_Nil2_cases: "list_emb P xs []" and
  list_emb_Cons_cases: "list_emb P xs (y#ys)"

lemma list_emb_trans_right:
  assumes "list_emb P xs ys" and "list_emb (\<lambda>y z. P y z \<and> (\<forall>x. P x y \<longrightarrow> P x z)) ys zs"
  shows "list_emb P xs zs"
  using assms(2, 1) by (induct arbitrary: xs) (auto elim!: list_emb_Nil2_cases list_emb_Cons_cases)

lemma emb_trans:
  assumes trans: "\<And>f g h. f \<in> F \<Longrightarrow> g \<in> F \<Longrightarrow> h \<in> F \<Longrightarrow> P f g \<Longrightarrow> P g h \<Longrightarrow> P f h"
  assumes "emb P s t" and "emb P t u"
  shows "emb P s u"
using assms(3, 2)
proof (induct arbitrary: s)
  case (arg f m ts v)
  then show ?case by (auto intro: emb.arg)
next
  case (list_emb f m g n ss ts)
  note IH = this
  from \<open>emb P s (mk f ss)\<close>
    show ?case
  proof (cases rule: emb_mk2)
    case arg
    then show ?thesis using IH by (auto elim!: list_emb_set intro: emb.arg)
  next
    case list_emb
    then show ?thesis using IH by (auto intro: emb.intros dest: trans list_emb_trans_right)
  qed
qed

lemma transp_on_emb:
  assumes "transp_on P F"
  shows "transp_on (emb P) trees"
  using assms and emb_trans [of P] unfolding transp_on_def by blast

lemma kruskal:
  assumes "wqo_on P F"
  shows "wqo_on (emb P) trees"
  using almost_full_on_trees [of P] and assms by (metis transp_on_emb wqo_on_def)

end

end