(*  Title:      ZF/Induct/Multiset.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory

A definitional theory of multisets,
including a wellfoundedness proof for the multiset order.

The theory features ordinal multisets and the usual ordering.
*)

theory Multiset
imports FoldSet Acc
begin

abbreviation (input)
  \<comment> \<open>Short cut for multiset space\<close>
  Mult :: "i\<Rightarrow>i" where
  "Mult(A) \<equiv> A -||> nat-{0}"

definition
  (* This is the original "restrict" from ZF.thy.
     Restricts the function f to the domain A
     FIXME: adapt Multiset to the new "restrict". *)
  funrestrict :: "[i,i] \<Rightarrow> i"  where
  "funrestrict(f,A) \<equiv> \<lambda>x \<in> A. f`x"

definition
  (* M is a multiset *)
  multiset :: "i \<Rightarrow> o"  where
  "multiset(M) \<equiv> \<exists>A. M \<in> A -> nat-{0} \<and> Finite(A)"

definition
  mset_of :: "i\<Rightarrow>i"  where
  "mset_of(M) \<equiv> domain(M)"

definition
  munion    :: "[i, i] \<Rightarrow> i" (infixl \<open>+#\<close> 65)  where
  "M +# N \<equiv> \<lambda>x \<in> mset_of(M) \<union> mset_of(N).
     if x \<in> mset_of(M) \<inter> mset_of(N) then  (M`x) #+ (N`x)
     else (if x \<in> mset_of(M) then M`x else N`x)"

definition
  (*convert a function to a multiset by eliminating 0*)
  normalize :: "i \<Rightarrow> i"  where
  "normalize(f) \<equiv>
       if (\<exists>A. f \<in> A -> nat \<and> Finite(A)) then
            funrestrict(f, {x \<in> mset_of(f). 0 < f`x})
       else 0"

definition
  mdiff  :: "[i, i] \<Rightarrow> i" (infixl \<open>-#\<close> 65)  where
  "M -# N \<equiv>  normalize(\<lambda>x \<in> mset_of(M).
                        if x \<in> mset_of(N) then M`x #- N`x else M`x)"

definition
  (* set of elements of a multiset *)
  msingle :: "i \<Rightarrow> i"    (\<open>{#_#}\<close>)  where
  "{#a#} \<equiv> {\<langle>a, 1\<rangle>}"

definition
  MCollect :: "[i, i\<Rightarrow>o] \<Rightarrow> i"  (*comprehension*)  where
  "MCollect(M, P) \<equiv> funrestrict(M, {x \<in> mset_of(M). P(x)})"

definition
  (* Counts the number of occurrences of an element in a multiset *)
  mcount :: "[i, i] \<Rightarrow> i"  where
  "mcount(M, a) \<equiv> if a \<in> mset_of(M) then  M`a else 0"

definition
  msize :: "i \<Rightarrow> i"  where
  "msize(M) \<equiv> setsum(\<lambda>a. $# mcount(M,a), mset_of(M))"

abbreviation
  melem :: "[i,i] \<Rightarrow> o"    (\<open>(_/ :# _)\<close> [50, 51] 50)  where
  "a :# M \<equiv> a \<in> mset_of(M)"

syntax
  "_MColl" :: "[pttrn, i, o] \<Rightarrow> i" (\<open>(1{# _ \<in> _./ _#})\<close>)
translations
  "{#x \<in> M. P#}" == "CONST MCollect(M, \<lambda>x. P)"

  (* multiset orderings *)

definition
   (* multirel1 has to be a set (not a predicate) so that we can form
      its transitive closure and reason about wf(.) and acc(.) *)
  multirel1 :: "[i,i]\<Rightarrow>i"  where
  "multirel1(A, r) \<equiv>
     {\<langle>M, N\<rangle> \<in> Mult(A)*Mult(A).
      \<exists>a \<in> A. \<exists>M0 \<in> Mult(A). \<exists>K \<in> Mult(A).
      N=M0 +# {#a#} \<and> M=M0 +# K \<and> (\<forall>b \<in> mset_of(K). \<langle>b,a\<rangle> \<in> r)}"

definition
  multirel :: "[i, i] \<Rightarrow> i"  where
  "multirel(A, r) \<equiv> multirel1(A, r)^+"

  (* ordinal multiset orderings *)

definition
  omultiset :: "i \<Rightarrow> o"  where
  "omultiset(M) \<equiv> \<exists>i. Ord(i) \<and> M \<in> Mult(field(Memrel(i)))"

definition
  mless :: "[i, i] \<Rightarrow> o" (infixl \<open><#\<close> 50)  where
  "M <# N \<equiv>  \<exists>i. Ord(i) \<and> \<langle>M, N\<rangle> \<in> multirel(field(Memrel(i)), Memrel(i))"

definition
  mle  :: "[i, i] \<Rightarrow> o"  (infixl \<open><#=\<close> 50)  where
  "M <#= N \<equiv> (omultiset(M) \<and> M = N) | M <# N"

subsection\<open>Properties of the original "restrict" from ZF.thy\<close>

lemma funrestrict_subset: "\<lbrakk>f \<in> Pi(C,B);  A\<subseteq>C\<rbrakk> \<Longrightarrow> funrestrict(f,A) \<subseteq> f"
by (auto simp add: funrestrict_def lam_def intro: apply_Pair)

lemma funrestrict_type:
    "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> f`x \<in> B(x)\<rbrakk> \<Longrightarrow> funrestrict(f,A) \<in> Pi(A,B)"
by (simp add: funrestrict_def lam_type)

lemma funrestrict_type2: "\<lbrakk>f \<in> Pi(C,B);  A\<subseteq>C\<rbrakk> \<Longrightarrow> funrestrict(f,A) \<in> Pi(A,B)"
by (blast intro: apply_type funrestrict_type)

lemma funrestrict [simp]: "a \<in> A \<Longrightarrow> funrestrict(f,A) ` a = f`a"
by (simp add: funrestrict_def)

lemma funrestrict_empty [simp]: "funrestrict(f,0) = 0"
by (simp add: funrestrict_def)

lemma domain_funrestrict [simp]: "domain(funrestrict(f,C)) = C"
by (auto simp add: funrestrict_def lam_def)

lemma fun_cons_funrestrict_eq:
     "f \<in> cons(a, b) -> B \<Longrightarrow> f = cons(<a, f ` a>, funrestrict(f, b))"
apply (rule equalityI)
prefer 2 apply (blast intro: apply_Pair funrestrict_subset [THEN subsetD])
apply (auto dest!: Pi_memberD simp add: funrestrict_def lam_def)
done

declare domain_of_fun [simp]
declare domainE [rule del]

text\<open>A useful simplification rule\<close>
lemma multiset_fun_iff:
     "(f \<in> A -> nat-{0}) \<longleftrightarrow> f \<in> A->nat\<and>(\<forall>a \<in> A. f`a \<in> nat \<and> 0 < f`a)"
apply safe
apply (rule_tac [4] B1 = "range (f) " in Pi_mono [THEN subsetD])
apply (auto intro!: Ord_0_lt
            dest: apply_type Diff_subset [THEN Pi_mono, THEN subsetD]
            simp add: range_of_fun apply_iff)
done

(** The multiset space  **)
lemma multiset_into_Mult: "\<lbrakk>multiset(M); mset_of(M)\<subseteq>A\<rbrakk> \<Longrightarrow> M \<in> Mult(A)"
apply (simp add: multiset_def)
apply (auto simp add: multiset_fun_iff mset_of_def)
apply (rule_tac B1 = "nat-{0}" in FiniteFun_mono [THEN subsetD], simp_all)
apply (rule Finite_into_Fin [THEN [2] Fin_mono [THEN subsetD], THEN fun_FiniteFunI])
apply (simp_all (no_asm_simp) add: multiset_fun_iff)
done

lemma Mult_into_multiset: "M \<in> Mult(A) \<Longrightarrow> multiset(M) \<and> mset_of(M)\<subseteq>A"
apply (simp add: multiset_def mset_of_def)
apply (frule FiniteFun_is_fun)
apply (drule FiniteFun_domain_Fin)
apply (frule FinD, clarify)
apply (rule_tac x = "domain (M) " in exI)
apply (blast intro: Fin_into_Finite)
done

lemma Mult_iff_multiset: "M \<in> Mult(A) \<longleftrightarrow> multiset(M) \<and> mset_of(M)\<subseteq>A"
by (blast dest: Mult_into_multiset intro: multiset_into_Mult)

lemma multiset_iff_Mult_mset_of: "multiset(M) \<longleftrightarrow> M \<in> Mult(mset_of(M))"
by (auto simp add: Mult_iff_multiset)

text\<open>The \<^term>\<open>multiset\<close> operator\<close>

(* the empty multiset is 0 *)

lemma multiset_0 [simp]: "multiset(0)"
by (auto intro: FiniteFun.intros simp add: multiset_iff_Mult_mset_of)

text\<open>The \<^term>\<open>mset_of\<close> operator\<close>

lemma multiset_set_of_Finite [simp]: "multiset(M) \<Longrightarrow> Finite(mset_of(M))"
by (simp add: multiset_def mset_of_def, auto)

lemma mset_of_0 [iff]: "mset_of(0) = 0"
by (simp add: mset_of_def)

lemma mset_is_0_iff: "multiset(M) \<Longrightarrow> mset_of(M)=0 \<longleftrightarrow> M=0"
by (auto simp add: multiset_def mset_of_def)

lemma mset_of_single [iff]: "mset_of({#a#}) = {a}"
by (simp add: msingle_def mset_of_def)

lemma mset_of_union [iff]: "mset_of(M +# N) = mset_of(M) \<union> mset_of(N)"
by (simp add: mset_of_def munion_def)

lemma mset_of_diff [simp]: "mset_of(M)\<subseteq>A \<Longrightarrow> mset_of(M -# N) \<subseteq> A"
by (auto simp add: mdiff_def multiset_def normalize_def mset_of_def)

(* msingle *)

lemma msingle_not_0 [iff]: "{#a#} \<noteq> 0 \<and> 0 \<noteq> {#a#}"
by (simp add: msingle_def)

lemma msingle_eq_iff [iff]: "({#a#} = {#b#}) \<longleftrightarrow>  (a = b)"
by (simp add: msingle_def)

lemma msingle_multiset [iff,TC]: "multiset({#a#})"
apply (simp add: multiset_def msingle_def)
apply (rule_tac x = "{a}" in exI)
apply (auto intro: Finite_cons Finite_0 fun_extend3)
done

(** normalize **)

lemmas Collect_Finite = Collect_subset [THEN subset_Finite]

lemma normalize_idem [simp]: "normalize(normalize(f)) = normalize(f)"
apply (simp add: normalize_def funrestrict_def mset_of_def)
apply (case_tac "\<exists>A. f \<in> A -> nat \<and> Finite (A) ")
apply clarify
apply (drule_tac x = "{x \<in> domain (f) . 0 < f ` x}" in spec)
apply auto
apply (auto  intro!: lam_type simp add: Collect_Finite)
done

lemma normalize_multiset [simp]: "multiset(M) \<Longrightarrow> normalize(M) = M"
by (auto simp add: multiset_def normalize_def mset_of_def funrestrict_def multiset_fun_iff)

lemma multiset_normalize [simp]: "multiset(normalize(f))"
apply (simp add: normalize_def)
apply (simp add: normalize_def mset_of_def multiset_def, auto)
apply (rule_tac x = "{x \<in> A . 0<f`x}" in exI)
apply (auto intro: Collect_subset [THEN subset_Finite] funrestrict_type)
done

(** Typechecking rules for union and difference of multisets **)

(* union *)

lemma munion_multiset [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk> \<Longrightarrow> multiset(M +# N)"
apply (unfold multiset_def munion_def mset_of_def, auto)
apply (rule_tac x = "A \<union> Aa" in exI)
apply (auto intro!: lam_type intro: Finite_Un simp add: multiset_fun_iff zero_less_add)
done

(* difference *)

lemma mdiff_multiset [simp]: "multiset(M -# N)"
by (simp add: mdiff_def)

(** Algebraic properties of multisets **)

(* Union *)

lemma munion_0 [simp]: "multiset(M) \<Longrightarrow> M +# 0 = M \<and> 0 +# M = M"
apply (simp add: multiset_def)
apply (auto simp add: munion_def mset_of_def)
done

lemma munion_commute: "M +# N = N +# M"
by (auto intro!: lam_cong simp add: munion_def)

lemma munion_assoc: "(M +# N) +# K = M +# (N +# K)"
  unfolding munion_def mset_of_def
apply (rule lam_cong, auto)
done

lemma munion_lcommute: "M +# (N +# K) = N +# (M +# K)"
  unfolding munion_def mset_of_def
apply (rule lam_cong, auto)
done

lemmas munion_ac = munion_commute munion_assoc munion_lcommute

(* Difference *)

lemma mdiff_self_eq_0 [simp]: "M -# M = 0"
by (simp add: mdiff_def normalize_def mset_of_def)

lemma mdiff_0 [simp]: "0 -# M = 0"
by (simp add: mdiff_def normalize_def)

lemma mdiff_0_right [simp]: "multiset(M) \<Longrightarrow> M -# 0 = M"
by (auto simp add: multiset_def mdiff_def normalize_def multiset_fun_iff mset_of_def funrestrict_def)

lemma mdiff_union_inverse2 [simp]: "multiset(M) \<Longrightarrow> M +# {#a#} -# {#a#} = M"
  unfolding multiset_def munion_def mdiff_def msingle_def normalize_def mset_of_def
apply (auto cong add: if_cong simp add: ltD multiset_fun_iff funrestrict_def subset_Un_iff2 [THEN iffD1])
prefer 2 apply (force intro!: lam_type)
apply (subgoal_tac [2] "{x \<in> A \<union> {a} . x \<noteq> a \<and> x \<in> A} = A")
apply (rule fun_extension, auto)
apply (drule_tac x = "A \<union> {a}" in spec)
apply (simp add: Finite_Un)
apply (force intro!: lam_type)
done

(** Count of elements **)

lemma mcount_type [simp,TC]: "multiset(M) \<Longrightarrow> mcount(M, a) \<in> nat"
by (auto simp add: multiset_def mcount_def mset_of_def multiset_fun_iff)

lemma mcount_0 [simp]: "mcount(0, a) = 0"
by (simp add: mcount_def)

lemma mcount_single [simp]: "mcount({#b#}, a) = (if a=b then 1 else 0)"
by (simp add: mcount_def mset_of_def msingle_def)

lemma mcount_union [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
                     \<Longrightarrow>  mcount(M +# N, a) = mcount(M, a) #+ mcount (N, a)"
apply (auto simp add: multiset_def multiset_fun_iff mcount_def munion_def mset_of_def)
done

lemma mcount_diff [simp]:
     "multiset(M) \<Longrightarrow> mcount(M -# N, a) = mcount(M, a) #- mcount(N, a)"
apply (simp add: multiset_def)
apply (auto dest!: not_lt_imp_le
     simp add: mdiff_def multiset_fun_iff mcount_def normalize_def mset_of_def)
apply (force intro!: lam_type)
apply (force intro!: lam_type)
done

lemma mcount_elem: "\<lbrakk>multiset(M); a \<in> mset_of(M)\<rbrakk> \<Longrightarrow> 0 < mcount(M, a)"
apply (simp add: multiset_def, clarify)
apply (simp add: mcount_def mset_of_def)
apply (simp add: multiset_fun_iff)
done

(** msize **)

lemma msize_0 [simp]: "msize(0) = #0"
by (simp add: msize_def)

lemma msize_single [simp]: "msize({#a#}) = #1"
by (simp add: msize_def)

lemma msize_type [simp,TC]: "msize(M) \<in> int"
by (simp add: msize_def)

lemma msize_zpositive: "multiset(M)\<Longrightarrow> #0 $\<le> msize(M)"
by (auto simp add: msize_def intro: g_zpos_imp_setsum_zpos)

lemma msize_int_of_nat: "multiset(M) \<Longrightarrow> \<exists>n \<in> nat. msize(M)= $# n"
apply (rule not_zneg_int_of)
apply (simp_all (no_asm_simp) add: msize_type [THEN znegative_iff_zless_0] not_zless_iff_zle msize_zpositive)
done

lemma not_empty_multiset_imp_exist:
     "\<lbrakk>M\<noteq>0; multiset(M)\<rbrakk> \<Longrightarrow> \<exists>a \<in> mset_of(M). 0 < mcount(M, a)"
apply (simp add: multiset_def)
apply (erule not_emptyE)
apply (auto simp add: mset_of_def mcount_def multiset_fun_iff)
apply (blast dest!: fun_is_rel)
done

lemma msize_eq_0_iff: "multiset(M) \<Longrightarrow> msize(M)=#0 \<longleftrightarrow> M=0"
apply (simp add: msize_def, auto)
apply (rule_tac P = "setsum (u,v) \<noteq> #0" for u v in swap)
apply blast
apply (drule not_empty_multiset_imp_exist, assumption, clarify)
apply (subgoal_tac "Finite (mset_of (M) - {a}) ")
 prefer 2 apply (simp add: Finite_Diff)
apply (subgoal_tac "setsum (\<lambda>x. $# mcount (M, x), cons (a, mset_of (M) -{a}))=#0")
 prefer 2 apply (simp add: cons_Diff, simp)
apply (subgoal_tac "#0 $\<le> setsum (\<lambda>x. $# mcount (M, x), mset_of (M) - {a}) ")
apply (rule_tac [2] g_zpos_imp_setsum_zpos)
apply (auto simp add: Finite_Diff not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])
apply (rule not_zneg_int_of [THEN bexE])
apply (auto simp del: int_of_0 simp add: int_of_add [symmetric] int_of_0 [symmetric])
done

lemma setsum_mcount_Int:
     "Finite(A) \<Longrightarrow> setsum(\<lambda>a. $# mcount(N, a), A \<inter> mset_of(N))
                  = setsum(\<lambda>a. $# mcount(N, a), A)"
apply (induct rule: Finite_induct)
 apply auto
apply (subgoal_tac "Finite (B \<inter> mset_of (N))")
prefer 2 apply (blast intro: subset_Finite)
apply (auto simp add: mcount_def Int_cons_left)
done

lemma msize_union [simp]:
     "\<lbrakk>multiset(M); multiset(N)\<rbrakk> \<Longrightarrow> msize(M +# N) = msize(M) $+ msize(N)"
apply (simp add: msize_def setsum_Un setsum_addf int_of_add setsum_mcount_Int)
apply (subst Int_commute)
apply (simp add: setsum_mcount_Int)
done

lemma msize_eq_succ_imp_elem: "\<lbrakk>msize(M)= $# succ(n); n \<in> nat\<rbrakk> \<Longrightarrow> \<exists>a. a \<in> mset_of(M)"
  unfolding msize_def
apply (blast dest: setsum_succD)
done

(** Equality of multisets **)

lemma equality_lemma:
     "\<lbrakk>multiset(M); multiset(N); \<forall>a. mcount(M, a)=mcount(N, a)\<rbrakk>
      \<Longrightarrow> mset_of(M)=mset_of(N)"
apply (simp add: multiset_def)
apply (rule sym, rule equalityI)
apply (auto simp add: multiset_fun_iff mcount_def mset_of_def)
apply (drule_tac [!] x=x in spec)
apply (case_tac [2] "x \<in> Aa", case_tac "x \<in> A", auto)
done

lemma multiset_equality:
  "\<lbrakk>multiset(M); multiset(N)\<rbrakk>\<Longrightarrow> M=N\<longleftrightarrow>(\<forall>a. mcount(M, a)=mcount(N, a))"
apply auto
apply (subgoal_tac "mset_of (M) = mset_of (N) ")
prefer 2 apply (blast intro: equality_lemma)
apply (simp add: multiset_def mset_of_def)
apply (auto simp add: multiset_fun_iff)
apply (rule fun_extension)
apply (blast, blast)
apply (drule_tac x = x in spec)
apply (auto simp add: mcount_def mset_of_def)
done

(** More algebraic properties of multisets **)

lemma munion_eq_0_iff [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>\<Longrightarrow>(M +# N =0) \<longleftrightarrow> (M=0 \<and> N=0)"
by (auto simp add: multiset_equality)

lemma empty_eq_munion_iff [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>\<Longrightarrow>(0=M +# N) \<longleftrightarrow> (M=0 \<and> N=0)"
apply (rule iffI, drule sym)
apply (simp_all add: multiset_equality)
done

lemma munion_right_cancel [simp]:
     "\<lbrakk>multiset(M); multiset(N); multiset(K)\<rbrakk>\<Longrightarrow>(M +# K = N +# K)\<longleftrightarrow>(M=N)"
by (auto simp add: multiset_equality)

lemma munion_left_cancel [simp]:
  "\<lbrakk>multiset(K); multiset(M); multiset(N)\<rbrakk> \<Longrightarrow>(K +# M = K +# N) \<longleftrightarrow> (M = N)"
by (auto simp add: multiset_equality)

lemma nat_add_eq_1_cases: "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> (m #+ n = 1) \<longleftrightarrow> (m=1 \<and> n=0) | (m=0 \<and> n=1)"
by (induct_tac n) auto

lemma munion_is_single:
     "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
      \<Longrightarrow> (M +# N = {#a#}) \<longleftrightarrow>  (M={#a#} \<and> N=0) | (M = 0 \<and> N = {#a#})"
apply (simp (no_asm_simp) add: multiset_equality)
apply safe
apply simp_all
apply (case_tac "aa=a")
apply (drule_tac [2] x = aa in spec)
apply (drule_tac x = a in spec)
apply (simp add: nat_add_eq_1_cases, simp)
apply (case_tac "aaa=aa", simp)
apply (drule_tac x = aa in spec)
apply (simp add: nat_add_eq_1_cases)
apply (case_tac "aaa=a")
apply (drule_tac [4] x = aa in spec)
apply (drule_tac [3] x = a in spec)
apply (drule_tac [2] x = aaa in spec)
apply (drule_tac x = aa in spec)
apply (simp_all add: nat_add_eq_1_cases)
done

lemma msingle_is_union: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
  \<Longrightarrow> ({#a#} = M +# N) \<longleftrightarrow> ({#a#} = M  \<and> N=0 | M = 0 \<and> {#a#} = N)"
apply (subgoal_tac " ({#a#} = M +# N) \<longleftrightarrow> (M +# N = {#a#}) ")
apply (simp (no_asm_simp) add: munion_is_single)
apply blast
apply (blast dest: sym)
done

(** Towards induction over multisets **)

lemma setsum_decr:
"Finite(A)
  \<Longrightarrow>  (\<forall>M. multiset(M) \<longrightarrow>
  (\<forall>a \<in> mset_of(M). setsum(\<lambda>z. $# mcount(M(a:=M`a #- 1), z), A) =
  (if a \<in> A then setsum(\<lambda>z. $# mcount(M, z), A) $- #1
           else setsum(\<lambda>z. $# mcount(M, z), A))))"
  unfolding multiset_def
apply (erule Finite_induct)
apply (auto simp add: multiset_fun_iff)
  unfolding mset_of_def mcount_def
apply (case_tac "x \<in> A", auto)
apply (subgoal_tac "$# M ` x $+ #-1 = $# M ` x $- $# 1")
apply (erule ssubst)
apply (rule int_of_diff, auto)
done

lemma setsum_decr2:
     "Finite(A)
      \<Longrightarrow> \<forall>M. multiset(M) \<longrightarrow> (\<forall>a \<in> mset_of(M).
           setsum(\<lambda>x. $# mcount(funrestrict(M, mset_of(M)-{a}), x), A) =
           (if a \<in> A then setsum(\<lambda>x. $# mcount(M, x), A) $- $# M`a
            else setsum(\<lambda>x. $# mcount(M, x), A)))"
apply (simp add: multiset_def)
apply (erule Finite_induct)
apply (auto simp add: multiset_fun_iff mcount_def mset_of_def)
done

lemma setsum_decr3: "\<lbrakk>Finite(A); multiset(M); a \<in> mset_of(M)\<rbrakk>
      \<Longrightarrow> setsum(\<lambda>x. $# mcount(funrestrict(M, mset_of(M)-{a}), x), A - {a}) =
          (if a \<in> A then setsum(\<lambda>x. $# mcount(M, x), A) $- $# M`a
           else setsum(\<lambda>x. $# mcount(M, x), A))"
apply (subgoal_tac "setsum (\<lambda>x. $# mcount (funrestrict (M, mset_of (M) -{a}),x),A-{a}) = setsum (\<lambda>x. $# mcount (funrestrict (M, mset_of (M) -{a}),x),A) ")
apply (rule_tac [2] setsum_Diff [symmetric])
apply (rule sym, rule ssubst, blast)
apply (rule sym, drule setsum_decr2, auto)
apply (simp add: mcount_def mset_of_def)
done

lemma nat_le_1_cases: "n \<in> nat \<Longrightarrow> n \<le> 1 \<longleftrightarrow> (n=0 | n=1)"
by (auto elim: natE)

lemma succ_pred_eq_self: "\<lbrakk>0<n; n \<in> nat\<rbrakk> \<Longrightarrow> succ(n #- 1) = n"
apply (subgoal_tac "1 \<le> n")
apply (drule add_diff_inverse2, auto)
done

text\<open>Specialized for use in the proof below.\<close>
lemma multiset_funrestict:
     "\<lbrakk>\<forall>a\<in>A. M ` a \<in> nat \<and> 0 < M ` a; Finite(A)\<rbrakk>
      \<Longrightarrow> multiset(funrestrict(M, A - {a}))"
apply (simp add: multiset_def multiset_fun_iff)
apply (rule_tac x="A-{a}" in exI)
apply (auto intro: Finite_Diff funrestrict_type)
done

lemma multiset_induct_aux:
  assumes prem1: "\<And>M a. \<lbrakk>multiset(M); a\<notin>mset_of(M); P(M)\<rbrakk> \<Longrightarrow> P(cons(\<langle>a, 1\<rangle>, M))"
      and prem2: "\<And>M b. \<lbrakk>multiset(M); b \<in> mset_of(M); P(M)\<rbrakk> \<Longrightarrow> P(M(b:= M`b #+ 1))"
  shows
  "\<lbrakk>n \<in> nat; P(0)\<rbrakk>
     \<Longrightarrow> (\<forall>M. multiset(M)\<longrightarrow>
  (setsum(\<lambda>x. $# mcount(M, x), {x \<in> mset_of(M). 0 < M`x}) = $# n) \<longrightarrow> P(M))"
apply (erule nat_induct, clarify)
apply (frule msize_eq_0_iff)
apply (auto simp add: mset_of_def multiset_def multiset_fun_iff msize_def)
apply (subgoal_tac "setsum (\<lambda>x. $# mcount (M, x), A) =$# succ (x) ")
apply (drule setsum_succD, auto)
apply (case_tac "1 <M`a")
apply (drule_tac [2] not_lt_imp_le)
apply (simp_all add: nat_le_1_cases)
apply (subgoal_tac "M= (M (a:=M`a #- 1)) (a:= (M (a:=M`a #- 1))`a #+ 1) ")
apply (rule_tac [2] A = A and B = "\<lambda>x. nat" and D = "\<lambda>x. nat" in fun_extension)
apply (rule_tac [3] update_type)+
apply (simp_all (no_asm_simp))
 apply (rule_tac [2] impI)
 apply (rule_tac [2] succ_pred_eq_self [symmetric])
apply (simp_all (no_asm_simp))
apply (rule subst, rule sym, blast, rule prem2)
apply (simp (no_asm) add: multiset_def multiset_fun_iff)
apply (rule_tac x = A in exI)
apply (force intro: update_type)
apply (simp (no_asm_simp) add: mset_of_def mcount_def)
apply (drule_tac x = "M (a := M ` a #- 1) " in spec)
apply (drule mp, drule_tac [2] mp, simp_all)
apply (rule_tac x = A in exI)
apply (auto intro: update_type)
apply (subgoal_tac "Finite ({x \<in> cons (a, A) . x\<noteq>a\<longrightarrow>0<M`x}) ")
prefer 2 apply (blast intro: Collect_subset [THEN subset_Finite] Finite_cons)
apply (drule_tac A = "{x \<in> cons (a, A) . x\<noteq>a\<longrightarrow>0<M`x}" in setsum_decr)
apply (drule_tac x = M in spec)
apply (subgoal_tac "multiset (M) ")
 prefer 2
 apply (simp add: multiset_def multiset_fun_iff)
 apply (rule_tac x = A in exI, force)
apply (simp_all add: mset_of_def)
apply (drule_tac psi = "\<forall>x \<in> A. u(x)" for u in asm_rl)
apply (drule_tac x = a in bspec)
apply (simp (no_asm_simp))
apply (subgoal_tac "cons (a, A) = A")
prefer 2 apply blast
apply simp
apply (subgoal_tac "M=cons (<a, M`a>, funrestrict (M, A-{a}))")
 prefer 2
 apply (rule fun_cons_funrestrict_eq)
 apply (subgoal_tac "cons (a, A-{a}) = A")
  apply force
  apply force
apply (rule_tac a = "cons (\<langle>a, 1\<rangle>, funrestrict (M, A - {a}))" in ssubst)
apply simp
apply (frule multiset_funrestict, assumption)
apply (rule prem1, assumption)
apply (simp add: mset_of_def)
apply (drule_tac x = "funrestrict (M, A-{a}) " in spec)
apply (drule mp)
apply (rule_tac x = "A-{a}" in exI)
apply (auto intro: Finite_Diff funrestrict_type simp add: funrestrict)
apply (frule_tac A = A and M = M and a = a in setsum_decr3)
apply (simp (no_asm_simp) add: multiset_def multiset_fun_iff)
apply blast
apply (simp (no_asm_simp) add: mset_of_def)
apply (drule_tac b = "if u then v else w" for u v w in sym, simp_all)
apply (subgoal_tac "{x \<in> A - {a} . 0 < funrestrict (M, A - {x}) ` x} = A - {a}")
apply (auto intro!: setsum_cong simp add: zdiff_eq_iff zadd_commute multiset_def multiset_fun_iff mset_of_def)
done

lemma multiset_induct2:
  "\<lbrakk>multiset(M); P(0);
    (\<And>M a. \<lbrakk>multiset(M); a\<notin>mset_of(M); P(M)\<rbrakk> \<Longrightarrow> P(cons(\<langle>a, 1\<rangle>, M)));
    (\<And>M b. \<lbrakk>multiset(M); b \<in> mset_of(M);  P(M)\<rbrakk> \<Longrightarrow> P(M(b:= M`b #+ 1)))\<rbrakk>
     \<Longrightarrow> P(M)"
apply (subgoal_tac "\<exists>n \<in> nat. setsum (\<lambda>x. $# mcount (M, x), {x \<in> mset_of (M) . 0 < M ` x}) = $# n")
apply (rule_tac [2] not_zneg_int_of)
apply (simp_all (no_asm_simp) add: znegative_iff_zless_0 not_zless_iff_zle)
apply (rule_tac [2] g_zpos_imp_setsum_zpos)
prefer 2 apply (blast intro:  multiset_set_of_Finite Collect_subset [THEN subset_Finite])
 prefer 2 apply (simp add: multiset_def multiset_fun_iff, clarify)
apply (rule multiset_induct_aux [rule_format], auto)
done

lemma munion_single_case1:
     "\<lbrakk>multiset(M); a \<notin>mset_of(M)\<rbrakk> \<Longrightarrow> M +# {#a#} = cons(\<langle>a, 1\<rangle>, M)"
apply (simp add: multiset_def msingle_def)
apply (auto simp add: munion_def)
apply (unfold mset_of_def, simp)
apply (rule fun_extension, rule lam_type, simp_all)
apply (auto simp add: multiset_fun_iff fun_extend_apply)
apply (drule_tac c = a and b = 1 in fun_extend3)
apply (auto simp add: cons_eq Un_commute [of _ "{a}"])
done

lemma munion_single_case2:
     "\<lbrakk>multiset(M); a \<in> mset_of(M)\<rbrakk> \<Longrightarrow> M +# {#a#} = M(a:=M`a #+ 1)"
apply (simp add: multiset_def)
apply (auto simp add: munion_def multiset_fun_iff msingle_def)
apply (unfold mset_of_def, simp)
apply (subgoal_tac "A \<union> {a} = A")
apply (rule fun_extension)
apply (auto dest: domain_type intro: lam_type update_type)
done

(* Induction principle for multisets *)

lemma multiset_induct:
  assumes M: "multiset(M)"
      and P0: "P(0)"
      and step: "\<And>M a. \<lbrakk>multiset(M); P(M)\<rbrakk> \<Longrightarrow> P(M +# {#a#})"
  shows "P(M)"
apply (rule multiset_induct2 [OF M])
apply (simp_all add: P0)
apply (frule_tac [2] a = b in munion_single_case2 [symmetric])
apply (frule_tac a = a in munion_single_case1 [symmetric])
apply (auto intro: step)
done

(** MCollect **)

lemma MCollect_multiset [simp]:
     "multiset(M) \<Longrightarrow> multiset({# x \<in> M. P(x)#})"
apply (simp add: MCollect_def multiset_def mset_of_def, clarify)
apply (rule_tac x = "{x \<in> A. P (x) }" in exI)
apply (auto dest: CollectD1 [THEN [2] apply_type]
            intro: Collect_subset [THEN subset_Finite] funrestrict_type)
done

lemma mset_of_MCollect [simp]:
     "multiset(M) \<Longrightarrow> mset_of({# x \<in> M. P(x) #}) \<subseteq> mset_of(M)"
by (auto simp add: mset_of_def MCollect_def multiset_def funrestrict_def)

lemma MCollect_mem_iff [iff]:
     "x \<in> mset_of({#x \<in> M. P(x)#}) \<longleftrightarrow>  x \<in> mset_of(M) \<and> P(x)"
by (simp add: MCollect_def mset_of_def)

lemma mcount_MCollect [simp]:
     "mcount({# x \<in> M. P(x) #}, a) = (if P(a) then mcount(M,a) else 0)"
by (simp add: mcount_def MCollect_def mset_of_def)

lemma multiset_partition: "multiset(M) \<Longrightarrow> M = {# x \<in> M. P(x) #} +# {# x \<in> M. \<not> P(x) #}"
by (simp add: multiset_equality)

lemma natify_elem_is_self [simp]:
     "\<lbrakk>multiset(M); a \<in> mset_of(M)\<rbrakk> \<Longrightarrow> natify(M`a) = M`a"
by (auto simp add: multiset_def mset_of_def multiset_fun_iff)

(* and more algebraic laws on multisets *)

lemma munion_eq_conv_diff: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
  \<Longrightarrow>  (M +# {#a#} = N +# {#b#}) \<longleftrightarrow>  (M = N \<and> a = b |
       M = N -# {#a#} +# {#b#} \<and> N = M -# {#b#} +# {#a#})"
apply (simp del: mcount_single add: multiset_equality)
apply (rule iffI, erule_tac [2] disjE, erule_tac [3] conjE)
apply (case_tac "a=b", auto)
apply (drule_tac x = a in spec)
apply (drule_tac [2] x = b in spec)
apply (drule_tac [3] x = aa in spec)
apply (drule_tac [4] x = a in spec, auto)
apply (subgoal_tac [!] "mcount (N,a) :nat")
apply (erule_tac [3] natE, erule natE, auto)
done

lemma melem_diff_single:
"multiset(M) \<Longrightarrow>
  k \<in> mset_of(M -# {#a#}) \<longleftrightarrow> (k=a \<and> 1 < mcount(M,a)) | (k\<noteq> a \<and> k \<in> mset_of(M))"
apply (simp add: multiset_def)
apply (simp add: normalize_def mset_of_def msingle_def mdiff_def mcount_def)
apply (auto dest: domain_type intro: zero_less_diff [THEN iffD1]
            simp add: multiset_fun_iff apply_iff)
apply (force intro!: lam_type)
apply (force intro!: lam_type)
apply (force intro!: lam_type)
done

lemma munion_eq_conv_exist:
"\<lbrakk>M \<in> Mult(A); N \<in> Mult(A)\<rbrakk>
  \<Longrightarrow> (M +# {#a#} = N +# {#b#}) \<longleftrightarrow>
      (M=N \<and> a=b | (\<exists>K \<in> Mult(A). M= K +# {#b#} \<and> N=K +# {#a#}))"
by (auto simp add: Mult_iff_multiset melem_diff_single munion_eq_conv_diff)

subsection\<open>Multiset Orderings\<close>

(* multiset on a domain A are finite functions from A to nat-{0} *)

(* multirel1 type *)

lemma multirel1_type: "multirel1(A, r) \<subseteq> Mult(A)*Mult(A)"
by (auto simp add: multirel1_def)

lemma multirel1_0 [simp]: "multirel1(0, r) =0"
by (auto simp add: multirel1_def)

lemma multirel1_iff:
" \<langle>N, M\<rangle> \<in> multirel1(A, r) \<longleftrightarrow>
  (\<exists>a. a \<in> A \<and>
  (\<exists>M0. M0 \<in> Mult(A) \<and> (\<exists>K. K \<in> Mult(A) \<and>
   M=M0 +# {#a#} \<and> N=M0 +# K \<and> (\<forall>b \<in> mset_of(K). \<langle>b,a\<rangle> \<in> r))))"
by (auto simp add: multirel1_def Mult_iff_multiset Bex_def)

text\<open>Monotonicity of \<^term>\<open>multirel1\<close>\<close>

lemma multirel1_mono1: "A\<subseteq>B \<Longrightarrow> multirel1(A, r)\<subseteq>multirel1(B, r)"
apply (auto simp add: multirel1_def)
apply (auto simp add: Un_subset_iff Mult_iff_multiset)
apply (rule_tac x = a in bexI)
apply (rule_tac x = M0 in bexI, simp)
apply (rule_tac x = K in bexI)
apply (auto simp add: Mult_iff_multiset)
done

lemma multirel1_mono2: "r\<subseteq>s \<Longrightarrow> multirel1(A,r)\<subseteq>multirel1(A, s)"
apply (simp add: multirel1_def, auto)
apply (rule_tac x = a in bexI)
apply (rule_tac x = M0 in bexI)
apply (simp_all add: Mult_iff_multiset)
apply (rule_tac x = K in bexI)
apply (simp_all add: Mult_iff_multiset, auto)
done

lemma multirel1_mono:
     "\<lbrakk>A\<subseteq>B; r\<subseteq>s\<rbrakk> \<Longrightarrow> multirel1(A, r) \<subseteq> multirel1(B, s)"
apply (rule subset_trans)
apply (rule multirel1_mono1)
apply (rule_tac [2] multirel1_mono2, auto)
done

subsection\<open>Toward the proof of well-foundedness of multirel1\<close>

lemma not_less_0 [iff]: "\<langle>M,0\<rangle> \<notin> multirel1(A, r)"
by (auto simp add: multirel1_def Mult_iff_multiset)

lemma less_munion: "\<lbrakk><N, M0 +# {#a#}> \<in> multirel1(A, r); M0 \<in> Mult(A)\<rbrakk> \<Longrightarrow>
  (\<exists>M. \<langle>M, M0\<rangle> \<in> multirel1(A, r) \<and> N = M +# {#a#}) |
  (\<exists>K. K \<in> Mult(A) \<and> (\<forall>b \<in> mset_of(K). \<langle>b, a\<rangle> \<in> r) \<and> N = M0 +# K)"
apply (frule multirel1_type [THEN subsetD])
apply (simp add: multirel1_iff)
apply (auto simp add: munion_eq_conv_exist)
apply (rule_tac x="Ka +# K" in exI, auto, simp add: Mult_iff_multiset)
apply (simp (no_asm_simp) add: munion_left_cancel munion_assoc)
apply (auto simp add: munion_commute)
done

lemma multirel1_base: "\<lbrakk>M \<in> Mult(A); a \<in> A\<rbrakk> \<Longrightarrow> <M, M +# {#a#}> \<in> multirel1(A, r)"
apply (auto simp add: multirel1_iff)
apply (simp add: Mult_iff_multiset)
apply (rule_tac x = a in exI, clarify)
apply (rule_tac x = M in exI, simp)
apply (rule_tac x = 0 in exI, auto)
done

lemma acc_0: "acc(0)=0"
by (auto intro!: equalityI dest: acc.dom_subset [THEN subsetD])

lemma lemma1: "\<lbrakk>\<forall>b \<in> A. \<langle>b,a\<rangle> \<in> r \<longrightarrow>
    (\<forall>M \<in> acc(multirel1(A, r)). M +# {#b#}:acc(multirel1(A, r)));
    M0 \<in> acc(multirel1(A, r)); a \<in> A;
    \<forall>M. \<langle>M,M0\<rangle> \<in> multirel1(A, r) \<longrightarrow> M +# {#a#} \<in> acc(multirel1(A, r))\<rbrakk>
  \<Longrightarrow> M0 +# {#a#} \<in> acc(multirel1(A, r))"
apply (subgoal_tac "M0 \<in> Mult(A) ")
 prefer 2
 apply (erule acc.cases)
 apply (erule fieldE)
 apply (auto dest: multirel1_type [THEN subsetD])
apply (rule accI)
apply (rename_tac "N")
apply (drule less_munion, blast)
apply (auto simp add: Mult_iff_multiset)
apply (erule_tac P = "\<forall>x \<in> mset_of (K) . \<langle>x, a\<rangle> \<in> r" in rev_mp)
apply (erule_tac P = "mset_of (K) \<subseteq>A" in rev_mp)
apply (erule_tac M = K in multiset_induct)
(* three subgoals *)
(* subgoal 1 \<in> the induction base case *)
apply (simp (no_asm_simp))
(* subgoal 2 \<in> the induction general case *)
apply (simp add: Ball_def Un_subset_iff, clarify)
apply (drule_tac x = aa in spec, simp)
apply (subgoal_tac "aa \<in> A")
prefer 2 apply blast
apply (drule_tac x = "M0 +# M" and P =
       "\<lambda>x. x \<in> acc(multirel1(A, r)) \<longrightarrow> Q(x)" for Q in spec)
apply (simp add: munion_assoc [symmetric])
(* subgoal 3 \<in> additional conditions *)
apply (auto intro!: multirel1_base [THEN fieldI2] simp add: Mult_iff_multiset)
done

lemma lemma2: "\<lbrakk>\<forall>b \<in> A. \<langle>b,a\<rangle> \<in> r
   \<longrightarrow> (\<forall>M \<in> acc(multirel1(A, r)). M +# {#b#} :acc(multirel1(A, r)));
        M \<in> acc(multirel1(A, r)); a \<in> A\<rbrakk> \<Longrightarrow> M +# {#a#} \<in> acc(multirel1(A, r))"
apply (erule acc_induct)
apply (blast intro: lemma1)
done

lemma lemma3: "\<lbrakk>wf[A](r); a \<in> A\<rbrakk>
      \<Longrightarrow> \<forall>M \<in> acc(multirel1(A, r)). M +# {#a#} \<in> acc(multirel1(A, r))"
apply (erule_tac a = a in wf_on_induct, blast)
apply (blast intro: lemma2)
done

lemma lemma4: "multiset(M) \<Longrightarrow> mset_of(M)\<subseteq>A \<longrightarrow>
   wf[A](r) \<longrightarrow> M \<in> field(multirel1(A, r)) \<longrightarrow> M \<in> acc(multirel1(A, r))"
apply (erule multiset_induct)
(* proving the base case *)
apply clarify
apply (rule accI, force)
apply (simp add: multirel1_def)
(* Proving the general case *)
apply clarify
apply simp
apply (subgoal_tac "mset_of (M) \<subseteq>A")
prefer 2 apply blast
apply clarify
apply (drule_tac a = a in lemma3, blast)
apply (subgoal_tac "M \<in> field (multirel1 (A,r))")
apply blast
apply (rule multirel1_base [THEN fieldI1])
apply (auto simp add: Mult_iff_multiset)
done

lemma all_accessible: "\<lbrakk>wf[A](r); M \<in> Mult(A); A \<noteq> 0\<rbrakk> \<Longrightarrow> M \<in> acc(multirel1(A, r))"
apply (erule not_emptyE)
apply  (rule lemma4 [THEN mp, THEN mp, THEN mp])
apply (rule_tac [4] multirel1_base [THEN fieldI1])
apply  (auto simp add: Mult_iff_multiset)
done

lemma wf_on_multirel1: "wf[A](r) \<Longrightarrow> wf[A-||>nat-{0}](multirel1(A, r))"
apply (case_tac "A=0")
apply (simp (no_asm_simp))
apply (rule wf_imp_wf_on)
apply (rule wf_on_field_imp_wf)
apply (simp (no_asm_simp) add: wf_on_0)
apply (rule_tac A = "acc (multirel1 (A,r))" in wf_on_subset_A)
apply (rule wf_on_acc)
apply (blast intro: all_accessible)
done

lemma wf_multirel1: "wf(r) \<Longrightarrow>wf(multirel1(field(r), r))"
apply (simp (no_asm_use) add: wf_iff_wf_on_field)
apply (drule wf_on_multirel1)
apply (rule_tac A = "field (r) -||> nat - {0}" in wf_on_subset_A)
apply (simp (no_asm_simp))
apply (rule field_rel_subset)
apply (rule multirel1_type)
done

(** multirel **)

lemma multirel_type: "multirel(A, r) \<subseteq> Mult(A)*Mult(A)"
apply (simp add: multirel_def)
apply (rule trancl_type [THEN subset_trans])
apply (auto dest: multirel1_type [THEN subsetD])
done

(* Monotonicity of multirel *)
lemma multirel_mono:
     "\<lbrakk>A\<subseteq>B; r\<subseteq>s\<rbrakk> \<Longrightarrow> multirel(A, r)\<subseteq>multirel(B,s)"
apply (simp add: multirel_def)
apply (rule trancl_mono)
apply (rule multirel1_mono, auto)
done

(* Equivalence of multirel with the usual (closure-free) definition *)

lemma add_diff_eq: "k \<in> nat \<Longrightarrow> 0 < k \<longrightarrow> n #+ k #- 1 = n #+ (k #- 1)"
by (erule nat_induct, auto)

lemma mdiff_union_single_conv: "\<lbrakk>a \<in> mset_of(J); multiset(I); multiset(J)\<rbrakk>
   \<Longrightarrow> I +# J -# {#a#} = I +# (J-# {#a#})"
apply (simp (no_asm_simp) add: multiset_equality)
apply (case_tac "a \<notin> mset_of (I) ")
apply (auto simp add: mcount_def mset_of_def multiset_def multiset_fun_iff)
apply (auto dest: domain_type simp add: add_diff_eq)
done

lemma diff_add_commute: "\<lbrakk>n \<le> m;  m \<in> nat; n \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> m #- n #+ k = m #+ k #- n"
by (auto simp add: le_iff less_iff_succ_add)

(* One direction *)

lemma multirel_implies_one_step:
"\<langle>M,N\<rangle> \<in> multirel(A, r) \<Longrightarrow>
     trans[A](r) \<longrightarrow>
     (\<exists>I J K.
         I \<in> Mult(A) \<and> J \<in> Mult(A) \<and>  K \<in> Mult(A) \<and>
         N = I +# J \<and> M = I +# K \<and> J \<noteq> 0 \<and>
        (\<forall>k \<in> mset_of(K). \<exists>j \<in> mset_of(J). \<langle>k,j\<rangle> \<in> r))"
apply (simp add: multirel_def Ball_def Bex_def)
apply (erule converse_trancl_induct)
apply (simp_all add: multirel1_iff Mult_iff_multiset)
(* Two subgoals remain *)
(* Subgoal 1 *)
apply clarify
apply (rule_tac x = M0 in exI, force)
(* Subgoal 2 *)
apply clarify
apply hypsubst_thin
apply (case_tac "a \<in> mset_of (Ka) ")
apply (rule_tac x = I in exI, simp (no_asm_simp))
apply (rule_tac x = J in exI, simp (no_asm_simp))
apply (rule_tac x = " (Ka -# {#a#}) +# K" in exI, simp (no_asm_simp))
apply (simp_all add: Un_subset_iff)
apply (simp (no_asm_simp) add: munion_assoc [symmetric])
apply (drule_tac t = "\<lambda>M. M-#{#a#}" in subst_context)
apply (simp add: mdiff_union_single_conv melem_diff_single, clarify)
apply (erule disjE, simp)
apply (erule disjE, simp)
apply (drule_tac x = a and P = "\<lambda>x. x :# Ka \<longrightarrow> Q(x)" for Q in spec)
apply clarify
apply (rule_tac x = xa in exI)
apply (simp (no_asm_simp))
apply (blast dest: trans_onD)
(* new we know that  a\<notin>mset_of(Ka) *)
apply (subgoal_tac "a :# I")
apply (rule_tac x = "I-#{#a#}" in exI, simp (no_asm_simp))
apply (rule_tac x = "J+#{#a#}" in exI)
apply (simp (no_asm_simp) add: Un_subset_iff)
apply (rule_tac x = "Ka +# K" in exI)
apply (simp (no_asm_simp) add: Un_subset_iff)
apply (rule conjI)
apply (simp (no_asm_simp) add: multiset_equality mcount_elem [THEN succ_pred_eq_self])
apply (rule conjI)
apply (drule_tac t = "\<lambda>M. M-#{#a#}" in subst_context)
apply (simp add: mdiff_union_inverse2)
apply (simp_all (no_asm_simp) add: multiset_equality)
apply (rule diff_add_commute [symmetric])
apply (auto intro: mcount_elem)
apply (subgoal_tac "a \<in> mset_of (I +# Ka) ")
apply (drule_tac [2] sym, auto)
done

lemma melem_imp_eq_diff_union [simp]: "\<lbrakk>a \<in> mset_of(M); multiset(M)\<rbrakk> \<Longrightarrow> M -# {#a#} +# {#a#} = M"
by (simp add: multiset_equality mcount_elem [THEN succ_pred_eq_self])

lemma msize_eq_succ_imp_eq_union:
     "\<lbrakk>msize(M)=$# succ(n); M \<in> Mult(A); n \<in> nat\<rbrakk>
      \<Longrightarrow> \<exists>a N. M = N +# {#a#} \<and> N \<in> Mult(A) \<and> a \<in> A"
apply (drule msize_eq_succ_imp_elem, auto)
apply (rule_tac x = a in exI)
apply (rule_tac x = "M -# {#a#}" in exI)
apply (frule Mult_into_multiset)
apply (simp (no_asm_simp))
apply (auto simp add: Mult_iff_multiset)
done

(* The second direction *)

lemma one_step_implies_multirel_lemma [rule_format (no_asm)]:
"n \<in> nat \<Longrightarrow>
   (\<forall>I J K.
    I \<in> Mult(A) \<and> J \<in> Mult(A) \<and> K \<in> Mult(A) \<and>
   (msize(J) = $# n \<and> J \<noteq>0 \<and>  (\<forall>k \<in> mset_of(K).  \<exists>j \<in> mset_of(J). \<langle>k, j\<rangle> \<in> r))
    \<longrightarrow> <I +# K, I +# J> \<in> multirel(A, r))"
apply (simp add: Mult_iff_multiset)
apply (erule nat_induct, clarify)
apply (drule_tac M = J in msize_eq_0_iff, auto)
(* one subgoal remains *)
apply (subgoal_tac "msize (J) =$# succ (x) ")
 prefer 2 apply simp
apply (frule_tac A = A in msize_eq_succ_imp_eq_union)
apply (simp_all add: Mult_iff_multiset, clarify)
apply (rename_tac "J'", simp)
apply (case_tac "J' = 0")
apply (simp add: multirel_def)
apply (rule r_into_trancl, clarify)
apply (simp add: multirel1_iff Mult_iff_multiset, force)
(*Now we know J' \<noteq>  0*)
apply (drule sym, rotate_tac -1, simp)
apply (erule_tac V = "$# x = msize (J') " in thin_rl)
apply (frule_tac M = K and P = "\<lambda>x. \<langle>x,a\<rangle> \<in> r" in multiset_partition)
apply (erule_tac P = "\<forall>k \<in> mset_of (K) . P(k)" for P in rev_mp)
apply (erule ssubst)
apply (simp add: Ball_def, auto)
apply (subgoal_tac "< (I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#}) +# {# x \<in> K. \<langle>x, a\<rangle> \<notin> r#}, (I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#}) +# J'> \<in> multirel(A, r) ")
 prefer 2
 apply (drule_tac x = "I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#}" in spec)
 apply (rotate_tac -1)
 apply (drule_tac x = "J'" in spec)
 apply (rotate_tac -1)
 apply (drule_tac x = "{# x \<in> K. \<langle>x, a\<rangle> \<notin> r#}" in spec, simp) apply blast
apply (simp add: munion_assoc [symmetric] multirel_def)
apply (rule_tac b = "I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#} +# J'" in trancl_trans, blast)
apply (rule r_into_trancl)
apply (simp add: multirel1_iff Mult_iff_multiset)
apply (rule_tac x = a in exI)
apply (simp (no_asm_simp))
apply (rule_tac x = "I +# J'" in exI)
apply (auto simp add: munion_ac Un_subset_iff)
done

lemma one_step_implies_multirel:
     "\<lbrakk>J \<noteq> 0;  \<forall>k \<in> mset_of(K). \<exists>j \<in> mset_of(J). \<langle>k,j\<rangle> \<in> r;
         I \<in> Mult(A); J \<in> Mult(A); K \<in> Mult(A)\<rbrakk>
      \<Longrightarrow> <I+#K, I+#J> \<in> multirel(A, r)"
apply (subgoal_tac "multiset (J) ")
 prefer 2 apply (simp add: Mult_iff_multiset)
apply (frule_tac M = J in msize_int_of_nat)
apply (auto intro: one_step_implies_multirel_lemma)
done

(** Proving that multisets are partially ordered **)

(*irreflexivity*)

lemma multirel_irrefl_lemma:
     "Finite(A) \<Longrightarrow> part_ord(A, r) \<longrightarrow> (\<forall>x \<in> A. \<exists>y \<in> A. \<langle>x,y\<rangle> \<in> r) \<longrightarrow>A=0"
apply (erule Finite_induct)
apply (auto dest: subset_consI [THEN [2] part_ord_subset])
apply (auto simp add: part_ord_def irrefl_def)
apply (drule_tac x = xa in bspec)
apply (drule_tac [2] a = xa and b = x in trans_onD, auto)
done

lemma irrefl_on_multirel:
     "part_ord(A, r) \<Longrightarrow> irrefl(Mult(A), multirel(A, r))"
apply (simp add: irrefl_def)
apply (subgoal_tac "trans[A](r) ")
 prefer 2 apply (simp add: part_ord_def, clarify)
apply (drule multirel_implies_one_step, clarify)
apply (simp add: Mult_iff_multiset, clarify)
apply (subgoal_tac "Finite (mset_of (K))")
apply (frule_tac r = r in multirel_irrefl_lemma)
apply (frule_tac B = "mset_of (K) " in part_ord_subset)
apply simp_all
apply (auto simp add: multiset_def mset_of_def)
done

lemma trans_on_multirel: "trans[Mult(A)](multirel(A, r))"
apply (simp add: multirel_def trans_on_def)
apply (blast intro: trancl_trans)
done

lemma multirel_trans:
 "\<lbrakk>\<langle>M, N\<rangle> \<in> multirel(A, r); \<langle>N, K\<rangle> \<in> multirel(A, r)\<rbrakk> \<Longrightarrow>  \<langle>M, K\<rangle> \<in> multirel(A,r)"
apply (simp add: multirel_def)
apply (blast intro: trancl_trans)
done

lemma trans_multirel: "trans(multirel(A,r))"
apply (simp add: multirel_def)
apply (rule trans_trancl)
done

lemma part_ord_multirel: "part_ord(A,r) \<Longrightarrow> part_ord(Mult(A), multirel(A, r))"
apply (simp (no_asm) add: part_ord_def)
apply (blast intro: irrefl_on_multirel trans_on_multirel)
done

(** Monotonicity of multiset union **)

lemma munion_multirel1_mono:
"\<lbrakk>\<langle>M,N\<rangle> \<in> multirel1(A, r); K \<in> Mult(A)\<rbrakk> \<Longrightarrow> <K +# M, K +# N> \<in> multirel1(A, r)"
apply (frule multirel1_type [THEN subsetD])
apply (auto simp add: multirel1_iff Mult_iff_multiset)
apply (rule_tac x = a in exI)
apply (simp (no_asm_simp))
apply (rule_tac x = "K+#M0" in exI)
apply (simp (no_asm_simp) add: Un_subset_iff)
apply (rule_tac x = Ka in exI)
apply (simp (no_asm_simp) add: munion_assoc)
done

lemma munion_multirel_mono2:
 "\<lbrakk>\<langle>M, N\<rangle> \<in> multirel(A, r); K \<in> Mult(A)\<rbrakk>\<Longrightarrow><K +# M, K +# N> \<in> multirel(A, r)"
apply (frule multirel_type [THEN subsetD])
apply (simp (no_asm_use) add: multirel_def)
apply clarify
apply (drule_tac psi = "\<langle>M,N\<rangle> \<in> multirel1 (A, r) ^+" in asm_rl)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule trancl_induct, clarify)
apply (blast intro: munion_multirel1_mono r_into_trancl, clarify)
apply (subgoal_tac "y \<in> Mult(A) ")
 prefer 2
 apply (blast dest: multirel_type [unfolded multirel_def, THEN subsetD])
apply (subgoal_tac "<K +# y, K +# z> \<in> multirel1 (A, r) ")
prefer 2 apply (blast intro: munion_multirel1_mono)
apply (blast intro: r_into_trancl trancl_trans)
done

lemma munion_multirel_mono1:
     "\<lbrakk>\<langle>M, N\<rangle> \<in> multirel(A, r); K \<in> Mult(A)\<rbrakk> \<Longrightarrow> <M +# K, N +# K> \<in> multirel(A, r)"
apply (frule multirel_type [THEN subsetD])
apply (rule_tac P = "\<lambda>x. \<langle>x,u\<rangle> \<in> multirel(A, r)" for u in munion_commute [THEN subst])
apply (subst munion_commute [of N])
apply (rule munion_multirel_mono2)
apply (auto simp add: Mult_iff_multiset)
done

lemma munion_multirel_mono:
     "\<lbrakk>\<langle>M,K\<rangle> \<in> multirel(A, r); \<langle>N,L\<rangle> \<in> multirel(A, r)\<rbrakk>
      \<Longrightarrow> <M +# N, K +# L> \<in> multirel(A, r)"
apply (subgoal_tac "M \<in> Mult(A) \<and> N \<in> Mult(A) \<and> K \<in> Mult(A) \<and> L \<in> Mult(A) ")
prefer 2 apply (blast dest: multirel_type [THEN subsetD])
apply (blast intro: munion_multirel_mono1 multirel_trans munion_multirel_mono2)
done

subsection\<open>Ordinal Multisets\<close>

(* A \<subseteq> B \<Longrightarrow>  field(Memrel(A)) \<subseteq> field(Memrel(B)) *)
lemmas field_Memrel_mono = Memrel_mono [THEN field_mono]

(*
\<lbrakk>Aa \<subseteq> Ba; A \<subseteq> B\<rbrakk> \<Longrightarrow>
multirel(field(Memrel(Aa)), Memrel(A))\<subseteq> multirel(field(Memrel(Ba)), Memrel(B))
*)

lemmas multirel_Memrel_mono = multirel_mono [OF field_Memrel_mono Memrel_mono]

lemma omultiset_is_multiset [simp]: "omultiset(M) \<Longrightarrow> multiset(M)"
apply (simp add: omultiset_def)
apply (auto simp add: Mult_iff_multiset)
done

lemma munion_omultiset [simp]: "\<lbrakk>omultiset(M); omultiset(N)\<rbrakk> \<Longrightarrow> omultiset(M +# N)"
apply (simp add: omultiset_def, clarify)
apply (rule_tac x = "i \<union> ia" in exI)
apply (simp add: Mult_iff_multiset Ord_Un Un_subset_iff)
apply (blast intro: field_Memrel_mono)
done

lemma mdiff_omultiset [simp]: "omultiset(M) \<Longrightarrow> omultiset(M -# N)"
apply (simp add: omultiset_def, clarify)
apply (simp add: Mult_iff_multiset)
apply (rule_tac x = i in exI)
apply (simp (no_asm_simp))
done

(** Proving that Memrel is a partial order **)

lemma irrefl_Memrel: "Ord(i) \<Longrightarrow> irrefl(field(Memrel(i)), Memrel(i))"
apply (rule irreflI, clarify)
apply (subgoal_tac "Ord (x) ")
prefer 2 apply (blast intro: Ord_in_Ord)
apply (drule_tac i = x in ltI [THEN lt_irrefl], auto)
done

lemma trans_iff_trans_on: "trans(r) \<longleftrightarrow> trans[field(r)](r)"
by (simp add: trans_on_def trans_def, auto)

lemma part_ord_Memrel: "Ord(i) \<Longrightarrow>part_ord(field(Memrel(i)), Memrel(i))"
apply (simp add: part_ord_def)
apply (simp (no_asm) add: trans_iff_trans_on [THEN iff_sym])
apply (blast intro: trans_Memrel irrefl_Memrel)
done

(*
  Ord(i) \<Longrightarrow>
  part_ord(field(Memrel(i))-||>nat-{0}, multirel(field(Memrel(i)), Memrel(i)))
*)

lemmas part_ord_mless = part_ord_Memrel [THEN part_ord_multirel]

(*irreflexivity*)

lemma mless_not_refl: "\<not>(M <# M)"
apply (simp add: mless_def, clarify)
apply (frule multirel_type [THEN subsetD])
apply (drule part_ord_mless)
apply (simp add: part_ord_def irrefl_def)
done

(* N<N \<Longrightarrow> R *)
lemmas mless_irrefl = mless_not_refl [THEN notE, elim!]

(*transitivity*)
lemma mless_trans: "\<lbrakk>K <# M; M <# N\<rbrakk> \<Longrightarrow> K <# N"
apply (simp add: mless_def, clarify)
apply (rule_tac x = "i \<union> ia" in exI)
apply (blast dest: multirel_Memrel_mono [OF Un_upper1 Un_upper1, THEN subsetD]
                   multirel_Memrel_mono [OF Un_upper2 Un_upper2, THEN subsetD]
        intro: multirel_trans Ord_Un)
done

(*asymmetry*)
lemma mless_not_sym: "M <# N \<Longrightarrow> \<not> N <# M"
apply clarify
apply (rule mless_not_refl [THEN notE])
apply (erule mless_trans, assumption)
done

lemma mless_asym: "\<lbrakk>M <# N; \<not>P \<Longrightarrow> N <# M\<rbrakk> \<Longrightarrow> P"
by (blast dest: mless_not_sym)

lemma mle_refl [simp]: "omultiset(M) \<Longrightarrow> M <#= M"
by (simp add: mle_def)

(*anti-symmetry*)
lemma mle_antisym:
     "\<lbrakk>M <#= N;  N <#= M\<rbrakk> \<Longrightarrow> M = N"
apply (simp add: mle_def)
apply (blast dest: mless_not_sym)
done

(*transitivity*)
lemma mle_trans: "\<lbrakk>K <#= M; M <#= N\<rbrakk> \<Longrightarrow> K <#= N"
apply (simp add: mle_def)
apply (blast intro: mless_trans)
done

lemma mless_le_iff: "M <# N \<longleftrightarrow> (M <#= N \<and> M \<noteq> N)"
by (simp add: mle_def, auto)

(** Monotonicity of mless **)

lemma munion_less_mono2: "\<lbrakk>M <# N; omultiset(K)\<rbrakk> \<Longrightarrow> K +# M <# K +# N"
apply (simp add: mless_def omultiset_def, clarify)
apply (rule_tac x = "i \<union> ia" in exI)
apply (simp add: Mult_iff_multiset Ord_Un Un_subset_iff)
apply (rule munion_multirel_mono2)
 apply (blast intro: multirel_Memrel_mono [THEN subsetD])
apply (simp add: Mult_iff_multiset)
apply (blast intro: field_Memrel_mono [THEN subsetD])
done

lemma munion_less_mono1: "\<lbrakk>M <# N; omultiset(K)\<rbrakk> \<Longrightarrow> M +# K <# N +# K"
by (force dest: munion_less_mono2 simp add: munion_commute)

lemma mless_imp_omultiset: "M <# N \<Longrightarrow> omultiset(M) \<and> omultiset(N)"
by (auto simp add: mless_def omultiset_def dest: multirel_type [THEN subsetD])

lemma munion_less_mono: "\<lbrakk>M <# K; N <# L\<rbrakk> \<Longrightarrow> M +# N <# K +# L"
apply (frule_tac M = M in mless_imp_omultiset)
apply (frule_tac M = N in mless_imp_omultiset)
apply (blast intro: munion_less_mono1 munion_less_mono2 mless_trans)
done

(* <#= *)

lemma mle_imp_omultiset: "M <#= N \<Longrightarrow> omultiset(M) \<and> omultiset(N)"
by (auto simp add: mle_def mless_imp_omultiset)

lemma mle_mono: "\<lbrakk>M <#= K;  N <#= L\<rbrakk> \<Longrightarrow> M +# N <#= K +# L"
apply (frule_tac M = M in mle_imp_omultiset)
apply (frule_tac M = N in mle_imp_omultiset)
apply (auto simp add: mle_def intro: munion_less_mono1 munion_less_mono2 munion_less_mono)
done

lemma omultiset_0 [iff]: "omultiset(0)"
by (auto simp add: omultiset_def Mult_iff_multiset)

lemma empty_leI [simp]: "omultiset(M) \<Longrightarrow> 0 <#= M"
apply (simp add: mle_def mless_def)
apply (subgoal_tac "\<exists>i. Ord (i) \<and> M \<in> Mult(field(Memrel(i))) ")
 prefer 2 apply (simp add: omultiset_def)
apply (case_tac "M=0", simp_all, clarify)
apply (subgoal_tac "<0 +# 0, 0 +# M> \<in> multirel(field (Memrel(i)), Memrel(i))")
apply (rule_tac [2] one_step_implies_multirel)
apply (auto simp add: Mult_iff_multiset)
done

lemma munion_upper1: "\<lbrakk>omultiset(M); omultiset(N)\<rbrakk> \<Longrightarrow> M <#= M +# N"
apply (subgoal_tac "M +# 0 <#= M +# N")
apply (rule_tac [2] mle_mono, auto)
done

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Typed_Lambda_Calculus
imports
  Main
  "List-Index.List_Index"
begin
(*>*)

section {* Typed Lambda Calculus *}
text {* \label{sec:simply-typed-lambda-calculus} *}

text {*
We now revisit the $\lambda$-calculus (Section~\ref{sec:untyped-lambda-calculus}) and augment it
with static types. Unlike the typed arithmetic expressions language, types are an integral part of
the language and its syntax. For this reason, we cannot import the theory of the untyped variant
and build on top of it, but need to provide new, although similar, definitions. We will prove type
safety through the progress and preservation theorems before showing that types can be safely erased
while preserving the semantics of the language.
*}

subsection {* Definitions *}

(* Definition 9.1.1 *)

text {*
In the untyped lambda-calculus, everything is a function. Thus, we need to provide the type of
functions, usually written @{text "a \<rightarrow> b"} which, given an argument of type @{term a}, will
evaluate to a value of type @{term b}. Since both @{term a} and @{term b} must be valid types, we
need to provide a base case to stop the recursion at some point. To keep the language minimal, we
only add the Boolean type as a base case:\footnote{The prefix \emph{l} stands for
\emph{lambda-calculus}.}
*}

datatype ltype =
  Bool |
  Fun (domain: ltype) (codomain: ltype) (infixr "\<rightarrow>" 225)

text {*
In the previous definition, @{text "\<rightarrow>"} is a type constructor which can be use to create function
types for some concrete domain and codomain. Examples of such types include the
following:\footnote{Note that the last two examples are equivalent, since the @{text "\<rightarrow>"} operator
is right-associative.}
\setcounter{equation}{0}
\begin{gather}
  @{term "Bool \<rightarrow> Bool"} \\
  @{term "(Bool \<rightarrow> Bool) \<rightarrow> Bool"} \\
  @{term [source] "(Bool \<rightarrow> Bool) \<rightarrow> (Bool \<rightarrow> Bool)"} \\
  @{term "(Bool \<rightarrow> Bool) \<rightarrow> Bool \<rightarrow> Bool"}
\end{gather}

Programming languages usually have more than our base type. Examples include integers, floating
point numbers, characters, arrays, etc.

Since variables can now range over infinitely many types, we need a way to know which type a
function requires as domain. There are two possible strategies: we can annotate the
$\lambda$-abstractions with the intended type of their arguments, or else we can analyze the body of
the abstraction to infer the required type. \emph{TAPL} chose the former strategy.

The syntax of this language differs from the pure $\lambda$-calculus by having constructions for
Boolean expressions and a type annotation on function abstractions:
*}

datatype lterm =
  LTrue |
  LFalse |
  LIf (bool_expr: lterm) (then_expr: lterm) (else_expr: lterm) |
  LVar nat |
  LAbs (arg_type: ltype) (body: lterm) |
  LApp lterm lterm

text {*
We define the shift and substitution functions for this extended language:
*}

primrec shift_L :: "int \<Rightarrow> nat \<Rightarrow> lterm \<Rightarrow> lterm" where
  "shift_L d c LTrue = LTrue" |
  "shift_L d c LFalse = LFalse" |
  "shift_L d c (LIf t1 t2 t3) = LIf (shift_L d c t1) (shift_L d c t2) (shift_L d c t3)" |
  "shift_L d c (LVar k) = LVar (if k < c then k else nat (int k + d))" |
  "shift_L d c (LAbs T t) = LAbs T (shift_L d (Suc c) t)" |
  "shift_L d c (LApp t1 t2) = LApp (shift_L d c t1) (shift_L d c t2)"

primrec subst_L :: "nat \<Rightarrow> lterm \<Rightarrow> lterm \<Rightarrow> lterm" where
  "subst_L j s LTrue = LTrue" |
  "subst_L j s LFalse = LFalse" |
  "subst_L j s (LIf t1 t2 t3) = LIf (subst_L j s t1) (subst_L j s t2) (subst_L j s t3)" |
  "subst_L j s (LVar k) = (if k = j then s else LVar k)" |
  "subst_L j s (LAbs T t) = LAbs T (subst_L (Suc j) (shift_L 1 0 s) t)" |
  "subst_L j s (LApp t1 t2) = LApp (subst_L j s t1) (subst_L j s t2)"

text {*
The semantics is similar to the pure $\lambda$-calculus. A first difference is that the set of values
also contain the Boolean constants:
*}

inductive is_value_L :: "lterm \<Rightarrow> bool" where
  "is_value_L LTrue" |
  "is_value_L LFalse" |
  "is_value_L (LAbs T t)"

text {*
A second difference is that the single-step evaluation relation also contains the rules for the
evaluation of the conditional statement:
*}

inductive eval1_L :: "lterm \<Rightarrow> lterm \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of Booleans\<close>
  eval1_LIf_LTrue:
    "eval1_L (LIf LTrue t2 t3) t2" |
  eval1_LIf_LFalse:
    "eval1_L (LIf LFalse t2 t3) t3" |
  eval1_LIf:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LIf t1 t2 t3) (LIf t1' t2 t3)" |

  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LApp1:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LApp t1 t2) (LApp t1' t2)" |
  eval1_LApp2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 t2' \<Longrightarrow> eval1_L (LApp v1 t2) (LApp v1 t2')" |
  eval1_LApp_LAbs:
    "is_value_L v2 \<Longrightarrow> eval1_L (LApp (LAbs T t12) v2)
      (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) t12))"

text {*
When type checking the body of a function abstraction, we assume that the given function argument
does have the type annotated. Since the body could itself be a function abstraction, we need to keep
track of this set of typing assumptions, also known as a typing context. Since the book considers
variables to be a named reference to a $\lambda$-abstraction, its typing context is a set of
identifier--type pairs. Our use of de Bruijn indices requires us to consider an alternative
representation. We define a context to be a list of types whose $n$th position contains the type of
the $n$th free variale:
*}

type_synonym lcontext = "ltype list"

text {*
To keep the notation similar to the book, we define some synonyms for the list operations
that mimic their set counterpart:
*}

notation Nil ("\<emptyset>")
abbreviation cons :: "lcontext \<Rightarrow> ltype \<Rightarrow> lcontext" (infixl "|,|" 200) where
  "cons \<Gamma> T \<equiv> T # \<Gamma>"
abbreviation elem' :: "(nat \<times> ltype) \<Rightarrow> lcontext \<Rightarrow> bool" (infix "|\<in>|" 200) where
  "elem' p \<Gamma> \<equiv> fst p < length \<Gamma> \<and> snd p = nth \<Gamma> (fst p)"

text \<open>
With the concept of typing concept, the syntax used for the typing relation needs to be extended:
\begin{equation*}
\Gamma \vdash t : T
\end{equation*}

This syntax can be read as ``under the context $\Gamma$, the term $t$ have type $T$. We now define
the typing relation by translating the induction rules present in the book to an inductive
definition:
\<close>

inductive has_type_L :: "lcontext \<Rightarrow> lterm \<Rightarrow> ltype \<Rightarrow> bool" ("((_)/ \<turnstile> (_)/ |:| (_))" [150, 150, 150] 150) where
  \<comment> \<open>Rules relating to the type of Booleans\<close>
  has_type_LTrue:
    "\<Gamma> \<turnstile> LTrue |:| Bool" |
  has_type_LFalse:
    "\<Gamma> \<turnstile> LFalse |:| Bool" |
  has_type_LIf:
    "\<Gamma> \<turnstile> t1 |:| Bool \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T \<Longrightarrow> \<Gamma> \<turnstile> t3 |:| T \<Longrightarrow> \<Gamma> \<turnstile> (LIf t1 t2 t3) |:| T" |

  \<comment> \<open>Rules relating to the type of the constructs of the $\lambda$-calculus\<close>
  has_type_LVar:
    "(x, T) |\<in>| \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> (LVar x) |:| T" |
  has_type_LAbs:
    "(\<Gamma> |,| T1) \<turnstile> t2 |:| T2 \<Longrightarrow> \<Gamma> \<turnstile> (LAbs T1 t2) |:| (T1 \<rightarrow> T2)" |
  has_type_LApp:
    "\<Gamma> \<turnstile> t1 |:| (T11 \<rightarrow> T12) \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T11 \<Longrightarrow> \<Gamma> \<turnstile> (LApp t1 t2) |:| T12"

text {*
The rules for Booleans are the same as in section \ref{sec:typed-arith-expr}. The rule
@{thm [source] has_type_LVar} states that the type of a variable must be in the typing context. The
rule @{thm [source] has_type_LAbs} states that the type of an $\lambda$-abstraction depends on the
type of both its argument and body. Finally, the rule @{thm [source] has_type_LApp} states that the
type of a function application is the codomain of the function. As an example of a usage of the
typing relation, consider the type of the application of @{term LTrue} to the Boolean identity
function:
*}

lemma "\<emptyset> \<turnstile> (LApp (LAbs Bool (LVar 0)) LTrue) |:| Bool"
  by (auto intro!: has_type_L.intros)

(* Exercise 9.2.2 *)

text {*
A more interesting example, assuming there is one variable of type @{term "Bool \<rightarrow> Bool"} in the
typing context, is the type of applying a Boolean expression to this variable:
*}

lemma
  assumes "\<Gamma> = \<emptyset> |,| (Bool \<rightarrow> Bool)"
  shows "\<Gamma> \<turnstile> LApp (LVar 0) (LIf LFalse LTrue LFalse) |:| Bool"
by (auto intro!: has_type_L.intros simp: assms)
(*<*)

lemma
  assumes "\<Gamma> = \<emptyset> |,| (Bool \<rightarrow> Bool)"
  shows "\<Gamma> \<turnstile> LAbs Bool (LApp (LVar 1) (LIf (LVar 0) LTrue LFalse)) |:| Bool \<rightarrow> Bool"
  by (auto intro!: has_type_L.intros simp: assms)

(* Exercise 9.2.3 *)

lemma
  assumes "\<Gamma> = \<emptyset> |,| Bool \<rightarrow> Bool \<rightarrow> Bool |,| Bool |,| Bool"
  shows "\<Gamma> \<turnstile> LApp (LApp (LVar 2) (LVar 1)) (LVar 0) |:| Bool"
  by (auto intro!: has_type_L.intros simp: assms)

lemma ex9_2_3_general:
  "\<emptyset> |,| T \<rightarrow> T \<rightarrow> Bool |,| T |,| T \<turnstile> LApp (LApp (LVar 2) (LVar 1)) (LVar 0) |:| Bool"
  by (auto intro!: has_type_L.intros)

lemmas ex9_2_3_bool = ex9_2_3_general[of Bool]

(*>*)
subsection {* Properties of Typing *}

(* Lemma 9.3.1 *)

text {*
The inversion of typing relation, which gives us information on types for specific terms, will be
a useful lemma in the following theorems:
*}

lemma inversion:
  "\<Gamma> \<turnstile> LTrue |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile> LFalse |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile> LIf t1 t2 t3 |:| R \<Longrightarrow> \<Gamma> \<turnstile> t1 |:| Bool \<and> \<Gamma> \<turnstile> t2 |:| R \<and> \<Gamma> \<turnstile> t3 |:| R"
  "\<Gamma> \<turnstile> LVar x |:| R \<Longrightarrow> (x, R) |\<in>| \<Gamma>"
  "\<Gamma> \<turnstile> LAbs T1 t2 |:| R \<Longrightarrow> \<exists>R2. R = T1 \<rightarrow> R2 \<and> \<Gamma> |,| T1 \<turnstile> t2 |:| R2"
  "\<Gamma> \<turnstile> LApp t1 t2 |:| R \<Longrightarrow> \<exists>T11. \<Gamma> \<turnstile> t1 |:| T11 \<rightarrow> R \<and> \<Gamma> \<turnstile> t2 |:| T11"
  by (auto elim: has_type_L.cases)
(*<*)
(* Exercise 9.3.2 *)

lemma "\<not> (\<Gamma> \<turnstile> LApp (LVar 0) (LVar 0) |:| T)"
proof
  assume "\<Gamma> \<turnstile> LApp (LVar 0) (LVar 0) |:| T"
  hence "\<exists>U. \<Gamma> \<turnstile> LVar 0 |:| U \<rightarrow> T \<and> \<Gamma> \<turnstile> LVar 0 |:| U" by (auto dest: inversion(6))
  hence "\<exists>U. (0, U \<rightarrow> T) |\<in>| \<Gamma> \<and> (0, U) |\<in>| \<Gamma>" by (auto dest!: inversion(4))
  hence "\<exists>U R. (0, R) |\<in>| \<Gamma> \<and> R = U \<rightarrow> T \<and> R = U" by simp
  hence "\<exists>U. U = U \<rightarrow> T" by auto
  thus "False" by (auto dest: arg_cong[of _ _ size])
qed

(*>*)
(* Theorem 9.3.3 *)

text {*
Every term has at most one type:
*}

theorem uniqueness_of_types:
  "\<Gamma> \<turnstile> t |:| T1 \<Longrightarrow> \<Gamma> \<turnstile> t |:| T2 \<Longrightarrow> T1 = T2"
by (induction \<Gamma> t T1 arbitrary: T2 rule: has_type_L.induct)
  (metis prod.sel ltype.sel inversion)+

(* Lemma 9.3.4 *)

text {*
The canonical form of values, which gives us information on terms for well-typed values, will also
be useful later:
*}

lemma canonical_forms:
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Bool \<Longrightarrow> v = LTrue \<or> v = LFalse"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LAbs T1 t"
by (auto elim: has_type_L.cases is_value_L.cases)

(* Theorem 9.3.5 *)

text {*
To formalize the concept of free variables (i.e. variables referring to a non existing
$\lambda$-abstraction), we provide a function that return the set of free variables of a term:
*}

primrec FV :: "lterm \<Rightarrow> nat set" where
  "FV LTrue = {}" |
  "FV LFalse = {}" |
  "FV (LIf t1 t2 t3) = FV t1 \<union> FV t2 \<union> FV t3" |
  "FV (LVar x) = {x}" |
  "FV (LAbs T t) = image (\<lambda>x. x - 1) (FV t - {0})" |
  "FV (LApp t1 t2) = FV t1 \<union> FV t2"
(*<*)

lemma "FV (LAbs Bool (LAbs Bool (LIf (LVar 2) (LVar 0) (LVar 1)))) = {0}"
  by (simp add: insert_commute[of _ 0])

(*>*)
text {*
Based on the @{const FV} function, we can now define a closed term to be a term whose set of
free-variables is empty:
*}

definition is_closed :: "lterm \<Rightarrow> bool" where
  "is_closed t \<equiv> FV t = {}"
(*<*)

lemma "\<not> is_closed (LAbs Bool (LAbs Bool (LIf (LVar 2) (LVar 0) (LVar 1))))"
  by (simp add: is_closed_def insert_commute[of _ 0])

lemma "is_closed (LAbs Bool (LAbs Bool (LAbs Bool (LIf (LVar 2) (LVar 0) (LVar 1)))))"
  by (simp add: is_closed_def insert_commute[of _ 0])

(*>*)
text {*
We now prove the progress theorem (i.e. a well-typed closed term is either a value or can take a
step according to the evaluation rules):
*}

theorem progress:
   "\<emptyset> \<turnstile> t |:| T \<Longrightarrow> is_closed t \<Longrightarrow> is_value_L t \<or> (\<exists>t'. eval1_L t t')"
proof (induction t T rule: has_type_L.induct)
  case (has_type_LIf \<Gamma> t1 t2 T t3)
  thus ?case by (cases "is_value_L t1")
    (auto intro: eval1_L.intros dest: canonical_forms simp: is_closed_def)
next
  case (has_type_LApp \<Gamma> t1 T11 T12 t2)
  thus ?case by (cases "is_value_L t1", cases "is_value_L t2")
    (auto intro: eval1_L.intros dest: canonical_forms simp: is_closed_def)
qed (simp_all add: is_value_L.intros is_closed_def)
(*<*)

(*>*)
(* Lemma 9.3.7 *)

text {*
Proving the preservation theorem requires us to first prove a number of helper lemmas. For these,
our reliance on "de Bruijn indices" forces us to depart substantially from the book.

The first lemma the book considers is the permutation of the typing context:

\begin{quotation}
  \noindent If $\Gamma \vdash t : T$ and $\Delta$ is a permutation of $\Gamma$, then
  $\Delta \vdash t : T$. Moreover, the latter derivation has the same depth as the former.
\end{quotation}

Translated naively, this lemma does not hold with our representation of the typing context as an
ordered. Instead, we will prove an other lemma which states that it is safe to remove a variable
from the context if it is not referenced in the considered term:
*}
(*<*)

lemma[simp]: "nat (int x - 1) = x - 1" by simp

(*>*)
lemma shift_down:
  "insert_nth n U \<Gamma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow>
   (\<And>x. x \<in> FV t \<Longrightarrow> x \<noteq> n) \<Longrightarrow> \<Gamma> \<turnstile> shift_L (- 1) n t |:| T"
proof (induction "insert_nth n U \<Gamma>" t T arbitrary: \<Gamma> n rule: has_type_L.induct)
  case (has_type_LAbs V t T)
  from this(1,3,4) show ?case
    by (fastforce intro: has_type_L.intros has_type_LAbs.hyps(2)[where n="Suc n"])+
qed (fastforce intro: has_type_L.intros simp: nth_append min_def)+

text {*
This lemma was the most challenging to express and prove. It was difficult to define the correct set
of assumptions and, prior to simplifications, the proof was quite imposing.

The book then consider the weakening the typing context:

\begin{quotation}
  \noindent If $\Gamma \vdash t : T$ and $x \notin dom(\Gamma)$, then $\Gamma , x:S \vdash t : T$.
  Moreover, the latter derivation has the same depth as the former.
\end{quotation}

This lemma does hold with our representation of the typing context, but we need to express it in
terms of list by inserting the type @{term S} at a fixed position @{term n}. Moreover, we need to
shift up every variable referring to a $\lambda$-abstraction further in the context than @{term n}.
*}

lemma weakening:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n S \<Gamma> \<turnstile> shift_L 1 n t |:| T"
proof (induction \<Gamma> t T arbitrary: n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t2 T2)
  from has_type_LAbs.prems has_type_LAbs.hyps
    has_type_LAbs.IH[where n="Suc n"]
  show ?case
    by (auto intro: has_type_L.intros)
qed (auto simp: nth_append min_def intro: has_type_L.intros)

text {*
This specific formulation was difficult to come with but the proof is, after simplifications, fairly
short. It is a typical situation in interactive theorem proving that the result seems simple and
does not make justice to the effort. It can be considered an achievement to reduce a huge and
unreadable proof to a small and readable one.
*}

(* Lemma 9.3.8 *)

text {*
The book then considers, as its last helper lemma, the preservation of types under substitution:

\begin{quotation}
  \noindent If $\Gamma, x:S \vdash t : T$ and $\Gamma \vdash s : S$, then
  $\Gamma \vdash [x \mapsto s] : T$.
\end{quotation}

We prove a slightly different theorem that is more suitable for the coming proofs:
*}

lemma substitution:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow>  \<Gamma> \<turnstile> LVar n |:| S \<Longrightarrow> \<Gamma> \<turnstile> s |:| S \<Longrightarrow> \<Gamma> \<turnstile> subst_L n s t |:| T"
proof (induction \<Gamma> t T arbitrary: s n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t T2)
  thus ?case by (fastforce
    intro: has_type_L.intros weakening[where n=0, unfolded insert_nth_def nat.rec]
    dest: inversion(4))
qed (auto intro!: has_type_L.intros dest: inversion(4))
(*<*)
(* Theorem 9.3.9 *)

inductive_cases eval1_LAppE: "eval1_L (LApp t1 t2) t"

(*>*)
text {*
We must provide a some more lemmas to define how the @{const FV} function behaves with respect to the
@{term shift_L} and @{term subst_L} functions:
*}
(*<*)

lemma gr_Suc_conv: "Suc x \<le> n \<longleftrightarrow> (\<exists>m. n = Suc m \<and> x \<le> m)"
  by (cases n) auto

(*>*)
lemma FV_shift:
  "FV (shift_L (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FV t)"
proof (induction t arbitrary: c rule: lterm.induct)
  case (LAbs T t)
  thus ?case  by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemmas int_1 = of_nat_1[where 'a=int]

lemma FV_subst:
  "FV (subst_L n t u) = (if n \<in> FV u then (FV u - {n}) \<union> FV t else FV u)"
proof (induction u arbitrary: n t rule: lterm.induct)
  case (LAbs T u)
  thus ?case
    by (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1],
        (metis DiffI One_nat_def UnCI diff_Suc_1 empty_iff imageI insert_iff nat.distinct(1))+)
qed (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1])

text {*
Again, these lemmas are not present in the book. It is usual for paper proofs to be a little sketchy
and rely on readers to imagine fill in the blanks with some simple lemmas. The need for these arise
from the use of the @{const FV} function in the @{thm [source] shift_down} lemma.

Finally, we can now prove the preservation theorem:
*}

theorem preservation:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> eval1_L t t' \<Longrightarrow> \<Gamma> \<turnstile> t' |:| T"
proof (induction \<Gamma> t T arbitrary: t' rule: has_type_L.induct)
  case (has_type_LIf \<Gamma> t1 t2 T t3)
  thus ?case by (auto intro: has_type_L.intros eval1_L.cases[OF has_type_LIf.prems])
next
  case (has_type_LApp \<Gamma> t1 T11 T12 t2)
  thus ?case  by (auto
    intro!: has_type_L.intros substitution shift_down
    dest!: inversion
    dest: weakening[where n=0, unfolded insert_nth_def nat.rec]
    elim!: eval1_LAppE
    split: lterm.splits if_splits
    simp: FV_subst FV_shift[of 1, unfolded int_1])
      (metis neq0_conv)
qed (auto elim: eval1_L.cases)

text {*
By proving the progress and the preservation theorems, we have shown that the typed
$\lambda$-calculus is type safe, i.e. every well-typed program has a well-defined semantics.
*}

subsection {* Erasure and Typability *}

text {*
The type system we formalized is completely static (i.e. there is no run-time checked involving the
types of terms). Since the type annotations are not used during evaluation, it is worth exploring
the possibility to erase them prior to execution. To this end, we define an untyped version of
our $\lambda$-calculus with Booleans:\footnote{The definitions are analogous to their typed
counterpart.}
*}

datatype uterm =
  UTrue |
  UFalse |
  UIf uterm uterm uterm |
  UVar nat |
  UAbs uterm |
  UApp uterm uterm

primrec shift_U :: "int \<Rightarrow> nat \<Rightarrow> uterm \<Rightarrow> uterm" (*<*) where
  "shift_U d c UTrue = UTrue" |
  "shift_U d c UFalse = UFalse" |
  "shift_U d c (UIf t1 t2 t3) =
    UIf (shift_U d c t1) (shift_U d c t2) (shift_U d c t3)" |
  "shift_U d c (UVar k) = UVar (if k < c then k else nat (int k + d))" |
  "shift_U d c (UAbs t) = UAbs (shift_U d (Suc c) t)" |
  "shift_U d c (UApp t1 t2) = UApp (shift_U d c t1) (shift_U d c t2)"
(*>*)

primrec subst_U :: "nat \<Rightarrow> uterm \<Rightarrow> uterm \<Rightarrow> uterm" (*<*) where
  "subst_U j s UTrue = UTrue" |
  "subst_U j s UFalse = UFalse" |
  "subst_U j s (UIf t1 t2 t3) =
    UIf (subst_U j s t1) (subst_U j s t2) (subst_U j s t3)" |
  "subst_U j s (UVar k) = (if k = j then s else UVar k)" |
  "subst_U j s (UAbs t) = UAbs (subst_U (Suc j) (shift_U 1 0 s) t)" |
  "subst_U j s (UApp t1 t2) = UApp (subst_U j s t1) (subst_U j s t2)"
(*>*)

inductive is_value_U :: "uterm \<Rightarrow> bool" (*<*) where
  "is_value_U UTrue" |
  "is_value_U UFalse" |
  "is_value_U (UAbs t)"
(*>*)

inductive eval1_U :: "uterm \<Rightarrow> uterm \<Rightarrow> bool" (*<*) where
  IfT:"eval1_U (UIf UTrue t2 t3) t2" |
  IfF:"eval1_U (UIf UFalse t2 t3) t3" |
  IfCdt:"eval1_U t1 t1' \<Longrightarrow> eval1_U (UIf t1 t2 t3) (UIf t1' t2 t3)" |
  Appl:"eval1_U t1 t1' \<Longrightarrow> eval1_U (UApp t1 t2) (UApp t1' t2)" |
  Appr:"is_value_U v1 \<Longrightarrow> eval1_U t2 t2' \<Longrightarrow> eval1_U (UApp v1 t2) (UApp v1 t2')" |
  beta_red:"is_value_U v2 \<Longrightarrow> eval1_U (UApp (UAbs t12) v2)
    (shift_U (-1) 0 (subst_U 0 (shift_U 1 0 v2) t12))"
(*>*)

text {*
We now define a morphism which maps every typed term to an equivalent untyped one:
*}

primrec erase :: "lterm \<Rightarrow> uterm" where
  "erase LTrue = UTrue" |
  "erase LFalse = UFalse" |
  "erase (LIf t1 t2 t3) = (UIf (erase t1) (erase t2) (erase t3))" |
  "erase (LVar x) = UVar x" |
  "erase (LAbs _ t) = UAbs (erase t)" |
  "erase (LApp t1 t2) = UApp (erase t1) (erase t2)"

text {*
We also characterize how the @{const erase} function reacts with respect to values and the
@{const shift_L} and @{const subst_L} functions.
*}

lemma is_value_erasure:
  "is_value_L t = is_value_U (erase t)"
by (induction t rule: lterm.induct) (auto simp: is_value_L.simps is_value_U.simps)

lemma shift_erasure:
  "erase (shift_L d c t) = shift_U d c (erase t)"
by (induction t arbitrary: d c rule: lterm.induct) auto

text {* \newpage *}

lemma subst_erasure:
  "erase (subst_L j s t) = subst_U j (erase s) (erase t)"
by (induction t arbitrary: j s rule: lterm.induct) (auto simp: shift_erasure)

(* Theorem 9.5.1 *)

text {*
We can now prove that every evaluation step on a typed term can be performed in parallel on a
corresponding untyped term.
*}

theorem
 "eval1_L t t' \<Longrightarrow> eval1_U (erase t) (erase t')"
by (induction t t' rule: eval1_L.induct)
  (auto intro: eval1_U.intros simp: shift_erasure subst_erasure is_value_erasure)

text {*
We can now prove that if an evaluation step on a untyped term leads to some untyped term m'
then there is an evaluation steps during corresponding typed terms
*}

(*Added by Michaël Noël Divo*)

lemma erase_inversions:
  "erase(t) = UIf t1 t2 t3 \<Longrightarrow>
  \<exists>t1' t2' t3'. erase(t1') = t1 \<and> erase(t2') = t2 \<and> erase(t3') = t3 \<and> t = LIf t1' t2' t3'"
  "erase(t) = UTrue \<Longrightarrow> t = LTrue"
  "erase(t) = UFalse \<Longrightarrow> t = LFalse"
  "erase(t) = UVar x \<Longrightarrow> t = LVar x"
  "erase(t) = UAbs (t1) \<Longrightarrow> \<exists> t1' y. erase(t1') = t1 \<and> t = LAbs y t1'"
  "erase(t) = UApp t1 t2 \<Longrightarrow> \<exists> t1' t2'. erase(t1') = t1 \<and> erase(t2') = t2 \<and> t = LApp t1' t2'"
by(induction t, auto)

(*Theorem 9.5.2*)

theorem
  "eval1_U (erase t) m' \<Longrightarrow> \<exists>t'. erase(t') = m' \<and> eval1_L t t'"
proof(induction "(erase t)" m' arbitrary: t rule: eval1_U.induct)
  case (IfCdt t1 t1' t2 t3)
    obtain b' t2' t3' where  "t1 = erase b'" "erase t2' = t2"
                                    "erase t3' = t3"
                                    "t = LIf b' t2' t3'"
      by (metis erase_inversions(1) IfCdt.hyps(3))

    thus ?case
      by (force intro: eval1_LIf dest:IfCdt.hyps(2))
next
  case (Appl t1 t1' t2)
    obtain a b  where  "t1 = erase a" "erase b = t2"
                             "t = LApp a b"
      by(metis erase_inversions(6) Appl.hyps(3))

    thus ?case
      by (force intro: eval1_LApp1 dest: Appl.hyps(2))
next
  case (Appr t1 t2 t2')
    obtain a b  where inv1: "erase a = t1" "erase b = t2"
                             "t = LApp a b"
      by (metis erase_inversions(6) Appr.hyps(4))

    have "\<exists>t3. erase (LApp a t3) = UApp t1 t2' \<and> eval1_L t (LApp a t3)"
      using Appr.hyps inv1 is_value_erasure eval1_LApp2
        by fastforce

    thus ?case by blast
next
  case(beta_red v1 t1)
    obtain a b c y where inv1: "(UAbs t1) = erase a" "a = LAbs y c" " erase b = v1"
                           "t = LApp a b" "erase c = t1"
      using beta_red.hyps(2) erase_inversions(5,6)
        by metis

    let ?t'="shift_L (-1) 0 (subst_L 0 (shift_L 1 0 b) c)"

    have "erase ?t' = shift_U (- 1) 0 (subst_U 0 (shift_U 1 0 v1) t1) \<and> eval1_L t ?t'"
      using inv1 shift_erasure subst_erasure eval1_LApp_LAbs is_value_erasure beta_red.hyps(1)
        by presburger
    thus ?case by blast
qed (metis erase_inversions erase_inversions eval1_L.intros)+

(*<*)

(* Definition 9.5.3 *)

abbreviation typable :: "uterm \<Rightarrow> bool" where
"typable t \<equiv> \<exists> t' T \<Gamma>. erase(t') = t \<and> \<Gamma> \<turnstile> t' |:| T"

end
(*>*)


theory Lambda_Exec
imports Name_Exec
begin

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  binds x in l ("Lam [_]. _" [100, 100] 100)

nominal_function
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_ [_ ::= _]" [90, 90, 90] 90)
where
  "(Var x)[y ::= s] = (if x = y then s else (Var x))"
| "(App t1 t2)[y ::= s] = App (t1[y ::= s]) (t2[y ::= s])"
| "atom x \<sharp> (y, s) \<Longrightarrow> (Lam [x]. t)[y ::= s] = Lam [x].(t[y ::= s])"
proof auto
  fix a b :: lam and aa :: name and P
  assume "\<And>x y s. a = Var x \<and> aa = y \<and> b = s \<Longrightarrow> P"
    "\<And>t1 t2 y s. a = App t1 t2 \<and> aa = y \<and> b = s \<Longrightarrow> P"
    "\<And>x y s t. \<lbrakk>atom x \<sharp> (y, s); a = Lam [x]. t \<and> aa = y \<and> b = s\<rbrakk> \<Longrightarrow> P"
  then show "P"
    by (rule_tac y="a" and c="(aa, b)" in lam.strong_exhaust)
       (blast, blast, simp add: fresh_star_def)
next
  fix x :: name and t and xa :: name and ya sa ta
  assume *: "eqvt_at subst_sumC (t, ya, sa)"
    "atom x \<sharp> (ya, sa)" "atom xa \<sharp> (ya, sa)"
    "[[atom x]]lst. t = [[atom xa]]lst. ta"
  then show "[[atom x]]lst. subst_sumC (t, ya, sa) = [[atom xa]]lst. subst_sumC (ta, ya, sa)"
    apply -
    apply (erule Abs_lst1_fcb)
    apply(simp (no_asm) add: Abs_fresh_iff)
    apply(drule_tac a="atom xa" in fresh_eqvt_at)
    apply(simp add: finite_supp)
    apply(simp_all add: fresh_Pair_elim Abs_fresh_iff Abs1_eq_iff)
    apply(subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> ya = ya")
    apply(subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> sa = sa")
    apply(simp add: atom_eqvt eqvt_at_def)
    apply(rule perm_supp_eq, simp add: supp_swap fresh_star_def fresh_Pair)+
    done
next
  show "eqvt subst_graph" unfolding eqvt_def subst_graph_def
    by (rule, perm_simp, rule)
qed

termination (eqvt) by lexicographic_order

datatype ln =
  LNBnd nat
| LNVar name
| LNApp ln ln
| LNLam ln

instantiation ln :: pt begin
fun
  permute_ln
where
  "p \<bullet> LNBnd n = LNBnd (p \<bullet> n)"
| "p \<bullet> LNVar v = LNVar (p \<bullet> v)"
| "p \<bullet> LNApp d1 d2 = LNApp (p \<bullet> d1) (p \<bullet> d2)"
| "p \<bullet> LNLam d = LNLam (p \<bullet> d)"
instance
  by (default, induct_tac [!] x) simp_all
end

lemmas [eqvt] = permute_ln.simps

lemma ln_supports:
  "supp (n) supports LNBnd n"
  "supp (v) supports LNVar v"
  "supp (za, z) supports LNApp z za"
  "supp (z) supports LNLam z"
  by (simp_all add: supports_def fresh_def[symmetric])
     (perm_simp, simp add: swap_fresh_fresh fresh_Pair)+

instance ln :: fs
  apply default
  apply (induct_tac x)
  apply (rule supports_finite, rule ln_supports, simp add: finite_supp supp_Pair)+
  done

lemma ln_supp:
  "supp (LNBnd n) = supp n"
  "supp (LNVar name) = supp name"
  "supp (LNApp ln1 ln2) = supp ln1 \<union> supp ln2"
  "supp (LNLam ln) = supp ln"
  unfolding supp_Pair[symmetric]
  by (simp_all add: supp_def)

lemma ln_fresh:
  "x \<sharp> LNBnd n \<longleftrightarrow> True"
  "x \<sharp> LNVar name \<longleftrightarrow> x \<sharp> name"
  "x \<sharp> LNApp ln1 ln2 \<longleftrightarrow> x \<sharp> ln1 \<and> x \<sharp> ln2"
  "x \<sharp> LNLam ln = x \<sharp> ln"
  unfolding fresh_def
  by (simp_all add: ln_supp pure_supp)

fun
  lookup :: "name list \<Rightarrow> nat \<Rightarrow> name \<Rightarrow> ln"
where
  "lookup [] n x = LNVar x"
| "lookup (y # ys) n x = (if x = y then LNBnd n else (lookup ys (n + 1) x))"

lemma supp_lookup:
  shows "supp (lookup xs n x) \<subseteq> {atom x}"
  by (induct arbitrary: n rule: lookup.induct)
     (simp_all add: supp_at_base ln_supp pure_supp)

lemma supp_lookup_in:
  shows "x \<in> set xs \<Longrightarrow> supp (lookup xs n x) = {}"
  by (induct arbitrary: n rule: lookup.induct) (auto simp add: ln_supp pure_supp)

lemma supp_lookup_notin:
  shows "x \<notin> set xs \<Longrightarrow> supp (lookup xs n x) = {atom x}"
  by (induct arbitrary: n rule: lookup.induct) (auto simp add: ln_supp pure_supp supp_at_base)

lemma supp_lookup_fresh:
  shows "atom ` set xs \<sharp>* lookup xs n x"
  by (case_tac "x \<in> set xs") (auto simp add: fresh_star_def fresh_def supp_lookup_in supp_lookup_notin)

lemma lookup_eqvt[eqvt]:
  shows "(p \<bullet> lookup xs n x) = lookup (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
  by (induct xs arbitrary: n) (simp_all add: permute_pure)

nominal_function (invariant "\<lambda>(_, xs) y. atom ` set xs \<sharp>* y")
  lam_ln_aux :: "lam \<Rightarrow> name list \<Rightarrow> ln"
where
  "lam_ln_aux (Var x) xs = lookup xs 0 x"
| "lam_ln_aux (App t1 t2) xs = LNApp (lam_ln_aux t1 xs) (lam_ln_aux t2 xs)"
| "atom x \<sharp> xs \<Longrightarrow> lam_ln_aux (Lam [x]. t) xs = LNLam (lam_ln_aux t (x # xs))"
  apply (simp add: eqvt_def lam_ln_aux_graph_def)
  apply (rule, perm_simp, rule)
  apply (erule lam_ln_aux_graph.induct)
  apply (auto simp add: ln_supp)[3]
  apply (simp add: supp_lookup_fresh)
  apply (simp add: fresh_star_def ln_supp fresh_def)
  apply (simp add: ln_supp fresh_def fresh_star_def)
  apply (case_tac x)
  apply (rule_tac y="a" and c="b" in lam.strong_exhaust)
  apply (auto simp add: fresh_star_def)[3]
  apply(simp_all)
  apply(erule conjE)
  apply (erule_tac c="xsa" in Abs_lst1_fcb2')
  apply (simp_all add: fresh_star_def)[2]
  apply (simp_all add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  done

termination (eqvt) by lexicographic_order

definition lam_ln where "lam_ln t \<equiv> lam_ln_aux t []"

fun nth_or_def where
  "nth_or_def [] _ d = d"
| "nth_or_def (h # t) 0 d = h"
| "nth_or_def (h # t) (Suc n) d = nth_or_def t n d"

lemma nth_or_def_eqvt [eqvt]:
  "p \<bullet> (nth_or_def l n d) = nth_or_def (p \<bullet> l) (p \<bullet> n) (p \<bullet> d)"
  apply (cases l)
  apply auto
  apply (induct n arbitrary: list)
  apply (auto simp add: permute_pure)
  apply (case_tac list)
  apply simp_all
  done

nominal_function
  ln_lam_aux :: "ln \<Rightarrow> name list \<Rightarrow> lam"
where
  "ln_lam_aux (LNBnd n) ns = (nth_or_def (map Var ns) n (Lam [x]. Var x))"
| "ln_lam_aux (LNVar v) ns = Var v"
| "ln_lam_aux (LNApp l1 l2) ns = App (ln_lam_aux l1 ns) (ln_lam_aux l2 ns)"
| "atom x \<sharp> (ns, l) \<Longrightarrow> ln_lam_aux (LNLam l) ns = Lam [x]. (ln_lam_aux l (x # ns))"
  apply (simp add: eqvt_def ln_lam_aux_graph_def)
  apply (rule, perm_simp, rule)
  apply rule
  apply(auto)[1]
  apply (rule_tac y="a" in ln.exhaust)
  apply (auto simp add: fresh_star_def)[4]
  using obtain_fresh apply metis
  apply (auto simp add: fresh_Pair_elim)
  apply (subgoal_tac "Lam [x]. Var x = Lam [xa]. Var xa")
  apply (simp del: lam.eq_iff)
  apply (simp add: Abs1_eq_iff lam.fresh fresh_at_base)
  apply (simp add: Abs1_eq_iff)
  apply (case_tac "x=xa")
  apply simp_all
  apply rule
  apply (auto simp add: eqvt_at_def swap_fresh_fresh)[1]
  apply (erule fresh_eqvt_at)
  apply (simp add: supp_Pair finite_supp)
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base)
  done

termination (eqvt)
  by lexicographic_order

definition ln_lam where "ln_lam t \<equiv> ln_lam_aux t []"

lemma l_fresh_lam_ln_aux: "atom ` set l \<sharp>* lam_ln_aux t l"
  apply (nominal_induct t avoiding: l rule: lam.strong_induct)
  apply (simp_all add: fresh_def ln_supp pure_supp)
  apply (auto simp add: fresh_star_def)[1]
  apply (case_tac "a = name")
  apply (auto simp add: supp_lookup_in fresh_def)[1]
  apply (simp add: fresh_def)
  using supp_lookup
  apply (metis (lifting) atom_eq_iff equals0D singletonE supp_lookup_in supp_lookup_notin)
  apply (simp add: fresh_star_def fresh_def ln_supp)+
  done

lemma supp_lam_ln_aux: "supp (lam_ln_aux t l) \<subseteq> supp t"
proof -
  have "eqvt lam_ln_aux" unfolding eqvt_def using eqvts_raw by simp
  then have "supp lam_ln_aux = {}" using supp_fun_eqvt by auto
  then have "supp (lam_ln_aux t) \<subseteq> supp t" using supp_fun_app by auto
  then have "supp (lam_ln_aux t l) \<subseteq> supp t \<union> supp l" using supp_fun_app by auto
  moreover have "\<forall>x \<in> supp l. x \<notin> supp (lam_ln_aux t l)"
    using l_fresh_lam_ln_aux unfolding fresh_star_def fresh_def
    by (metis finite_set supp_finite_set_at_base supp_set)
  ultimately show "supp (lam_ln_aux t l) \<subseteq> supp t" by blast
qed

lemma lookup_flip: "x \<noteq> y \<Longrightarrow> y \<noteq> a \<Longrightarrow> lookup ((x \<leftrightarrow> a) \<bullet> xs) n y = lookup xs n y"
  apply (induct xs arbitrary: n)
  apply simp
  apply (simp only: Cons_eqvt)
  apply (simp only: lookup.simps)
  apply (subgoal_tac "y = (x \<leftrightarrow> a) \<bullet> aa \<longleftrightarrow> y = aa")
  apply simp
  by (metis permute_flip_at)

lemma lookup_append_flip: "x \<noteq> y \<Longrightarrow> lookup (l @ a # (x \<leftrightarrow> a) \<bullet> xs) n y = lookup (l @ a # xs) n y"
  by (induct l arbitrary: n) (auto simp add: lookup_flip)

lemma lam_ln_aux_flip: "atom x \<sharp> t \<Longrightarrow> lam_ln_aux t (l @ a # (x \<leftrightarrow> a) \<bullet> xs) = lam_ln_aux t (l @ a # xs)"
  apply (nominal_induct t avoiding: x a xs l rule: lam.strong_induct)
  apply (simp_all add: lam_ln_aux.eqvt lam.fresh lookup_append_flip fresh_at_base)[2]
  apply (simp add: lam.fresh fresh_at_base)
  apply (subst lam_ln_aux.simps)
  apply (simp add: fresh_Cons fresh_at_base fresh_append)
  apply (metis atom_eqvt atom_name_def flip_at_base_simps(3) flip_commute fresh_permute_iff)
  apply (subst lam_ln_aux.simps)
  apply (simp add: fresh_Cons fresh_at_base fresh_append)
  apply simp
  apply (drule_tac x="x" in meta_spec)
  apply (drule_tac x="a" in meta_spec)
  apply (drule_tac x="xs" in meta_spec)
  apply (drule_tac x="name # l" in meta_spec)
  apply simp
  done

lemma lam_ln_aux4: "lam_ln_aux (Lam [x]. t) xs = LNLam (lam_ln_aux t (x # xs))"
  apply (rule_tac 'a="name" and x="(xs, x, t)" in obtain_fresh)
  apply (simp add: fresh_Pair_elim)
  apply (rule_tac t="Lam [x]. t" and s="Lam [a]. ((x \<leftrightarrow> a) \<bullet> t)" in subst)
  apply (auto simp add: Abs1_eq_iff lam.fresh flip_def swap_commute)[1]
  apply simp
  apply (rule_tac s="(x \<leftrightarrow> a) \<bullet> lam_ln_aux t (x # xs)" in trans)
  apply (simp add: lam_ln_aux.eqvt)
  apply (subst lam_ln_aux_flip[of _ _ "[]", simplified])
  apply (metis atom_eqvt flip_at_simps(2) fresh_permute_iff)
  apply rule
  apply (rule flip_fresh_fresh)
  apply (simp add: l_fresh_lam_ln_aux[of "x # xs", simplified fresh_star_def, simplified])
  apply (simp add: fresh_def)
  apply (metis set_rev_mp supp_lam_ln_aux)
  done

lemma lookup_in: "n \<notin> set l \<Longrightarrow> lookup l i n = LNVar n"
  by (induct l arbitrary: i n) simp_all

lemma lookup_in2: "n \<in> set l \<Longrightarrow> \<exists>i. lookup l j n = LNBnd i"
  by (induct l arbitrary: j n) auto

lemma lookup_in2': "lookup l j n = LNBnd i \<Longrightarrow> lookup l (Suc j) n = LNBnd (Suc i)"
  by (induct l arbitrary: j n) auto

lemma ln_lam_Var: "ln_lam_aux (lookup l (0\<Colon>nat) n) l = Var n"
  apply (cases "n \<in> set l")
  apply (simp_all add: lookup_in)
  apply (induct l arbitrary: n)
  apply simp
  apply (case_tac "a = n")
  apply (simp_all add: ln_lam_aux.simps(1)[of _ _ "Name 0"] )[2]
  apply (drule_tac x="n" in meta_spec)
  apply (frule lookup_in2[of _ _ 0])
  apply (erule exE)
  apply simp
  apply (frule lookup_in2')
  apply simp
  apply (simp_all add: ln_lam_aux.simps(1)[of _ _ "Name 0"] )
  done

lemma ln_lam_ln_aux: "ln_lam_aux (lam_ln_aux t l) l = t"
  apply (nominal_induct t avoiding: l rule: lam.strong_induct)
  apply (simp_all add: ln_lam_Var)
  apply (subst ln_lam_aux.simps(4)[of name])
  apply (simp add: fresh_Pair)
  apply (subgoal_tac "atom ` set (name # l) \<sharp>* lam_ln_aux lam (name # l)")
  apply (simp add: fresh_star_def)
  apply (rule l_fresh_lam_ln_aux)
  apply simp
  done

fun subst_ln_nat where
  "subst_ln_nat (LNBnd n) x _ = LNBnd n"
| "subst_ln_nat (LNVar v) x n = (if x = v then LNBnd n else LNVar v)"
| "subst_ln_nat (LNApp l r) x n = LNApp (subst_ln_nat l x n) (subst_ln_nat r x n)"
| "subst_ln_nat (LNLam l) x n = LNLam (subst_ln_nat l x (n + 1))"

lemma subst_ln_nat_eqvt[eqvt]:
  shows "(p \<bullet> subst_ln_nat t x n) = subst_ln_nat (p \<bullet> t) (p \<bullet> x) (p \<bullet> n)"
  by (induct t arbitrary: n) (simp_all add: permute_pure)

lemma supp_subst_ln_nat:
  "supp (subst_ln_nat t x n) = supp t - {atom x}"
  by (induct t arbitrary: n) (auto simp add: permute_pure ln_supp pure_supp supp_at_base)

lemma fresh_subst_ln_nat:
  "atom y \<sharp> subst_ln_nat t x n \<longleftrightarrow> y = x \<or> atom y \<sharp> t"
  unfolding fresh_def supp_subst_ln_nat by auto

nominal_function
  lam_ln_ex :: "lam \<Rightarrow> ln"
where
  "lam_ln_ex (Var x) = LNVar x"
| "lam_ln_ex (App t1 t2) = LNApp (lam_ln_ex t1) (lam_ln_ex t2)"
| "lam_ln_ex (Lam [x]. t) = LNLam (subst_ln_nat (lam_ln_ex t) x 0)"
  apply (simp add: eqvt_def lam_ln_ex_graph_def)
  apply (rule, perm_simp, rule)
  apply rule
  apply (rule_tac y="x" in lam.exhaust)
  apply (auto simp add: fresh_star_def)[3]
  apply(simp_all)
  apply (erule_tac Abs_lst1_fcb)
  apply (simp add: fresh_subst_ln_nat)
  apply (simp add: fresh_subst_ln_nat)
  apply (erule fresh_eqvt_at)
  apply (simp add: finite_supp)
  apply assumption
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq
    subst_ln_nat_eqvt permute_pure)
  apply simp
  done

termination (eqvt) by lexicographic_order

lemma lookup_in3: "lookup l j n = LNBnd i \<Longrightarrow> lookup (l @ l2) j n = LNBnd i"
  by (induct l arbitrary: j n) auto

lemma lookup_in4: "n \<notin> set l \<Longrightarrow> lookup (l @ [n]) j n = LNBnd (length l + j)"
  by (induct l arbitrary: j n) auto

lemma subst_ln_nat_lam_ln_aux: "subst_ln_nat (lam_ln_aux l ns) n (List.length ns) = lam_ln_aux l (ns @ [n])"
  apply (nominal_induct l avoiding: n ns rule: lam.strong_induct)
  apply simp defer
  apply simp
  apply (simp add: fresh_Nil fresh_Cons fresh_append)
  apply (drule_tac x="n" in meta_spec)
  apply (drule_tac x="name # ns" in meta_spec)
  apply simp
  apply (case_tac "name \<in> set ns")
  apply (simp_all add: lookup_in)
  apply (frule lookup_in2[of _ _ 0])
  apply (erule exE)
  apply (simp add: lookup_in3)
  apply (simp add: lookup_in4)
  done

lemma lam_ln_ex: "lam_ln_ex t = lam_ln t"
  apply (induct t rule: lam.induct)
  apply (simp_all add: lam_ln_def fresh_Nil)
  by (metis (lifting) list.size(3) self_append_conv2 subst_ln_nat_lam_ln_aux)

(* Lambda terms as a code-abstype *)
lemma ln_abstype[code abstype]:
  "ln_lam (lam_ln_ex t) = t"
  by (simp add: ln_lam_def lam_ln_ex lam_ln_def ln_lam_ln_aux)

lemmas [code abstract] = lam_ln_ex.simps

(* Equality for lambda-terms *)
instantiation lam :: equal begin

definition equal_lam_def: "equal_lam a b \<longleftrightarrow> lam_ln_ex a = lam_ln_ex b"

instance
  by default
    (metis equal_lam_def lam_ln_def lam_ln_ex ln_lam_ln_aux)

end

(* Execute permutations *)
lemmas [code abstract] = lam_ln_ex.eqvt[symmetric]

fun subst_ln where
  "subst_ln (LNBnd n) _ _ = LNBnd n"
| "subst_ln (LNVar v) x t = (if x = v then t else LNVar v)"
| "subst_ln (LNApp l r) x t = LNApp (subst_ln l x t) (subst_ln r x t)"
| "subst_ln (LNLam l) x t = LNLam (subst_ln l x t)"

lemma subst_ln_nat_id[simp]:
  "atom name \<sharp> s \<Longrightarrow> name \<noteq> y \<Longrightarrow> subst_ln_nat s name n = s"
  by (induct s arbitrary: n) (simp_all add: ln_fresh fresh_at_base)

lemma subst_ln_nat_subst_ln_commute:
  assumes "name \<noteq> y" and "atom name \<sharp> s"
  shows "subst_ln_nat (subst_ln ln y s) name n = subst_ln (subst_ln_nat ln name n) y s"
  using assms by (induct ln arbitrary: n) auto

lemma supp_lam_ln_ex: "supp (lam_ln_ex t) = supp t"
  by (induct t rule: lam.induct) (simp_all add: lam.supp ln_supp supp_subst_ln_nat)

lemma subst_code[code abstract]:
  "lam_ln_ex (subst t y s) = subst_ln (lam_ln_ex t) y (lam_ln_ex s)"
  apply (nominal_induct t avoiding: y s rule: lam.strong_induct)
  apply simp_all
  apply (subst subst_ln_nat_subst_ln_commute)
  apply (simp_all add: fresh_at_base supp_lam_ln_ex fresh_def)
  done

(*definition "I0 \<equiv> Lam [N0]. (Var N0)"
definition "I1 \<equiv> Lam [N1]. (Var N1)"
definition "ppp = (atom N0 \<rightleftharpoons> atom N1)"
definition "pp \<equiv> ppp \<bullet> I1 = I0"

export_code pp in SML*)

lemma subst_ln_nat_funpow[simp]:
  "subst_ln_nat ((LNLam^^p) l) x n = (LNLam ^^ p) (subst_ln_nat l x (n + p))"
  by (induct p arbitrary: n) simp_all

(*

Tests:

fun Umn :: "nat \<Rightarrow> nat \<Rightarrow> lam"
where
  "Umn 0 n = Lam [Name 0]. Var (Name n)"
| "Umn (Suc m) n = Lam [Name (Suc m)]. Umn m n"

lemma Umn_faster:
  "lam_ln_ex (Umn m n) = (LNLam ^^ (Suc m)) (if n \<le> m then LNBnd n else LNVar (Name n))"
  apply (induct m)
  apply (auto simp add: Umn.simps)
  apply (simp_all add: Name_def Abs_name_inject le_SucE)
  apply (erule le_SucE)
  apply simp_all
  done

definition "Bla = Umn 2 2"

definition vara where "vara \<equiv> Lam [N0]. Lam [N1]. (App (Var N1) (App (Umn 2 2) (App (Var N0) (Var N1))))"

export_code ln_lam_aux nth_or_def ln_lam subst vara in SML

value "(atom N0 \<rightleftharpoons> atom N1) \<bullet> (App (Var N0) (Lam [N1]. (Var N1)))"
value "subst ((N0 \<leftrightarrow> N1) \<bullet> (App (Var N0) (Lam [N1]. (Var N1)))) N1 (Var N0)"*)

end