theory Closures2
imports
  Closures
  Well_Quasi_Orders.Well_Quasi_Orders
begin

section \<open>Closure under \<open>SUBSEQ\<close> and \<open>SUPSEQ\<close>\<close>

text \<open>Properties about the embedding relation\<close>

lemma subseq_strict_length:
  assumes a: "subseq x y" "x \<noteq> y"
  shows "length x < length y"
using a
by (induct) (auto simp add: less_Suc_eq)

lemma subseq_wf:
  shows "wf {(x, y). subseq x y \<and> x \<noteq> y}"
proof -
  have "wf (measure length)" by simp
  moreover
  have "{(x, y). subseq x y \<and> x \<noteq> y} \<subseteq> measure length"
    unfolding measure_def by (auto simp add: subseq_strict_length)
  ultimately
  show "wf {(x, y). subseq x y \<and> x \<noteq> y}" by (rule wf_subset)
qed

lemma subseq_good:
  shows "good subseq (f :: nat \<Rightarrow> ('a::finite) list)"
using wqo_on_imp_good[where f="f", OF wqo_on_lists_over_finite_sets]
by simp

lemma subseq_Higman_antichains:
  assumes a: "\<forall>(x::('a::finite) list) \<in> A. \<forall>y \<in> A. x \<noteq> y \<longrightarrow> \<not>(subseq x y) \<and> \<not>(subseq y x)"
  shows "finite A"
proof (rule ccontr)
  assume "infinite A"
  then obtain f::"nat \<Rightarrow> 'a::finite list" where b: "inj f" and c: "range f \<subseteq> A"
    by (auto simp add: infinite_iff_countable_subset)
  from subseq_good[where f="f"]
  obtain i j where d: "i < j" and e: "subseq (f i) (f j) \<or> f i = f j"
    unfolding good_def
    by auto
  have "f i \<noteq> f j" using b d by (auto simp add: inj_on_def)
  moreover
  have "f i \<in> A" using c by auto
  moreover
  have "f j \<in> A" using c by auto
  ultimately have "\<not>(subseq (f i) (f j))" using a by simp
  with e show "False" by auto
qed

subsection \<open>Sub- and Supersequences\<close>

definition
 "SUBSEQ A \<equiv> {x::('a::finite) list. \<exists>y \<in> A. subseq x y}"

definition
 "SUPSEQ A \<equiv> {x::('a::finite) list. \<exists>y \<in> A. subseq y x}"

lemma SUPSEQ_atom [simp]:
  shows "SUPSEQ {[c]} = UNIV \<cdot> {[c]} \<cdot> UNIV"
unfolding SUPSEQ_def conc_def
by (auto dest: list_emb_ConsD)

lemma SUPSEQ_union [simp]:
  shows "SUPSEQ (A \<union> B) = SUPSEQ A \<union> SUPSEQ B"
unfolding SUPSEQ_def by auto

lemma SUPSEQ_conc [simp]:
  shows "SUPSEQ (A \<cdot> B) = SUPSEQ A \<cdot> SUPSEQ B"
unfolding SUPSEQ_def conc_def
apply(auto)
apply(drule list_emb_appendD)
apply(auto)
by (metis list_emb_append_mono)

lemma SUPSEQ_star [simp]:
  shows "SUPSEQ (A\<star>) = UNIV"
apply(subst star_unfold_left)
apply(simp only: SUPSEQ_union)
apply(simp)
done

subsection \<open>Regular expression that recognises every character\<close>

definition
  Allreg :: "'a::finite rexp"
where
  "Allreg \<equiv> \<Uplus>(Atom ` UNIV)"

lemma Allreg_lang [simp]:
  shows "lang Allreg = (\<Union>a. {[a]})"
unfolding Allreg_def by auto

lemma Star_Allreg_lang [simp]:
  shows "lang (Star Allreg) = UNIV"
by simp

fun
  UP :: "'a::finite rexp \<Rightarrow> 'a rexp"
where
  "UP (Zero) = Zero"
| "UP (One) = Star Allreg"
| "UP (Atom c) = Times (Star Allreg) (Times (Atom c) (Star Allreg))"
| "UP (Plus r1 r2) = Plus (UP r1) (UP r2)"
| "UP (Times r1 r2) = Times (UP r1) (UP r2)"
| "UP (Star r) = Star Allreg"

lemma lang_UP:
  fixes r::"'a::finite rexp"
  shows "lang (UP r) = SUPSEQ (lang r)"
by (induct r) (simp_all)

lemma SUPSEQ_regular:
  fixes A::"'a::finite lang"
  assumes "regular A"
  shows "regular (SUPSEQ A)"
proof -
  from assms obtain r::"'a::finite rexp" where "lang r = A" by auto
  then have "lang (UP r) = SUPSEQ A" by (simp add: lang_UP)
  then show "regular (SUPSEQ A)" by auto
qed

lemma SUPSEQ_subset:
  fixes A::"'a::finite list set"
  shows "A \<subseteq> SUPSEQ A"
unfolding SUPSEQ_def by auto

lemma SUBSEQ_complement:
  shows "- (SUBSEQ A) = SUPSEQ (- (SUBSEQ A))"
proof -
  have "- (SUBSEQ A) \<subseteq> SUPSEQ (- (SUBSEQ A))"
    by (rule SUPSEQ_subset)
  moreover
  have "SUPSEQ (- (SUBSEQ A)) \<subseteq> - (SUBSEQ A)"
  proof (rule ccontr)
    assume "\<not> (SUPSEQ (- (SUBSEQ A)) \<subseteq> - (SUBSEQ A))"
    then obtain x where
       a: "x \<in> SUPSEQ (- (SUBSEQ A))" and
       b: "x \<notin> - (SUBSEQ A)" by auto

    from a obtain y where c: "y \<in> - (SUBSEQ A)" and d: "subseq y x"
      by (auto simp add: SUPSEQ_def)

    from b have "x \<in> SUBSEQ A" by simp
    then obtain x' where f: "x' \<in> A" and e: "subseq x x'"
      by (auto simp add: SUBSEQ_def)

    from d e have "subseq y x'"
      by (rule subseq_order.order_trans)
    then have "y \<in> SUBSEQ A" using f
      by (auto simp add: SUBSEQ_def)
    with c show "False" by simp
  qed
  ultimately show "- (SUBSEQ A) = SUPSEQ (- (SUBSEQ A))" by simp
qed

definition
  minimal :: "'a::finite list \<Rightarrow> 'a lang \<Rightarrow> bool"
where
  "minimal x A \<equiv> (\<forall>y \<in> A. subseq y x \<longrightarrow> subseq x y)"

subsection \<open>Closure of @{const SUBSEQ} and @{const SUPSEQ}\<close>

lemma closure_SUPSEQ:
  fixes A::"'a::finite lang"
  shows "regular (SUPSEQ A)"
proof -
  obtain M where a: "finite M" and b: "SUPSEQ A = SUPSEQ M"
    using main_lemma by blast
  have "regular M" using a by (rule finite_regular)
  then have "regular (SUPSEQ M)" by (rule SUPSEQ_regular)
  then show "regular (SUPSEQ A)" using b by simp
qed

lemma closure_SUBSEQ:
  fixes A::"'a::finite lang"
  shows "regular (SUBSEQ A)"
proof -
  have "regular (SUPSEQ (- SUBSEQ A))" by (rule closure_SUPSEQ)
  then have "regular (- SUBSEQ A)" by (subst SUBSEQ_complement) (simp)
  then have "regular (- (- (SUBSEQ A)))" by (rule closure_complement)
  then show "regular (SUBSEQ A)" by simp
qed

end


section \<open>Simply-typed lambda-calculus with let and tuple patterns\<close>

theory Pattern
imports "../Nominal"
begin

no_syntax
  "_Map" :: "maplets => 'a \<rightharpoonup> 'b"  ("(1[_])")

atom_decl name

nominal_datatype ty =
    Atom nat
  | Arrow ty ty  (infixr "\<rightarrow>" 200)
  | TupleT ty ty  (infixr "\<otimes>" 210)

lemma fresh_type [simp]: "(a::name) \<sharp> (T::ty)"
  by (induct T rule: ty.induct) (simp_all add: fresh_nat)

lemma supp_type [simp]: "supp (T::ty) = ({} :: name set)"
  by (induct T rule: ty.induct) (simp_all add: ty.supp supp_nat)

lemma perm_type: "(pi::name prm) \<bullet> (T::ty) = T"
  by (induct T rule: ty.induct) (simp_all add: perm_nat_def)

nominal_datatype trm =
    Var name
  | Tuple trm trm  ("(1'\<langle>_,/ _'\<rangle>)")
  | Abs ty "\<guillemotleft>name\<guillemotright>trm"
  | App trm trm  (infixl "\<cdot>" 200)
  | Let ty trm btrm
and btrm =
    Base trm
  | Bind ty "\<guillemotleft>name\<guillemotright>btrm"

abbreviation
  Abs_syn :: "name \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm"  ("(3\<lambda>_:_./ _)" [0, 0, 10] 10)
where
  "\<lambda>x:T. t \<equiv> Abs T x t"

datatype pat =
    PVar name ty
  | PTuple pat pat  ("(1'\<langle>\<langle>_,/ _'\<rangle>\<rangle>)")

(* FIXME: The following should be done automatically by the nominal package *)
overloading pat_perm \<equiv> "perm :: name prm \<Rightarrow> pat \<Rightarrow> pat" (unchecked)
begin

primrec pat_perm
where
  "pat_perm pi (PVar x ty) = PVar (pi \<bullet> x) (pi \<bullet> ty)"
| "pat_perm pi \<langle>\<langle>p, q\<rangle>\<rangle> = \<langle>\<langle>pat_perm pi p, pat_perm pi q\<rangle>\<rangle>"

end

declare pat_perm.simps [eqvt]

lemma supp_PVar [simp]: "((supp (PVar x T))::name set) = supp x"
  by (simp add: supp_def perm_fresh_fresh)

lemma supp_PTuple [simp]: "((supp \<langle>\<langle>p, q\<rangle>\<rangle>)::name set) = supp p \<union> supp q"
  by (simp add: supp_def Collect_disj_eq del: disj_not1)

instance pat :: pt_name
proof (standard, goal_cases)
  case (1 x)
  show ?case by (induct x) simp_all
next
  case (2 _ _ x)
  show ?case by (induct x) (simp_all add: pt_name2)
next
  case (3 _ _ x)
  then show ?case by (induct x) (simp_all add: pt_name3)
qed

instance pat :: fs_name
proof (standard, goal_cases)
  case (1 x)
  show ?case by (induct x) (simp_all add: fin_supp)
qed

(* the following function cannot be defined using nominal_primrec, *)
(* since variable parameters are currently not allowed.            *)
primrec abs_pat :: "pat \<Rightarrow> btrm \<Rightarrow> btrm" ("(3\<lambda>[_]./ _)" [0, 10] 10)
where
  "(\<lambda>[PVar x T]. t) = Bind T x t"
| "(\<lambda>[\<langle>\<langle>p, q\<rangle>\<rangle>]. t) = (\<lambda>[p]. \<lambda>[q]. t)"

lemma abs_pat_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. (pi \<bullet> t))"
  by (induct p arbitrary: t) simp_all

lemma abs_pat_fresh [simp]:
  "(x::name) \<sharp> (\<lambda>[p]. t) = (x \<in> supp p \<or> x \<sharp> t)"
  by (induct p arbitrary: t) (simp_all add: abs_fresh supp_atm)

lemma abs_pat_alpha:
  assumes fresh: "((pi::name prm) \<bullet> supp p::name set) \<sharp>* t"
  and pi: "set pi \<subseteq> supp p \<times> pi \<bullet> supp p"
  shows "(\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. pi \<bullet> t)"
proof -
  note pt_name_inst at_name_inst pi
  moreover have "(supp p::name set) \<sharp>* (\<lambda>[p]. t)"
    by (simp add: fresh_star_def)
  moreover from fresh
  have "(pi \<bullet> supp p::name set) \<sharp>* (\<lambda>[p]. t)"
    by (simp add: fresh_star_def)
  ultimately have "pi \<bullet> (\<lambda>[p]. t) = (\<lambda>[p]. t)"
    by (rule pt_freshs_freshs)
  then show ?thesis by (simp add: eqvts)
qed

primrec pat_vars :: "pat \<Rightarrow> name list"
where
  "pat_vars (PVar x T) = [x]"
| "pat_vars \<langle>\<langle>p, q\<rangle>\<rangle> = pat_vars q @ pat_vars p"

lemma pat_vars_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (pat_vars p) = pat_vars (pi \<bullet> p)"
  by (induct p rule: pat.induct) (simp_all add: eqvts)

lemma set_pat_vars_supp: "set (pat_vars p) = supp p"
  by (induct p) (auto simp add: supp_atm)

lemma distinct_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (distinct (xs::name list)) = distinct (pi \<bullet> xs)"
  by (induct xs) (simp_all add: eqvts)

primrec pat_type :: "pat \<Rightarrow> ty"
where
  "pat_type (PVar x T) = T"
| "pat_type \<langle>\<langle>p, q\<rangle>\<rangle> = pat_type p \<otimes> pat_type q"

lemma pat_type_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (pat_type p) = pat_type (pi \<bullet> p)"
  by (induct p) simp_all

lemma pat_type_perm_eq: "pat_type ((pi :: name prm) \<bullet> p) = pat_type p"
  by (induct p) (simp_all add: perm_type)

type_synonym ctx = "(name \<times> ty) list"

inductive
  ptyping :: "pat \<Rightarrow> ty \<Rightarrow> ctx \<Rightarrow> bool"  ("\<turnstile> _ : _ \<Rightarrow> _" [60, 60, 60] 60)
where
  PVar: "\<turnstile> PVar x T : T \<Rightarrow> [(x, T)]"
| PTuple: "\<turnstile> p : T \<Rightarrow> \<Delta>\<^sub>1 \<Longrightarrow> \<turnstile> q : U \<Rightarrow> \<Delta>\<^sub>2 \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> : T \<otimes> U \<Rightarrow> \<Delta>\<^sub>2 @ \<Delta>\<^sub>1"

lemma pat_vars_ptyping:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "pat_vars p = map fst \<Delta>" using assms
  by induct simp_all

inductive
  valid :: "ctx \<Rightarrow> bool"
where
  Nil [intro!]: "valid []"
| Cons [intro!]: "valid \<Gamma> \<Longrightarrow> x \<sharp> \<Gamma> \<Longrightarrow> valid ((x, T) # \<Gamma>)"

inductive_cases validE[elim!]: "valid ((x, T) # \<Gamma>)"

lemma fresh_ctxt_set_eq: "((x::name) \<sharp> (\<Gamma>::ctx)) = (x \<notin> fst ` set \<Gamma>)"
  by (induct \<Gamma>) (auto simp add: fresh_list_nil fresh_list_cons fresh_prod fresh_atm)

lemma valid_distinct: "valid \<Gamma> = distinct (map fst \<Gamma>)"
  by (induct \<Gamma>) (auto simp add: fresh_ctxt_set_eq [symmetric])

abbreviation
  "sub_ctx" :: "ctx \<Rightarrow> ctx \<Rightarrow> bool" ("_ \<sqsubseteq> _")
where
  "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^sub>1 \<longrightarrow> x \<in> set \<Gamma>\<^sub>2"

abbreviation
  Let_syn :: "pat \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm"  ("(LET (_ =/ _)/ IN (_))" 10)
where
  "LET p = t IN u \<equiv> Let (pat_type p) t (\<lambda>[p]. Base u)"

inductive typing :: "ctx \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60, 60, 60] 60)
where
  Var [intro]: "valid \<Gamma> \<Longrightarrow> (x, T) \<in> set \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| Tuple [intro]: "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> u : U \<Longrightarrow> \<Gamma> \<turnstile> \<langle>t, u\<rangle> : T \<otimes> U"
| Abs [intro]: "(x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>x:T. t) : T \<rightarrow> U"
| App [intro]: "\<Gamma> \<turnstile> t : T \<rightarrow> U \<Longrightarrow> \<Gamma> \<turnstile> u : T \<Longrightarrow> \<Gamma> \<turnstile> t \<cdot> u : U"
| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow>
    \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow>
    \<Gamma> \<turnstile> (LET p = t IN u) : U"

equivariance ptyping

equivariance valid

equivariance typing

lemma valid_typing:
  assumes "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>" using assms
  by induct auto

lemma pat_var:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "(supp p::name set) = supp \<Delta>" using assms
  by induct (auto simp add: supp_list_nil supp_list_cons supp_prod supp_list_append)

lemma valid_app_fresh:
  assumes "valid (\<Delta> @ \<Gamma>)" and "(x::name) \<in> supp \<Delta>"
  shows "x \<sharp> \<Gamma>" using assms
  by (induct \<Delta>)
    (auto simp add: supp_list_nil supp_list_cons supp_prod supp_atm fresh_list_append)

lemma pat_freshs:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "(supp p::name set) \<sharp>* c = (supp \<Delta>::name set) \<sharp>* c" using assms
  by (auto simp add: fresh_star_def pat_var)

lemma valid_app_mono:
  assumes "valid (\<Delta> @ \<Gamma>\<^sub>1)" and "(supp \<Delta>::name set) \<sharp>* \<Gamma>\<^sub>2" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2"
  shows "valid (\<Delta> @ \<Gamma>\<^sub>2)" using assms
  by (induct \<Delta>)
    (auto simp add: supp_list_cons fresh_star_Un_elim supp_prod
       fresh_list_append supp_atm fresh_star_insert_elim fresh_star_empty_elim)

nominal_inductive2 typing
avoids
  Abs: "{x}"
| Let: "(supp p)::name set"
  by (auto simp add: fresh_star_def abs_fresh fin_supp pat_var
    dest!: valid_typing valid_app_fresh)

lemma better_T_Let [intro]:
  assumes t: "\<Gamma> \<turnstile> t : T" and p: "\<turnstile> p : T \<Rightarrow> \<Delta>" and u: "\<Delta> @ \<Gamma> \<turnstile> u : U"
  shows "\<Gamma> \<turnstile> (LET p = t IN u) : U"
proof -
  obtain pi::"name prm" where pi: "(pi \<bullet> (supp p::name set)) \<sharp>* (t, Base u, \<Gamma>)"
    and pi': "set pi \<subseteq> supp p \<times> (pi \<bullet> supp p)"
    by (rule at_set_avoiding [OF at_name_inst fin_supp fin_supp])
  from p u have p_fresh: "(supp p::name set) \<sharp>* \<Gamma>"
    by (auto simp add: fresh_star_def pat_var dest!: valid_typing valid_app_fresh)
  from pi have p_fresh': "(pi \<bullet> (supp p::name set)) \<sharp>* \<Gamma>"
    by (simp add: fresh_star_prod_elim)
  from pi have p_fresh'': "(pi \<bullet> (supp p::name set)) \<sharp>* Base u"
    by (simp add: fresh_star_prod_elim)
  from pi have "(supp (pi \<bullet> p)::name set) \<sharp>* t"
    by (simp add: fresh_star_prod_elim eqvts)
  moreover note t
  moreover from p have "pi \<bullet> (\<turnstile> p : T \<Rightarrow> \<Delta>)" by (rule perm_boolI)
  then have "\<turnstile> (pi \<bullet> p) : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: eqvts perm_type)
  moreover from u have "pi \<bullet> (\<Delta> @ \<Gamma> \<turnstile> u : U)" by (rule perm_boolI)
  with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' p_fresh p_fresh']
  have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> (pi \<bullet> u) : U" by (simp add: eqvts perm_type)
  ultimately have "\<Gamma> \<turnstile> (LET (pi \<bullet> p) = t IN (pi \<bullet> u)) : U"
    by (rule Let)
  then show ?thesis by (simp add: abs_pat_alpha [OF p_fresh'' pi'] pat_type_perm_eq)
qed

lemma weakening:
  assumes "\<Gamma>\<^sub>1 \<turnstile> t : T" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2"
  shows "\<Gamma>\<^sub>2 \<turnstile> t : T" using assms
  apply (nominal_induct \<Gamma>\<^sub>1 t T avoiding: \<Gamma>\<^sub>2 rule: typing.strong_induct)
  apply auto
  apply (drule_tac x="(x, T) # \<Gamma>\<^sub>2" in meta_spec)
  apply (auto intro: valid_typing)
  apply (drule_tac x="\<Gamma>\<^sub>2" in meta_spec)
  apply (drule_tac x="\<Delta> @ \<Gamma>\<^sub>2" in meta_spec)
  apply (auto intro: valid_typing)
  apply (rule typing.Let)
  apply assumption+
  apply (drule meta_mp)
  apply (rule valid_app_mono)
  apply (rule valid_typing)
  apply assumption
  apply (auto simp add: pat_freshs)
  done

inductive
  match :: "pat \<Rightarrow> trm \<Rightarrow> (name \<times> trm) list \<Rightarrow> bool"  ("\<turnstile> _ \<rhd> _ \<Rightarrow> _" [50, 50, 50] 50)
where
  PVar: "\<turnstile> PVar x T \<rhd> t \<Rightarrow> [(x, t)]"
| PProd: "\<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> \<turnstile> q \<rhd> u \<Rightarrow> \<theta>' \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> \<langle>t, u\<rangle> \<Rightarrow> \<theta> @ \<theta>'"

fun
  lookup :: "(name \<times> trm) list \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x = Var x"
| "lookup ((y, e) # \<theta>) x = (if x = y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi :: "name prm"
  and   \<theta> :: "(name \<times> trm) list"
  and   X :: "name"
  shows "pi \<bullet> (lookup \<theta> X) = lookup (pi \<bullet> \<theta>) (pi \<bullet> X)"
  by (induct \<theta>) (auto simp add: eqvts)

nominal_primrec
  psubst :: "(name \<times> trm) list \<Rightarrow> trm \<Rightarrow> trm"  ("_\<lparr>_\<rparr>" [95,0] 210)
  and psubstb :: "(name \<times> trm) list \<Rightarrow> btrm \<Rightarrow> btrm"  ("_\<lparr>_\<rparr>\<^sub>b" [95,0] 210)
where
  "\<theta>\<lparr>Var x\<rparr> = (lookup \<theta> x)"
| "\<theta>\<lparr>t \<cdot> u\<rparr> = \<theta>\<lparr>t\<rparr> \<cdot> \<theta>\<lparr>u\<rparr>"
| "\<theta>\<lparr>\<langle>t, u\<rangle>\<rparr> = \<langle>\<theta>\<lparr>t\<rparr>, \<theta>\<lparr>u\<rparr>\<rangle>"
| "\<theta>\<lparr>Let T t u\<rparr> = Let T (\<theta>\<lparr>t\<rparr>) (\<theta>\<lparr>u\<rparr>\<^sub>b)"
| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>x:T. t\<rparr> = (\<lambda>x:T. \<theta>\<lparr>t\<rparr>)"
| "\<theta>\<lparr>Base t\<rparr>\<^sub>b = Base (\<theta>\<lparr>t\<rparr>)"
| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>Bind T x t\<rparr>\<^sub>b = Bind T x (\<theta>\<lparr>t\<rparr>\<^sub>b)"
  apply finite_guess+
  apply (simp add: abs_fresh | fresh_guess)+
  done

lemma lookup_fresh:
  "x = y \<longrightarrow> x \<in> set (map fst \<theta>) \<Longrightarrow> \<forall>(y, t)\<in>set \<theta>. x \<sharp> t \<Longrightarrow> x \<sharp> lookup \<theta> y"
  apply (induct \<theta>)
  apply (simp_all add: split_paired_all fresh_atm)
  apply (case_tac "x = y")
  apply (auto simp add: fresh_atm)
  done

lemma psubst_fresh:
  assumes "x \<in> set (map fst \<theta>)" and "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t"
  shows "x \<sharp> \<theta>\<lparr>t\<rparr>" and "x \<sharp> \<theta>\<lparr>t'\<rparr>\<^sub>b" using assms
  apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
  apply simp
  apply (rule lookup_fresh)
  apply (rule impI)
  apply (simp_all add: abs_fresh)
  done

lemma psubst_eqvt[eqvt]:
  fixes pi :: "name prm"
  shows "pi \<bullet> (\<theta>\<lparr>t\<rparr>) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t\<rparr>"
  and "pi \<bullet> (\<theta>\<lparr>t'\<rparr>\<^sub>b) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t'\<rparr>\<^sub>b"
  by (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
    (simp_all add: eqvts fresh_bij)

abbreviation
  subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_\<mapsto>_]" [100,0,0] 100)
where
  "t[x\<mapsto>t'] \<equiv> [(x,t')]\<lparr>t\<rparr>"

abbreviation
  substb :: "btrm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> btrm" ("_[_\<mapsto>_]\<^sub>b" [100,0,0] 100)
where
  "t[x\<mapsto>t']\<^sub>b \<equiv> [(x,t')]\<lparr>t\<rparr>\<^sub>b"

lemma lookup_forget:
  "(supp (map fst \<theta>)::name set) \<sharp>* x \<Longrightarrow> lookup \<theta> x = Var x"
  by (induct \<theta>) (auto simp add: split_paired_all fresh_star_def fresh_atm supp_list_cons supp_atm)

lemma supp_fst: "(x::name) \<in> supp (map fst (\<theta>::(name \<times> trm) list)) \<Longrightarrow> x \<in> supp \<theta>"
  by (induct \<theta>) (auto simp add: supp_list_nil supp_list_cons supp_prod)

lemma psubst_forget:
  "(supp (map fst \<theta>)::name set) \<sharp>* t \<Longrightarrow> \<theta>\<lparr>t\<rparr> = t"
  "(supp (map fst \<theta>)::name set) \<sharp>* t' \<Longrightarrow> \<theta>\<lparr>t'\<rparr>\<^sub>b = t'"
  apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
  apply (auto simp add: fresh_star_def lookup_forget abs_fresh)
  apply (drule_tac x=\<theta> in meta_spec)
  apply (drule meta_mp)
  apply (rule ballI)
  apply (drule_tac x=x in bspec)
  apply assumption
  apply (drule supp_fst)
  apply (auto simp add: fresh_def)
  apply (drule_tac x=\<theta> in meta_spec)
  apply (drule meta_mp)
  apply (rule ballI)
  apply (drule_tac x=x in bspec)
  apply assumption
  apply (drule supp_fst)
  apply (auto simp add: fresh_def)
  done

lemma psubst_nil: "[]\<lparr>t\<rparr> = t" "[]\<lparr>t'\<rparr>\<^sub>b = t'"
  by (induct t and t' rule: trm_btrm.inducts) (simp_all add: fresh_list_nil)

lemma psubst_cons:
  assumes "(supp (map fst \<theta>)::name set) \<sharp>* u"
  shows "((x, u) # \<theta>)\<lparr>t\<rparr> = \<theta>\<lparr>t[x\<mapsto>u]\<rparr>" and "((x, u) # \<theta>)\<lparr>t'\<rparr>\<^sub>b = \<theta>\<lparr>t'[x\<mapsto>u]\<^sub>b\<rparr>\<^sub>b"
  using assms
  by (nominal_induct t and t' avoiding: x u \<theta> rule: trm_btrm.strong_inducts)
    (simp_all add: fresh_list_nil fresh_list_cons psubst_forget)

lemma psubst_append:
  "(supp (map fst (\<theta>\<^sub>1 @ \<theta>\<^sub>2))::name set) \<sharp>* map snd (\<theta>\<^sub>1 @ \<theta>\<^sub>2) \<Longrightarrow> (\<theta>\<^sub>1 @ \<theta>\<^sub>2)\<lparr>t\<rparr> = \<theta>\<^sub>2\<lparr>\<theta>\<^sub>1\<lparr>t\<rparr>\<rparr>"
  by (induct \<theta>\<^sub>1 arbitrary: t)
    (simp_all add: psubst_nil split_paired_all supp_list_cons psubst_cons fresh_star_def
      fresh_list_cons fresh_list_append supp_list_append)

lemma abs_pat_psubst [simp]:
  "(supp p::name set) \<sharp>* \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>[p]. t\<rparr>\<^sub>b = (\<lambda>[p]. \<theta>\<lparr>t\<rparr>\<^sub>b)"
  by (induct p arbitrary: t) (auto simp add: fresh_star_def supp_atm)

lemma valid_insert:
  assumes "valid (\<Delta> @ [(x, T)] @ \<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)" using assms
  by (induct \<Delta>)
    (auto simp add: fresh_list_append fresh_list_cons)

lemma fresh_set:
  shows "y \<sharp> xs = (\<forall>x\<in>set xs. y \<sharp> x)"
  by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes "valid \<Gamma>"
  and "(x, T) \<in> set \<Gamma>"
  and "(x, U) \<in> set \<Gamma>"
  shows "T = U" using assms
  by induct (auto simp add: fresh_set fresh_prod fresh_atm)

lemma subst_type_aux:
  assumes a: "\<Delta> @ [(x, U)] @ \<Gamma> \<turnstile> t : T"
  and b: "\<Gamma> \<turnstile> u : U"
  shows "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" using a b
proof (nominal_induct \<Gamma>'\<equiv>"\<Delta> @ [(x, U)] @ \<Gamma>" t T avoiding: x u \<Delta> rule: typing.strong_induct)
  case (Var y T x u \<Delta>)
  from \<open>valid (\<Delta> @ [(x, U)] @ \<Gamma>)\<close>
  have valid: "valid (\<Delta> @ \<Gamma>)" by (rule valid_insert)
  show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T"
  proof cases
    assume eq: "x = y"
    from Var eq have "T = U" by (auto intro: context_unique)
    with Var eq valid show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" by (auto intro: weakening)
  next
    assume ineq: "x \<noteq> y"
    from Var ineq have "(y, T) \<in> set (\<Delta> @ \<Gamma>)" by simp
    then show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" using ineq valid by auto
  qed
next
  case (Tuple t\<^sub>1 T\<^sub>1 t\<^sub>2 T\<^sub>2)
  from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>1[x\<mapsto>u] : T\<^sub>1" by (rule Tuple)
  moreover from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2[x\<mapsto>u] : T\<^sub>2" by (rule Tuple)
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> \<langle>t\<^sub>1[x\<mapsto>u], t\<^sub>2[x\<mapsto>u]\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2" ..
  then show ?case by simp
next
  case (Let p t T \<Delta>' s S)
  from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" by (rule Let)
  moreover note \<open>\<turnstile> p : T \<Rightarrow> \<Delta>'\<close>
  moreover have "\<Delta>' @ (\<Delta> @ [(x, U)] @ \<Gamma>) = (\<Delta>' @ \<Delta>) @ [(x, U)] @ \<Gamma>" by simp
  then have "(\<Delta>' @ \<Delta>) @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" using \<open>\<Gamma> \<turnstile> u : U\<close> by (rule Let)
  then have "\<Delta>' @ \<Delta> @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" by simp
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> (LET p = t[x\<mapsto>u] IN s[x\<mapsto>u]) : S"
    by (rule better_T_Let)
  moreover from Let have "(supp p::name set) \<sharp>* [(x, u)]"
    by (simp add: fresh_star_def fresh_list_nil fresh_list_cons)
  ultimately show ?case by simp
next
  case (Abs y T t S)
  have "(y, T) # \<Delta> @ [(x, U)] @ \<Gamma> = ((y, T) # \<Delta>) @ [(x, U)] @ \<Gamma>"
    by simp
  then have "((y, T) # \<Delta>) @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" using \<open>\<Gamma> \<turnstile> u : U\<close> by (rule Abs)
  then have "(y, T) # \<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" by simp
  then have "\<Delta> @ \<Gamma> \<turnstile> (\<lambda>y:T. t[x\<mapsto>u]) : T \<rightarrow> S"
    by (rule typing.Abs)
  moreover from Abs have "y \<sharp> [(x, u)]"
    by (simp add: fresh_list_nil fresh_list_cons)
  ultimately show ?case by simp
next
  case (App t\<^sub>1 T S t\<^sub>2)
  from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>1[x\<mapsto>u] : T \<rightarrow> S" by (rule App)
  moreover from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2[x\<mapsto>u] : T" by (rule App)
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> (t\<^sub>1[x\<mapsto>u]) \<cdot> (t\<^sub>2[x\<mapsto>u]) : S"
    by (rule typing.App)
  then show ?case by simp
qed

lemmas subst_type = subst_type_aux [of "[]", simplified]

lemma match_supp_fst:
  assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map fst \<theta>)::name set) = supp p" using assms
  by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append)

lemma match_supp_snd:
  assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map snd \<theta>)::name set) = supp u" using assms
  by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append trm.supp)

lemma match_fresh: "\<turnstile> p \<rhd> u \<Rightarrow> \<theta> \<Longrightarrow> (supp p::name set) \<sharp>* u \<Longrightarrow>
  (supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
  by (simp add: fresh_star_def fresh_def match_supp_fst match_supp_snd)

lemma match_type_aux:
  assumes "\<turnstile> p : U \<Rightarrow> \<Delta>"
  and "\<Gamma>\<^sub>2 \<turnstile> u : U"
  and "\<Gamma>\<^sub>1 @ \<Delta> @ \<Gamma>\<^sub>2 \<turnstile> t : T"
  and "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>"
  and "(supp p::name set) \<sharp>* u"
  shows "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<lparr>t\<rparr> : T" using assms
proof (induct arbitrary: \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 t u T \<theta>)
  case (PVar x U)
  from \<open>\<Gamma>\<^sub>1 @ [(x, U)] @ \<Gamma>\<^sub>2 \<turnstile> t : T\<close> \<open>\<Gamma>\<^sub>2 \<turnstile> u : U\<close>
  have "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> t[x\<mapsto>u] : T" by (rule subst_type_aux)
  moreover from \<open>\<turnstile> PVar x U \<rhd> u \<Rightarrow> \<theta>\<close> have "\<theta> = [(x, u)]"
    by cases simp_all
  ultimately show ?case by simp
next
  case (PTuple p S \<Delta>\<^sub>1 q U \<Delta>\<^sub>2)
  from \<open>\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>\<close> obtain u\<^sub>1 u\<^sub>2 \<theta>\<^sub>1 \<theta>\<^sub>2
    where u: "u = \<langle>u\<^sub>1, u\<^sub>2\<rangle>" and \<theta>: "\<theta> = \<theta>\<^sub>1 @ \<theta>\<^sub>2"
    and p: "\<turnstile> p \<rhd> u\<^sub>1 \<Rightarrow> \<theta>\<^sub>1" and q: "\<turnstile> q \<rhd> u\<^sub>2 \<Rightarrow> \<theta>\<^sub>2"
    by cases simp_all
  with PTuple have "\<Gamma>\<^sub>2 \<turnstile> \<langle>u\<^sub>1, u\<^sub>2\<rangle> : S \<otimes> U" by simp
  then obtain u\<^sub>1: "\<Gamma>\<^sub>2 \<turnstile> u\<^sub>1 : S" and u\<^sub>2: "\<Gamma>\<^sub>2 \<turnstile> u\<^sub>2 : U"
    by cases (simp_all add: ty.inject trm.inject)
  note u\<^sub>1
  moreover from \<open>\<Gamma>\<^sub>1 @ (\<Delta>\<^sub>2 @ \<Delta>\<^sub>1) @ \<Gamma>\<^sub>2 \<turnstile> t : T\<close>
  have "(\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2) @ \<Delta>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> t : T" by simp
  moreover note p
  moreover from \<open>supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u\<close> and u
  have "(supp p::name set) \<sharp>* u\<^sub>1" by (simp add: fresh_star_def)
  ultimately have \<theta>\<^sub>1: "(\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2) @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>1\<lparr>t\<rparr> : T"
    by (rule PTuple)
  note u\<^sub>2
  moreover from \<theta>\<^sub>1
  have "\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>1\<lparr>t\<rparr> : T" by simp
  moreover note q
  moreover from \<open>supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u\<close> and u
  have "(supp q::name set) \<sharp>* u\<^sub>2" by (simp add: fresh_star_def)
  ultimately have "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>2\<lparr>\<theta>\<^sub>1\<lparr>t\<rparr>\<rparr> : T"
    by (rule PTuple)
  moreover from \<open>\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>\<close> \<open>supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u\<close>
  have "(supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
    by (rule match_fresh)
  ultimately show ?case using \<theta> by (simp add: psubst_append)
qed

lemmas match_type = match_type_aux [where \<Gamma>\<^sub>1="[]", simplified]

inductive eval :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<longmapsto> _" [60,60] 60)
where
  TupleL: "t \<longmapsto> t' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t', u\<rangle>"
| TupleR: "u \<longmapsto> u' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t, u'\<rangle>"
| Abs: "t \<longmapsto> t' \<Longrightarrow> (\<lambda>x:T. t) \<longmapsto> (\<lambda>x:T. t')"
| AppL: "t \<longmapsto> t' \<Longrightarrow> t \<cdot> u \<longmapsto> t' \<cdot> u"
| AppR: "u \<longmapsto> u' \<Longrightarrow> t \<cdot> u \<longmapsto> t \<cdot> u'"
| Beta: "x \<sharp> u \<Longrightarrow> (\<lambda>x:T. t) \<cdot> u \<longmapsto> t[x\<mapsto>u]"
| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow> distinct (pat_vars p) \<Longrightarrow>
    \<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> (LET p = t IN u) \<longmapsto> \<theta>\<lparr>u\<rparr>"

equivariance match

equivariance eval

lemma match_vars:
  assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "x \<in> supp p"
  shows "x \<in> set (map fst \<theta>)" using assms
  by induct (auto simp add: supp_atm)

lemma match_fresh_mono:
  assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "(x::name) \<sharp> t"
  shows "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t" using assms
  by induct auto

nominal_inductive2 eval
avoids
  Abs: "{x}"
| Beta: "{x}"
| Let: "(supp p)::name set"
  apply (simp_all add: fresh_star_def abs_fresh fin_supp)
  apply (rule psubst_fresh)
  apply simp
  apply simp
  apply (rule ballI)
  apply (rule psubst_fresh)
  apply (rule match_vars)
  apply assumption+
  apply (rule match_fresh_mono)
  apply auto
  done

lemma typing_case_Abs:
  assumes ty: "\<Gamma> \<turnstile> (\<lambda>x:T. t) : S"
  and fresh: "x \<sharp> \<Gamma>"
  and R: "\<And>U. S = T \<rightarrow> U \<Longrightarrow> (x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> P"
  shows P using ty
proof cases
  case (Abs x' T' t' U)
  obtain y::name where y: "y \<sharp> (x, \<Gamma>, \<lambda>x':T'. t')"
    by (rule exists_fresh) (auto intro: fin_supp)
  from \<open>(\<lambda>x:T. t) = (\<lambda>x':T'. t')\<close> [symmetric]
  have x: "x \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
  have x': "x' \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
  from \<open>(x', T') # \<Gamma> \<turnstile> t' : U\<close> have x'': "x' \<sharp> \<Gamma>"
    by (auto dest: valid_typing)
  have "(\<lambda>x:T. t) = (\<lambda>x':T'. t')" by fact
  also from x x' y have "\<dots> = [(x, y)] \<bullet> [(x', y)] \<bullet> (\<lambda>x':T'. t')"
    by (simp only: perm_fresh_fresh fresh_prod)
  also have "\<dots> = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')"
    by (simp add: swap_simps perm_fresh_fresh)
  finally have "(\<lambda>x:T. t) = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')" .
  then have T: "T = T'" and t: "[(x, y)] \<bullet> [(x', y)] \<bullet> t' = t"
    by (simp_all add: trm.inject alpha)
  from Abs T have "S = T \<rightarrow> U" by simp
  moreover from \<open>(x', T') # \<Gamma> \<turnstile> t' : U\<close>
  have "[(x, y)] \<bullet> [(x', y)] \<bullet> ((x', T') # \<Gamma> \<turnstile> t' : U)"
    by (simp add: perm_bool)
  with T t y x'' fresh have "(x, T) # \<Gamma> \<turnstile> t : U"
    by (simp add: eqvts swap_simps perm_fresh_fresh fresh_prod)
  ultimately show ?thesis by (rule R)
qed simp_all

nominal_primrec ty_size :: "ty \<Rightarrow> nat"
where
  "ty_size (Atom n) = 0"
| "ty_size (T \<rightarrow> U) = ty_size T + ty_size U + 1"
| "ty_size (T \<otimes> U) = ty_size T + ty_size U + 1"
  by (rule TrueI)+

lemma bind_tuple_ineq:
  "ty_size (pat_type p) < ty_size U \<Longrightarrow> Bind U x t \<noteq> (\<lambda>[p]. u)"
  by (induct p arbitrary: U x t u) (auto simp add: btrm.inject)

lemma valid_appD: assumes "valid (\<Gamma> @ \<Delta>)"
  shows "valid \<Gamma>" "valid \<Delta>" using assms
  by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
    (auto simp add: Cons_eq_append_conv fresh_list_append)

lemma valid_app_freshs: assumes "valid (\<Gamma> @ \<Delta>)"
  shows "(supp \<Gamma>::name set) \<sharp>* \<Delta>" "(supp \<Delta>::name set) \<sharp>* \<Gamma>" using assms
  by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
    (auto simp add: Cons_eq_append_conv fresh_star_def
     fresh_list_nil fresh_list_cons supp_list_nil supp_list_cons fresh_list_append
     supp_prod fresh_prod supp_atm fresh_atm
     dest: notE [OF iffD1 [OF fresh_def]])

lemma perm_mem_left: "(x::name) \<in> ((pi::name prm) \<bullet> A) \<Longrightarrow> (rev pi \<bullet> x) \<in> A"
  by (drule perm_boolI [of _ "rev pi"]) (simp add: eqvts perm_pi_simp)

lemma perm_mem_right: "(rev (pi::name prm) \<bullet> (x::name)) \<in> A \<Longrightarrow> x \<in> (pi \<bullet> A)"
  by (drule perm_boolI [of _ pi]) (simp add: eqvts perm_pi_simp)

lemma perm_cases:
  assumes pi: "set pi \<subseteq> A \<times> A"
  shows "((pi::name prm) \<bullet> B) \<subseteq> A \<union> B"
proof
  fix x assume "x \<in> pi \<bullet> B"
  then show "x \<in> A \<union> B" using pi
    apply (induct pi arbitrary: x B rule: rev_induct)
    apply simp
    apply (simp add: split_paired_all supp_eqvt)
    apply (drule perm_mem_left)
    apply (simp add: calc_atm split: if_split_asm)
    apply (auto dest: perm_mem_right)
    done
qed

lemma abs_pat_alpha':
  assumes eq: "(\<lambda>[p]. t) = (\<lambda>[q]. u)"
  and ty: "pat_type p = pat_type q"
  and pv: "distinct (pat_vars p)"
  and qv: "distinct (pat_vars q)"
  shows "\<exists>pi::name prm. p = pi \<bullet> q \<and> t = pi \<bullet> u \<and>
    set pi \<subseteq> (supp p \<union> supp q) \<times> (supp p \<union> supp q)"
  using assms
proof (induct p arbitrary: q t u)
  case (PVar x T)
  note PVar' = this
  show ?case
  proof (cases q)
    case (PVar x' T')
    with \<open>(\<lambda>[PVar x T]. t) = (\<lambda>[q]. u)\<close>
    have "x = x' \<and> t = u \<or> x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
      by (simp add: btrm.inject alpha)
    then show ?thesis
    proof
      assume "x = x' \<and> t = u"
      with PVar PVar' have "PVar x T = ([]::name prm) \<bullet> q \<and>
        t = ([]::name prm) \<bullet> u \<and>
        set ([]::name prm) \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
          (supp (PVar x T) \<union> supp q)" by simp
      then show ?thesis ..
    next
      assume "x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
      with PVar PVar' have "PVar x T = [(x, x')] \<bullet> q \<and>
        t = [(x, x')] \<bullet> u \<and>
        set [(x, x')] \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
          (supp (PVar x T) \<union> supp q)"
        by (simp add: perm_swap swap_simps supp_atm perm_type)
      then show ?thesis ..
    qed
  next
    case (PTuple p\<^sub>1 p\<^sub>2)
    with PVar have "ty_size (pat_type p\<^sub>1) < ty_size T" by simp
    then have "Bind T x t \<noteq> (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. u)"
      by (rule bind_tuple_ineq)
    moreover from PTuple PVar
    have "Bind T x t = (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. u)" by simp
    ultimately show ?thesis ..
  qed
next
  case (PTuple p\<^sub>1 p\<^sub>2)
  note PTuple' = this
  show ?case
  proof (cases q)
    case (PVar x T)
    with PTuple have "ty_size (pat_type p\<^sub>1) < ty_size T" by auto
    then have "Bind T x u \<noteq> (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t)"
      by (rule bind_tuple_ineq)
    moreover from PTuple PVar
    have "Bind T x u = (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t)" by simp
    ultimately show ?thesis ..
  next
    case (PTuple p\<^sub>1' p\<^sub>2')
    with PTuple' have "(\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t) = (\<lambda>[p\<^sub>1']. \<lambda>[p\<^sub>2']. u)" by simp
    moreover from PTuple PTuple' have "pat_type p\<^sub>1 = pat_type p\<^sub>1'"
      by (simp add: ty.inject)
    moreover from PTuple' have "distinct (pat_vars p\<^sub>1)" by simp
    moreover from PTuple PTuple' have "distinct (pat_vars p\<^sub>1')" by simp
    ultimately have "\<exists>pi::name prm. p\<^sub>1 = pi \<bullet> p\<^sub>1' \<and>
      (\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u) \<and>
      set pi \<subseteq> (supp p\<^sub>1 \<union> supp p\<^sub>1') \<times> (supp p\<^sub>1 \<union> supp p\<^sub>1')"
      by (rule PTuple')
    then obtain pi::"name prm" where
      "p\<^sub>1 = pi \<bullet> p\<^sub>1'" "(\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u)" and
      pi: "set pi \<subseteq> (supp p\<^sub>1 \<union> supp p\<^sub>1') \<times> (supp p\<^sub>1 \<union> supp p\<^sub>1')" by auto
    from \<open>(\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u)\<close>
    have "(\<lambda>[p\<^sub>2]. t) = (\<lambda>[pi \<bullet> p\<^sub>2']. pi \<bullet> u)"
      by (simp add: eqvts)
    moreover from PTuple PTuple' have "pat_type p\<^sub>2 = pat_type (pi \<bullet> p\<^sub>2')"
      by (simp add: ty.inject pat_type_perm_eq)
    moreover from PTuple' have "distinct (pat_vars p\<^sub>2)" by simp
    moreover from PTuple PTuple' have "distinct (pat_vars (pi \<bullet> p\<^sub>2'))"
      by (simp add: pat_vars_eqvt [symmetric] distinct_eqvt [symmetric])
    ultimately have "\<exists>pi'::name prm. p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2' \<and>
      t = pi' \<bullet> pi \<bullet> u \<and>
      set pi' \<subseteq> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2'))"
      by (rule PTuple')
    then obtain pi'::"name prm" where
      "p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2'" "t = pi' \<bullet> pi \<bullet> u" and
      pi': "set pi' \<subseteq> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2')) \<times>
        (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2'))" by auto
    from PTuple PTuple' have "pi \<bullet> distinct (pat_vars \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>)" by simp
    then have "distinct (pat_vars \<langle>\<langle>pi \<bullet> p\<^sub>1', pi \<bullet> p\<^sub>2'\<rangle>\<rangle>)" by (simp only: eqvts)
    with \<open>p\<^sub>1 = pi \<bullet> p\<^sub>1'\<close> PTuple'
    have fresh: "(supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2') :: name set) \<sharp>* p\<^sub>1"
      by (auto simp add: set_pat_vars_supp fresh_star_def fresh_def eqvts)
    from \<open>p\<^sub>1 = pi \<bullet> p\<^sub>1'\<close> have "pi' \<bullet> (p\<^sub>1 = pi \<bullet> p\<^sub>1')" by (rule perm_boolI)
    with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' fresh fresh]
    have "p\<^sub>1 = pi' \<bullet> pi \<bullet> p\<^sub>1'" by (simp add: eqvts)
    with \<open>p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2'\<close> have "\<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>"
      by (simp add: pt_name2)
    moreover
    have "((supp p\<^sub>2 \<union> (pi \<bullet> supp p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> (pi \<bullet> supp p\<^sub>2'))::(name \<times> name) set) \<subseteq>
      (supp p\<^sub>2 \<union> (supp p\<^sub>1 \<union> supp p\<^sub>1' \<union> supp p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> (supp p\<^sub>1 \<union> supp p\<^sub>1' \<union> supp p\<^sub>2'))"
      by (rule subset_refl Sigma_mono Un_mono perm_cases [OF pi])+
    with pi' have "set pi' \<subseteq> \<dots>" by (simp add: supp_eqvt [symmetric])
    with pi have "set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>) \<times>
      (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>)"
      by (simp add: Sigma_Un_distrib1 Sigma_Un_distrib2 Un_ac) blast
    moreover note \<open>t = pi' \<bullet> pi \<bullet> u\<close>
    ultimately have "\<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> q \<and> t = (pi' @ pi) \<bullet> u \<and>
      set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp q) \<times>
        (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp q)" using PTuple
      by (simp add: pt_name2)
    then show ?thesis ..
  qed
qed

lemma typing_case_Let:
  assumes ty: "\<Gamma> \<turnstile> (LET p = t IN u) : U"
  and fresh: "(supp p::name set) \<sharp>* \<Gamma>"
  and distinct: "distinct (pat_vars p)"
  and R: "\<And>T \<Delta>. \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow> P"
  shows P using ty
proof cases
  case (Let p' t' T \<Delta> u')
  then have "(supp \<Delta>::name set) \<sharp>* \<Gamma>"
    by (auto intro: valid_typing valid_app_freshs)
  with Let have "(supp p'::name set) \<sharp>* \<Gamma>"
    by (simp add: pat_var)
  with fresh have fresh': "(supp p \<union> supp p' :: name set) \<sharp>* \<Gamma>"
    by (auto simp add: fresh_star_def)
  from Let have "(\<lambda>[p]. Base u) = (\<lambda>[p']. Base u')"
    by (simp add: trm.inject)
  moreover from Let have "pat_type p = pat_type p'"
    by (simp add: trm.inject)
  moreover note distinct
  moreover from \<open>\<Delta> @ \<Gamma> \<turnstile> u' : U\<close> have "valid (\<Delta> @ \<Gamma>)"
    by (rule valid_typing)
  then have "valid \<Delta>" by (rule valid_appD)
  with \<open>\<turnstile> p' : T \<Rightarrow> \<Delta>\<close> have "distinct (pat_vars p')"
    by (simp add: valid_distinct pat_vars_ptyping)
  ultimately have "\<exists>pi::name prm. p = pi \<bullet> p' \<and> Base u = pi \<bullet> Base u' \<and>
    set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
    by (rule abs_pat_alpha')
  then obtain pi::"name prm" where pi: "p = pi \<bullet> p'" "u = pi \<bullet> u'"
    and pi': "set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
    by (auto simp add: btrm.inject)
  from Let have "\<Gamma> \<turnstile> t : T" by (simp add: trm.inject)
  moreover from \<open>\<turnstile> p' : T \<Rightarrow> \<Delta>\<close> have "\<turnstile> (pi \<bullet> p') : (pi \<bullet> T) \<Rightarrow> (pi \<bullet> \<Delta>)"
    by (simp add: ptyping.eqvt)
  with pi have "\<turnstile> p : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: perm_type)
  moreover from Let
  have "(pi \<bullet> \<Delta>) @ (pi \<bullet> \<Gamma>) \<turnstile> (pi \<bullet> u') : (pi \<bullet> U)"
    by (simp add: append_eqvt [symmetric] typing.eqvt)
  with pi have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> u : U"
    by (simp add: perm_type pt_freshs_freshs
      [OF pt_name_inst at_name_inst pi' fresh' fresh'])
  ultimately show ?thesis by (rule R)
qed simp_all

lemma preservation:
  assumes "t \<longmapsto> t'" and "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T" using assms
proof (nominal_induct avoiding: \<Gamma> T rule: eval.strong_induct)
  case (TupleL t t' u)
  from \<open>\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T\<close> obtain T\<^sub>1 T\<^sub>2
    where "T = T\<^sub>1 \<otimes> T\<^sub>2" "\<Gamma> \<turnstile> t : T\<^sub>1" "\<Gamma> \<turnstile> u : T\<^sub>2"
    by cases (simp_all add: trm.inject)
  from \<open>\<Gamma> \<turnstile> t : T\<^sub>1\<close> have "\<Gamma> \<turnstile> t' : T\<^sub>1" by (rule TupleL)
  then have "\<Gamma> \<turnstile> \<langle>t', u\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2" using \<open>\<Gamma> \<turnstile> u : T\<^sub>2\<close>
    by (rule Tuple)
  with \<open>T = T\<^sub>1 \<otimes> T\<^sub>2\<close> show ?case by simp
next
  case (TupleR u u' t)
  from \<open>\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T\<close> obtain T\<^sub>1 T\<^sub>2
    where "T = T\<^sub>1 \<otimes> T\<^sub>2" "\<Gamma> \<turnstile> t : T\<^sub>1" "\<Gamma> \<turnstile> u : T\<^sub>2"
    by cases (simp_all add: trm.inject)
  from \<open>\<Gamma> \<turnstile> u : T\<^sub>2\<close> have "\<Gamma> \<turnstile> u' : T\<^sub>2" by (rule TupleR)
  with \<open>\<Gamma> \<turnstile> t : T\<^sub>1\<close> have "\<Gamma> \<turnstile> \<langle>t, u'\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2"
    by (rule Tuple)
  with \<open>T = T\<^sub>1 \<otimes> T\<^sub>2\<close> show ?case by simp
next
  case (Abs t t' x S)
  from \<open>\<Gamma> \<turnstile> (\<lambda>x:S. t) : T\<close> \<open>x \<sharp> \<Gamma>\<close> obtain U where
    T: "T = S \<rightarrow> U" and U: "(x, S) # \<Gamma> \<turnstile> t : U"
    by (rule typing_case_Abs)
  from U have "(x, S) # \<Gamma> \<turnstile> t' : U" by (rule Abs)
  then have "\<Gamma> \<turnstile> (\<lambda>x:S. t') : S \<rightarrow> U"
    by (rule typing.Abs)
  with T show ?case by simp
next
  case (Beta x u S t)
  from \<open>\<Gamma> \<turnstile> (\<lambda>x:S. t) \<cdot> u : T\<close> \<open>x \<sharp> \<Gamma>\<close>
  obtain "(x, S) # \<Gamma> \<turnstile> t : T" and "\<Gamma> \<turnstile> u : S"
    by cases (auto simp add: trm.inject ty.inject elim: typing_case_Abs)
  then show ?case by (rule subst_type)
next
  case (Let p t \<theta> u)
  from \<open>\<Gamma> \<turnstile> (LET p = t IN u) : T\<close> \<open>supp p \<sharp>* \<Gamma>\<close> \<open>distinct (pat_vars p)\<close>
  obtain U \<Delta> where "\<turnstile> p : U \<Rightarrow> \<Delta>" "\<Gamma> \<turnstile> t : U" "\<Delta> @ \<Gamma> \<turnstile> u : T"
    by (rule typing_case_Let)
  then show ?case using \<open>\<turnstile> p \<rhd> t \<Rightarrow> \<theta>\<close> \<open>supp p \<sharp>* t\<close>
    by (rule match_type)
next
  case (AppL t t' u)
  from \<open>\<Gamma> \<turnstile> t \<cdot> u : T\<close> obtain U where
    t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
    by cases (auto simp add: trm.inject)
  from t have "\<Gamma> \<turnstile> t' : U \<rightarrow> T" by (rule AppL)
  then show ?case using u by (rule typing.App)
next
  case (AppR u u' t)
  from \<open>\<Gamma> \<turnstile> t \<cdot> u : T\<close> obtain U where
    t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
    by cases (auto simp add: trm.inject)
  from u have "\<Gamma> \<turnstile> u' : U" by (rule AppR)
  with t show ?case by (rule typing.App)
qed

end


header{* Filters and Congruences *}

theory PseudoHoopFilters
imports PseudoHoops
begin

context pseudo_hoop_algebra
begin
definition
  "filters = {F . F \<noteq> {} \<and> (\<forall> a b . a \<in> F \<and> b \<in> F \<longrightarrow> a * b \<in> F) \<and> (\<forall> a b . a \<in> F \<and> a \<le> b \<longrightarrow> b \<in> F)}"

definition
  "properfilters = {F . F \<in> filters \<and> F \<noteq> UNIV}"

definition
  "maximalfilters = {F . F \<in> filters \<and> (\<forall> A . A \<in> filters \<and> F \<subseteq> A \<longrightarrow> A = F \<or> A = UNIV)}"

definition
  "ultrafilters = properfilters \<inter> maximalfilters"

lemma filter_i: "F \<in> filters \<Longrightarrow> a \<in> F \<Longrightarrow> b \<in> F \<Longrightarrow> a * b \<in> F"
  by (simp add: filters_def)

lemma filter_ii: "F \<in> filters \<Longrightarrow> a \<in> F \<Longrightarrow> a \<le> b \<Longrightarrow> b \<in> F"
 by (simp add: filters_def)

lemma filter_iii [simp]: "F \<in> filters \<Longrightarrow> 1 \<in> F"
 apply (simp add: filters_def)
 by auto

lemma filter_left_impl:
  "(F \<in> filters) = ((1 \<in> F) \<and> (\<forall> a b . a \<in> F \<and> a l\<rightarrow> b \<in> F \<longrightarrow> b \<in> F))"
  apply safe
  apply simp
  apply (frule_tac a = "a l\<rightarrow> b" and b = a in filter_i)
  apply simp
  apply simp
  apply (rule_tac a = "(a l\<rightarrow> b) * a" in filter_ii)
  apply simp
  apply simp
  apply (simp add: inf_l_def [THEN sym])
  apply (subst filters_def)
  apply safe
  apply (subgoal_tac "a l\<rightarrow> (b l\<rightarrow> a * b) \<in> F")
  apply blast
  apply (subst left_impl_ded [THEN sym])
  apply (subst left_impl_one)
  apply safe
  apply (subst (asm) left_lesseq)
  by blast

lemma filter_right_impl:
  "(F \<in> filters) = ((1 \<in> F) \<and> (\<forall> a b . a \<in> F \<and> a r\<rightarrow> b \<in> F \<longrightarrow> b \<in> F))"
  apply safe
  apply simp
  apply (frule_tac a = a and b = "a r\<rightarrow> b" in filter_i)
  apply simp
  apply simp
  apply (rule_tac a = "a * (a r\<rightarrow> b)" in filter_ii)
  apply simp
  apply simp
  apply (simp add: inf_r_def [THEN sym])
  apply (subst filters_def)
  apply safe
  apply (subgoal_tac "b r\<rightarrow> (a r\<rightarrow> a * b) \<in> F")
  apply blast
  apply (subst right_impl_ded [THEN sym])
  apply (subst right_impl_one)
  apply safe
  apply (subst (asm) right_lesseq)
  by blast

definition
  "filterof X = \<Inter> {F . F \<in> filters \<and> X \<subseteq> F}"

lemma [simp]: "filterof X \<in> filters"
  apply (simp add: filterof_def)
  apply (subgoal_tac "{F \<in> filters. X \<subseteq> F} \<subseteq> filters")
  apply simp
  by blast

lemma times_le_mono [simp]: "x \<le> y \<Longrightarrow> u \<le> v \<Longrightarrow> x * u \<le> y * v"
  apply (rule_tac y = "x * v" in order_trans)
  by (simp_all add: mult_left_mono mult_right_mono)

lemma prop_3_2_i:
  "filterof X = {a . \<exists> n x . x \<in> X *^ n \<and> x \<le> a}"
  apply safe
  apply (subgoal_tac "{a . \<exists> n x . x \<in> X *^ n \<and> x \<le> a} \<in> filters")
  apply (simp add: filterof_def)
  apply (drule_tac x = "{a\<Colon>'a. \<exists>(n\<Colon>nat) x\<Colon>'a. x \<in> X *^ n \<and> x \<le> a}" in spec)
  apply safe
  apply (rule_tac x = "1::nat" in exI)
  apply (rule_tac x = "xa" in exI)
  apply (simp add: times_set_def)
  apply (drule drop_assumption)
  apply (simp add: filters_def)
  apply safe
  apply (rule_tac x = "1" in exI)
  apply (rule_tac x = "0" in exI)
  apply (rule_tac x = "1" in exI)
  apply simp
  apply (rule_tac x = "n + na" in exI)
  apply (rule_tac x = "x * xa" in exI)
  apply safe
  apply (simp add: power_set_add times_set_def)
  apply blast
  apply simp
  apply (rule_tac x = "n" in exI)
  apply (rule_tac x = "x" in exI)
  apply simp
  apply (simp add: filterof_def)
  apply safe
  apply (rule filter_ii)
  apply simp_all
  apply (subgoal_tac "!x . x \<in> X *^ n \<longrightarrow> x \<in> xb")
  apply simp
  apply (induct_tac n)
  apply (simp add: power_set_0)
  apply (simp add: power_set_Suc times_set_def)
  apply safe
  apply (rule filter_i)
  apply simp_all
  by blast

lemma ultrafilter_union:
  "ultrafilters = {F . F \<in> filters \<and> F \<noteq> UNIV \<and> (\<forall> x . x \<notin> F \<longrightarrow> filterof (F \<union> {x}) = UNIV)}"
  apply (simp add: ultrafilters_def maximalfilters_def properfilters_def filterof_def)
  by auto

lemma filterof_sub: "F \<in> filters \<Longrightarrow> X \<subseteq> F \<Longrightarrow> filterof X \<subseteq> F"
  apply (simp add: filterof_def)
  by blast

lemma filterof_elem [simp]: "x \<in> X \<Longrightarrow> x \<in>  filterof X"
  apply (simp add: filterof_def)
  by blast

lemma [simp]: "filterof X \<in> filters"
  apply (simp add: filters_def  prop_3_2_i)
  apply safe
  apply (rule_tac x = 1 in exI)
  apply (rule_tac x = 0 in exI)
  apply (rule_tac x = 1 in exI)
  apply auto [1]
  apply (rule_tac x = "n + na" in exI)
  apply (rule_tac x = "x * xa" in exI)
  apply safe
  apply (unfold power_set_add)
  apply (simp add: times_set_def)
  apply auto [1]
  apply (rule_tac y = "x * b" in order_trans)
  apply (rule mult_left_mono)
  apply simp
  apply (simp add: mult_right_mono)
  apply (rule_tac x = n in exI)
  apply (rule_tac x = x in exI)
  by simp

lemma singleton_power [simp]: "{a} *^ n = {b . b = a ^ n}"
  apply (induct_tac n)
  apply auto [1]
  by (simp add: times_set_def)

lemma power_pair: "x \<in> {a, b} *^ n \<Longrightarrow> \<exists> i j . i + j = n \<and> x \<le> a ^ i \<and> x \<le> b ^ j"
  apply (subgoal_tac "\<forall> x . x \<in> {a, b} *^ n \<longrightarrow> (\<exists> i j . i + j = n \<and> x \<le> a ^ i \<and> x \<le> b ^ j)")
  apply auto[1]
  apply (drule drop_assumption)
  apply (induct_tac n)
  apply auto [1]
  apply safe
  apply (simp add: times_set_def)
  apply safe
  apply (drule_tac x = y in spec)
  apply safe
  apply (rule_tac x = "i + 1" in exI)
  apply (rule_tac x = "j" in exI)
  apply simp
  apply (rule_tac y = y in order_trans)
  apply simp_all
  apply (drule_tac x = y in spec)
  apply safe
  apply (rule_tac x = "i" in exI)
  apply (rule_tac x = "j+1" in exI)
  apply simp
  apply (rule_tac y = y in order_trans)
  by simp_all

lemma filterof_supremum:
  "c \<in> supremum {a, b} \<Longrightarrow> filterof {c} = filterof {a} \<inter> filterof {b}"
  apply safe
  apply (cut_tac X = "{c}" and F = "filterof {a}" in filterof_sub)
  apply simp_all
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (rule_tac  a = a in filter_ii)
  apply simp_all
  apply blast
  apply (cut_tac X = "{c}" and F = "filterof {b}" in filterof_sub)
  apply simp_all
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (rule_tac  a = b in filter_ii)
  apply simp_all
  apply blast
  apply (subst (asm) prop_3_2_i)
  apply simp
  apply (subst (asm) prop_3_2_i)
  apply simp
  apply safe
  apply (cut_tac A = "{a, b}" and a = c and b = x and n = "n + na" in  lemma_2_8_ii1)
  apply simp
  apply (subst prop_3_2_i)
  apply simp
  apply (rule_tac x = "n + na" in exI)
  apply (subgoal_tac "infimum ((\<lambda>xa\<Colon>'a. xa r\<rightarrow> x) ` ({a, b} *^ (n + na))) = {1}")
  apply simp
  apply (simp add: right_lesseq)
  apply (subst infimum_unique)
  apply (subst infimum_def lower_bound_def)
  apply (subst lower_bound_def)
  apply safe
  apply simp_all
  apply (drule power_pair)
  apply safe
  apply (subst right_residual [THEN sym])
  apply simp
  apply (case_tac "n \<le> i")
  apply (rule_tac y = "a ^ n" in order_trans)
  apply (rule_tac y = "a ^ i" in order_trans)
  apply simp_all
  apply (subgoal_tac "na \<le> j")
  apply (rule_tac y = "b ^ na" in order_trans)
  apply (rule_tac y = "b ^ j" in order_trans)
  by simp_all

definition "d1 a b = (a l\<rightarrow> b) * (b l\<rightarrow> a)"
definition "d2 a b = (a r\<rightarrow> b) * (b r\<rightarrow> a)"

definition "d3 a b = d1 b a"
definition "d4 a b = d2 b a"

lemma [simp]: "(a * b = 1) = (a = 1 \<and> b = 1)"
  apply (rule iffI)
  apply (rule conjI)
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "a*b" in order_trans)
  apply simp
  apply (drule drop_assumption)
  apply simp
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "a*b" in order_trans)
  apply simp
  apply (drule drop_assumption)
  apply simp
  by simp

lemma lemma_3_5_i_1: "(d1 a b = 1) = (a = b)"
  apply (simp add: d1_def left_lesseq [THEN sym])
  by auto

lemma lemma_3_5_i_2: "(d2 a b = 1) = (a = b)"
  apply (simp add: d2_def right_lesseq [THEN sym])
  by auto

lemma lemma_3_5_i_3: "(d3 a b = 1) = (a = b)"
  apply (simp add: d3_def lemma_3_5_i_1)
  by auto

lemma lemma_3_5_i_4: "(d4 a b = 1) = (a = b)"
  apply (simp add: d4_def lemma_3_5_i_2)
  by auto

lemma lemma_3_5_ii_1 [simp]: "d1 a a = 1"
  apply (subst lemma_3_5_i_1)
  by simp

lemma lemma_3_5_ii_2 [simp]: "d2 a a = 1"
  apply (subst lemma_3_5_i_2)
  by simp

lemma lemma_3_5_ii_3 [simp]: "d3 a a = 1"
  apply (subst lemma_3_5_i_3)
  by simp

lemma lemma_3_5_ii_4 [simp]: "d4 a a = 1"
  apply (subst lemma_3_5_i_4)
  by simp

lemma [simp]: "(a l\<rightarrow> 1) = 1"
  by (simp add: left_lesseq [THEN sym])

end

context pseudo_hoop_algebra begin

lemma [simp]: "(a r\<rightarrow> 1) = 1"
  by simp

lemma lemma_3_5_iii_1 [simp]: "d1 a 1 = a"
  by (simp add: d1_def)

lemma lemma_3_5_iii_2 [simp]: "d2 a 1 = a"
  by (simp add: d2_def)

lemma lemma_3_5_iii_3 [simp]: "d3 a 1 = a"
  by (simp add: d3_def d1_def)

lemma lemma_3_5_iii_4 [simp]: "d4 a 1 = a"
  by (simp add: d4_def d2_def)

lemma lemma_3_5_iv_1: "(d1 b c) * (d1 a b) * (d1 b c) \<le> d1 a c"
  apply (simp add: d1_def)
  apply (subgoal_tac "(b l\<rightarrow> c) * (c l\<rightarrow> b) * ((a l\<rightarrow> b) * (b l\<rightarrow> a)) * ((b l\<rightarrow> c) * (c l\<rightarrow> b)) =
    ((b l\<rightarrow> c) * (c l\<rightarrow> b) * (a l\<rightarrow> b)) * ((b l\<rightarrow> a) * (b l\<rightarrow> c) * (c l\<rightarrow> b))")
  apply simp
  apply (rule mult_mono)
  apply (rule_tac y = "(b l\<rightarrow> c) * (a l\<rightarrow> b)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_14)
  apply (rule_tac y = "(b l\<rightarrow> a) * (c l\<rightarrow> b)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_14)
  by (simp add: mult.assoc)

lemma lemma_3_5_iv_2: "(d2 a b) * (d2 b c) * (d2 a b) \<le> d2 a c"
  apply (simp add: d2_def)
  apply (subgoal_tac "(a r\<rightarrow> b) * (b r\<rightarrow> a) * ((b r\<rightarrow> c) * (c r\<rightarrow> b)) * ((a r\<rightarrow> b) * (b r\<rightarrow> a)) =
    ((a r\<rightarrow> b) * (b r\<rightarrow> a) * (b r\<rightarrow> c)) * ((c r\<rightarrow> b) * (a r\<rightarrow> b) * (b r\<rightarrow> a))")
  apply simp
  apply (rule mult_mono)
  apply (rule_tac y = "(a r\<rightarrow> b) * (b r\<rightarrow> c)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_15)
  apply (rule_tac y = "(c r\<rightarrow> b) * (b r\<rightarrow> a)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_15)
  by (simp add: mult.assoc)

lemma lemma_3_5_iv_3: "(d3 a b) * (d3 b c) * (d3 a b) \<le> d3 a c"
  by (simp add: d3_def lemma_3_5_iv_1)

lemma lemma_3_5_iv_4: "(d4 b c) * (d4 a b) * (d4 b c) \<le> d4 a c"
  by (simp add: d4_def lemma_3_5_iv_2)

definition
  "cong_r F a b \<equiv> d1 a b \<in> F"

definition
  "cong_l F a b \<equiv> d2 a b \<in> F"

lemma cong_r_filter: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (a l\<rightarrow> b \<in> F \<and> b l\<rightarrow> a \<in> F)"
  apply (simp add: cong_r_def d1_def)
  apply safe
  apply (rule filter_ii)
  apply simp_all
  apply simp
  apply (rule filter_ii)
  apply simp_all
  apply simp
  by (simp add: filter_i)

lemma cong_r_symmetric: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (cong_r F b a)"
  apply (simp add: cong_r_filter)
  by blast

lemma cong_r_d3: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (d3 a b \<in> F)"
  apply (simp add: d3_def)
  apply (subst cong_r_symmetric)
  by (simp_all add: cong_r_def)

lemma cong_l_filter: "F \<in> filters \<Longrightarrow> (cong_l F a b) = (a r\<rightarrow> b \<in> F \<and> b r\<rightarrow> a \<in> F)"
  apply (simp add: cong_l_def d2_def)
  apply safe
  apply (rule filter_ii)
  apply simp_all
  apply simp
  apply (rule filter_ii)
  apply simp_all
  apply simp
  by (simp add: filter_i)

lemma cong_l_d4: "F \<in> filters \<Longrightarrow> (cong_l F a b) = (d4 a b \<in> F)"
  apply (simp add: d4_def)
  apply (subst cong_l_symmetric)
  by (simp_all add: cong_l_def)

lemma cong_r_reflexive: "F \<in> filters \<Longrightarrow> cong_r F a a"
  by (simp add: cong_r_def)

lemma cong_r_transitive: "F \<in> filters \<Longrightarrow> cong_r F a b \<Longrightarrow> cong_r F b c \<Longrightarrow> cong_r F a c"
  apply (simp add: cong_r_filter)
  apply safe
  apply (rule_tac a = "(b l\<rightarrow> c) * (a l\<rightarrow> b)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  apply (simp add: lemma_2_5_14)
  apply (rule_tac a = "(b l\<rightarrow> a) * (c l\<rightarrow> b)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  by (simp add: lemma_2_5_14)

lemma cong_l_reflexive: "F \<in> filters \<Longrightarrow> cong_l F a a"
  by (simp add: cong_l_def)

lemma cong_l_transitive: "F \<in> filters \<Longrightarrow> cong_l F a b \<Longrightarrow> cong_l F b c \<Longrightarrow> cong_l F a c"
  apply (simp add: cong_l_filter)
  apply safe
  apply (rule_tac a = "(a r\<rightarrow> b) * (b r\<rightarrow> c)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  apply (simp add: lemma_2_5_15)
  apply (rule_tac a = "(c r\<rightarrow> b) * (b r\<rightarrow> a)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  by (simp add: lemma_2_5_15)

lemma lemma_3_7_i: "F \<in> filters \<Longrightarrow> F = {a . cong_r F a 1}"
  by (simp add: cong_r_def)

lemma lemma_3_7_ii: "F \<in> filters \<Longrightarrow> F = {a . cong_l F a 1}"
  by (simp add: cong_l_def)

lemma lemma_3_8_i: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (\<exists> x y . x \<in> F \<and> y \<in> F \<and> x * a = y * b)"
  apply (subst cong_r_filter)
  apply safe
  apply (rule_tac x = "a l\<rightarrow> b" in exI)
  apply (rule_tac x = "b l\<rightarrow> a" in exI)
  apply (simp add: left_impl_times)
  apply (subgoal_tac "x \<le> a l\<rightarrow> b")
  apply (simp add: filter_ii)
  apply (simp add: left_residual [THEN sym])
  apply (subgoal_tac "y \<le> b l\<rightarrow> a")
  apply (simp add: filter_ii)
  apply (simp add: left_residual [THEN sym])
  apply (subgoal_tac "y * b = x * a")
  by simp_all

lemma lemma_3_8_ii: "F \<in> filters \<Longrightarrow> (cong_l F a b) = (\<exists> x y . x \<in> F \<and> y \<in> F \<and> a * x = b * y)"
  apply (subst cong_l_filter)
  apply safe
  apply (rule_tac x = "a r\<rightarrow> b" in exI)
  apply (rule_tac x = "b r\<rightarrow> a" in exI)
  apply (simp add: right_impl_times)
  apply (subgoal_tac "x \<le> a r\<rightarrow> b")
  apply (simp add: filter_ii)
  apply (simp add: right_residual [THEN sym])
  apply (subgoal_tac "y \<le> b r\<rightarrow> a")
  apply (simp add: filter_ii)
  apply (simp add: right_residual [THEN sym])
  apply (subgoal_tac "b * y = a * x")
  by simp_all

lemma lemma_3_9_i: "F \<in> filters \<Longrightarrow> cong_r F a b  \<Longrightarrow> cong_r F c d \<Longrightarrow> (a l\<rightarrow> c \<in> F) = (b l\<rightarrow> d \<in> F)"
  apply (simp add: cong_r_filter)
  apply safe
  apply (rule_tac a = "(a l\<rightarrow> d) * (b l\<rightarrow> a)" in filter_ii)
  apply (simp_all add: lemma_2_5_14)
  apply (rule_tac a = "((c l\<rightarrow> d) * (a l\<rightarrow> c)) * (b l\<rightarrow> a)" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_right_mono)
  apply (simp_all add: lemma_2_5_14)

  apply (rule_tac a = "(b l\<rightarrow> c) * (a l\<rightarrow> b)" in filter_ii)
  apply (simp_all add: lemma_2_5_14)
  apply (rule_tac a = "((d l\<rightarrow> c) * (b l\<rightarrow> d)) * (a l\<rightarrow> b)" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_right_mono)
  by (simp_all add: lemma_2_5_14)

lemma lemma_3_9_ii: "F \<in> filters \<Longrightarrow> cong_l F a b  \<Longrightarrow> cong_l F c d \<Longrightarrow> (a r\<rightarrow> c \<in> F) = (b r\<rightarrow> d \<in> F)"
  apply (simp add: cong_l_filter)
  apply safe
  apply (rule_tac a = "(b r\<rightarrow> a) * (a r\<rightarrow> d)" in filter_ii)
  apply (simp_all add: lemma_2_5_15)
  apply (rule_tac a = "(b r\<rightarrow> a) * ((a r\<rightarrow> c) * (c r\<rightarrow> d))" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_left_mono)
  apply (simp_all add: lemma_2_5_15)

  apply (rule_tac a = "(a r\<rightarrow> b) * (b r\<rightarrow> c)" in filter_ii)
  apply (simp_all add: lemma_2_5_15)
  apply (rule_tac a = "(a r\<rightarrow> b) * ((b r\<rightarrow> d) * (d r\<rightarrow> c))" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_left_mono)
  by (simp_all add: lemma_2_5_15)

definition
  "normalfilters = {F . F \<in> filters \<and> (\<forall> a b . (a l\<rightarrow> b \<in> F) = (a r\<rightarrow> b \<in> F))}"

lemma normalfilter_i:
  "H \<in> normalfilters \<Longrightarrow> a l\<rightarrow> b \<in> H \<Longrightarrow> a r\<rightarrow> b \<in> H"
  by (simp add: normalfilters_def)

lemma normalfilter_ii:
  "H \<in> normalfilters \<Longrightarrow> a r\<rightarrow> b \<in> H \<Longrightarrow> a l\<rightarrow> b \<in> H"
  by (simp add: normalfilters_def)

lemma [simp]: "H \<in> normalfilters \<Longrightarrow> H \<in> filters"
  by (simp add: normalfilters_def)

lemma lemma_3_10_i_ii:
  "H \<in> normalfilters \<Longrightarrow> {a} ** H = H ** {a}"
  apply (simp add: times_set_def)
  apply safe
  apply simp
  apply (rule_tac x = "a l\<rightarrow> a * y" in bexI)
  apply (simp add: inf_l_def [THEN sym])
  apply (rule antisym)
  apply simp
  apply simp
  apply (rule normalfilter_ii)
  apply simp_all
  apply (rule_tac a = "y" in filter_ii)
  apply simp_all
  apply (simp add: right_residual [THEN sym])

  apply (rule_tac x = "a r\<rightarrow> xa * a" in bexI)
  apply (simp add: inf_r_def [THEN sym])
  apply (rule antisym)
  apply simp
  apply simp
  apply (rule normalfilter_i)
  apply simp_all
  apply (rule_tac a = "xa" in filter_ii)
  apply simp_all
  by (simp add: left_residual [THEN sym])

lemma lemma_3_10_ii_iii:
  "H \<in> filters \<Longrightarrow> (\<forall> a . {a} ** H = H ** {a}) \<Longrightarrow> cong_r H = cong_l H"
  apply (subst fun_eq_iff)
  apply (subst fun_eq_iff)
  apply safe
  apply (subst (asm) lemma_3_8_i)
  apply simp_all
  apply safe
  apply (subst lemma_3_8_ii)
  apply simp_all
  apply (subgoal_tac "xb * x \<in> {x} ** H")
  apply (subgoal_tac "y * xa \<in> {xa} ** H")
  apply (drule drop_assumption)
  apply (drule drop_assumption)
  apply (simp add: times_set_def)
  apply safe
  apply (rule_tac x = ya in exI)
  apply simp
  apply (rule_tac x = yb in exI)
  apply simp
  apply (drule_tac x = xa in spec)
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac x = x in spec)
  apply simp
  apply (simp add: times_set_def)
  apply (rule_tac x = xb in bexI)
  apply simp_all

  apply (subst (asm) lemma_3_8_ii)
  apply simp_all
  apply safe
  apply (subst lemma_3_8_i)
  apply simp_all
  apply (subgoal_tac "x * xb \<in> H ** {x}")
  apply (subgoal_tac "xa * y \<in> H ** {xa}")
  apply (drule drop_assumption)
  apply (drule drop_assumption)
  apply (simp add: times_set_def)
  apply safe
  apply (rule_tac x = xc in exI)
  apply simp
  apply (rule_tac x = xd in exI)
  apply simp
  apply (drule_tac x = xa in spec)
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac x = x in spec)
  apply (subgoal_tac "x * xb \<in> {x} ** H")
  apply simp
  apply (subst times_set_def)
  by blast

lemma lemma_3_10_i_iii:
  "H \<in> normalfilters \<Longrightarrow> cong_r H = cong_l H"
  by (simp add: lemma_3_10_i_ii lemma_3_10_ii_iii)

lemma order_impl_l [simp]: "a \<le> b \<Longrightarrow> a l\<rightarrow> b = 1"
  by (simp add: left_lesseq)

end

context pseudo_hoop_algebra begin

lemma impl_l_d1: "(a l\<rightarrow> b) = d1 a (a \<sqinter> b)"
  by (simp add: d1_def lemma_2_6_20_a )

lemma impl_r_d2: "(a r\<rightarrow> b) = d2 a (a \<sqinter> b)"
  by (simp add: d2_def lemma_2_6_21_a)

lemma lemma_3_10_iii_i:
  "H \<in> filters \<Longrightarrow> cong_r H = cong_l H \<Longrightarrow> H \<in> normalfilters"
  apply (unfold normalfilters_def)
  apply (simp add: impl_l_d1 impl_r_d2)
  apply safe
  apply (subgoal_tac  "cong_r H a (a \<sqinter> b)")
  apply simp
  apply (subst (asm) cong_l_def)
  apply simp
  apply (subst cong_r_def)
  apply simp
  apply (subgoal_tac  "cong_r H a (a \<sqinter> b)")
  apply (subst (asm) cong_r_def)
  apply simp
  apply simp
  apply (subst cong_l_def)
  by simp

lemma lemma_3_10_ii_i:
  "H \<in> filters \<Longrightarrow>  (\<forall> a . {a} ** H = H ** {a}) \<Longrightarrow> H \<in> normalfilters"
  apply (rule lemma_3_10_iii_i)
  apply simp
  apply (rule lemma_3_10_ii_iii)
  by simp_all

definition
  "allpowers x n = {y . \<exists> i. i < n \<and> y = x ^ i}"

lemma times_set_in: "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> c = a * b \<Longrightarrow> c \<in> A ** B"
  apply (simp add: times_set_def)
  by auto

lemma power_set_power: "a \<in> A \<Longrightarrow> a ^ n \<in> A *^ n"
  apply (induct_tac n)
  apply simp
  apply simp
  apply (rule_tac a = a and b = "a ^ n" in times_set_in)
  by simp_all

lemma normal_filter_union: "H \<in> normalfilters \<Longrightarrow> (H \<union> {x}) *^ n = (H ** (allpowers x n)) \<union> {x ^ n} "
  apply (induct_tac n)
  apply (simp add: times_set_def allpowers_def)
  apply safe
  apply simp
  apply (simp add:  times_set_def)
  apply safe
  apply (simp add:  allpowers_def)
  apply safe
  apply (subgoal_tac "x * xa \<in> H ** {x}")
  apply (simp add: times_set_def)
  apply safe
  apply (drule_tac x = "xb" in bspec)
  apply simp
  apply (drule_tac x = "x ^ (i + 1)" in spec)
  apply simp
  apply safe
  apply (erule notE)
  apply (rule_tac x = "i + 1" in exI)
  apply simp
  apply (erule notE)
  apply (simp add: mult.assoc [THEN sym])
  apply (drule_tac a = x in lemma_3_10_i_ii)
  apply (subgoal_tac "H ** {x} = {x} ** H")
  apply simp
  apply (simp add: times_set_def)
  apply auto[1]
  apply simp
  apply (drule_tac x = "xaa" in bspec)
  apply simp
  apply (drule_tac x = "x ^ n" in bspec)
  apply (simp add: allpowers_def)
  apply blast
  apply simp
  apply (drule_tac x = "xaa * xb" in bspec)
  apply (simp add: filter_i)
  apply (simp add: mult.assoc)
  apply (drule_tac x = "ya" in bspec)
  apply (simp add: allpowers_def)
  apply safe
  apply (rule_tac x = i in exI)
  apply simp
  apply simp
  apply (subst (asm)  times_set_def)
  apply (subst (asm)  times_set_def)
  apply simp
  apply safe
  apply (subst (asm) allpowers_def)
  apply (subst (asm) allpowers_def)
  apply safe
  apply (case_tac "i = 0")
  apply simp
  apply (rule_tac a = xa and b = 1 in times_set_in)
  apply blast
  apply (simp add: allpowers_def times_set_def)
  apply safe
  apply simp
  apply (drule_tac x = 1 in bspec)
  apply simp
  apply (drule_tac x = 1 in spec)
  apply simp
  apply (drule_tac x = 0 in spec)
  apply auto[1]
  apply simp
  apply (rule_tac a = xaa and b = "x ^ i" in times_set_in)
  apply blast
  apply (case_tac "i = n")
  apply simp
  apply (simp add: allpowers_def)
  apply safe
  apply (subgoal_tac "x ^ i \<in>  H ** {y . \<exists>i<n. y = x ^ i}")
  apply simp
  apply (rule_tac a = 1 and b = "x ^ i" in times_set_in)
  apply simp
  apply simp
  apply (rule_tac x = i in exI)
  apply simp
  apply simp
  apply (rule power_set_power)
  by simp

lemma lemma_3_11_ii: "H \<in> normalfilters \<Longrightarrow> filterof (H \<union> {x}) = {a . \<exists> n h . h \<in> H \<and> (x ^ n) * h \<le> a}"
  apply (subst lemma_3_11_i)
  apply simp_all
  apply safe
  apply (rule_tac x = n in exI)
  apply (subgoal_tac "h * x ^ n \<in> {x ^ n} ** H")
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac a = "x ^ n" in lemma_3_10_i_ii)
  apply simp
  apply (simp add: times_set_def)
  apply auto[1]
  apply (rule_tac x = n in exI)
  apply (subgoal_tac "(x ^ n) * h \<in> H ** {x ^ n}")
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac a = "x ^ n" in lemma_3_10_i_ii)
  apply (drule_tac sym)
  apply simp
  apply (simp add: times_set_def)
  by auto

lemma lemma_3_12_i_ii:
  "H \<in> normalfilters \<Longrightarrow> H \<in> ultrafilters \<Longrightarrow> x \<notin> H \<Longrightarrow> (\<exists> n . x ^ n l\<rightarrow> a \<in> H)"
  apply (subst (asm) ultrafilter_union)
  apply clarify
  apply (drule_tac x = x in spec)
  apply clarify
  apply (subst (asm) lemma_3_11_i)
  apply assumption
  apply (subgoal_tac "a \<in> {a\<Colon>'a. \<exists>(n\<Colon>nat) h\<Colon>'a. h \<in> H \<and> h * x ^ n \<le> a}")
  apply clarify
  apply (rule_tac x = n in exI)
  apply (simp add: left_residual)
  apply (rule filter_ii)
  by simp_all

lemma lemma_3_12_ii_i:
  "H \<in> normalfilters \<Longrightarrow> H \<in> properfilters \<Longrightarrow> (\<forall> x a . x \<notin> H \<longrightarrow> (\<exists> n . x ^ n l\<rightarrow> a \<in> H)) \<Longrightarrow> H \<in> maximalfilters"
  apply (subgoal_tac "H \<in> ultrafilters")
  apply (simp add: ultrafilters_def)
  apply (subst ultrafilter_union)
  apply clarify
  apply (subst (asm) properfilters_def)
  apply clarify
  apply (subst lemma_3_11_i)
  apply simp_all
  apply safe
  apply simp_all
  apply (drule_tac x = x in spec)
  apply clarify
  apply (drule_tac x = xb in spec)
  apply clarify
  apply (rule_tac x = n in exI)
  apply (rule_tac x = "x ^ n l\<rightarrow> xb" in exI)
  apply clarify
  apply (subst inf_l_def [THEN sym])
  by simp

lemma lemma_3_12_i_iii:
  "H \<in> normalfilters \<Longrightarrow> H \<in> ultrafilters \<Longrightarrow> x \<notin> H \<Longrightarrow> (\<exists> n . x ^ n r\<rightarrow> a \<in> H)"
  apply (subst (asm) ultrafilter_union)
  apply clarify
  apply (drule_tac x = x in spec)
  apply clarify
  apply (subst (asm) lemma_3_11_ii)
  apply assumption
  apply (subgoal_tac "a \<in> {a\<Colon>'a. \<exists>(n\<Colon>nat) h\<Colon>'a. h \<in> H \<and> (x ^ n) * h \<le> a}")
  apply clarify
  apply (rule_tac x = n in exI)
  apply (simp add: right_residual)
  apply (rule filter_ii)
  by simp_all

lemma lemma_3_12_iii_i:
  "H \<in> normalfilters \<Longrightarrow> H \<in> properfilters \<Longrightarrow> (\<forall> x a . x \<notin> H \<longrightarrow> (\<exists> n . x ^ n r\<rightarrow> a \<in> H)) \<Longrightarrow> H \<in> maximalfilters"
  apply (subgoal_tac "H \<in> ultrafilters")
  apply (simp add: ultrafilters_def)
  apply (subst ultrafilter_union)
  apply clarify
  apply (subst (asm) properfilters_def)
  apply clarify
  apply (subst lemma_3_11_ii)
  apply simp_all
  apply safe
  apply simp_all
  apply (drule_tac x = x in spec)
  apply clarify
  apply (drule_tac x = xb in spec)
  apply clarify
  apply (rule_tac x = n in exI)
  apply (rule_tac x = "x ^ n r\<rightarrow> xb" in exI)
  apply clarify
  apply (subst inf_r_def [THEN sym])
  by simp

definition
  "cong H = (\<lambda> x y . cong_l H x y \<and> cong_r H x y)"

definition
  "congruences = {R . equivp R \<and> (\<forall> a b c d . R a b \<and> R c d \<longrightarrow> R (a * c) (b * d) \<and>  R (a l\<rightarrow> c) (b l\<rightarrow> d) \<and>  R (a r\<rightarrow> c) (b r\<rightarrow> d))}"

lemma cong_l: "H \<in> normalfilters \<Longrightarrow> cong H = cong_l H"
  by (simp add: cong_def lemma_3_10_i_iii)

lemma cong_r: "H \<in> normalfilters \<Longrightarrow> cong H = cong_r H"
  by (simp add: cong_def lemma_3_10_i_iii)

lemma cong_equiv: "H \<in> normalfilters \<Longrightarrow> equivp (cong H)"
  apply (simp add: cong_l)
  apply (simp add: equivp_reflp_symp_transp reflp_def refl_on_def cong_l_reflexive cong_l_symmetric symp_def sym_def transp_def trans_def)
  apply safe
  apply (rule cong_l_transitive)
  by simp_all

lemma cong_trans: "H \<in> normalfilters \<Longrightarrow> cong H x y \<Longrightarrow> cong H y z \<Longrightarrow> cong H x z"
  apply (drule cong_equiv)
  apply (drule equivp_transp)
  by simp_all

lemma lemma_3_13 [simp]:
  "H \<in> normalfilters \<Longrightarrow> cong H \<in> congruences"
  apply (subst congruences_def)
  apply safe
  apply (simp add: cong_equiv)
  apply (rule_tac y = "b * c" in cong_trans)
  apply simp_all
  apply (simp add: cong_r lemma_3_8_i)
  apply safe
  apply (rule_tac x = x in exI)
  apply simp
  apply (rule_tac x = y in exI)
  apply (simp add: mult.assoc [THEN sym])
  apply (simp add: cong_l lemma_3_8_ii)
  apply safe
  apply (rule_tac x = xa in exI)
  apply simp
  apply (rule_tac x = ya in exI)
  apply (simp add: mult.assoc)
  apply (rule_tac y = "a l\<rightarrow> d" in cong_trans)
  apply simp
  apply (simp add: cong_r cong_r_filter)
  apply safe
  apply (rule_tac a = "c l\<rightarrow> d" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  apply (simp add: lemma_2_5_14)
  apply (rule_tac a = "d l\<rightarrow> c" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  apply (simp add: lemma_2_5_14)
  apply (subst cong_l)
  apply simp
  apply (simp add: cong_r cong_r_filter cong_l_filter)
  apply safe
  apply (rule_tac a = "b l\<rightarrow> a" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_14)
  apply (rule_tac a = "a l\<rightarrow> b" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_14)

  apply (rule_tac y = "a r\<rightarrow> d" in cong_trans)
  apply simp
  apply (simp add: cong_l cong_l_filter)
  apply safe
  apply (rule_tac a = "c r\<rightarrow> d" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_15)
  apply (rule_tac a = "d r\<rightarrow> c" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_15)

  apply (subst cong_r)
  apply simp
  apply (simp add: cong_l cong_l_filter cong_r_filter)
  apply safe
  apply (rule_tac a = "b r\<rightarrow> a" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  apply (simp add: lemma_2_5_15)
  apply (rule_tac a = "a r\<rightarrow> b" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  by (simp add: lemma_2_5_15)

lemma cong_times: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R c d \<Longrightarrow> R (a * c) (b * d)"
  by (simp add: congruences_def)

lemma cong_impl_l: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R c d \<Longrightarrow> R (a l\<rightarrow> c) (b l\<rightarrow> d)"
  by (simp add: congruences_def)

lemma cong_impl_r: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R c d \<Longrightarrow> R (a r\<rightarrow> c) (b r\<rightarrow> d)"
  by (simp add: congruences_def)

lemma cong_refl [simp]: "R \<in> congruences \<Longrightarrow> R a a"
  by (simp add: congruences_def equivp_reflp)

lemma cong_trans_a: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R b c \<Longrightarrow> R a c"
  apply (simp add: congruences_def)
  apply (rule_tac y = b in equivp_transp)
  by simp_all

lemma cong_sym: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R b a"
  by (simp add: congruences_def equivp_symp)

definition
  "normalfilter R = {a . R a 1}"

lemma lemma_3_14 [simp]:
  "R \<in> congruences \<Longrightarrow> (normalfilter R) \<in> normalfilters"
  apply (unfold normalfilters_def)
  apply safe
  apply (simp add: filters_def)
  apply safe
  apply (simp add: normalfilter_def)
  apply (drule_tac x = 1 in spec)
  apply (simp add: congruences_def  equivp_reflp)
  apply (simp add: normalfilter_def)
  apply (drule_tac a = a and c = b and b = 1 and d = 1 and R = R in cong_times)
  apply simp_all
  apply (simp add: normalfilter_def)
  apply (simp add: left_lesseq)
  apply (cut_tac R = R and a = a and b = 1 and c = b and d = b in cong_impl_l)
  apply simp_all
  apply (simp add: cong_sym)
  apply (simp_all add: normalfilter_def)
  apply (cut_tac R = R and a = "a l\<rightarrow> b" and b = 1 and c = a and d = a in cong_times)
  apply simp_all
  apply (simp add: inf_l_def [THEN sym])
  apply (cut_tac R = R and a = a and b = "a \<sqinter> b" and c = b and d = b in cong_impl_r)
  apply simp_all
  apply (simp add: cong_sym)
  apply (cut_tac R = R and c = "a r\<rightarrow> b" and d = 1 and a = a and b = a in cong_times)
  apply simp_all
  apply (simp add: inf_r_def [THEN sym])
  apply (cut_tac R = R and a = a and b = "a \<sqinter> b" and c = b and d = b in cong_impl_l)
  apply simp_all
  by (simp add: cong_sym)

lemma lemma_3_15_ii:
  "R \<in> congruences \<Longrightarrow> cong (normalfilter R) = R"
  apply (simp add: fun_eq_iff cong_r cong_r_filter)
  apply (simp add: normalfilter_def)
  apply safe
  apply (cut_tac R = R and a = "x l\<rightarrow> xa" and b = 1 and c = x and d = x in cong_times)
  apply simp_all
  apply (cut_tac R = R and a = "xa l\<rightarrow> x" and b = 1 and c = xa and d = xa in cong_times)
  apply simp_all
  apply (simp add: inf_l_def [THEN sym])
  apply (rule_tac b = "x \<sqinter> xa" in cong_trans_a)
  apply simp_all
  apply (subst cong_sym)
  apply simp_all
  apply (subst inf.commute)
  apply simp_all
  apply (cut_tac R = R and a = x and b = xa and c = xa and d = xa in cong_impl_l)
  apply simp_all
  apply (cut_tac R = R and a = xa and b = xa and c = x and d = xa in cong_impl_l)
  by simp_all

lemma lemma_3_15_iii: "H1 \<in> normalfilters \<Longrightarrow> H2 \<in> normalfilters \<Longrightarrow> (H1 \<subseteq> H2) = (cong H1 \<le> cong H2)"
  apply safe
  apply (simp add: cong_l cong_l_filter)
  apply blast
  apply (subgoal_tac "cong H2 x 1")
  apply (simp add: cong_l cong_l_def)
  apply (subgoal_tac "cong H1 x 1")
  apply blast
  by (simp add: cong_l cong_l_def)

definition
  "p x y z = ((x l\<rightarrow> y) r\<rightarrow> z) \<sqinter> ((z l\<rightarrow> y) r\<rightarrow> x)"

lemma lemma_3_16_i: "p x x y = y \<and> p x y y = x"
  apply safe
  apply (simp_all add: p_def)
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_24)
  apply (rule antisym)
  by (simp_all add: lemma_2_10_24)

definition "M x y z = ((y l\<rightarrow> x) r\<rightarrow> x) \<sqinter> ((z l\<rightarrow> y) r\<rightarrow> y) \<sqinter> ((x l\<rightarrow> z) r\<rightarrow> z)"

lemma "M x x y = x \<and> M x y x = x \<and> M y x x = x"
  apply (simp add: M_def)
  apply safe
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_24 lemma_2_5_9_b)
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_24 lemma_2_5_9_b)
  apply (rule antisym)
  by (simp_all add: lemma_2_10_24 lemma_2_5_9_b)
end

end