(*<*)
theory Trivia
imports Main "HOL-Library.Sublist"
begin

lemma measure_induct2[case_names IH]:
fixes meas :: "'a \<Rightarrow> 'b \<Rightarrow> nat"
assumes "\<And>x1 x2. (\<And>y1 y2. meas y1 y2 < meas x1 x2 \<Longrightarrow> S y1 y2) \<Longrightarrow> S x1 x2"
shows "S x1 x2"
proof-
  let ?m = "\<lambda> x1x2. meas (fst x1x2) (snd x1x2)" let ?S = "\<lambda> x1x2. S (fst x1x2) (snd x1x2)"
  have "?S (x1,x2)"
  apply(rule measure_induct[of ?m ?S])
  using assms by (metis fst_conv snd_conv)
  thus ?thesis by auto
qed

text\<open>Right cons:\<close>

abbreviation Rcons (infix "##" 70) where "xs ## x \<equiv> xs @ [x]"

lemma two_singl_Rcons: "[a,b] = [a] ## b" by auto

lemma length_gt_1_Cons_snoc:
  assumes "length ys > 1"
  obtains x1 xs x2 where "ys = x1 # xs ## x2"
using assms
proof (cases ys)
  case (Cons x1 xs)
    with assms obtain xs' x2 where "xs = xs' ## x2" by (cases xs rule: rev_cases) auto
    with Cons show thesis by (intro that) auto
qed auto

abbreviation lmember ("(_/ \<in>\<in> _)" [50, 51] 50) where "x \<in>\<in> xs \<equiv> x \<in> set xs"

lemma right_cons_left[simp]: "i < length as \<Longrightarrow> (as ## a)!i = as!i"
by (metis butlast_snoc nth_butlast)+

definition "update2 f x y a \<equiv> \<lambda> x' y'. if x = x' \<and> y = y' then a else f x' y'"

fun fst3 where "fst3 (a,b,c) = a"
fun snd3 where "snd3 (a,b,c) = b"
fun trd3 where "trd3 (a,b,c) = c"

lemma subliteq_induct[consumes 1, case_names Nil Cons1 Cons2, induct pred: subseq]:
assumes 0: "subseq xs ys"
and Nil: "\<And> ys. \<phi> [] ys"
and Cons1: "\<And> xs ys y. \<lbrakk>subseq xs ys; \<phi> xs ys\<rbrakk> \<Longrightarrow> \<phi> xs (y#ys)"
and Cons2: "\<And> xs ys x. \<lbrakk>subseq xs ys; \<phi> xs ys\<rbrakk> \<Longrightarrow> \<phi> (x#xs) (x#ys)"
shows "\<phi> xs ys"
using assms by (induct) auto

lemma append_ex_unique_list_ex:
assumes e: "\<exists>!i. i < length as \<and> pred (as!i)"
and as: "as = as1 @ [a] @ as2" and pred: "pred a"
shows "\<not> list_ex pred as1 \<and> \<not> list_ex pred as2"
proof
  let ?i = "length as1"
  have a: "a = as!?i" using as by auto
  have i: "?i < length as" using as by auto
  {fix j assume jl: "j < length as1" and pj: "pred (as1!j)"
   hence "pred (as!j)" apply(subst as) by (metis nth_append)
   moreover have "?i \<noteq> j" and "j < length as" using jl as by auto
   ultimately have False using e pred[unfolded a] i by blast
  }
  thus  "\<not> list_ex pred as1" unfolding list_ex_length by auto
  {fix j assume jl: "j < length as2" and pj: "pred (as2!j)"
   define k where "k \<equiv> Suc (length as1) + j"
   have "pred (as!k)" unfolding k_def apply(subst as)
   using pj nth_append[of "as1 @ [a]" as2] by simp
   moreover have "?i \<noteq> k" and "k < length as" using jl as unfolding k_def by auto
   ultimately have False using e pred[unfolded a] i by blast
  }
  thus  "\<not> list_ex pred as2" unfolding list_ex_length by auto
qed

lemma list_ex_find:
assumes "list_ex P xs"
shows "List.find P xs \<noteq> None"
using assms by (induct xs) auto

lemma list_all_map: "list_all (h o i) l \<longleftrightarrow> list_all h (map i l)"
by (induction l) auto

lemma list_ex_list_all_inj:
  assumes "list_ex (Q u) l"
      and "list_all (Q v) l"
      and "\<And> u v x. Q u x \<Longrightarrow> Q v x \<Longrightarrow> u = v"
  shows "u = v"
using assms by (induction l) auto

definition fun_upd2 where
"fun_upd2 f a b c \<equiv> \<lambda> a' b'. if a = a' \<and> b = b' then c else f a' b'"

lemma fun_upd2_eq_but_a_b:
assumes "a' \<noteq> a \<or> b' \<noteq> b"
shows "(fun_upd2 f a b c) a' b' = f a' b'"
using assms unfolding fun_upd2_def by auto

lemma fun_upd2_comm:
assumes "a' = a \<and> b' = b \<longrightarrow> c' = c"
shows "fun_upd2 (fun_upd2 f a b c) a' b' c' = fun_upd2 (fun_upd2 f a' b' c') a b c"
using assms unfolding fun_upd2_def by (intro ext) auto

lemma fun_upd2_absorb:
shows "fun_upd2 (fun_upd2 f a b c) a b c' = fun_upd2 f a b c'"
unfolding fun_upd2_def by (intro ext) auto

definition "zip3 as bs cs \<equiv> zip as (zip bs cs)"
definition "zip4 as bs cs ds \<equiv> zip as (zip bs (zip cs ds))"

lemma set_map_fst: "set as \<subseteq> set bs \<Longrightarrow> set (map fst as) \<subseteq> set (map fst bs)"
by auto

lemma set_map_snd: "set as \<subseteq> set bs \<Longrightarrow> set (map snd as) \<subseteq> set (map snd bs)"
by auto

lemma filter_cong_empty:
assumes "\<forall> x. \<not> pred1 x \<and> \<not> pred2 x"
shows "filter pred1 xl1 = filter pred2 xl2"
using assms by auto

(*****************)
abbreviation "cmap ff aal \<equiv> concat (map ff aal)"

lemma cmap_empty:
assumes "\<forall> x. x \<in>\<in> xl \<longrightarrow> ff x = []"
shows "cmap ff xl = []"
using assms by (induct xl) auto

lemma cmap_cong_empty:
assumes "\<forall> x. ff x = [] \<and> gg x = []"
shows "cmap ff xl = cmap gg yl"
using assms by (auto simp: cmap_empty)

lemma list_ex_cmap:
"list_ex P (cmap f xs) \<longleftrightarrow> (\<exists> x. x \<in>\<in> xs \<and> list_ex P (f x))"
by (induction xs) auto

lemma not_list_ex_filter:
assumes "\<not> list_ex P xs" shows "filter P xs = []"
using assms by (induct xs) auto

lemma cmap_filter_cong:
assumes "\<And> x u. x \<in>\<in> xs \<Longrightarrow> u \<in>\<in> ff x \<Longrightarrow> (q x \<longleftrightarrow> p u)"
and "\<And> x. x \<in>\<in> xs \<Longrightarrow> q x \<Longrightarrow> gg x = ff x"
shows "cmap ((filter p) o ff) xs = cmap gg (filter q xs)"
using assms by (induction xs) fastforce+

lemma cmap_cong:
  assumes "xs = ys" and "\<And>x. x \<in>\<in> xs \<Longrightarrow> ff x = gg x"
  shows "cmap ff xs = cmap gg ys"
  using assms by (induction xs arbitrary: ys) auto

lemma cmap_empty_singl_filter[simp]:
"cmap (\<lambda>x. if pred x then [x] else []) xl = filter pred xl"
  by (induct xl) auto

lemma cmap_insort_empty:
  assumes "ff x = []"
  shows "cmap ff (insort_key f x xs) = cmap ff xs"
  using assms by (induction xs) auto

lemma cmap_insort_empty_cong:
  assumes "xs = ys" and "\<And>x. x \<in>\<in> xs \<Longrightarrow> ff x = gg x" and x: "ff x = []"
  shows "cmap ff (insort_key f x xs) = cmap gg ys"
  using assms by (auto intro: cmap_cong simp: cmap_insort_empty)

abbreviation never :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where "never U \<equiv> list_all (\<lambda> a. \<not> U a)"

lemma never_list_ex: "never pred tr \<longleftrightarrow> \<not> list_ex pred tr"
by (induction tr) auto

lemma notNil_list_all_list_ex:
assumes "xs \<noteq> Nil" and "list_all pred xs"
shows "list_ex pred xs"
using assms by (induct xs) auto

fun remove1ByFirst :: "'a \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
"remove1ByFirst a [] = []"
|
"remove1ByFirst a ((a1,b1) # a_bs) = (if a = a1 then a_bs else (a1,b1) # (remove1ByFirst a a_bs))"

(* "insert2 a b ab_s" searches in the list of pairs ab_s for a the first component a and replaces the second component with b;
if no match is found, (a,b) is added at the end.
It's similar to a function update applied to a list of pairs, with adding if missing.  *)
definition "insert2 a b ab_s \<equiv>
  if a \<in>\<in> map fst ab_s
    then map (\<lambda> (a',b'). if a' = a then (a',b) else (a',b')) ab_s
    else ab_s ## (a,b)"

lemma test_insert2:
"insert2 (1::nat) (2::nat) [(2,3),(1,5)] = [(2,3),(1,2)]"
"insert2 (1::nat) (2::nat) [(2,3),(4,5)] = [(2,3),(4,5),(1,2)]"
unfolding insert2_def by simp_all

lemma map_prod_cong:
"map (fst o f) xys = map (fst o f2) xys' \<Longrightarrow>
 map (snd o f) xys = map (snd o f2) xys'
 \<Longrightarrow> map f xys = map f2 xys'"
by (simp add: pair_list_eqI)

lemma map_const_eq: "length xs = length xs' \<Longrightarrow> map (\<lambda> x. a) xs = map (\<lambda> x. a) xs'"
by (simp add: map_replicate_const)

fun these :: "'a option list \<Rightarrow> 'a list" where
  "these [] = []"
| "these (None # xs) = these xs"
| "these (Some x # xs) = x # these xs"

lemma these_map_Some[simp]: "these (map (Some o f) xs) = map f xs"
by (induction xs) auto

end
(*>*)


(*                                                        *)
(* Formalisation of some typical SOS-proofs.              *)
(*                                                        *)
(* This work was inspired by challenge suggested by Adam  *)
(* Chlipala on the POPLmark mailing list.                 *)
(*                                                        *)
(* We thank Nick Benton for helping us with the           *)
(* termination-proof for evaluation.                      *)
(*                                                        *)
(* The formalisation was done by Julien Narboux and       *)
(* Christian Urban.                                       *)

theory SOS
  imports "../Nominal"
begin

atom_decl name

text {* types and terms *}
nominal_datatype ty =
    TVar "nat"
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
    Var "name"
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm"

lemma fresh_ty:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_nat)

text {* Parallel and single substitution. *}
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"
  shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
by (induct \<theta>) (auto simp add: eqvts)

lemma lookup_fresh:
  fixes z::"name"
  assumes a: "z\<sharp>\<theta>" and b: "z\<sharp>x"
  shows "z \<sharp>lookup \<theta> x"
using a b
by (induct rule: lookup.induct) (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using assms
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

(* parallel substitution *)

nominal_primrec
  psubst :: "(name\<times>trm) list \<Rightarrow> trm \<Rightarrow> trm"  ("_<_>" [95,95] 105)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App e\<^sub>1 e\<^sub>2)> = App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>)"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma psubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t::"trm"
  shows "pi\<bullet>(\<theta><t>) = (pi\<bullet>\<theta>)<(pi\<bullet>t)>"
by (nominal_induct t avoiding: \<theta> rule: trm.strong_induct)
   (perm_simp add: fresh_bij lookup_eqvt)+

lemma fresh_psubst:
  fixes z::"name"
  and   t::"trm"
  assumes "z\<sharp>t" and "z\<sharp>\<theta>"
  shows "z\<sharp>(\<theta><t>)"
using assms
by (nominal_induct t avoiding: z \<theta> t rule: trm.strong_induct)
   (auto simp add: abs_fresh lookup_fresh)

lemma psubst_empty[simp]:
  shows "[]<t> = t"
  by (nominal_induct t rule: trm.strong_induct)
     (auto simp add: fresh_list_nil)

text {* Single substitution *}
abbreviation
  subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t\<^sub>1 t\<^sub>2)[y::=t'] = App (t\<^sub>1[y::=t']) (t\<^sub>2[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
by (simp_all add: fresh_list_cons fresh_list_nil)

lemma fresh_subst:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

lemma forget:
  assumes a: "x\<sharp>e"
  shows "e[x::=e'] = e"
using a
by (nominal_induct e avoiding: x e' rule: trm.strong_induct)
   (auto simp add: fresh_atm abs_fresh)

lemma psubst_subst_psubst:
  assumes h: "x\<sharp>\<theta>"
  shows "\<theta><e>[x::=e'] = ((x,e')#\<theta>)<e>"
  using h
by (nominal_induct e avoiding: \<theta> x e' rule: trm.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh')

text {* Typing Judgements *}

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
  v_nil[intro]:  "valid []"
| v_cons[intro]: "\<lbrakk>valid \<Gamma>;x\<sharp>\<Gamma>\<rbrakk> \<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

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

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

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 a1: "valid \<Gamma>"
  and     a2: "(x,T) \<in> set \<Gamma>"
  and     a3: "(x,U) \<in> set \<Gamma>"
  shows "T = U"
using a1 a2 a3
by (induct) (auto simp add: fresh_set fresh_prod fresh_atm)

text {* Typing Relation *}

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
  t_Var[intro]:   "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| t_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> e\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> e\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T\<^sub>2"
| t_Lam[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> e : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].e : T\<^sub>1\<rightarrow>T\<^sub>2"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh fresh_ty)

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
using a by (induct) (auto)

lemma t_App_elim:
  assumes a: "\<Gamma> \<turnstile> App t1 t2 : T"
  obtains T' where "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T" and "\<Gamma> \<turnstile> t2 : T'"
using a
by (cases) (auto simp add: trm.inject)

lemma t_Lam_elim:
  assumes a: "\<Gamma> \<turnstile> Lam [x].t : T" "x\<sharp>\<Gamma>"
  obtains T\<^sub>1 and T\<^sub>2 where "(x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2" and "T=T\<^sub>1\<rightarrow>T\<^sub>2"
using a
by (cases rule: typing.strong_cases [where x="x"])
   (auto simp add: abs_fresh fresh_ty alpha trm.inject)

abbreviation
  "sub_context" :: "(name\<times>ty) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ \<subseteq> _" [55,55] 55)
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>\<^sub>1 \<longrightarrow> (x,T)\<in>set \<Gamma>\<^sub>2"

lemma weakening:
  fixes \<Gamma>\<^sub>1 \<Gamma>\<^sub>2::"(name\<times>ty) list"
  assumes "\<Gamma>\<^sub>1 \<turnstile> e: T" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2"
  shows "\<Gamma>\<^sub>2 \<turnstile> e: T"
  using assms
proof(nominal_induct \<Gamma>\<^sub>1 e T avoiding: \<Gamma>\<^sub>2 rule: typing.strong_induct)
  case (t_Lam x \<Gamma>\<^sub>1 T\<^sub>1 t T\<^sub>2 \<Gamma>\<^sub>2)
  have vc: "x\<sharp>\<Gamma>\<^sub>2" by fact
  have ih: "\<lbrakk>valid ((x,T\<^sub>1)#\<Gamma>\<^sub>2); (x,T\<^sub>1)#\<Gamma>\<^sub>1 \<subseteq> (x,T\<^sub>1)#\<Gamma>\<^sub>2\<rbrakk> \<Longrightarrow> (x,T\<^sub>1)#\<Gamma>\<^sub>2 \<turnstile> t : T\<^sub>2" by fact
  have "valid \<Gamma>\<^sub>2" by fact
  then have "valid ((x,T\<^sub>1)#\<Gamma>\<^sub>2)" using vc by auto
  moreover
  have "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2" by fact
  then have "(x,T\<^sub>1)#\<Gamma>\<^sub>1 \<subseteq> (x,T\<^sub>1)#\<Gamma>\<^sub>2" by simp
  ultimately have "(x,T\<^sub>1)#\<Gamma>\<^sub>2 \<turnstile> t : T\<^sub>2" using ih by simp
  with vc show "\<Gamma>\<^sub>2 \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
qed (auto)

lemma type_substitutivity_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct \<Gamma>\<equiv>"\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: e' \<Delta> rule: typing.strong_induct)
  case (t_Var y T e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" by blast
qed (force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitutivity:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b type_substitutivity_aux[where \<Delta>="[]"]
by (auto)

text {* Values *}
inductive
  val :: "trm\<Rightarrow>bool"
where
  v_Lam[intro]:   "val (Lam [x].e)"

equivariance val

lemma not_val_App[simp]:
  shows
  "\<not> val (App e\<^sub>1 e\<^sub>2)"
  "\<not> val (Var x)"
  by (auto elim: val.cases)

text {* Big-Step Evaluation *}

inductive
  big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  b_Lam[intro]:   "Lam [x].e \<Down> Lam [x].e"
| b_App[intro]:   "\<lbrakk>x\<sharp>(e\<^sub>1,e\<^sub>2,e'); e\<^sub>1\<Down>Lam [x].e; e\<^sub>2\<Down>e\<^sub>2'; e[x::=e\<^sub>2']\<Down>e'\<rbrakk> \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<Down> e'"

equivariance big

nominal_inductive big
  by (simp_all add: abs_fresh)

lemma big_preserves_fresh:
  fixes x::"name"
  assumes a: "e \<Down> e'" "x\<sharp>e"
  shows "x\<sharp>e'"
  using a by (induct) (auto simp add: abs_fresh fresh_subst)

lemma b_App_elim:
  assumes a: "App e\<^sub>1 e\<^sub>2 \<Down> e'" "x\<sharp>(e\<^sub>1,e\<^sub>2,e')"
  obtains f\<^sub>1 and f\<^sub>2 where "e\<^sub>1 \<Down> Lam [x]. f\<^sub>1" "e\<^sub>2 \<Down> f\<^sub>2" "f\<^sub>1[x::=f\<^sub>2] \<Down> e'"
  using a
by (cases rule: big.strong_cases[where x="x" and xa="x"])
   (auto simp add: trm.inject)

lemma subject_reduction:
  assumes a: "e \<Down> e'" and b: "\<Gamma> \<turnstile> e : T"
  shows "\<Gamma> \<turnstile> e' : T"
  using a b
proof (nominal_induct avoiding: \<Gamma> arbitrary: T rule: big.strong_induct)
  case (b_App x e\<^sub>1 e\<^sub>2 e' e e\<^sub>2' \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> e\<^sub>1 : T'\<rightarrow>T" and a2: "\<Gamma> \<turnstile> e\<^sub>2 : T'"
    by (cases) (auto simp add: trm.inject)
  have ih1: "\<Gamma> \<turnstile> e\<^sub>1 : T' \<rightarrow> T \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].e : T' \<rightarrow> T" by fact
  have ih2: "\<Gamma> \<turnstile> e\<^sub>2 : T' \<Longrightarrow> \<Gamma> \<turnstile> e\<^sub>2' : T'" by fact
  have ih3: "\<Gamma> \<turnstile> e[x::=e\<^sub>2'] : T \<Longrightarrow> \<Gamma> \<turnstile> e' : T" by fact
  have "\<Gamma> \<turnstile> Lam [x].e : T'\<rightarrow>T" using ih1 a1 by simp
  then have "((x,T')#\<Gamma>) \<turnstile> e : T" using vc
    by (auto elim: t_Lam_elim simp add: ty.inject)
  moreover
  have "\<Gamma> \<turnstile> e\<^sub>2': T'" using ih2 a2 by simp
  ultimately have "\<Gamma> \<turnstile> e[x::=e\<^sub>2'] : T" by (simp add: type_substitutivity)
  thus "\<Gamma> \<turnstile> e' : T" using ih3 by simp
qed (blast)

lemma subject_reduction2:
  assumes a: "e \<Down> e'" and b: "\<Gamma> \<turnstile> e : T"
  shows "\<Gamma> \<turnstile> e' : T"
  using a b
by (nominal_induct avoiding: \<Gamma> T rule: big.strong_induct)
   (force elim: t_App_elim t_Lam_elim simp add: ty.inject type_substitutivity)+

lemma unicity_of_evaluation:
  assumes a: "e \<Down> e\<^sub>1"
  and     b: "e \<Down> e\<^sub>2"
  shows "e\<^sub>1 = e\<^sub>2"
  using a b
proof (nominal_induct e e\<^sub>1 avoiding: e\<^sub>2 rule: big.strong_induct)
  case (b_Lam x e t\<^sub>2)
  have "Lam [x].e \<Down> t\<^sub>2" by fact
  thus "Lam [x].e = t\<^sub>2" by cases (simp_all add: trm.inject)
next
  case (b_App x e\<^sub>1 e\<^sub>2 e' e\<^sub>1' e\<^sub>2' t\<^sub>2)
  have ih1: "\<And>t. e\<^sub>1 \<Down> t \<Longrightarrow> Lam [x].e\<^sub>1' = t" by fact
  have ih2:"\<And>t. e\<^sub>2 \<Down> t \<Longrightarrow> e\<^sub>2' = t" by fact
  have ih3: "\<And>t. e\<^sub>1'[x::=e\<^sub>2'] \<Down> t \<Longrightarrow> e' = t" by fact
  have app: "App e\<^sub>1 e\<^sub>2 \<Down> t\<^sub>2" by fact
  have vc: "x\<sharp>e\<^sub>1" "x\<sharp>e\<^sub>2" "x\<sharp>t\<^sub>2" by fact+
  then have "x\<sharp>App e\<^sub>1 e\<^sub>2" by auto
  from app vc obtain f\<^sub>1 f\<^sub>2 where x1: "e\<^sub>1 \<Down> Lam [x]. f\<^sub>1" and x2: "e\<^sub>2 \<Down> f\<^sub>2" and x3: "f\<^sub>1[x::=f\<^sub>2] \<Down> t\<^sub>2"
    by (auto elim!: b_App_elim)
  then have "Lam [x]. f\<^sub>1 = Lam [x]. e\<^sub>1'" using ih1 by simp
  then
  have "f\<^sub>1 = e\<^sub>1'" by (auto simp add: trm.inject alpha)
  moreover
  have "f\<^sub>2 = e\<^sub>2'" using x2 ih2 by simp
  ultimately have "e\<^sub>1'[x::=e\<^sub>2'] \<Down> t\<^sub>2" using x3 by simp
  thus "e' = t\<^sub>2" using ih3 by simp
qed

lemma reduces_evaluates_to_values:
  assumes h: "t \<Down> t'"
  shows "val t'"
using h by (induct) (auto)

(* Valuation *)

nominal_primrec
  V :: "ty \<Rightarrow> trm set"
where
  "V (TVar x) = {e. val e}"
| "V (T\<^sub>1 \<rightarrow> T\<^sub>2) = {Lam [x].e | x e. \<forall> v \<in> (V T\<^sub>1). \<exists> v'. e[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2}"
  by (rule TrueI)+

lemma V_eqvt:
  fixes pi::"name prm"
  assumes a: "x\<in>V T"
  shows "(pi\<bullet>x)\<in>V T"
using a
apply(nominal_induct T arbitrary: pi x rule: ty.strong_induct)
apply(auto simp add: trm.inject)
apply(simp add: eqvts)
apply(rule_tac x="pi\<bullet>xa" in exI)
apply(rule_tac x="pi\<bullet>e" in exI)
apply(simp)
apply(auto)
apply(drule_tac x="(rev pi)\<bullet>v" in bspec)
apply(force)
apply(auto)
apply(rule_tac x="pi\<bullet>v'" in exI)
apply(auto)
apply(drule_tac pi="pi" in big.eqvt)
apply(perm_simp add: eqvts)
done

lemma V_arrow_elim_weak:
  assumes h:"u \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)"
  obtains a t where "u = Lam [a].t" and "\<forall> v \<in> (V T\<^sub>1). \<exists> v'. t[a::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
using h by (auto)

lemma V_arrow_elim_strong:
  fixes c::"'a::fs_name"
  assumes h: "u \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)"
  obtains a t where "a\<sharp>c" "u = Lam [a].t" "\<forall>v \<in> (V T\<^sub>1). \<exists> v'. t[a::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
using h
apply -
apply(erule V_arrow_elim_weak)
apply(subgoal_tac "\<exists>a'::name. a'\<sharp>(a,t,c)") (*A*)
apply(erule exE)
apply(drule_tac x="a'" in meta_spec)
apply(drule_tac x="[(a,a')]\<bullet>t" in meta_spec)
apply(drule meta_mp)
apply(simp)
apply(drule meta_mp)
apply(simp add: trm.inject alpha fresh_left fresh_prod calc_atm fresh_atm)
apply(perm_simp)
apply(force)
apply(drule meta_mp)
apply(rule ballI)
apply(drule_tac x="[(a,a')]\<bullet>v" in bspec)
apply(simp add: V_eqvt)
apply(auto)
apply(rule_tac x="[(a,a')]\<bullet>v'" in exI)
apply(auto)
apply(drule_tac pi="[(a,a')]" in big.eqvt)
apply(perm_simp add: eqvts calc_atm)
apply(simp add: V_eqvt)
(*A*)
apply(rule exists_fresh')
apply(simp add: fin_supp)
done

lemma Vs_are_values:
  assumes a: "e \<in> V T"
  shows "val e"
using a by (nominal_induct T arbitrary: e rule: ty.strong_induct) (auto)

lemma values_reduce_to_themselves:
  assumes a: "val v"
  shows "v \<Down> v"
using a by (induct) (auto)

lemma Vs_reduce_to_themselves:
  assumes a: "v \<in> V T"
  shows "v \<Down> v"
using a by (simp add: values_reduce_to_themselves Vs_are_values)

text {* '\<theta> maps x to e' asserts that \<theta> substitutes x with e *}
abbreviation
  mapsto :: "(name\<times>trm) list \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> bool" ("_ maps _ to _" [55,55,55] 55)
where
 "\<theta> maps x to e \<equiv> (lookup \<theta> x) = e"

abbreviation
  v_closes :: "(name\<times>trm) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ Vcloses _" [55,55] 55)
where
  "\<theta> Vcloses \<Gamma> \<equiv> \<forall>x T. (x,T) \<in> set \<Gamma> \<longrightarrow> (\<exists>v. \<theta> maps x to v \<and> v \<in> V T)"

lemma case_distinction_on_context:
  fixes \<Gamma>::"(name\<times>ty) list"
  assumes asm1: "valid ((m,t)#\<Gamma>)"
  and     asm2: "(n,U) \<in> set ((m,T)#\<Gamma>)"
  shows "(n,U) = (m,T) \<or> ((n,U) \<in> set \<Gamma> \<and> n \<noteq> m)"
proof -
  from asm2 have "(n,U) \<in> set [(m,T)] \<or> (n,U) \<in> set \<Gamma>" by auto
  moreover
  { assume eq: "m=n"
    assume "(n,U) \<in> set \<Gamma>"
    then have "\<not> n\<sharp>\<Gamma>"
      by (induct \<Gamma>) (auto simp add: fresh_list_cons fresh_prod fresh_atm)
    moreover have "m\<sharp>\<Gamma>" using asm1 by auto
    ultimately have False using eq by auto
  }
  ultimately show ?thesis by auto
qed

lemma monotonicity:
  fixes m::"name"
  fixes \<theta>::"(name \<times> trm) list"
  assumes h1: "\<theta> Vcloses \<Gamma>"
  and     h2: "e \<in> V T"
  and     h3: "valid ((x,T)#\<Gamma>)"
  shows "(x,e)#\<theta> Vcloses (x,T)#\<Gamma>"
proof(intro strip)
  fix x' T'
  assume "(x',T') \<in> set ((x,T)#\<Gamma>)"
  then have "((x',T')=(x,T)) \<or> ((x',T')\<in>set \<Gamma> \<and> x'\<noteq>x)" using h3
    by (rule_tac case_distinction_on_context)
  moreover
  { (* first case *)
    assume "(x',T') = (x,T)"
    then have "\<exists>e'. ((x,e)#\<theta>) maps x to e' \<and> e' \<in> V T'" using h2 by auto
  }
  moreover
  { (* second case *)
    assume "(x',T') \<in> set \<Gamma>" and neq:"x' \<noteq> x"
      then have "\<exists>e'. \<theta> maps x' to e' \<and> e' \<in> V T'" using h1 by auto
      then have "\<exists>e'. ((x,e)#\<theta>) maps x' to e' \<and> e' \<in> V T'" using neq by auto
  }
  ultimately show "\<exists>e'.  ((x,e)#\<theta>) maps x' to e'  \<and> e' \<in> V T'" by blast
qed

lemma termination_aux:
  assumes h1: "\<Gamma> \<turnstile> e : T"
  and     h2: "\<theta> Vcloses \<Gamma>"
  shows "\<exists>v. \<theta><e> \<Down> v \<and> v \<in> V T"
using h2 h1
proof(nominal_induct e avoiding: \<Gamma> \<theta> arbitrary: T rule: trm.strong_induct)
  case (App e\<^sub>1 e\<^sub>2 \<Gamma> \<theta> T)
  have ih\<^sub>1: "\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e\<^sub>1 : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e\<^sub>1> \<Down> v \<and> v \<in> V T" by fact
  have ih\<^sub>2: "\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e\<^sub>2 : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e\<^sub>2> \<Down> v \<and> v \<in> V T" by fact
  have as\<^sub>1: "\<theta> Vcloses \<Gamma>" by fact
  have as\<^sub>2: "\<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T" by fact
  then obtain T' where "\<Gamma> \<turnstile> e\<^sub>1 : T' \<rightarrow> T" and "\<Gamma> \<turnstile> e\<^sub>2 : T'" by (auto elim: t_App_elim)
  then obtain v\<^sub>1 v\<^sub>2 where "(i)": "\<theta><e\<^sub>1> \<Down> v\<^sub>1" "v\<^sub>1 \<in> V (T' \<rightarrow> T)"
                      and "(ii)": "\<theta><e\<^sub>2> \<Down> v\<^sub>2" "v\<^sub>2 \<in> V T'" using ih\<^sub>1 ih\<^sub>2 as\<^sub>1 by blast
  from "(i)" obtain x e'
            where "v\<^sub>1 = Lam [x].e'"
            and "(iii)": "(\<forall>v \<in> (V T').\<exists> v'. e'[x::=v] \<Down> v' \<and> v' \<in> V T)"
            and "(iv)":  "\<theta><e\<^sub>1> \<Down> Lam [x].e'"
            and fr: "x\<sharp>(\<theta>,e\<^sub>1,e\<^sub>2)" by (blast elim: V_arrow_elim_strong)
  from fr have fr\<^sub>1: "x\<sharp>\<theta><e\<^sub>1>" and fr\<^sub>2: "x\<sharp>\<theta><e\<^sub>2>" by (simp_all add: fresh_psubst)
  from "(ii)" "(iii)" obtain v\<^sub>3 where "(v)": "e'[x::=v\<^sub>2] \<Down> v\<^sub>3" "v\<^sub>3 \<in> V T" by auto
  from fr\<^sub>2 "(ii)" have "x\<sharp>v\<^sub>2" by (simp add: big_preserves_fresh)
  then have "x\<sharp>e'[x::=v\<^sub>2]" by (simp add: fresh_subst)
  then have fr\<^sub>3: "x\<sharp>v\<^sub>3" using "(v)" by (simp add: big_preserves_fresh)
  from fr\<^sub>1 fr\<^sub>2 fr\<^sub>3 have "x\<sharp>(\<theta><e\<^sub>1>,\<theta><e\<^sub>2>,v\<^sub>3)" by simp
  with "(iv)" "(ii)" "(v)" have "App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>) \<Down> v\<^sub>3" by auto
  then show "\<exists>v. \<theta><App e\<^sub>1 e\<^sub>2> \<Down> v \<and> v \<in> V T" using "(v)" by auto
next
  case (Lam x e \<Gamma> \<theta> T)
  have ih:"\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e> \<Down> v \<and> v \<in> V T" by fact
  have as\<^sub>1: "\<theta> Vcloses \<Gamma>" by fact
  have as\<^sub>2: "\<Gamma> \<turnstile> Lam [x].e : T" by fact
  have fs: "x\<sharp>\<Gamma>" "x\<sharp>\<theta>" by fact+
  from as\<^sub>2 fs obtain T\<^sub>1 T\<^sub>2
    where "(i)": "(x,T\<^sub>1)#\<Gamma> \<turnstile> e:T\<^sub>2" and "(ii)": "T = T\<^sub>1 \<rightarrow> T\<^sub>2" using fs
    by (auto elim: t_Lam_elim)
  from "(i)" have "(iii)": "valid ((x,T\<^sub>1)#\<Gamma>)" by (simp add: typing_implies_valid)
  have "\<forall>v \<in> (V T\<^sub>1). \<exists>v'. (\<theta><e>)[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
  proof
    fix v
    assume "v \<in> (V T\<^sub>1)"
    with "(iii)" as\<^sub>1 have "(x,v)#\<theta> Vcloses (x,T\<^sub>1)#\<Gamma>" using monotonicity by auto
    with ih "(i)" obtain v' where "((x,v)#\<theta>)<e> \<Down> v' \<and> v' \<in> V T\<^sub>2" by blast
    then have "\<theta><e>[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2" using fs by (simp add: psubst_subst_psubst)
    then show "\<exists>v'. \<theta><e>[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2" by auto
  qed
  then have "Lam[x].\<theta><e> \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)" by auto
  then have "\<theta><Lam [x].e> \<Down> Lam [x].\<theta><e> \<and> Lam [x].\<theta><e> \<in> V (T\<^sub>1\<rightarrow>T\<^sub>2)" using fs by auto
  thus "\<exists>v. \<theta><Lam [x].e> \<Down> v \<and> v \<in> V T" using "(ii)" by auto
next
  case (Var x \<Gamma> \<theta> T)
  have "\<Gamma> \<turnstile> (Var x) : T" by fact
  then have "(x,T)\<in>set \<Gamma>" by (cases) (auto simp add: trm.inject)
  with Var have "\<theta><Var x> \<Down> \<theta><Var x> \<and> \<theta><Var x>\<in> V T"
    by (auto intro!: Vs_reduce_to_themselves)
  then show "\<exists>v. \<theta><Var x> \<Down> v \<and> v \<in> V T" by auto
qed

theorem termination_of_evaluation:
  assumes a: "[] \<turnstile> e : T"
  shows "\<exists>v. e \<Down> v \<and> val v"
proof -
  from a have "\<exists>v. []<e> \<Down> v \<and> v \<in> V T" by (rule termination_aux) (auto)
  thus "\<exists>v. e \<Down> v \<and> val v" using Vs_are_values by auto
qed

end


section \<open>Instantiation of class \<open>term\<close> for type \<open>term\<close>\<close>

theory Term
imports Term_Class
begin

instantiation "term" :: "term" begin

text \<open>
  All of these definitions need to be marked as \<open>code del\<close>; otherwise the code generator will
  attempt to generate these, which will fail because they are not executable.
\<close>

definition abs_pred_term :: "(term \<Rightarrow> bool) \<Rightarrow> term \<Rightarrow> bool" where
[code del]: "abs_pred P t \<longleftrightarrow>
  (\<forall>x. t = Bound x \<longrightarrow> P t) \<and>
  (\<forall>t'. t = \<Lambda> t' \<longrightarrow> P t' \<longrightarrow> P t)"

instance proof (standard, goal_cases)
  case (1 P t)
  then show ?case
    by (induction t) (auto simp: abs_pred_term_def const_term_def free_term_def app_term_def)
qed (auto simp: abs_pred_term_def)

end

lemma is_const_free[simp]: "\<not> is_const (Free name)"
unfolding is_const_def by simp

lemma is_free_app[simp]: "\<not> is_free (t $ u)"
unfolding is_free_def by simp

lemma is_free_free[simp]: "is_free (Free name)"
unfolding is_free_def by simp

lemma is_const_const[simp]: "is_const (Const name)"
unfolding is_const_def by simp

lemma list_comb_free: "is_free (list_comb f xs) \<Longrightarrow> is_free f"
apply (induction xs arbitrary: f)
apply auto
subgoal premises prems
  apply (insert prems(1)[OF prems(2)])
  unfolding app_term_def
  by simp
done

lemma const_list_comb_free[simp]: "\<not> is_free (name $$ args)"
by (fastforce dest: list_comb_free simp: const_term_def)

corollary const_list_comb_neq_free[simp]: "name $$ args \<noteq> free name'"
by (metis const_list_comb_free is_free_simps(1))

declare const_list_comb_neq_free[symmetric, simp]

lemma match_list_comb_list_comb_eq_lengths[simp]:
  assumes "length ps = length vs"
  shows "match (list_comb f ps) (list_comb g vs) =
    (case match f g of
      Some env \<Rightarrow>
        (case those (map2 match ps vs) of
          Some envs \<Rightarrow> Some (foldl (++\<^sub>f) env envs)
        | None \<Rightarrow> None)
    | None \<Rightarrow> None)"
using assms
by (induction ps vs arbitrary: f g rule: list_induct2) (auto split: option.splits simp: app_term_def)

lemma matchs_match_list_comb[simp]: "match (name $$ xs) (name $$ ys) = matchs xs ys"
proof (induction xs arbitrary: ys rule: rev_induct)
  case Nil
  show ?case
    by (cases ys rule: rev_cases) (auto simp: const_term_def)
next
  case (snoc x xs)
  note snoc0 = snoc
  have "match (name $$ xs $ x) (name $$ ys) = matchs (xs @ [x]) ys"
    proof (cases ys rule: rev_cases)
      case (snoc zs z)
      show ?thesis
        unfolding snoc using snoc0
        by simp
    qed auto
  thus ?case
    by (simp add: app_term_def)
qed

fun bounds :: "term \<Rightarrow> nat fset" where
"bounds (Bound i) = {| i |}" |
"bounds (t\<^sub>1 $ t\<^sub>2) = bounds t\<^sub>1 |\<union>| bounds t\<^sub>2" |
"bounds (\<Lambda> t) = (\<lambda>i. i - 1) |`| (bounds t - {| 0 |})" |
"bounds _ = {||}"

definition shift_nat :: "nat \<Rightarrow> int \<Rightarrow> nat" where
[simp]: "shift_nat n k = (if k \<ge> 0 then n + nat k else n - nat \<bar>k\<bar>)"

fun incr_bounds :: "int \<Rightarrow> nat \<Rightarrow> term \<Rightarrow> term" where
"incr_bounds inc lev (Bound i) = (if i \<ge> lev then Bound (shift_nat i inc) else Bound i)" |
"incr_bounds inc lev (\<Lambda> u) = \<Lambda> incr_bounds inc (lev + 1) u" |
"incr_bounds inc lev (t\<^sub>1 $ t\<^sub>2) = incr_bounds inc lev t\<^sub>1 $ incr_bounds inc lev t\<^sub>2" |
"incr_bounds _ _ t = t"

lemma incr_bounds_frees[simp]: "frees (incr_bounds n k t) = frees t"
by (induction n k t rule: incr_bounds.induct) auto

lemma incr_bounds_zero[simp]: "incr_bounds 0 i t = t"
by (induct t arbitrary: i) auto

fun replace_bound :: "nat \<Rightarrow> term \<Rightarrow> term \<Rightarrow> term" where
"replace_bound lev (Bound i) t = (if i < lev then Bound i else if i = lev then incr_bounds (int lev) 0 t else Bound (i - 1))" |
"replace_bound lev (t\<^sub>1 $ t\<^sub>2) t = replace_bound lev t\<^sub>1 t $ replace_bound lev t\<^sub>2 t" |
"replace_bound lev (\<Lambda> u) t = \<Lambda> replace_bound (lev + 1) u t" |
"replace_bound _ t _ = t"

abbreviation \<beta>_reduce :: "term \<Rightarrow> term \<Rightarrow> term" ("_ [_]\<^sub>\<beta>") where
"t [u]\<^sub>\<beta> \<equiv> replace_bound 0 t u"

lemma replace_bound_frees: "frees (replace_bound n t t') |\<subseteq>| frees t |\<union>| frees t'"
by (induction n t t' rule: replace_bound.induct) auto

lemma replace_bound_eq:
  assumes "i |\<notin>| bounds t"
  shows "replace_bound i t t' = incr_bounds (-1) (i + 1) t"
using assms
by (induct t arbitrary: i) force+

fun wellformed' :: "nat \<Rightarrow> term \<Rightarrow> bool" where
"wellformed' n (t\<^sub>1 $ t\<^sub>2) \<longleftrightarrow> wellformed' n t\<^sub>1 \<and> wellformed' n t\<^sub>2" |
"wellformed' n (Bound n') \<longleftrightarrow> n' < n" |
"wellformed' n (\<Lambda> t) \<longleftrightarrow> wellformed' (n + 1) t" |
"wellformed' _ _ \<longleftrightarrow> True"

lemma wellformed_inc:
  assumes "wellformed' k t" "k \<le> n"
  shows "wellformed' n t"
using assms
by (induct t arbitrary: k n) auto

abbreviation wellformed :: "term \<Rightarrow> bool" where
"wellformed \<equiv> wellformed' 0"

lemma wellformed'_replace_bound_eq:
  assumes "wellformed' n t" "k \<ge> n"
  shows "replace_bound k t u = t"
using assms
by (induction t arbitrary: n k) auto

lemma wellformed_replace_bound_eq: "wellformed t \<Longrightarrow> replace_bound k t u = t"
by (rule wellformed'_replace_bound_eq) simp+

lemma incr_bounds_eq: "n \<ge> k \<Longrightarrow> wellformed' k t \<Longrightarrow> incr_bounds i n t = t"
by (induct t arbitrary: k n) force+

lemma incr_bounds_subst:
  assumes "\<And>t. t \<in> fmran' env \<Longrightarrow> wellformed t"
  shows "incr_bounds i n (subst t env) = subst (incr_bounds i n t) env"
proof (induction t arbitrary: n)
  case (Free name)
  show ?case
    proof (cases "fmlookup env name")
      case (Some t)
      hence "wellformed t"
        using assms by (auto intro: fmran'I)
      hence "incr_bounds i n t = t"
        by (subst incr_bounds_eq) auto
      with Some show ?thesis
        by simp
    qed auto
qed auto

lemma incr_bounds_wellformed:
  assumes "wellformed' m u"
  shows "wellformed' (k + m) (incr_bounds (int k) n u)"
using assms
by (induct u arbitrary: n m) force+

lemma replace_bound_wellformed:
  assumes "wellformed u" "wellformed' (Suc k) t" "i \<le> k"
  shows "wellformed' k (replace_bound i t u)"
using assms
apply (induction t arbitrary: i k)
apply auto
using incr_bounds_wellformed[where m = 0, simplified]
using wellformed_inc by blast

lemma subst_wellformed:
  assumes "wellformed' n t" "fmpred (\<lambda>_. wellformed) env"
  shows "wellformed' n (subst t env)"
using assms
by (induction t arbitrary: n) (auto split: option.splits intro: wellformed_inc)

global_interpretation wellformed: simple_syntactic_and "wellformed' n" for n
by standard (auto simp: app_term_def)

global_interpretation wellformed: subst_syntactic_and wellformed
by standard (auto intro: subst_wellformed)

lemma match_list_combE:
  assumes "match (name $$ xs) t = Some env"
  obtains ys where "t = name $$ ys" "matchs xs ys = Some env"
proof -
  from assms that show thesis
    proof (induction xs arbitrary: t env thesis rule: rev_induct)
      case Nil
      from Nil(1) show ?case
        apply (auto simp: const_term_def split: option.splits if_splits)
        using Nil(2)[where ys = "[]"]
        by auto
    next
      case (snoc x xs)
      obtain t' y where "t = app t' y"
        using \<open>match _ t = Some env\<close>
        by (auto simp: app_term_def elim!: option_bindE)
      from snoc(2) obtain env\<^sub>1 env\<^sub>2
        where "match (name $$ xs) t' = Some env\<^sub>1" "match x y = Some env\<^sub>2" "env = env\<^sub>1 ++\<^sub>f env\<^sub>2"
        unfolding \<open>t = _\<close> by (fastforce simp: app_term_def elim: option_bindE)

      with snoc obtain ys where "t' = name $$ ys" "matchs xs ys = Some env\<^sub>1"
        by blast

      show ?case
        proof (rule snoc(3))
          show "t = name $$ (ys @ [y])"
            unfolding \<open>t = _\<close> \<open>t' = _\<close>
            by simp
        next
          have "matchs [x] [y] = Some env\<^sub>2"
            using \<open>match x y = _\<close> by simp
          thus "matchs (xs @ [x]) (ys @ [y]) = Some env"
            unfolding \<open>env = _\<close> using \<open>matchs xs ys = _\<close>
            by simp
        qed
    qed
qed

lemma left_nesting_neq_match:
  "left_nesting f \<noteq> left_nesting g \<Longrightarrow> is_const (fst (strip_comb f)) \<Longrightarrow> match f g = None"
proof (induction f arbitrary: g)
  case (Const x)
  then show ?case
    apply (auto split: option.splits)
    apply (fold const_term_def)
    apply auto
    done
next
  case (App f1 f2)
  then have f1_g: "Suc (left_nesting f1) \<noteq> left_nesting g" and f1: "is_const (fst (strip_comb f1))"
    apply (fold app_term_def)
    by (auto split: prod.splits)
  show ?case
    proof (cases "unapp g")
      case (Some g')
      obtain g1 g2 where "g' = (g1, g2)"
        by (cases g') auto
      with Some have "g = app g1 g2"
        by auto
      with f1_g have "left_nesting f1 \<noteq> left_nesting g1"
        by simp
      with f1 App have "match f1 g1 = None"
        by simp
      then show ?thesis
        unfolding \<open>g' = _\<close> \<open>g = _\<close>
        by simp
    qed simp
qed auto

context begin

private lemma match_list_comb_list_comb_none_structure:
  assumes "length ps = length vs" "left_nesting f \<noteq> left_nesting g"
  assumes "is_const (fst (strip_comb f))"
  shows "match (list_comb f ps) (list_comb g vs) = None"
using assms
by (induction ps vs arbitrary: f g rule: list_induct2) (auto simp: split_beta left_nesting_neq_match)

      have "match (list_comb f ps) (list_comb (list_comb g vs\<^sub>1) vs\<^sub>2) = None"
        proof (rule match_list_comb_list_comb_none_structure)
          show "left_nesting f \<noteq> left_nesting (list_comb g vs\<^sub>1)"
            using assms(2) \<open>0 < length vs\<^sub>1\<close> by simp
        qed fact+
      hence "match (list_comb f ps) (list_comb g vs) = None"
        unfolding \<open>vs = _\<close> by simp
      hence False
        using assms by auto
      thus ?thesis ..
    next
      assume "length vs < length ps"
      then obtain ps\<^sub>1 ps\<^sub>2 where "ps = ps\<^sub>1 @ ps\<^sub>2" "length ps\<^sub>2 = length vs" "0 < length ps\<^sub>1"
        by (auto elim: list_split)

      have "match (list_comb (list_comb f ps\<^sub>1) ps\<^sub>2) (list_comb g vs) = None"
        proof (rule match_list_comb_list_comb_none_structure)
          show "left_nesting (list_comb f ps\<^sub>1) \<noteq> left_nesting g"
            using assms \<open>0 < length ps\<^sub>1\<close> by simp
        next
          show "is_const (fst (strip_comb (list_comb f ps\<^sub>1)))"
            using assms by (simp add: strip_list_comb)
        qed fact
      hence "match (list_comb f ps) (list_comb g vs) = None"
        unfolding \<open>ps = _\<close> by simp
      hence False
        using assms by auto
      thus ?thesis ..
    qed
  thus "match f g \<noteq> None" "length ps = length vs"
    by simp+
qed

end

lemma match_list_comb_list_comb_none_length[simp]:
  assumes "length ps \<noteq> length vs"
  shows "match (name $$ ps) (name' $$ vs) = None"
proof (rule ccontr)
  assume "match (name $$ ps) (name' $$ vs) \<noteq> None"
  then obtain env where "match (name $$ ps) (name' $$ vs) = Some env"
    by blast
  hence "length ps = length vs"
    by (rule match_list_comb_list_comb_some) (simp add: is_const_def)+
  thus False
    using assms by blast
qed

context term_struct_rel begin

corollary related_matchs:
  assumes "matchs ps ts\<^sub>2 = Some env\<^sub>2" "list_all2 P ts\<^sub>1 ts\<^sub>2"
  obtains env\<^sub>1 where "matchs ps ts\<^sub>1 = Some env\<^sub>1" "P_env env\<^sub>1 env\<^sub>2"
proof -
  fix name \<comment> \<open>dummy\<close>

  from assms have "match (name $$ ps) (name $$ ts\<^sub>2) = Some env\<^sub>2"
    by simp
  moreover have "P (name $$ ts\<^sub>1) (name $$ ts\<^sub>2)"
    using assms by (auto intro: P_const_const list_combI)
  ultimately obtain env\<^sub>1 where "match (name $$ ps) (name $$ ts\<^sub>1) = Some env\<^sub>1" "P_env env\<^sub>1 env\<^sub>2"
    by (metis related_match)
  hence "matchs ps ts\<^sub>1 = Some env\<^sub>1"
    by simp

  show thesis
    by (rule that) fact+
qed

end

end


(*  Title:      HOL/Library/RBT_Set.thy
    Author:     Ondrej Kuncar
*)

section \<open>Implementation of sets using RBT trees\<close>

theory RBT_Set
imports RBT Product_Lexorder
begin

(*
  Users should be aware that by including this file all code equations
  outside of List.thy using 'a list as an implementation of sets cannot be
  used for code generation. If such equations are not needed, they can be
  deleted from the code generator. Otherwise, a user has to provide their
  own equations using RBT trees.
*)

section \<open>Definition of code datatype constructors\<close>

definition Set :: "('a::linorder, unit) rbt \<Rightarrow> 'a set"
  where "Set t = {x . RBT.lookup t x = Some ()}"

definition Coset :: "('a::linorder, unit) rbt \<Rightarrow> 'a set"
  where [simp]: "Coset t = - Set t"

section \<open>Deletion of already existing code equations\<close>

declare [[code drop: Set.empty Set.is_empty uminus_set_inst.uminus_set
  Set.member Set.insert Set.remove UNIV Set.filter image
  Set.subset_eq Ball Bex can_select Set.union minus_set_inst.minus_set Set.inter
  card the_elem Pow sum prod Product_Type.product Id_on
  Image trancl relcomp wf Min Inf_fin Max Sup_fin
  "(Inf :: 'a set set \<Rightarrow> 'a set)" "(Sup :: 'a set set \<Rightarrow> 'a set)"
  sorted_list_of_set List.map_project List.Bleast]]

section \<open>Lemmas\<close>

subsection \<open>Auxiliary lemmas\<close>

lemma Set_set_keys: "Set x = dom (RBT.lookup x)"
by (auto simp: Set_def)

lemma finite_Set [simp, intro!]: "finite (Set x)"
by (simp add: Set_set_keys)

lemma set_keys: "Set t = set(RBT.keys t)"
by (simp add: Set_set_keys lookup_keys)

subsection \<open>fold and filter\<close>

lemma finite_fold_rbt_fold_eq:
  assumes "comp_fun_commute f"
  shows "Finite_Set.fold f A (set (RBT.entries t)) = RBT.fold (curry f) t A"
proof -
  have *: "remdups (RBT.entries t) = RBT.entries t"
    using distinct_entries distinct_map by (auto intro: distinct_remdups_id)
  show ?thesis using assms by (auto simp: fold_def_alt comp_fun_commute.fold_set_fold_remdups *)
qed

definition fold_keys :: "('a :: linorder \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, _) rbt \<Rightarrow> 'b \<Rightarrow> 'b"
  where [code_unfold]:"fold_keys f t A = RBT.fold (\<lambda>k _ t. f k t) t A"

lemma fold_keys_def_alt:
  "fold_keys f t s = List.fold f (RBT.keys t) s"
by (auto simp: fold_map o_def split_def fold_def_alt keys_def_alt fold_keys_def)

lemma finite_fold_fold_keys:
  assumes "comp_fun_commute f"
  shows "Finite_Set.fold f A (Set t) = fold_keys f t A"
using assms
proof -
  interpret comp_fun_commute f by fact
  have "set (RBT.keys t) = fst ` (set (RBT.entries t))" by (auto simp: fst_eq_Domain keys_entries)
  moreover have "inj_on fst (set (RBT.entries t))" using distinct_entries distinct_map by auto
  ultimately show ?thesis
    by (auto simp add: set_keys fold_keys_def curry_def fold_image finite_fold_rbt_fold_eq
      comp_comp_fun_commute)
qed

definition rbt_filter :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> 'a set" where
  "rbt_filter P t = RBT.fold (\<lambda>k _ A'. if P k then Set.insert k A' else A') t {}"

lemma Set_filter_rbt_filter:
  "Set.filter P (Set t) = rbt_filter P t"
by (simp add: fold_keys_def Set_filter_fold rbt_filter_def
  finite_fold_fold_keys[OF comp_fun_commute_filter_fold])

subsection \<open>foldi and Ball\<close>

lemma Ball_False: "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t False = False"
by (induction t) auto

lemma rbt_foldi_fold_conj:
  "RBT_Impl.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t val"
proof (induction t arbitrary: val)
  case (Branch c t1) then show ?case
    by (cases "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t1 True") (simp_all add: Ball_False)
qed simp

lemma foldi_fold_conj: "RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = fold_keys (\<lambda>k s. s \<and> P k) t val"
unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_conj)

subsection \<open>foldi and Bex\<close>

lemma Bex_True: "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t True = True"
by (induction t) auto

lemma rbt_foldi_fold_disj:
  "RBT_Impl.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t val"
proof (induction t arbitrary: val)
  case (Branch c t1) then show ?case
    by (cases "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t1 False") (simp_all add: Bex_True)
qed simp

lemma foldi_fold_disj: "RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = fold_keys (\<lambda>k s. s \<or> P k) t val"
unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_disj)

subsection \<open>folding over non empty trees and selecting the minimal and maximal element\<close>

subsubsection \<open>concrete\<close>

text \<open>The concrete part is here because it's probably not general enough to be moved to \<open>RBT_Impl\<close>\<close>

definition rbt_fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_fold1_keys f t = List.fold f (tl(RBT_Impl.keys t)) (hd(RBT_Impl.keys t))"

paragraph \<open>minimum\<close>

definition rbt_min :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_min t = rbt_fold1_keys min t"

lemma key_le_right: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys rt) \<Longrightarrow> k \<le> x)"
by  (auto simp: rbt_greater_prop less_imp_le)

lemma left_le_key: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys lt) \<Longrightarrow> x \<le> k)"
by (auto simp: rbt_less_prop less_imp_le)

lemma fold_min_triv:
  fixes k :: "_ :: linorder"
  shows "(\<forall>x\<in>set xs. k \<le> x) \<Longrightarrow> List.fold min xs k = k"
by (induct xs) (auto simp add: min_def)

lemma rbt_min_simps:
  "is_rbt (Branch c RBT_Impl.Empty k v rt) \<Longrightarrow> rbt_min (Branch c RBT_Impl.Empty k v rt) = k"
by (auto intro: fold_min_triv dest: key_le_right is_rbt_rbt_sorted simp: rbt_fold1_keys_def rbt_min_def)

fun rbt_min_opt where
  "rbt_min_opt (Branch c RBT_Impl.Empty k v rt) = k" |
  "rbt_min_opt (Branch c (Branch lc llc lk lv lrt) k v rt) = rbt_min_opt (Branch lc llc lk lv lrt)"

lemma rbt_min_opt_Branch:
  "t1 \<noteq> rbt.Empty \<Longrightarrow> rbt_min_opt (Branch c t1 k () t2) = rbt_min_opt t1"
by (cases t1) auto

lemma rbt_min_opt_induct [case_names empty left_empty left_non_empty]:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "P rbt.Empty"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  shows "P t"
  using assms
proof (induct t)
  case Empty
  then show ?case by simp
next
  case (Branch x1 t1 x3 x4 t2)
  then show ?case by (cases "t1 = rbt.Empty") simp_all
qed

lemma rbt_min_opt_in_set:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "t \<noteq> rbt.Empty"
  shows "rbt_min_opt t \<in> set (RBT_Impl.keys t)"
using assms by (induction t rule: rbt_min_opt.induct) (auto)

lemma rbt_min_opt_is_min:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "rbt_sorted t"
  assumes "t \<noteq> rbt.Empty"
  shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<ge> rbt_min_opt t"
using assms
proof (induction t rule: rbt_min_opt_induct)
  case empty
  then show ?case by simp
next
  case left_empty
  then show ?case by (auto intro: key_le_right simp del: rbt_sorted.simps)
next
  case (left_non_empty c t1 k v t2 y)
  then consider "y = k" | "y \<in> set (RBT_Impl.keys t1)" | "y \<in> set (RBT_Impl.keys t2)"
    by auto
  then show ?case
  proof cases
    case 1
    with left_non_empty show ?thesis
      by (auto simp add: rbt_min_opt_Branch intro: left_le_key rbt_min_opt_in_set)
  next
    case 2
    with left_non_empty show ?thesis
      by (auto simp add: rbt_min_opt_Branch)
  next
    case y: 3
    have "rbt_min_opt t1 \<le> k"
      using left_non_empty by (simp add: left_le_key rbt_min_opt_in_set)
    moreover have "k \<le> y"
      using left_non_empty y by (simp add: key_le_right)
    ultimately show ?thesis
      using left_non_empty y by (simp add: rbt_min_opt_Branch)
  qed
qed

lemma rbt_min_eq_rbt_min_opt:
  assumes "t \<noteq> RBT_Impl.Empty"
  assumes "is_rbt t"
  shows "rbt_min t = rbt_min_opt t"
proof -
  from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
  with assms show ?thesis
    by (simp add: rbt_min_def rbt_fold1_keys_def rbt_min_opt_is_min
      Min.set_eq_fold [symmetric] Min_eqI rbt_min_opt_in_set)
qed

paragraph \<open>maximum\<close>

definition rbt_max :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_max t = rbt_fold1_keys max t"

lemma fold_max_triv:
  fixes k :: "_ :: linorder"
  shows "(\<forall>x\<in>set xs. x \<le> k) \<Longrightarrow> List.fold max xs k = k"
by (induct xs) (auto simp add: max_def)

lemma fold_max_rev_eq:
  fixes xs :: "('a :: linorder) list"
  assumes "xs \<noteq> []"
  shows "List.fold max (tl xs) (hd xs) = List.fold max (tl (rev xs)) (hd (rev xs))"
  using assms by (simp add: Max.set_eq_fold [symmetric])

lemma rbt_max_simps:
  assumes "is_rbt (Branch c lt k v RBT_Impl.Empty)"
  shows "rbt_max (Branch c lt k v RBT_Impl.Empty) = k"
proof -
  have "List.fold max (tl (rev(RBT_Impl.keys lt @ [k]))) (hd (rev(RBT_Impl.keys lt @ [k]))) = k"
    using assms by (auto intro!: fold_max_triv dest!: left_le_key is_rbt_rbt_sorted)
  then show ?thesis by (auto simp add: rbt_max_def rbt_fold1_keys_def fold_max_rev_eq)
qed

fun rbt_max_opt where
  "rbt_max_opt (Branch c lt k v RBT_Impl.Empty) = k" |
  "rbt_max_opt (Branch c lt k v (Branch rc rlc rk rv rrt)) = rbt_max_opt (Branch rc rlc rk rv rrt)"

lemma rbt_max_opt_Branch:
  "t2 \<noteq> rbt.Empty \<Longrightarrow> rbt_max_opt (Branch c t1 k () t2) = rbt_max_opt t2"
by (cases t2) auto

lemma rbt_max_opt_induct [case_names empty right_empty right_non_empty]:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "P rbt.Empty"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  shows "P t"
  using assms
proof (induct t)
  case Empty
  then show ?case by simp
next
  case (Branch x1 t1 x3 x4 t2)
  then show ?case by (cases "t2 = rbt.Empty") simp_all
qed

lemma rbt_max_opt_in_set:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "t \<noteq> rbt.Empty"
  shows "rbt_max_opt t \<in> set (RBT_Impl.keys t)"
using assms by (induction t rule: rbt_max_opt.induct) (auto)

lemma rbt_max_opt_is_max:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "rbt_sorted t"
  assumes "t \<noteq> rbt.Empty"
  shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<le> rbt_max_opt t"
using assms
proof (induction t rule: rbt_max_opt_induct)
  case empty
  then show ?case by simp
next
  case right_empty
  then show ?case by (auto intro: left_le_key simp del: rbt_sorted.simps)
next
  case (right_non_empty c t1 k v t2 y)
  then consider "y = k" | "y \<in> set (RBT_Impl.keys t2)" | "y \<in> set (RBT_Impl.keys t1)"
    by auto
  then show ?case
  proof cases
    case 1
    with right_non_empty show ?thesis
      by (auto simp add: rbt_max_opt_Branch intro: key_le_right rbt_max_opt_in_set)
  next
    case 2
    with right_non_empty show ?thesis
      by (auto simp add: rbt_max_opt_Branch)
  next
    case y: 3
    have "rbt_max_opt t2 \<ge> k"
      using right_non_empty by (simp add: key_le_right rbt_max_opt_in_set)
    moreover have "y \<le> k"
      using right_non_empty y by (simp add: left_le_key)
    ultimately show ?thesis
      using right_non_empty by (simp add: rbt_max_opt_Branch)
  qed
qed

lemma rbt_max_eq_rbt_max_opt:
  assumes "t \<noteq> RBT_Impl.Empty"
  assumes "is_rbt t"
  shows "rbt_max t = rbt_max_opt t"
proof -
  from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
  with assms show ?thesis
    by (simp add: rbt_max_def rbt_fold1_keys_def rbt_max_opt_is_max
      Max.set_eq_fold [symmetric] Max_eqI rbt_max_opt_in_set)
qed

subsubsection \<open>abstract\<close>

context includes rbt.lifting begin
lift_definition fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'a"
  is rbt_fold1_keys .

lemma fold1_keys_def_alt:
  "fold1_keys f t = List.fold f (tl (RBT.keys t)) (hd (RBT.keys t))"
  by transfer (simp add: rbt_fold1_keys_def)

lemma finite_fold1_fold1_keys:
  assumes "semilattice f"
  assumes "\<not> RBT.is_empty t"
  shows "semilattice_set.F f (Set t) = fold1_keys f t"
proof -
  from \<open>semilattice f\<close> interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis using assms
    by (auto simp: fold1_keys_def_alt set_keys fold_def_alt non_empty_keys set_eq_fold [symmetric])
qed

paragraph \<open>minimum\<close>

lift_definition r_min :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min .

lift_definition r_min_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min_opt .

lemma r_min_alt_def: "r_min t = fold1_keys min t"
by transfer (simp add: rbt_min_def)

lemma r_min_eq_r_min_opt:
  assumes "\<not> (RBT.is_empty t)"
  shows "r_min t = r_min_opt t"
using assms unfolding is_empty_empty by transfer (auto intro: rbt_min_eq_rbt_min_opt)

lemma fold_keys_min_top_eq:
  fixes t :: "('a::{linorder,bounded_lattice_top}, unit) rbt"
  assumes "\<not> (RBT.is_empty t)"
  shows "fold_keys min t top = fold1_keys min t"
proof -
  have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold min (RBT_Impl.keys t) top =
      List.fold min (hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t)) top"
    by (simp add: hd_Cons_tl[symmetric])
  have **: "List.fold min (x # xs) top = List.fold min xs x" for x :: 'a and xs
    by (simp add: inf_min[symmetric])
  show ?thesis
    using assms
    unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
    apply transfer
    apply (case_tac t)
     apply simp
    apply (subst *)
     apply simp
    apply (subst **)
    apply simp
    done
qed

paragraph \<open>maximum\<close>

lift_definition r_max :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max .

lift_definition r_max_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max_opt .

lemma r_max_alt_def: "r_max t = fold1_keys max t"
by transfer (simp add: rbt_max_def)

lemma r_max_eq_r_max_opt:
  assumes "\<not> (RBT.is_empty t)"
  shows "r_max t = r_max_opt t"
using assms unfolding is_empty_empty by transfer (auto intro: rbt_max_eq_rbt_max_opt)

lemma fold_keys_max_bot_eq:
  fixes t :: "('a::{linorder,bounded_lattice_bot}, unit) rbt"
  assumes "\<not> (RBT.is_empty t)"
  shows "fold_keys max t bot = fold1_keys max t"
proof -
  have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold max (RBT_Impl.keys t) bot =
      List.fold max (hd(RBT_Impl.keys t) # tl(RBT_Impl.keys t)) bot"
    by (simp add: hd_Cons_tl[symmetric])
  have **: "List.fold max (x # xs) bot = List.fold max xs x" for x :: 'a and xs
    by (simp add: sup_max[symmetric])
  show ?thesis
    using assms
    unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
    apply transfer
    apply (case_tac t)
     apply simp
    apply (subst *)
     apply simp
    apply (subst **)
    apply simp
    done
qed

end

section \<open>Code equations\<close>

code_datatype Set Coset

declare list.set[code] (* needed? *)

lemma empty_Set [code]:
  "Set.empty = Set RBT.empty"
by (auto simp: Set_def)

lemma UNIV_Coset [code]:
  "UNIV = Coset RBT.empty"
by (auto simp: Set_def)

lemma is_empty_Set [code]:
  "Set.is_empty (Set t) = RBT.is_empty t"
  unfolding Set.is_empty_def by (auto simp: fun_eq_iff Set_def intro: lookup_empty_empty[THEN iffD1])

lemma compl_code [code]:
  "- Set xs = Coset xs"
  "- Coset xs = Set xs"
by (simp_all add: Set_def)

lemma member_code [code]:
  "x \<in> (Set t) = (RBT.lookup t x = Some ())"
  "x \<in> (Coset t) = (RBT.lookup t x = None)"
by (simp_all add: Set_def)

lemma insert_code [code]:
  "Set.insert x (Set t) = Set (RBT.insert x () t)"
  "Set.insert x (Coset t) = Coset (RBT.delete x t)"
by (auto simp: Set_def)

lemma remove_code [code]:
  "Set.remove x (Set t) = Set (RBT.delete x t)"
  "Set.remove x (Coset t) = Coset (RBT.insert x () t)"
by (auto simp: Set_def)

lemma union_Set [code]:
  "Set t \<union> A = fold_keys Set.insert t A"
proof -
  interpret comp_fun_idem Set.insert
    by (fact comp_fun_idem_insert)
  from finite_fold_fold_keys[OF comp_fun_commute_axioms]
  show ?thesis by (auto simp add: union_fold_insert)
qed

lemma inter_Set [code]:
  "A \<inter> Set t = rbt_filter (\<lambda>k. k \<in> A) t"
by (simp add: inter_Set_filter Set_filter_rbt_filter)

lemma minus_Set [code]:
  "A - Set t = fold_keys Set.remove t A"
proof -
  interpret comp_fun_idem Set.remove
    by (fact comp_fun_idem_remove)
  from finite_fold_fold_keys[OF comp_fun_commute_axioms]
  show ?thesis by (auto simp add: minus_fold_remove)
qed

lemma union_Coset [code]:
  "Coset t \<union> A = - rbt_filter (\<lambda>k. k \<notin> A) t"
proof -
  have *: "\<And>A B. (-A \<union> B) = -(-B \<inter> A)" by blast
  show ?thesis by (simp del: boolean_algebra_class.compl_inf add: * inter_Set)
qed

lemma union_Set_Set [code]:
  "Set t1 \<union> Set t2 = Set (RBT.union t1 t2)"
by (auto simp add: lookup_union map_add_Some_iff Set_def)

lemma inter_Coset [code]:
  "A \<inter> Coset t = fold_keys Set.remove t A"
by (simp add: Diff_eq [symmetric] minus_Set)

lemma inter_Coset_Coset [code]:
  "Coset t1 \<inter> Coset t2 = Coset (RBT.union t1 t2)"
by (auto simp add: lookup_union map_add_Some_iff Set_def)

lemma minus_Coset [code]:
  "A - Coset t = rbt_filter (\<lambda>k. k \<in> A) t"
by (simp add: inter_Set[simplified Int_commute])

lemma filter_Set [code]:
  "Set.filter P (Set t) = (rbt_filter P t)"
by (auto simp add: Set_filter_rbt_filter)

lemma image_Set [code]:
  "image f (Set t) = fold_keys (\<lambda>k A. Set.insert (f k) A) t {}"
proof -
  have "comp_fun_commute (\<lambda>k. Set.insert (f k))"
    by standard auto
  then show ?thesis
    by (auto simp add: image_fold_insert intro!: finite_fold_fold_keys)
qed

lemma Ball_Set [code]:
  "Ball (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t True"
proof -
  have "comp_fun_commute (\<lambda>k s. s \<and> P k)"
    by standard auto
  then show ?thesis
    by (simp add: foldi_fold_conj[symmetric] Ball_fold finite_fold_fold_keys)
qed

lemma Bex_Set [code]:
  "Bex (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t False"
proof -
  have "comp_fun_commute (\<lambda>k s. s \<or> P k)"
    by standard auto
  then show ?thesis
    by (simp add: foldi_fold_disj[symmetric] Bex_fold finite_fold_fold_keys)
qed

lemma subset_code [code]:
  "Set t \<le> B \<longleftrightarrow> (\<forall>x\<in>Set t. x \<in> B)"
  "A \<le> Coset t \<longleftrightarrow> (\<forall>y\<in>Set t. y \<notin> A)"
by auto

lemma subset_Coset_empty_Set_empty [code]:
  "Coset t1 \<le> Set t2 \<longleftrightarrow> (case (RBT.impl_of t1, RBT.impl_of t2) of
    (rbt.Empty, rbt.Empty) \<Rightarrow> False |
    (_, _) \<Rightarrow> Code.abort (STR ''non_empty_trees'') (\<lambda>_. Coset t1 \<le> Set t2))"
proof -
  have *: "\<And>t. RBT.impl_of t = rbt.Empty \<Longrightarrow> t = RBT rbt.Empty"
    by (subst(asm) RBT_inverse[symmetric]) (auto simp: impl_of_inject)
  have **: "eq_onp is_rbt rbt.Empty rbt.Empty" unfolding eq_onp_def by simp
  show ?thesis
    by (auto simp: Set_def lookup.abs_eq[OF **] dest!: * split: rbt.split)
qed

text \<open>A frequent case -- avoid intermediate sets\<close>
lemma [code_unfold]:
  "Set t1 \<subseteq> Set t2 \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> k \<in> Set t2) t1 True"
by (simp add: subset_code Ball_Set)

lemma card_Set [code]:
  "card (Set t) = fold_keys (\<lambda>_ n. n + 1) t 0"
  by (auto simp add: card.eq_fold intro: finite_fold_fold_keys comp_fun_commute_const)

lemma sum_Set [code]:
  "sum f (Set xs) = fold_keys (plus \<circ> f) xs 0"
proof -
  have "comp_fun_commute (\<lambda>x. (+) (f x))"
    by standard (auto simp: ac_simps)
  then show ?thesis
    by (auto simp add: sum.eq_fold finite_fold_fold_keys o_def)
qed

lemma the_elem_set [code]:
  fixes t :: "('a :: linorder, unit) rbt"
  shows "the_elem (Set t) = (case RBT.impl_of t of
    (Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty) \<Rightarrow> x
    | _ \<Rightarrow> Code.abort (STR ''not_a_singleton_tree'') (\<lambda>_. the_elem (Set t)))"
proof -
  {
    fix x :: "'a :: linorder"
    let ?t = "Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty"
    have *:"?t \<in> {t. is_rbt t}" unfolding is_rbt_def by auto
    then have **:"eq_onp is_rbt ?t ?t" unfolding eq_onp_def by auto

    have "RBT.impl_of t = ?t \<Longrightarrow> the_elem (Set t) = x"
      by (subst(asm) RBT_inverse[symmetric, OF *])
        (auto simp: Set_def the_elem_def lookup.abs_eq[OF **] impl_of_inject)
  }
  then show ?thesis
    by(auto split: rbt.split unit.split color.split)
qed

lemma Pow_Set [code]: "Pow (Set t) = fold_keys (\<lambda>x A. A \<union> Set.insert x ` A) t {{}}"
  by (simp add: Pow_fold finite_fold_fold_keys[OF comp_fun_commute_Pow_fold])

lemma product_Set [code]:
  "Product_Type.product (Set t1) (Set t2) =
    fold_keys (\<lambda>x A. fold_keys (\<lambda>y. Set.insert (x, y)) t2 A) t1 {}"
proof -
  have *: "comp_fun_commute (\<lambda>y. Set.insert (x, y))" for x
    by standard auto
  show ?thesis using finite_fold_fold_keys[OF comp_fun_commute_product_fold, of "Set t2" "{}" "t1"]
    by (simp add: product_fold Product_Type.product_def finite_fold_fold_keys[OF *])
qed

lemma Id_on_Set [code]: "Id_on (Set t) =  fold_keys (\<lambda>x. Set.insert (x, x)) t {}"
proof -
  have "comp_fun_commute (\<lambda>x. Set.insert (x, x))"
    by standard auto
  then show ?thesis
    by (auto simp add: Id_on_fold intro!: finite_fold_fold_keys)
qed

lemma Image_Set [code]:
  "(Set t) `` S = fold_keys (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) t {}"
by (auto simp add: Image_fold finite_fold_fold_keys[OF comp_fun_commute_Image_fold])

lemma trancl_set_ntrancl [code]:
  "trancl (Set t) = ntrancl (card (Set t) - 1) (Set t)"
by (simp add: finite_trancl_ntranl)

lemma relcomp_Set[code]:
  "(Set t1) O (Set t2) = fold_keys
    (\<lambda>(x,y) A. fold_keys (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') t2 A) t1 {}"
proof -
  interpret comp_fun_idem Set.insert
    by (fact comp_fun_idem_insert)
  have *: "\<And>x y. comp_fun_commute (\<lambda>(w, z) A'. if y = w then Set.insert (x, z) A' else A')"
    by standard (auto simp add: fun_eq_iff)
  show ?thesis
    using finite_fold_fold_keys[OF comp_fun_commute_relcomp_fold, of "Set t2" "{}" t1]
    by (simp add: relcomp_fold finite_fold_fold_keys[OF *])
qed

lemma wf_set [code]:
  "wf (Set t) = acyclic (Set t)"
by (simp add: wf_iff_acyclic_if_finite)

lemma Min_fin_set_fold [code]:
  "Min (Set t) =
  (if RBT.is_empty t
   then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Min (Set t))
   else r_min_opt t)"
proof -
  have *: "semilattice (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
  with finite_fold1_fold1_keys [OF *, folded Min_def]
  show ?thesis
    by (simp add: r_min_alt_def r_min_eq_r_min_opt [symmetric])
qed

lemma Inf_fin_set_fold [code]:
  "Inf_fin (Set t) = Min (Set t)"
by (simp add: inf_min Inf_fin_def Min_def)

lemma Inf_Set_fold:
  fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
  shows "Inf (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
proof -
  have "comp_fun_commute (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)"
    by standard (simp add: fun_eq_iff ac_simps)
  then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold min top (Set t) = fold1_keys min t"
    by (simp add: finite_fold_fold_keys fold_keys_min_top_eq)
  then show ?thesis
    by (auto simp add: Inf_fold_inf inf_min empty_Set[symmetric]
      r_min_eq_r_min_opt[symmetric] r_min_alt_def)
qed

lemma Max_fin_set_fold [code]:
  "Max (Set t) =
  (if RBT.is_empty t
   then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Max (Set t))
   else r_max_opt t)"
proof -
  have *: "semilattice (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
  with finite_fold1_fold1_keys [OF *, folded Max_def]
  show ?thesis
    by (simp add: r_max_alt_def r_max_eq_r_max_opt [symmetric])
qed

lemma Sup_fin_set_fold [code]:
  "Sup_fin (Set t) = Max (Set t)"
by (simp add: sup_max Sup_fin_def Max_def)

lemma Sup_Set_fold:
  fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
  shows "Sup (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
proof -
  have "comp_fun_commute (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)"
    by standard (simp add: fun_eq_iff ac_simps)
  then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold max bot (Set t) = fold1_keys max t"
    by (simp add: finite_fold_fold_keys fold_keys_max_bot_eq)
  then show ?thesis
    by (auto simp add: Sup_fold_sup sup_max empty_Set[symmetric]
      r_max_eq_r_max_opt[symmetric] r_max_alt_def)
qed

context
begin

qualified definition Inf' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a"
  where [code_abbrev]: "Inf' = Inf"

lemma Inf'_Set_fold [code]:
  "Inf' (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
  by (simp add: Inf'_def Inf_Set_fold)

qualified definition Sup' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a"
  where [code_abbrev]: "Sup' = Sup"

lemma Sup'_Set_fold [code]:
  "Sup' (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
  by (simp add: Sup'_def Sup_Set_fold)

lemma [code drop: Gcd_fin, code]:
  "Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) = fold_keys gcd t (0::'a::{semiring_gcd, linorder})"
proof -
  have "comp_fun_commute (gcd :: 'a \<Rightarrow> _)"
    by standard (simp add: fun_eq_iff ac_simps)
  with finite_fold_fold_keys [of _ 0 t]
  have "Finite_Set.fold gcd 0 (Set t) = fold_keys gcd t 0"
    by blast
  then show ?thesis
    by (simp add: Gcd_fin.eq_fold)
qed

lemma [code drop: "Gcd :: _ \<Rightarrow> nat", code]:
  "Gcd (Set t) = (Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) :: nat)"
  by simp

lemma [code drop: "Gcd :: _ \<Rightarrow> int", code]:
  "Gcd (Set t) = (Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) :: int)"
  by simp

lemma [code drop: Lcm_fin,code]:
  "Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) = fold_keys lcm t (1::'a::{semiring_gcd, linorder})"
proof -
  have "comp_fun_commute (lcm :: 'a \<Rightarrow> _)"
    by standard (simp add: fun_eq_iff ac_simps)
  with finite_fold_fold_keys [of _ 1 t]
  have "Finite_Set.fold lcm 1 (Set t) = fold_keys lcm t 1"
    by blast
  then show ?thesis
    by (simp add: Lcm_fin.eq_fold)
qed

qualified definition Lcm' :: "'a :: semiring_Gcd set \<Rightarrow> 'a"
  where [code_abbrev]: "Lcm' = Lcm"

lemma [code drop: "Lcm :: _ \<Rightarrow> nat", code]:
  "Lcm (Set t) = (Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) :: nat)"
  by simp

lemma [code drop: "Lcm :: _ \<Rightarrow> int", code]:
  "Lcm (Set t) = (Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) :: int)"
  by simp

end

lemma sorted_list_set[code]: "sorted_list_of_set (Set t) = RBT.keys t"
  by (auto simp add: set_keys intro: sorted_distinct_set_unique)

lemma Bleast_code [code]:
  "Bleast (Set t) P =
    (case List.filter P (RBT.keys t) of
      x # xs \<Rightarrow> x
    | [] \<Rightarrow> abort_Bleast (Set t) P)"
proof (cases "List.filter P (RBT.keys t)")
  case Nil
  thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
next
  case (Cons x ys)
  have "(LEAST x. x \<in> Set t \<and> P x) = x"
  proof (rule Least_equality)
    show "x \<in> Set t \<and> P x"
      using Cons[symmetric]
      by (auto simp add: set_keys Cons_eq_filter_iff)
    next
      fix y
      assume "y \<in> Set t \<and> P y"
      then show "x \<le> y"
        using Cons[symmetric]
        by(auto simp add: set_keys Cons_eq_filter_iff)
          (metis sorted.simps(2) sorted_append sorted_keys)
  qed
  thus ?thesis using Cons by (simp add: Bleast_def)
qed

hide_const (open) RBT_Set.Set RBT_Set.Coset

end