(*  Title:      ZF/Constructible/Datatype_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness Properties for Recursive Datatypes\<close>

theory Datatype_absolute imports Formula WF_absolute begin

subsection\<open>The lfp of a continuous function can be expressed as a union\<close>

definition
  directed :: "i=>o" where
   "directed(A) == A\<noteq>0 & (\<forall>x\<in>A. \<forall>y\<in>A. x \<union> y \<in> A)"

definition
  contin :: "(i=>i) => o" where
   "contin(h) == (\<forall>A. directed(A) \<longrightarrow> h(\<Union>A) = (\<Union>X\<in>A. h(X)))"

lemma bnd_mono_iterates_subset: "[|bnd_mono(D, h); n \<in> nat|] ==> h^n (0) \<subseteq> D"
apply (induct_tac n)
 apply (simp_all add: bnd_mono_def, blast)
done

lemma bnd_mono_increasing [rule_format]:
     "[|i \<in> nat; j \<in> nat; bnd_mono(D,h)|] ==> i \<le> j \<longrightarrow> h^i(0) \<subseteq> h^j(0)"
apply (rule_tac m=i and n=j in diff_induct, simp_all)
apply (blast del: subsetI
             intro: bnd_mono_iterates_subset bnd_monoD2 [of concl: h])
done

lemma directed_iterates: "bnd_mono(D,h) ==> directed({h^n (0). n\<in>nat})"
apply (simp add: directed_def, clarify)
apply (rename_tac i j)
apply (rule_tac x="i \<union> j" in bexI)
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (simp_all add: subset_Un_iff [THEN iffD1] le_imp_subset
                     subset_Un_iff2 [THEN iffD1])
apply (simp_all add: subset_Un_iff [THEN iff_sym] bnd_mono_increasing
                     subset_Un_iff2 [THEN iff_sym])
done

lemma contin_iterates_eq:
    "[|bnd_mono(D, h); contin(h)|]
     ==> h(\<Union>n\<in>nat. h^n (0)) = (\<Union>n\<in>nat. h^n (0))"
apply (simp add: contin_def directed_iterates)
apply (rule trans)
apply (rule equalityI)
 apply (simp_all add: UN_subset_iff)
 apply safe
 apply (erule_tac [2] natE)
  apply (rule_tac a="succ(x)" in UN_I)
   apply simp_all
apply blast
done

lemma lfp_subset_Union:
     "[|bnd_mono(D, h); contin(h)|] ==> lfp(D,h) \<subseteq> (\<Union>n\<in>nat. h^n(0))"
apply (rule lfp_lowerbound)
 apply (simp add: contin_iterates_eq)
apply (simp add: contin_def bnd_mono_iterates_subset UN_subset_iff)
done

lemma Union_subset_lfp:
     "bnd_mono(D,h) ==> (\<Union>n\<in>nat. h^n(0)) \<subseteq> lfp(D,h)"
apply (simp add: UN_subset_iff)
apply (rule ballI)
apply (induct_tac n, simp_all)
apply (rule subset_trans [of _ "h(lfp(D,h))"])
 apply (blast dest: bnd_monoD2 [OF _ _ lfp_subset])
apply (erule lfp_lemma2)
done

lemma lfp_eq_Union:
     "[|bnd_mono(D, h); contin(h)|] ==> lfp(D,h) = (\<Union>n\<in>nat. h^n(0))"
by (blast del: subsetI
          intro: lfp_subset_Union Union_subset_lfp)

subsubsection\<open>Some Standard Datatype Constructions Preserve Continuity\<close>

lemma contin_imp_mono: "[|X\<subseteq>Y; contin(F)|] ==> F(X) \<subseteq> F(Y)"
apply (simp add: contin_def)
apply (drule_tac x="{X,Y}" in spec)
apply (simp add: directed_def subset_Un_iff2 Un_commute)
done

lemma sum_contin: "[|contin(F); contin(G)|] ==> contin(\<lambda>X. F(X) + G(X))"
by (simp add: contin_def, blast)

lemma prod_contin: "[|contin(F); contin(G)|] ==> contin(\<lambda>X. F(X) * G(X))"
apply (subgoal_tac "\<forall>B C. F(B) \<subseteq> F(B \<union> C)")
 prefer 2 apply (simp add: Un_upper1 contin_imp_mono)
apply (subgoal_tac "\<forall>B C. G(C) \<subseteq> G(B \<union> C)")
 prefer 2 apply (simp add: Un_upper2 contin_imp_mono)
apply (simp add: contin_def, clarify)
apply (rule equalityI)
 prefer 2 apply blast
apply clarify
apply (rename_tac B C)
apply (rule_tac a="B \<union> C" in UN_I)
 apply (simp add: directed_def, blast)
done

lemma const_contin: "contin(\<lambda>X. A)"
by (simp add: contin_def directed_def)

lemma id_contin: "contin(\<lambda>X. X)"
by (simp add: contin_def)

subsection \<open>Absoluteness for "Iterates"\<close>

definition
  iterates_MH :: "[i=>o, [i,i]=>o, i, i, i, i] => o" where
   "iterates_MH(M,isF,v,n,g,z) ==
        is_nat_case(M, v, \<lambda>m u. \<exists>gm[M]. fun_apply(M,g,m,gm) & isF(gm,u),
                    n, z)"

definition
  is_iterates :: "[i=>o, [i,i]=>o, i, i, i] => o" where
    "is_iterates(M,isF,v,n,Z) ==
      \<exists>sn[M]. \<exists>msn[M]. successor(M,n,sn) & membership(M,sn,msn) &
                       is_wfrec(M, iterates_MH(M,isF,v), msn, n, Z)"

definition
  iterates_replacement :: "[i=>o, [i,i]=>o, i] => o" where
   "iterates_replacement(M,isF,v) ==
      \<forall>n[M]. n\<in>nat \<longrightarrow>
         wfrec_replacement(M, iterates_MH(M,isF,v), Memrel(succ(n)))"

lemma (in M_basic) iterates_MH_abs:
  "[| relation1(M,isF,F); M(n); M(g); M(z) |]
   ==> iterates_MH(M,isF,v,n,g,z) \<longleftrightarrow> z = nat_case(v, \<lambda>m. F(g`m), n)"
by (simp add: nat_case_abs [of _ "\<lambda>m. F(g ` m)"]
              relation1_def iterates_MH_def)

lemma (in M_basic) iterates_imp_wfrec_replacement:
  "[|relation1(M,isF,F); n \<in> nat; iterates_replacement(M,isF,v)|]
   ==> wfrec_replacement(M, \<lambda>n f z. z = nat_case(v, \<lambda>m. F(f`m), n),
                       Memrel(succ(n)))"
by (simp add: iterates_replacement_def iterates_MH_abs)

theorem (in M_trancl) iterates_abs:
  "[| iterates_replacement(M,isF,v); relation1(M,isF,F);
      n \<in> nat; M(v); M(z); \<forall>x[M]. M(F(x)) |]
   ==> is_iterates(M,isF,v,n,z) \<longleftrightarrow> z = iterates(F,n,v)"
apply (frule iterates_imp_wfrec_replacement, assumption+)
apply (simp add: wf_Memrel trans_Memrel relation_Memrel nat_into_M
                 is_iterates_def relation2_def iterates_MH_abs
                 iterates_nat_def recursor_def transrec_def
                 eclose_sing_Ord_eq nat_into_M
         trans_wfrec_abs [of _ _ _ _ "\<lambda>n g. nat_case(v, \<lambda>m. F(g`m), n)"])
done

lemma (in M_trancl) iterates_closed [intro,simp]:
  "[| iterates_replacement(M,isF,v); relation1(M,isF,F);
      n \<in> nat; M(v); \<forall>x[M]. M(F(x)) |]
   ==> M(iterates(F,n,v))"
apply (frule iterates_imp_wfrec_replacement, assumption+)
apply (simp add: wf_Memrel trans_Memrel relation_Memrel nat_into_M
                 relation2_def iterates_MH_abs
                 iterates_nat_def recursor_def transrec_def
                 eclose_sing_Ord_eq nat_into_M
         trans_wfrec_closed [of _ _ _ "\<lambda>n g. nat_case(v, \<lambda>m. F(g`m), n)"])
done

subsection \<open>lists without univ\<close>

lemmas datatype_univs = Inl_in_univ Inr_in_univ
                        Pair_in_univ nat_into_univ A_into_univ

lemma list_fun_bnd_mono: "bnd_mono(univ(A), \<lambda>X. {0} + A*X)"
apply (rule bnd_monoI)
 apply (intro subset_refl zero_subset_univ A_subset_univ
              sum_subset_univ Sigma_subset_univ)
apply (rule subset_refl sum_mono Sigma_mono | assumption)+
done

lemma list_fun_contin: "contin(\<lambda>X. {0} + A*X)"
by (intro sum_contin prod_contin id_contin const_contin)

text\<open>Re-expresses lists using sum and product\<close>
lemma list_eq_lfp2: "list(A) = lfp(univ(A), \<lambda>X. {0} + A*X)"
apply (simp add: list_def)
apply (rule equalityI)
 apply (rule lfp_lowerbound)
  prefer 2 apply (rule lfp_subset)
 apply (clarify, subst lfp_unfold [OF list_fun_bnd_mono])
 apply (simp add: Nil_def Cons_def)
 apply blast
txt\<open>Opposite inclusion\<close>
apply (rule lfp_lowerbound)
 prefer 2 apply (rule lfp_subset)
apply (clarify, subst lfp_unfold [OF list.bnd_mono])
apply (simp add: Nil_def Cons_def)
apply (blast intro: datatype_univs
             dest: lfp_subset [THEN subsetD])
done

text\<open>Re-expresses lists using "iterates", no univ.\<close>
lemma list_eq_Union:
     "list(A) = (\<Union>n\<in>nat. (\<lambda>X. {0} + A*X) ^ n (0))"
by (simp add: list_eq_lfp2 lfp_eq_Union list_fun_bnd_mono list_fun_contin)

definition
  is_list_functor :: "[i=>o,i,i,i] => o" where
    "is_list_functor(M,A,X,Z) ==
        \<exists>n1[M]. \<exists>AX[M].
         number1(M,n1) & cartprod(M,A,X,AX) & is_sum(M,n1,AX,Z)"

lemma (in M_basic) list_functor_abs [simp]:
     "[| M(A); M(X); M(Z) |] ==> is_list_functor(M,A,X,Z) \<longleftrightarrow> (Z = {0} + A*X)"
by (simp add: is_list_functor_def singleton_0 nat_into_M)

subsection \<open>formulas without univ\<close>

lemma formula_fun_bnd_mono:
     "bnd_mono(univ(0), \<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))"
apply (rule bnd_monoI)
 apply (intro subset_refl zero_subset_univ A_subset_univ
              sum_subset_univ Sigma_subset_univ nat_subset_univ)
apply (rule subset_refl sum_mono Sigma_mono | assumption)+
done

lemma formula_fun_contin:
     "contin(\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))"
by (intro sum_contin prod_contin id_contin const_contin)

text\<open>Re-expresses formulas using sum and product\<close>
lemma formula_eq_lfp2:
    "formula = lfp(univ(0), \<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))"
apply (simp add: formula_def)
apply (rule equalityI)
 apply (rule lfp_lowerbound)
  prefer 2 apply (rule lfp_subset)
 apply (clarify, subst lfp_unfold [OF formula_fun_bnd_mono])
 apply (simp add: Member_def Equal_def Nand_def Forall_def)
 apply blast
txt\<open>Opposite inclusion\<close>
apply (rule lfp_lowerbound)
 prefer 2 apply (rule lfp_subset, clarify)
apply (subst lfp_unfold [OF formula.bnd_mono, simplified])
apply (simp add: Member_def Equal_def Nand_def Forall_def)
apply (elim sumE SigmaE, simp_all)
apply (blast intro: datatype_univs dest: lfp_subset [THEN subsetD])+
done

text\<open>Re-expresses formulas using "iterates", no univ.\<close>
lemma formula_eq_Union:
     "formula =
      (\<Union>n\<in>nat. (\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X)) ^ n (0))"
by (simp add: formula_eq_lfp2 lfp_eq_Union formula_fun_bnd_mono
              formula_fun_contin)

definition
  is_formula_functor :: "[i=>o,i,i] => o" where
    "is_formula_functor(M,X,Z) ==
        \<exists>nat'[M]. \<exists>natnat[M]. \<exists>natnatsum[M]. \<exists>XX[M]. \<exists>X3[M].
          omega(M,nat') & cartprod(M,nat',nat',natnat) &
          is_sum(M,natnat,natnat,natnatsum) &
          cartprod(M,X,X,XX) & is_sum(M,XX,X,X3) &
          is_sum(M,natnatsum,X3,Z)"

lemma (in M_basic) formula_functor_abs [simp]:
     "[| M(X); M(Z) |]
      ==> is_formula_functor(M,X,Z) \<longleftrightarrow>
          Z = ((nat*nat) + (nat*nat)) + (X*X + X)"
by (simp add: is_formula_functor_def)

subsection\<open>@{term M} Contains the List and Formula Datatypes\<close>

definition
  list_N :: "[i,i] => i" where
    "list_N(A,n) == (\<lambda>X. {0} + A * X)^n (0)"

lemma Nil_in_list_N [simp]: "[] \<in> list_N(A,succ(n))"
by (simp add: list_N_def Nil_def)

lemma Cons_in_list_N [simp]:
     "Cons(a,l) \<in> list_N(A,succ(n)) \<longleftrightarrow> a\<in>A & l \<in> list_N(A,n)"
by (simp add: list_N_def Cons_def)

text\<open>These two aren't simprules because they reveal the underlying
list representation.\<close>
lemma list_N_0: "list_N(A,0) = 0"
by (simp add: list_N_def)

lemma list_N_succ: "list_N(A,succ(n)) = {0} + A * (list_N(A,n))"
by (simp add: list_N_def)

lemma list_N_imp_list:
  "[| l \<in> list_N(A,n); n \<in> nat |] ==> l \<in> list(A)"
by (force simp add: list_eq_Union list_N_def)

lemma list_N_imp_length_lt [rule_format]:
     "n \<in> nat ==> \<forall>l \<in> list_N(A,n). length(l) < n"
apply (induct_tac n)
apply (auto simp add: list_N_0 list_N_succ
                      Nil_def [symmetric] Cons_def [symmetric])
done

lemma list_imp_list_N [rule_format]:
     "l \<in> list(A) ==> \<forall>n\<in>nat. length(l) < n \<longrightarrow> l \<in> list_N(A, n)"
apply (induct_tac l)
apply (force elim: natE)+
done

lemma list_N_imp_eq_length:
      "[|n \<in> nat; l \<notin> list_N(A, n); l \<in> list_N(A, succ(n))|]
       ==> n = length(l)"
apply (rule le_anti_sym)
 prefer 2 apply (simp add: list_N_imp_length_lt)
apply (frule list_N_imp_list, simp)
apply (simp add: not_lt_iff_le [symmetric])
apply (blast intro: list_imp_list_N)
done

text\<open>Express @{term list_rec} without using @{term rank} or @{term Vset},
neither of which is absolute.\<close>
lemma (in M_trivial) list_rec_eq:
  "l \<in> list(A) ==>
   list_rec(a,g,l) =
   transrec (succ(length(l)),
      \<lambda>x h. Lambda (list(A),
                    list_case' (a,
                           \<lambda>a l. g(a, l, h ` succ(length(l)) ` l)))) ` l"
apply (induct_tac l)
apply (subst transrec, simp)
apply (subst transrec)
apply (simp add: list_imp_list_N)
done

definition
  is_list_N :: "[i=>o,i,i,i] => o" where
    "is_list_N(M,A,n,Z) ==
      \<exists>zero[M]. empty(M,zero) &
                is_iterates(M, is_list_functor(M,A), zero, n, Z)"

definition
  mem_list :: "[i=>o,i,i] => o" where
    "mem_list(M,A,l) ==
      \<exists>n[M]. \<exists>listn[M].
       finite_ordinal(M,n) & is_list_N(M,A,n,listn) & l \<in> listn"

definition
  is_list :: "[i=>o,i,i] => o" where
    "is_list(M,A,Z) == \<forall>l[M]. l \<in> Z \<longleftrightarrow> mem_list(M,A,l)"

subsubsection\<open>Towards Absoluteness of @{term formula_rec}\<close>

consts   depth :: "i=>i"
primrec
  "depth(Member(x,y)) = 0"
  "depth(Equal(x,y))  = 0"
  "depth(Nand(p,q)) = succ(depth(p) \<union> depth(q))"
  "depth(Forall(p)) = succ(depth(p))"

lemma depth_type [TC]: "p \<in> formula ==> depth(p) \<in> nat"
by (induct_tac p, simp_all)

definition
  formula_N :: "i => i" where
    "formula_N(n) == (\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X)) ^ n (0)"

lemma Member_in_formula_N [simp]:
     "Member(x,y) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> nat & y \<in> nat"
by (simp add: formula_N_def Member_def)

lemma Equal_in_formula_N [simp]:
     "Equal(x,y) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> nat & y \<in> nat"
by (simp add: formula_N_def Equal_def)

lemma Nand_in_formula_N [simp]:
     "Nand(x,y) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> formula_N(n) & y \<in> formula_N(n)"
by (simp add: formula_N_def Nand_def)

lemma Forall_in_formula_N [simp]:
     "Forall(x) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> formula_N(n)"
by (simp add: formula_N_def Forall_def)

text\<open>These two aren't simprules because they reveal the underlying
formula representation.\<close>
lemma formula_N_0: "formula_N(0) = 0"
by (simp add: formula_N_def)

lemma formula_N_succ:
     "formula_N(succ(n)) =
      ((nat*nat) + (nat*nat)) + (formula_N(n) * formula_N(n) + formula_N(n))"
by (simp add: formula_N_def)

lemma formula_N_imp_formula:
  "[| p \<in> formula_N(n); n \<in> nat |] ==> p \<in> formula"
by (force simp add: formula_eq_Union formula_N_def)

lemma formula_N_imp_depth_lt [rule_format]:
     "n \<in> nat ==> \<forall>p \<in> formula_N(n). depth(p) < n"
apply (induct_tac n)
apply (auto simp add: formula_N_0 formula_N_succ
                      depth_type formula_N_imp_formula Un_least_lt_iff
                      Member_def [symmetric] Equal_def [symmetric]
                      Nand_def [symmetric] Forall_def [symmetric])
done

lemma formula_imp_formula_N [rule_format]:
     "p \<in> formula ==> \<forall>n\<in>nat. depth(p) < n \<longrightarrow> p \<in> formula_N(n)"
apply (induct_tac p)
apply (simp_all add: succ_Un_distrib Un_least_lt_iff)
apply (force elim: natE)+
done

lemma formula_N_imp_eq_depth:
      "[|n \<in> nat; p \<notin> formula_N(n); p \<in> formula_N(succ(n))|]
       ==> n = depth(p)"
apply (rule le_anti_sym)
 prefer 2 apply (simp add: formula_N_imp_depth_lt)
apply (frule formula_N_imp_formula, simp)
apply (simp add: not_lt_iff_le [symmetric])
apply (blast intro: formula_imp_formula_N)
done

text\<open>This result and the next are unused.\<close>
lemma formula_N_mono [rule_format]:
  "[| m \<in> nat; n \<in> nat |] ==> m\<le>n \<longrightarrow> formula_N(m) \<subseteq> formula_N(n)"
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all add: formula_N_0 formula_N_succ, blast)
done

lemma formula_N_distrib:
  "[| m \<in> nat; n \<in> nat |] ==> formula_N(m \<union> n) = formula_N(m) \<union> formula_N(n)"
apply (rule_tac i = m and j = n in Ord_linear_le, auto)
apply (simp_all add: subset_Un_iff [THEN iffD1] subset_Un_iff2 [THEN iffD1]
                     le_imp_subset formula_N_mono)
done

definition
  is_formula_N :: "[i=>o,i,i] => o" where
    "is_formula_N(M,n,Z) ==
      \<exists>zero[M]. empty(M,zero) &
                is_iterates(M, is_formula_functor(M), zero, n, Z)"

definition
  mem_formula :: "[i=>o,i] => o" where
    "mem_formula(M,p) ==
      \<exists>n[M]. \<exists>formn[M].
       finite_ordinal(M,n) & is_formula_N(M,n,formn) & p \<in> formn"

definition
  is_formula :: "[i=>o,i] => o" where
    "is_formula(M,Z) == \<forall>p[M]. p \<in> Z \<longleftrightarrow> mem_formula(M,p)"

locale M_datatypes = M_trancl +
 assumes list_replacement1:
   "M(A) ==> iterates_replacement(M, is_list_functor(M,A), 0)"
  and list_replacement2:
   "M(A) ==> strong_replacement(M,
         \<lambda>n y. n\<in>nat & is_iterates(M, is_list_functor(M,A), 0, n, y))"
  and formula_replacement1:
   "iterates_replacement(M, is_formula_functor(M), 0)"
  and formula_replacement2:
   "strong_replacement(M,
         \<lambda>n y. n\<in>nat & is_iterates(M, is_formula_functor(M), 0, n, y))"
  and nth_replacement:
   "M(l) ==> iterates_replacement(M, %l t. is_tl(M,l,t), l)"

subsubsection\<open>Absoluteness of the List Construction\<close>

lemma (in M_datatypes) list_replacement2':
  "M(A) ==> strong_replacement(M, \<lambda>n y. n\<in>nat & y = (\<lambda>X. {0} + A * X)^n (0))"
apply (insert list_replacement2 [of A])
apply (rule strong_replacement_cong [THEN iffD1])
apply (rule conj_cong [OF iff_refl iterates_abs [of "is_list_functor(M,A)"]])
apply (simp_all add: list_replacement1 relation1_def)
done

lemma (in M_datatypes) list_closed [intro,simp]:
     "M(A) ==> M(list(A))"
apply (insert list_replacement1)
by  (simp add: RepFun_closed2 list_eq_Union
               list_replacement2' relation1_def
               iterates_closed [of "is_list_functor(M,A)"])

text\<open>WARNING: use only with \<open>dest:\<close> or with variables fixed!\<close>
lemmas (in M_datatypes) list_into_M = transM [OF _ list_closed]

lemma (in M_datatypes) list_N_abs [simp]:
     "[|M(A); n\<in>nat; M(Z)|]
      ==> is_list_N(M,A,n,Z) \<longleftrightarrow> Z = list_N(A,n)"
apply (insert list_replacement1)
apply (simp add: is_list_N_def list_N_def relation1_def nat_into_M
                 iterates_abs [of "is_list_functor(M,A)" _ "\<lambda>X. {0} + A*X"])
done

lemma (in M_datatypes) list_N_closed [intro,simp]:
     "[|M(A); n\<in>nat|] ==> M(list_N(A,n))"
apply (insert list_replacement1)
apply (simp add: is_list_N_def list_N_def relation1_def nat_into_M
                 iterates_closed [of "is_list_functor(M,A)"])
done

lemma (in M_datatypes) mem_list_abs [simp]:
     "M(A) ==> mem_list(M,A,l) \<longleftrightarrow> l \<in> list(A)"
apply (insert list_replacement1)
apply (simp add: mem_list_def list_N_def relation1_def list_eq_Union
                 iterates_closed [of "is_list_functor(M,A)"])
done

lemma (in M_datatypes) list_abs [simp]:
     "[|M(A); M(Z)|] ==> is_list(M,A,Z) \<longleftrightarrow> Z = list(A)"
apply (simp add: is_list_def, safe)
apply (rule M_equalityI, simp_all)
done

subsubsection\<open>Absoluteness of Formulas\<close>

lemma (in M_datatypes) formula_replacement2':
  "strong_replacement(M, \<lambda>n y. n\<in>nat & y = (\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))^n (0))"
apply (insert formula_replacement2)
apply (rule strong_replacement_cong [THEN iffD1])
apply (rule conj_cong [OF iff_refl iterates_abs [of "is_formula_functor(M)"]])
apply (simp_all add: formula_replacement1 relation1_def)
done

lemma (in M_datatypes) formula_closed [intro,simp]:
     "M(formula)"
apply (insert formula_replacement1)
apply  (simp add: RepFun_closed2 formula_eq_Union
                  formula_replacement2' relation1_def
                  iterates_closed [of "is_formula_functor(M)"])
done

lemmas (in M_datatypes) formula_into_M = transM [OF _ formula_closed]

lemma (in M_datatypes) formula_N_abs [simp]:
     "[|n\<in>nat; M(Z)|]
      ==> is_formula_N(M,n,Z) \<longleftrightarrow> Z = formula_N(n)"
apply (insert formula_replacement1)
apply (simp add: is_formula_N_def formula_N_def relation1_def nat_into_M
                 iterates_abs [of "is_formula_functor(M)" _
                                  "\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X)"])
done

lemma (in M_datatypes) formula_N_closed [intro,simp]:
     "n\<in>nat ==> M(formula_N(n))"
apply (insert formula_replacement1)
apply (simp add: is_formula_N_def formula_N_def relation1_def nat_into_M
                 iterates_closed [of "is_formula_functor(M)"])
done

lemma (in M_datatypes) mem_formula_abs [simp]:
     "mem_formula(M,l) \<longleftrightarrow> l \<in> formula"
apply (insert formula_replacement1)
apply (simp add: mem_formula_def relation1_def formula_eq_Union formula_N_def
                 iterates_closed [of "is_formula_functor(M)"])
done

lemma (in M_datatypes) formula_abs [simp]:
     "[|M(Z)|] ==> is_formula(M,Z) \<longleftrightarrow> Z = formula"
apply (simp add: is_formula_def, safe)
apply (rule M_equalityI, simp_all)
done

subsection\<open>Absoluteness for \<open>\<epsilon>\<close>-Closure: the @{term eclose} Operator\<close>

text\<open>Re-expresses eclose using "iterates"\<close>
lemma eclose_eq_Union:
     "eclose(A) = (\<Union>n\<in>nat. Union^n (A))"
apply (simp add: eclose_def)
apply (rule UN_cong)
apply (rule refl)
apply (induct_tac n)
apply (simp add: nat_rec_0)
apply (simp add: nat_rec_succ)
done

definition
  is_eclose_n :: "[i=>o,i,i,i] => o" where
    "is_eclose_n(M,A,n,Z) == is_iterates(M, big_union(M), A, n, Z)"

definition
  mem_eclose :: "[i=>o,i,i] => o" where
    "mem_eclose(M,A,l) ==
      \<exists>n[M]. \<exists>eclosen[M].
       finite_ordinal(M,n) & is_eclose_n(M,A,n,eclosen) & l \<in> eclosen"

definition
  is_eclose :: "[i=>o,i,i] => o" where
    "is_eclose(M,A,Z) == \<forall>u[M]. u \<in> Z \<longleftrightarrow> mem_eclose(M,A,u)"

locale M_eclose = M_datatypes +
 assumes eclose_replacement1:
   "M(A) ==> iterates_replacement(M, big_union(M), A)"
  and eclose_replacement2:
   "M(A) ==> strong_replacement(M,
         \<lambda>n y. n\<in>nat & is_iterates(M, big_union(M), A, n, y))"

lemma (in M_eclose) eclose_replacement2':
  "M(A) ==> strong_replacement(M, \<lambda>n y. n\<in>nat & y = Union^n (A))"
apply (insert eclose_replacement2 [of A])
apply (rule strong_replacement_cong [THEN iffD1])
apply (rule conj_cong [OF iff_refl iterates_abs [of "big_union(M)"]])
apply (simp_all add: eclose_replacement1 relation1_def)
done

lemma (in M_eclose) eclose_closed [intro,simp]:
     "M(A) ==> M(eclose(A))"
apply (insert eclose_replacement1)
by  (simp add: RepFun_closed2 eclose_eq_Union
               eclose_replacement2' relation1_def
               iterates_closed [of "big_union(M)"])

lemma (in M_eclose) is_eclose_n_abs [simp]:
     "[|M(A); n\<in>nat; M(Z)|] ==> is_eclose_n(M,A,n,Z) \<longleftrightarrow> Z = Union^n (A)"
apply (insert eclose_replacement1)
apply (simp add: is_eclose_n_def relation1_def nat_into_M
                 iterates_abs [of "big_union(M)" _ "Union"])
done

lemma (in M_eclose) mem_eclose_abs [simp]:
     "M(A) ==> mem_eclose(M,A,l) \<longleftrightarrow> l \<in> eclose(A)"
apply (insert eclose_replacement1)
apply (simp add: mem_eclose_def relation1_def eclose_eq_Union
                 iterates_closed [of "big_union(M)"])
done

lemma (in M_eclose) eclose_abs [simp]:
     "[|M(A); M(Z)|] ==> is_eclose(M,A,Z) \<longleftrightarrow> Z = eclose(A)"
apply (simp add: is_eclose_def, safe)
apply (rule M_equalityI, simp_all)
done

subsection \<open>Absoluteness for @{term transrec}\<close>

text\<open>@{prop "transrec(a,H) \<equiv> wfrec(Memrel(eclose({a})), a, H)"}\<close>

definition
  is_transrec :: "[i=>o, [i,i,i]=>o, i, i] => o" where
   "is_transrec(M,MH,a,z) ==
      \<exists>sa[M]. \<exists>esa[M]. \<exists>mesa[M].
       upair(M,a,a,sa) & is_eclose(M,sa,esa) & membership(M,esa,mesa) &
       is_wfrec(M,MH,mesa,a,z)"

definition
  transrec_replacement :: "[i=>o, [i,i,i]=>o, i] => o" where
   "transrec_replacement(M,MH,a) ==
      \<exists>sa[M]. \<exists>esa[M]. \<exists>mesa[M].
       upair(M,a,a,sa) & is_eclose(M,sa,esa) & membership(M,esa,mesa) &
       wfrec_replacement(M,MH,mesa)"

text\<open>The condition @{term "Ord(i)"} lets us use the simpler
  \<open>trans_wfrec_abs\<close> rather than \<open>trans_wfrec_abs\<close>,
  which I haven't even proved yet.\<close>
theorem (in M_eclose) transrec_abs:
  "[|transrec_replacement(M,MH,i);  relation2(M,MH,H);
     Ord(i);  M(i);  M(z);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> is_transrec(M,MH,i,z) \<longleftrightarrow> z = transrec(i,H)"
by (simp add: trans_wfrec_abs transrec_replacement_def is_transrec_def
       transrec_def eclose_sing_Ord_eq wf_Memrel trans_Memrel relation_Memrel)

theorem (in M_eclose) transrec_closed:
     "[|transrec_replacement(M,MH,i);  relation2(M,MH,H);
        Ord(i);  M(i);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
      ==> M(transrec(i,H))"
by (simp add: trans_wfrec_closed transrec_replacement_def is_transrec_def
        transrec_def eclose_sing_Ord_eq wf_Memrel trans_Memrel relation_Memrel)

text\<open>Helps to prove instances of @{term transrec_replacement}\<close>
lemma (in M_eclose) transrec_replacementI:
   "[|M(a);
      strong_replacement (M,
                  \<lambda>x z. \<exists>y[M]. pair(M, x, y, z) &
                               is_wfrec(M,MH,Memrel(eclose({a})),x,y))|]
    ==> transrec_replacement(M,MH,a)"
by (simp add: transrec_replacement_def wfrec_replacement_def)

subsection\<open>Absoluteness for the List Operator @{term length}\<close>
text\<open>But it is never used.\<close>

definition
  is_length :: "[i=>o,i,i,i] => o" where
    "is_length(M,A,l,n) ==
       \<exists>sn[M]. \<exists>list_n[M]. \<exists>list_sn[M].
        is_list_N(M,A,n,list_n) & l \<notin> list_n &
        successor(M,n,sn) & is_list_N(M,A,sn,list_sn) & l \<in> list_sn"

lemma (in M_datatypes) length_abs [simp]:
     "[|M(A); l \<in> list(A); n \<in> nat|] ==> is_length(M,A,l,n) \<longleftrightarrow> n = length(l)"
apply (subgoal_tac "M(l) & M(n)")
 prefer 2 apply (blast dest: transM)
apply (simp add: is_length_def)
apply (blast intro: list_imp_list_N nat_into_Ord list_N_imp_eq_length
             dest: list_N_imp_length_lt)
done

text\<open>Proof is trivial since @{term length} returns natural numbers.\<close>
lemma (in M_trivial) length_closed [intro,simp]:
     "l \<in> list(A) ==> M(length(l))"
by (simp add: nat_into_M)

subsection \<open>Absoluteness for the List Operator @{term nth}\<close>

lemma nth_eq_hd_iterates_tl [rule_format]:
     "xs \<in> list(A) ==> \<forall>n \<in> nat. nth(n,xs) = hd' (tl'^n (xs))"
apply (induct_tac xs)
apply (simp add: iterates_tl_Nil hd'_Nil, clarify)
apply (erule natE)
apply (simp add: hd'_Cons)
apply (simp add: tl'_Cons iterates_commute)
done

lemma (in M_basic) iterates_tl'_closed:
     "[|n \<in> nat; M(x)|] ==> M(tl'^n (x))"
apply (induct_tac n, simp)
apply (simp add: tl'_Cons tl'_closed)
done

text\<open>Immediate by type-checking\<close>
lemma (in M_datatypes) nth_closed [intro,simp]:
     "[|xs \<in> list(A); n \<in> nat; M(A)|] ==> M(nth(n,xs))"
apply (case_tac "n < length(xs)")
 apply (blast intro: nth_type transM)
apply (simp add: not_lt_iff_le nth_eq_0)
done

definition
  is_nth :: "[i=>o,i,i,i] => o" where
    "is_nth(M,n,l,Z) ==
      \<exists>X[M]. is_iterates(M, is_tl(M), l, n, X) & is_hd(M,X,Z)"

lemma (in M_datatypes) nth_abs [simp]:
     "[|M(A); n \<in> nat; l \<in> list(A); M(Z)|]
      ==> is_nth(M,n,l,Z) \<longleftrightarrow> Z = nth(n,l)"
apply (subgoal_tac "M(l)")
 prefer 2 apply (blast intro: transM)
apply (simp add: is_nth_def nth_eq_hd_iterates_tl nat_into_M
                 tl'_closed iterates_tl'_closed
                 iterates_abs [OF _ relation1_tl] nth_replacement)
done

subsection\<open>Relativization and Absoluteness for the @{term formula} Constructors\<close>

definition
  is_Member :: "[i=>o,i,i,i] => o" where
     \<comment>\<open>because @{term "Member(x,y) \<equiv> Inl(Inl(\<langle>x,y\<rangle>))"}\<close>
    "is_Member(M,x,y,Z) ==
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) & is_Inl(M,p,u) & is_Inl(M,u,Z)"

lemma (in M_trivial) Member_abs [simp]:
     "[|M(x); M(y); M(Z)|] ==> is_Member(M,x,y,Z) \<longleftrightarrow> (Z = Member(x,y))"
by (simp add: is_Member_def Member_def)

lemma (in M_trivial) Member_in_M_iff [iff]:
     "M(Member(x,y)) \<longleftrightarrow> M(x) & M(y)"
by (simp add: Member_def)

definition
  is_Equal :: "[i=>o,i,i,i] => o" where
     \<comment>\<open>because @{term "Equal(x,y) \<equiv> Inl(Inr(\<langle>x,y\<rangle>))"}\<close>
    "is_Equal(M,x,y,Z) ==
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) & is_Inr(M,p,u) & is_Inl(M,u,Z)"

lemma (in M_trivial) Equal_abs [simp]:
     "[|M(x); M(y); M(Z)|] ==> is_Equal(M,x,y,Z) \<longleftrightarrow> (Z = Equal(x,y))"
by (simp add: is_Equal_def Equal_def)

lemma (in M_trivial) Equal_in_M_iff [iff]: "M(Equal(x,y)) \<longleftrightarrow> M(x) & M(y)"
by (simp add: Equal_def)

definition
  is_Nand :: "[i=>o,i,i,i] => o" where
     \<comment>\<open>because @{term "Nand(x,y) \<equiv> Inr(Inl(\<langle>x,y\<rangle>))"}\<close>
    "is_Nand(M,x,y,Z) ==
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) & is_Inl(M,p,u) & is_Inr(M,u,Z)"

lemma (in M_trivial) Nand_abs [simp]:
     "[|M(x); M(y); M(Z)|] ==> is_Nand(M,x,y,Z) \<longleftrightarrow> (Z = Nand(x,y))"
by (simp add: is_Nand_def Nand_def)

lemma (in M_trivial) Nand_in_M_iff [iff]: "M(Nand(x,y)) \<longleftrightarrow> M(x) & M(y)"
by (simp add: Nand_def)

definition
  is_Forall :: "[i=>o,i,i] => o" where
     \<comment>\<open>because @{term "Forall(x) \<equiv> Inr(Inr(p))"}\<close>
    "is_Forall(M,p,Z) == \<exists>u[M]. is_Inr(M,p,u) & is_Inr(M,u,Z)"

lemma (in M_trivial) Forall_abs [simp]:
     "[|M(x); M(Z)|] ==> is_Forall(M,x,Z) \<longleftrightarrow> (Z = Forall(x))"
by (simp add: is_Forall_def Forall_def)

lemma (in M_trivial) Forall_in_M_iff [iff]: "M(Forall(x)) \<longleftrightarrow> M(x)"
by (simp add: Forall_def)

subsection \<open>Absoluteness for @{term formula_rec}\<close>

definition
  formula_rec_case :: "[[i,i]=>i, [i,i]=>i, [i,i,i,i]=>i, [i,i]=>i, i, i] => i" where
    \<comment>\<open>the instance of @{term formula_case} in @{term formula_rec}\<close>
   "formula_rec_case(a,b,c,d,h) ==
        formula_case (a, b,
                \<lambda>u v. c(u, v, h ` succ(depth(u)) ` u,
                              h ` succ(depth(v)) ` v),
                \<lambda>u. d(u, h ` succ(depth(u)) ` u))"

text\<open>Unfold @{term formula_rec} to @{term formula_rec_case}.
     Express @{term formula_rec} without using @{term rank} or @{term Vset},
neither of which is absolute.\<close>
lemma (in M_trivial) formula_rec_eq:
  "p \<in> formula ==>
   formula_rec(a,b,c,d,p) =
   transrec (succ(depth(p)),
             \<lambda>x h. Lambda (formula, formula_rec_case(a,b,c,d,h))) ` p"
apply (simp add: formula_rec_case_def)
apply (induct_tac p)
   txt\<open>Base case for @{term Member}\<close>
   apply (subst transrec, simp add: formula.intros)
  txt\<open>Base case for @{term Equal}\<close>
  apply (subst transrec, simp add: formula.intros)
 txt\<open>Inductive step for @{term Nand}\<close>
 apply (subst transrec)
 apply (simp add: succ_Un_distrib formula.intros)
txt\<open>Inductive step for @{term Forall}\<close>
apply (subst transrec)
apply (simp add: formula_imp_formula_N formula.intros)
done

subsubsection\<open>Absoluteness for the Formula Operator @{term depth}\<close>

definition
  is_depth :: "[i=>o,i,i] => o" where
    "is_depth(M,p,n) ==
       \<exists>sn[M]. \<exists>formula_n[M]. \<exists>formula_sn[M].
        is_formula_N(M,n,formula_n) & p \<notin> formula_n &
        successor(M,n,sn) & is_formula_N(M,sn,formula_sn) & p \<in> formula_sn"

lemma (in M_datatypes) depth_abs [simp]:
     "[|p \<in> formula; n \<in> nat|] ==> is_depth(M,p,n) \<longleftrightarrow> n = depth(p)"
apply (subgoal_tac "M(p) & M(n)")
 prefer 2 apply (blast dest: transM)
apply (simp add: is_depth_def)
apply (blast intro: formula_imp_formula_N nat_into_Ord formula_N_imp_eq_depth
             dest: formula_N_imp_depth_lt)
done

text\<open>Proof is trivial since @{term depth} returns natural numbers.\<close>
lemma (in M_trivial) depth_closed [intro,simp]:
     "p \<in> formula ==> M(depth(p))"
by (simp add: nat_into_M)

subsubsection\<open>@{term is_formula_case}: relativization of @{term formula_case}\<close>

definition
 is_formula_case ::
    "[i=>o, [i,i,i]=>o, [i,i,i]=>o, [i,i,i]=>o, [i,i]=>o, i, i] => o" where
  \<comment>\<open>no constraint on non-formulas\<close>
  "is_formula_case(M, is_a, is_b, is_c, is_d, p, z) ==
      (\<forall>x[M]. \<forall>y[M]. finite_ordinal(M,x) \<longrightarrow> finite_ordinal(M,y) \<longrightarrow>
                      is_Member(M,x,y,p) \<longrightarrow> is_a(x,y,z)) &
      (\<forall>x[M]. \<forall>y[M]. finite_ordinal(M,x) \<longrightarrow> finite_ordinal(M,y) \<longrightarrow>
                      is_Equal(M,x,y,p) \<longrightarrow> is_b(x,y,z)) &
      (\<forall>x[M]. \<forall>y[M]. mem_formula(M,x) \<longrightarrow> mem_formula(M,y) \<longrightarrow>
                     is_Nand(M,x,y,p) \<longrightarrow> is_c(x,y,z)) &
      (\<forall>x[M]. mem_formula(M,x) \<longrightarrow> is_Forall(M,x,p) \<longrightarrow> is_d(x,z))"

lemma (in M_datatypes) formula_case_abs [simp]:
     "[| Relation2(M,nat,nat,is_a,a); Relation2(M,nat,nat,is_b,b);
         Relation2(M,formula,formula,is_c,c); Relation1(M,formula,is_d,d);
         p \<in> formula; M(z) |]
      ==> is_formula_case(M,is_a,is_b,is_c,is_d,p,z) \<longleftrightarrow>
          z = formula_case(a,b,c,d,p)"
apply (simp add: formula_into_M is_formula_case_def)
apply (erule formula.cases)
   apply (simp_all add: Relation1_def Relation2_def)
done

lemma (in M_datatypes) formula_case_closed [intro,simp]:
  "[|p \<in> formula;
     \<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> M(a(x,y));
     \<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> M(b(x,y));
     \<forall>x[M]. \<forall>y[M]. x\<in>formula \<longrightarrow> y\<in>formula \<longrightarrow> M(c(x,y));
     \<forall>x[M]. x\<in>formula \<longrightarrow> M(d(x))|] ==> M(formula_case(a,b,c,d,p))"
by (erule formula.cases, simp_all)

subsubsection \<open>Absoluteness for @{term formula_rec}: Final Results\<close>

definition
  is_formula_rec :: "[i=>o, [i,i,i]=>o, i, i] => o" where
    \<comment>\<open>predicate to relativize the functional @{term formula_rec}\<close>
   "is_formula_rec(M,MH,p,z)  ==
      \<exists>dp[M]. \<exists>i[M]. \<exists>f[M]. finite_ordinal(M,dp) & is_depth(M,p,dp) &
             successor(M,dp,i) & fun_apply(M,f,p,z) & is_transrec(M,MH,i,f)"

text\<open>Sufficient conditions to relativize the instance of @{term formula_case}
      in @{term formula_rec}\<close>
lemma (in M_datatypes) Relation1_formula_rec_case:
     "[|Relation2(M, nat, nat, is_a, a);
        Relation2(M, nat, nat, is_b, b);
        Relation2 (M, formula, formula,
           is_c, \<lambda>u v. c(u, v, h`succ(depth(u))`u, h`succ(depth(v))`v));
        Relation1(M, formula,
           is_d, \<lambda>u. d(u, h ` succ(depth(u)) ` u));
        M(h) |]
      ==> Relation1(M, formula,
                         is_formula_case (M, is_a, is_b, is_c, is_d),
                         formula_rec_case(a, b, c, d, h))"
apply (simp (no_asm) add: formula_rec_case_def Relation1_def)
apply (simp add: formula_case_abs)
done

text\<open>This locale packages the premises of the following theorems,
      which is the normal purpose of locales.  It doesn't accumulate
      constraints on the class @{term M}, as in most of this deveopment.\<close>
locale Formula_Rec = M_eclose +
  fixes a and is_a and b and is_b and c and is_c and d and is_d and MH
  defines
      "MH(u::i,f,z) ==
        \<forall>fml[M]. is_formula(M,fml) \<longrightarrow>
             is_lambda
         (M, fml, is_formula_case (M, is_a, is_b, is_c(f), is_d(f)), z)"

  assumes a_closed: "[|x\<in>nat; y\<in>nat|] ==> M(a(x,y))"
      and a_rel:    "Relation2(M, nat, nat, is_a, a)"
      and b_closed: "[|x\<in>nat; y\<in>nat|] ==> M(b(x,y))"
      and b_rel:    "Relation2(M, nat, nat, is_b, b)"
      and c_closed: "[|x \<in> formula; y \<in> formula; M(gx); M(gy)|]
                     ==> M(c(x, y, gx, gy))"
      and c_rel:
         "M(f) ==>
          Relation2 (M, formula, formula, is_c(f),
             \<lambda>u v. c(u, v, f ` succ(depth(u)) ` u, f ` succ(depth(v)) ` v))"
      and d_closed: "[|x \<in> formula; M(gx)|] ==> M(d(x, gx))"
      and d_rel:
         "M(f) ==>
          Relation1(M, formula, is_d(f), \<lambda>u. d(u, f ` succ(depth(u)) ` u))"
      and fr_replace: "n \<in> nat ==> transrec_replacement(M,MH,n)"
      and fr_lam_replace:
           "M(g) ==>
            strong_replacement
              (M, \<lambda>x y. x \<in> formula &
                  y = \<langle>x, formula_rec_case(a,b,c,d,g,x)\<rangle>)"

lemma (in Formula_Rec) formula_rec_case_closed:
    "[|M(g); p \<in> formula|] ==> M(formula_rec_case(a, b, c, d, g, p))"
by (simp add: formula_rec_case_def a_closed b_closed c_closed d_closed)

lemma (in Formula_Rec) formula_rec_lam_closed:
    "M(g) ==> M(Lambda (formula, formula_rec_case(a,b,c,d,g)))"
by (simp add: lam_closed2 fr_lam_replace formula_rec_case_closed)

lemma (in Formula_Rec) MH_rel2:
     "relation2 (M, MH,
             \<lambda>x h. Lambda (formula, formula_rec_case(a,b,c,d,h)))"
apply (simp add: relation2_def MH_def, clarify)
apply (rule lambda_abs2)
apply (rule Relation1_formula_rec_case)
apply (simp_all add: a_rel b_rel c_rel d_rel formula_rec_case_closed)
done

lemma (in Formula_Rec) fr_transrec_closed:
    "n \<in> nat
     ==> M(transrec
          (n, \<lambda>x h. Lambda(formula, formula_rec_case(a, b, c, d, h))))"
by (simp add: transrec_closed [OF fr_replace MH_rel2]
              nat_into_M formula_rec_lam_closed)

text\<open>The main two results: @{term formula_rec} is absolute for @{term M}.\<close>
theorem (in Formula_Rec) formula_rec_closed:
    "p \<in> formula ==> M(formula_rec(a,b,c,d,p))"
by (simp add: formula_rec_eq fr_transrec_closed
              transM [OF _ formula_closed])

theorem (in Formula_Rec) formula_rec_abs:
  "[| p \<in> formula; M(z)|]
   ==> is_formula_rec(M,MH,p,z) \<longleftrightarrow> z = formula_rec(a,b,c,d,p)"
by (simp add: is_formula_rec_def formula_rec_eq transM [OF _ formula_closed]
              transrec_abs [OF fr_replace MH_rel2] depth_type
              fr_transrec_closed formula_rec_lam_closed eq_commute)

end


theory Typed_Predicate_Language
  imports Typed_Memory
begin

datatype ('var,'val) exp =
  Var "'var"
  | Const "'val"
  | Op "('val \<Rightarrow> 'val \<Rightarrow> 'val)" "('var,'val) exp" "('var,'val) exp"
  | Ternary "('var,'val) exp" "('var,'val) exp" "('var,'val) exp" "('var,'val) exp"

datatype ('var, 'val) pred =
  Pb "bool"
  | PDisj "('var,'val) pred" "('var,'val) pred" (infixr "\<or>\<^sub>p" 30)
  | PConj "('var,'val) pred" "('var,'val) pred" (infixr "\<and>\<^sub>p" 35)
  | PImp  "('var,'val) pred" "('var,'val) pred" (infixr "\<longrightarrow>\<^sub>p" 25)
  | PNeg  "('var,'val) pred"
  | PCmp  "('val \<Rightarrow> 'val \<Rightarrow> bool)" "('var,'val) exp" "('var,'val) exp"
  | PBoo  "bool \<Rightarrow> ('var, 'val) pred"
  | Low   "('var)"
  | PTer "('var,'val) exp" "('var,'val) exp" "('var,'val) pred" "('var,'val) pred"

primrec
  eval :: "('var,'val) Mem \<Rightarrow> ('var,'val) exp \<Rightarrow> 'val"
where
  "eval m (Var v) = m v" |
  "eval m (Const c) = c" |
  "eval m (Op bop e f) = bop (eval m e) (eval m f)" |
  "eval m (Ternary v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (if (eval m v\<^sub>1) = (eval m v\<^sub>2) then (eval m e\<^sub>1) else (eval m e\<^sub>2))"

primrec
  test :: "('var,'val) Mem \<Rightarrow> 'var Type \<Rightarrow> ('var,'val) pred \<Rightarrow> bool"
where
  "test m \<Gamma> (Pb v) = v" |
  "test m \<Gamma> (PDisj p q) = (test m \<Gamma> p \<or> test m \<Gamma> q)" |
  "test m \<Gamma> (PConj p q) = (test m \<Gamma> p \<and> test m \<Gamma> q)" |
  "test m \<Gamma> (PImp p q) = (test m \<Gamma> p \<longrightarrow> test m \<Gamma> q)" |
  "test m \<Gamma> (PNeg p) = (\<not> test m \<Gamma> p)" |
  "test m \<Gamma> (PCmp c e f) = (c (eval m e) (eval m f))" |
  "test m \<Gamma> (PBoo p) = (\<forall>c. test m \<Gamma> (p c))" |
  "test m \<Gamma> (Low v) = (\<Gamma> v)" |
  "test m \<Gamma> (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (if (eval m v\<^sub>1) = (eval m v\<^sub>2) then (test m \<Gamma> e\<^sub>1) else (test m \<Gamma> e\<^sub>2))"

primrec
  vars\<^sub>e :: "('var,'val) exp \<Rightarrow> ('var) set"
where
  "vars\<^sub>e (Var v) = { v }" |
  "vars\<^sub>e (Const c) = {}" |
  "vars\<^sub>e (Op bop e f) = (vars\<^sub>e e \<union> vars\<^sub>e f)" |
  "vars\<^sub>e (Ternary v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (vars\<^sub>e v\<^sub>1 \<union> vars\<^sub>e v\<^sub>2 \<union> vars\<^sub>e e\<^sub>1 \<union> vars\<^sub>e e\<^sub>2)"

primrec
  vars\<^sub>p :: "('var,'val) pred \<Rightarrow> ('var) set"
where
  "vars\<^sub>p (Pb v) = {}" |
  "vars\<^sub>p (PNeg p) = vars\<^sub>p p" |
  "vars\<^sub>p (PConj p q) = (vars\<^sub>p p \<union> vars\<^sub>p q)" |
  "vars\<^sub>p (PDisj p q) = (vars\<^sub>p p \<union> vars\<^sub>p q)" |
  "vars\<^sub>p (PImp p q) = (vars\<^sub>p p \<union> vars\<^sub>p q)" |
  "vars\<^sub>p (PCmp cmp e f) = (vars\<^sub>e e \<union> vars\<^sub>e f)" |
  "vars\<^sub>p (PBoo p) = (\<Union>v. vars\<^sub>p (p v))" |
  "vars\<^sub>p (Low v) = {}" |
  "vars\<^sub>p (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (vars\<^sub>e v\<^sub>1 \<union> vars\<^sub>e v\<^sub>2 \<union> vars\<^sub>p e\<^sub>1 \<union> vars\<^sub>p e\<^sub>2)"

primrec
  vars\<^sub>\<Gamma> :: "('var, 'val) pred \<Rightarrow> ('var) set"
where
  "vars\<^sub>\<Gamma> (Pb v) = {}" |
  "vars\<^sub>\<Gamma> (PNeg p) = vars\<^sub>\<Gamma> p" |
  "vars\<^sub>\<Gamma> (PConj p q) = (vars\<^sub>\<Gamma> p \<union> vars\<^sub>\<Gamma> q)" |
  "vars\<^sub>\<Gamma> (PDisj p q) = (vars\<^sub>\<Gamma> p \<union> vars\<^sub>\<Gamma> q)" |
  "vars\<^sub>\<Gamma> (PImp p q) = (vars\<^sub>\<Gamma> p \<union> vars\<^sub>\<Gamma> q)" |
  "vars\<^sub>\<Gamma> (PCmp cmp e f) = {}" |
  "vars\<^sub>\<Gamma> (PBoo p) = (\<Union>v. vars\<^sub>\<Gamma> (p v))" |
  "vars\<^sub>\<Gamma> (Low v) = {v}" |
  "vars\<^sub>\<Gamma> (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (vars\<^sub>\<Gamma> e\<^sub>1 \<union> vars\<^sub>\<Gamma> e\<^sub>2)"

primrec
  subst\<^sub>e :: "('var,'val) exp \<Rightarrow> ('var) \<Rightarrow> ('var,'val) exp \<Rightarrow> ('var,'val) exp"
where
  "subst\<^sub>e (Var v) x e = (if v = x then e else Var v)" |
  "subst\<^sub>e (Const c) x e = (Const c)" |
  "subst\<^sub>e (Op bop f s) x e = (Op bop (subst\<^sub>e f x e) (subst\<^sub>e s x e))" |
  "subst\<^sub>e (Ternary v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) x e = (Ternary (subst\<^sub>e v\<^sub>1 x e) (subst\<^sub>e v\<^sub>2 x e) (subst\<^sub>e e\<^sub>1 x e) (subst\<^sub>e e\<^sub>2 x e))"

primrec
  subst\<^sub>p :: "('var,'val) pred \<Rightarrow> ('var) \<Rightarrow> ('var,'val) exp \<Rightarrow> ('var,'val) pred"
where
  "subst\<^sub>p (Pb v) x e = (Pb v)" |
  "subst\<^sub>p (PNeg p) x e = (PNeg (subst\<^sub>p p x e))" |
  "subst\<^sub>p (PConj p q) x e = (PConj (subst\<^sub>p p x e) (subst\<^sub>p q x e))" |
  "subst\<^sub>p (PDisj p q) x e = (PDisj (subst\<^sub>p p x e) (subst\<^sub>p q x e))" |
  "subst\<^sub>p (PCmp cmp f s) x e = (PCmp cmp (subst\<^sub>e f x e) (subst\<^sub>e s x e))" |
  "subst\<^sub>p (PImp p q) x e = (PImp (subst\<^sub>p p x e) (subst\<^sub>p q x e))" |
  "subst\<^sub>p (PBoo p) x e = PBoo (\<lambda>v . subst\<^sub>p (p v ) x e)" |
  "subst\<^sub>p (Low p) x e = Low p" |
  "subst\<^sub>p (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) x e = (PTer (subst\<^sub>e v\<^sub>1 x e) (subst\<^sub>e v\<^sub>2 x e) (subst\<^sub>p e\<^sub>1 x e) (subst\<^sub>p e\<^sub>2 x e))"

primrec
  subst\<^sub>\<Gamma> :: "('var,'val) pred \<Rightarrow> ('var) \<Rightarrow> ('var,'val) pred \<Rightarrow> ('var,'val) pred"
where
  "subst\<^sub>\<Gamma> (Pb v) x e = (Pb v)" |
  "subst\<^sub>\<Gamma> (PNeg p) x e = (PNeg (subst\<^sub>\<Gamma> p x e))" |
  "subst\<^sub>\<Gamma> (PConj p q) x e = (PConj (subst\<^sub>\<Gamma> p x e) (subst\<^sub>\<Gamma> q x e))" |
  "subst\<^sub>\<Gamma> (PDisj p q) x e = (PDisj (subst\<^sub>\<Gamma> p x e) (subst\<^sub>\<Gamma> q x e))" |
  "subst\<^sub>\<Gamma> (PCmp cmp f s) x e = (PCmp cmp f s)" |
  "subst\<^sub>\<Gamma> (PImp p q) x e = (PImp (subst\<^sub>\<Gamma> p x e) (subst\<^sub>\<Gamma> q x e))" |
  "subst\<^sub>\<Gamma> (PBoo p) x e = PBoo (\<lambda>v . subst\<^sub>\<Gamma> (p v ) x e)" |
  "subst\<^sub>\<Gamma> (Low p) x e = (if p = x then e else Low p)" |
  "subst\<^sub>\<Gamma> (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) x e = (PTer (v\<^sub>1) (v\<^sub>2) (subst\<^sub>\<Gamma> e\<^sub>1 x e) (subst\<^sub>\<Gamma> e\<^sub>2 x e))"

primrec
  map\<^sub>e :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'val) exp \<Rightarrow> ('b, 'val) exp"
  where
  "map\<^sub>e f (Var p) = (Var (f p))" |
  "map\<^sub>e f (Const v) = (Const v)" |
  "map\<^sub>e f (Op c e g) = (Op c (map\<^sub>e f e) (map\<^sub>e f g))" |
  "map\<^sub>e f (Ternary v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (Ternary (map\<^sub>e f v\<^sub>1) (map\<^sub>e f v\<^sub>2) (map\<^sub>e f e\<^sub>1) (map\<^sub>e f e\<^sub>2))"

primrec
  map\<^sub>p :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'val) pred \<Rightarrow> ('b, 'val) pred"
where
  "map\<^sub>p f (Pb v) = (Pb v)" |
  "map\<^sub>p f (PNeg p) = PNeg (map\<^sub>p f p)" |
  "map\<^sub>p f (PConj p q) = (PConj (map\<^sub>p f p) (map\<^sub>p f q))" |
  "map\<^sub>p f (PDisj p q) = (PDisj (map\<^sub>p f p) (map\<^sub>p f q))" |
  "map\<^sub>p f (PCmp cmp e g) = (PCmp cmp (map\<^sub>e f e) (map\<^sub>e f g))" |
  "map\<^sub>p f (PImp p q) = (PImp (map\<^sub>p f p) (map\<^sub>p f q))" |
  "map\<^sub>p f (PBoo p) = PBoo (\<lambda>v. map\<^sub>p f (p v))" |
  "map\<^sub>p f (Low p) = (Low (f p))" |
  "map\<^sub>p f (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (PTer (map\<^sub>e f v\<^sub>1) (map\<^sub>e f v\<^sub>2) (map\<^sub>p f e\<^sub>1) (map\<^sub>p f e\<^sub>2))"

primrec
  map\<^sub>o :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'val) pred \<Rightarrow> ('a, 'val) pred"
where
  "map\<^sub>o f (Pb v) = (Pb v)" |
  "map\<^sub>o f (PNeg p) = PNeg (map\<^sub>o f p)" |
  "map\<^sub>o f (PConj p q) = (PConj (map\<^sub>o f p) (map\<^sub>o f q))" |
  "map\<^sub>o f (PDisj p q) = (PDisj (map\<^sub>o f p) (map\<^sub>o f q))" |
  "map\<^sub>o f (PCmp cmp e g) = (PCmp cmp ( e) ( g))" |
  "map\<^sub>o f (PImp p q) = (PImp (map\<^sub>o f p) (map\<^sub>o f q))" |
  "map\<^sub>o f (PBoo p) = PBoo (\<lambda>v. map\<^sub>o f (p v))" |
  "map\<^sub>o f (Low p) = (Low (f p))" |
  "map\<^sub>o f (PTer v\<^sub>1 v\<^sub>2 e\<^sub>1 e\<^sub>2) = (PTer ( v\<^sub>1) ( v\<^sub>2) (map\<^sub>o f e\<^sub>1) (map\<^sub>o f e\<^sub>2))"

definition entail :: "('Var,'Val) pred \<Rightarrow> ('Var,'Val) pred \<Rightarrow> bool"
  (infix "\<turnstile>\<^sub>p" 25)
  where "entail P P' \<equiv> \<forall>mem \<Gamma>. test mem \<Gamma> P \<longrightarrow> test mem \<Gamma> P'"

definition equiv :: "('Var,'Val) pred \<Rightarrow> ('Var,'Val) pred \<Rightarrow> bool"
  (infixl "=\<^sub>p" 50)
  where "equiv P P' \<equiv> \<forall>mem \<Gamma>. test mem \<Gamma> P = test mem \<Gamma> P'"

definition \<Gamma>_ord :: "('var) Type \<Rightarrow> ('var) Type \<Rightarrow> bool"
  (infix "\<sqsupseteq>" 50)
  where "\<Gamma>_ord \<Gamma> \<Gamma>' \<equiv> \<forall>x. \<Gamma>' x \<longrightarrow> \<Gamma> x"

definition \<Gamma>_wf :: "('Var,'Val) pred \<Rightarrow> bool"
  where "\<Gamma>_wf P \<equiv> \<forall>m \<Gamma> \<Gamma>'. test m \<Gamma> P \<and> \<Gamma>' \<sqsupseteq> \<Gamma> \<longrightarrow> test m \<Gamma>' P"

definition fold_conj :: "(_,_) pred list \<Rightarrow> (_,_) pred"
  where "fold_conj l \<equiv> fold PConj l (Pb True)"

definition forVars :: "'a list \<Rightarrow> ('a \<Rightarrow> (_,_) pred) \<Rightarrow> (_,_) pred"
  where "forVars V f = fold_conj (map f V)"

(*
definition for_all :: "'a list \<Rightarrow> (_,_) pred \<Rightarrow> (_,_) pred"
  where "for_all V P \<equiv> fold (\<lambda>x P. PBoo (\<lambda>b. PVal (\<lambda>v. subst\<^sub>\<Gamma> (subst\<^sub>p P x (Const v)) x (Pb b)))) V P"
*)

lemma entail_refl [intro]:
  "P \<turnstile>\<^sub>p P"
  by (auto simp: entail_def)

lemma eval_vars_det:
  "\<forall>v \<in> vars\<^sub>e e. mem v = mem' v \<Longrightarrow> eval mem e = eval mem' e"
  by (induct e, auto)

lemma test_vars_det:
  "\<forall>v \<in> vars\<^sub>p e. m v = m' v \<Longrightarrow> \<forall>v \<in> vars\<^sub>\<Gamma> e. \<Gamma> v = \<Gamma>' v \<Longrightarrow> test m \<Gamma> e = test m' \<Gamma>' e"
proof (induct e)
  case (PCmp c e1 e2)
  hence "\<forall>v\<in>vars\<^sub>e e1. m v = m' v" "\<forall>v\<in>vars\<^sub>e e2. m v = m' v"
    by auto
  hence "eval m e1 = eval m' e1" "eval m e2 = eval m' e2"
    using eval_vars_det by blast+
  then show ?case by auto
next
  case (PTer e1 e2 v1 v2)
  hence "\<forall>v\<in>vars\<^sub>e e1. m v = m' v" "\<forall>v\<in>vars\<^sub>e e2. m v = m' v"
    by auto
  hence "eval m e1 = eval m' e1" "eval m e2 = eval m' e2"
    using eval_vars_det by blast+
  then show ?case using PTer by auto
qed (auto)

lemma map\<^sub>e_vars_det:
  "\<forall>v \<in> vars\<^sub>e e. mem v = mem' (f v) \<Longrightarrow> eval mem e = eval mem' (map\<^sub>e f e)"
  by (induct e, auto)

subsection \<open> subste \<close>

lemma subst\<^sub>e_mem_upd:
  assumes "(\<And>y. y \<noteq> x \<Longrightarrow> mem' y = mem y)"
  assumes "eval mem' e = mem x"
  shows "eval mem' (subst\<^sub>e f x e) = eval mem f"
  using assms by (induct f, auto)

lemma subst\<^sub>e_nop [simp]:
  assumes "x \<notin> vars\<^sub>e f"
  shows "subst\<^sub>e f x v = f"
  using assms by (induct f, auto)

lemma subst\<^sub>e_vars [simp]:
  shows "vars\<^sub>e (subst\<^sub>e f x e) = vars\<^sub>e f - {x} \<union> (if x \<in> vars\<^sub>e f then vars\<^sub>e e else {})"
  by (induct f, auto)

subsection \<open> substp \<close>

lemma subst\<^sub>p_mem_upd:
  assumes "\<And>y. y \<noteq> x \<Longrightarrow> mem' y = mem y"
  assumes "eval mem' e = mem x"
  shows "test mem' \<Gamma> (subst\<^sub>p P x e) = test mem \<Gamma> P"
  using assms
  by (induct P, auto simp: subst\<^sub>e_mem_upd)

lemma subst\<^sub>p_nop [simp]:
  shows "x \<notin> vars\<^sub>p P \<Longrightarrow> subst\<^sub>p P x v = P"
  by (induct P, auto)

lemma subst\<^sub>p_vars\<^sub>p [simp]:
  shows "vars\<^sub>p (subst\<^sub>p P x v) = vars\<^sub>p P - {x} \<union> (if x \<in> vars\<^sub>p P then vars\<^sub>e v else {})"
proof (induct P)

  case (PBoo z)
  hence "vars\<^sub>p (subst\<^sub>p (PBoo z) x v) = (\<Union>y. vars\<^sub>p (z y) - {x} \<union> (if x \<in> vars\<^sub>p (z y) then vars\<^sub>e v else {}))"
    by auto
  also have "... = (\<Union>y. vars\<^sub>p (z y) - {x}) \<union> (\<Union>y. (if x \<in> vars\<^sub>p (z y) then vars\<^sub>e v else {}))"
    by blast
  finally show ?case by simp
qed auto

lemma subst\<^sub>p_vars\<^sub>\<Gamma> [simp]:
  "vars\<^sub>\<Gamma> (subst\<^sub>p P x v) = vars\<^sub>\<Gamma> P"
  by (induct P, auto)

subsection \<open> subst\<Gamma> \<close>

lemma subst\<^sub>\<Gamma>_mem_upd:
  assumes "\<And>y. y \<noteq> x \<Longrightarrow> \<Gamma>' y = \<Gamma> y"
  assumes "test mem \<Gamma>' e = \<Gamma> x"
  shows "test mem \<Gamma>' (subst\<^sub>\<Gamma> P x e) = test mem \<Gamma> P"
  using assms
  by (induct P, auto simp: subst\<^sub>e_mem_upd)

lemma subst\<^sub>\<Gamma>_nop [simp]:
  shows "x \<notin> vars\<^sub>\<Gamma> P \<Longrightarrow> subst\<^sub>\<Gamma> P x v = P"
  by (induct P, auto)

lemma subst\<^sub>\<Gamma>_vars [simp]:
  shows "vars\<^sub>\<Gamma> (subst\<^sub>\<Gamma> P x v) = vars\<^sub>\<Gamma> P - {x} \<union> (if x \<in> vars\<^sub>\<Gamma> P then vars\<^sub>\<Gamma> v else {})"
proof (induct P)

  case (PBoo z)
  hence "vars\<^sub>\<Gamma> (subst\<^sub>\<Gamma> (PBoo z) x v) = (\<Union>y. vars\<^sub>\<Gamma> (z y) - {x} \<union> (if x \<in> vars\<^sub>\<Gamma> (z y) then vars\<^sub>\<Gamma> v else {}))"
    by auto
  also have "... = (\<Union>y. vars\<^sub>\<Gamma> (z y) - {x}) \<union> (\<Union>y. (if x \<in> vars\<^sub>\<Gamma> (z y) then vars\<^sub>\<Gamma> v else {}))"
    by blast
  finally show ?case by simp
qed auto

lemma subst\<^sub>\<Gamma>_vars\<^sub>p [simp]:
  "vars\<^sub>p (subst\<^sub>\<Gamma> P x v) = vars\<^sub>p P \<union> (if x \<in> vars\<^sub>\<Gamma> P then vars\<^sub>p v else {})"
proof (induct P)

  case (PBoo z)
  hence "vars\<^sub>p (subst\<^sub>\<Gamma> (PBoo z) x v) = (\<Union>y. vars\<^sub>p (z y)  \<union> (if x \<in> vars\<^sub>\<Gamma> (z y) then vars\<^sub>p v else {}))"
    by auto
  also have "... = (\<Union>y. vars\<^sub>p (z y)) \<union> (\<Union>y. (if x \<in> vars\<^sub>\<Gamma> (z y) then vars\<^sub>p v else {}))"
    by blast
  finally show ?case by simp
qed auto

lemma map\<^sub>p_vars_det:
  shows "\<forall>v \<in> vars\<^sub>p P. mem v = mem' (f v) \<Longrightarrow> \<forall>v \<in> vars\<^sub>\<Gamma> P. \<Gamma> v = \<Gamma>' (f v) \<Longrightarrow> test mem \<Gamma> P = test mem' \<Gamma>' (map\<^sub>p f P)"
proof (induct P)
  case (PCmp c e1 e2)
  then show ?case using map\<^sub>e_vars_det
    by (metis (no_types, lifting) map\<^sub>p.simps(5) subset_iff sup_ge1 sup_ge2 test.simps(6) vars\<^sub>p.simps(6))
next
  case (PTer e1 e2 v1 v2)
  then show ?case using map\<^sub>e_vars_det
    by (metis (no_types, lifting) UnCI map\<^sub>p.simps(9) test.simps(9) vars\<^sub>\<Gamma>.simps(9) vars\<^sub>p.simps(9))
qed auto

lemma map\<^sub>o_vars_det:
  shows "\<forall>v \<in> vars\<^sub>\<Gamma> P. \<Gamma> v = \<Gamma>' (f v) \<Longrightarrow> test mem \<Gamma> P = test mem \<Gamma>' (map\<^sub>o f P)"
  by (induct P) auto

lemma vars_map\<^sub>e [simp]:
  "vars\<^sub>e (map\<^sub>e f e) = f ` vars\<^sub>e e"
  by (induct e) auto

lemma vars_map\<^sub>p [simp]:
  "vars\<^sub>p (map\<^sub>p f e) = f ` vars\<^sub>p e"
  by (induct e) auto

lemma vars_map\<^sub>\<Gamma> [simp]:
  "vars\<^sub>\<Gamma> (map\<^sub>p f e) = f ` vars\<^sub>\<Gamma> e"
  by (induct e) auto

lemma \<Gamma>_ord_refl [intro]:
  shows "\<Gamma> \<sqsupseteq> \<Gamma>"
  by (auto simp: \<Gamma>_ord_def)

lemma entail_trans[trans]:
  "P \<turnstile>\<^sub>p Q \<Longrightarrow> Q \<turnstile>\<^sub>p R \<Longrightarrow> P \<turnstile>\<^sub>p R"
  by (auto simp: entail_def)

lemma entail_conj1[intro]:
  "P \<and>\<^sub>p Q \<turnstile>\<^sub>p Q"
  by (auto simp: entail_def)

lemma entail_conj2[intro]:
  "P \<and>\<^sub>p Q \<turnstile>\<^sub>p P"
  by (auto simp: entail_def)

lemma test_fold:
  "test e \<Gamma> (fold (\<and>\<^sub>p) (map f L) P) = ((\<forall>v \<in> set L. test e \<Gamma> (f v)) \<and> test e \<Gamma> P)"
  by (induct L arbitrary: P, auto)

lemma test_low [simp]:
  "test e \<Gamma> (forVars (V :: 'a list) f) = (\<forall>v \<in> set V. test e \<Gamma> (f v))"
  using test_fold[of e \<Gamma> f] by (auto simp: forVars_def fold_conj_def)

lemma test_subst\<^sub>\<Gamma> [simp]:
  "test m \<Gamma> (subst\<^sub>\<Gamma> P y Q) = test m (\<Gamma> (y := test m \<Gamma> Q)) P"
  by (intro subst\<^sub>\<Gamma>_mem_upd, auto)

lemma test_subst\<^sub>p [simp]:
  "test m \<Gamma> (subst\<^sub>p P y e) = test (m (y := eval m e)) \<Gamma> P"
  by (intro subst\<^sub>p_mem_upd, auto)

lemma wf_subst\<^sub>p[intro]:
  assumes "\<Gamma>_wf Q"
  shows "\<Gamma>_wf (subst\<^sub>p Q x e)"
  using assms by (auto simp: \<Gamma>_wf_def)

lemma vars_const [elim]:
  assumes "vars\<^sub>p Q = {}" "vars\<^sub>\<Gamma> Q = {}"
  obtains (T) "Q =\<^sub>p Pb True" | (F) "Q =\<^sub>p Pb False"
  using assms
proof (cases "\<exists>m \<Gamma>. test m \<Gamma> Q")
  case True
  then obtain m' \<Gamma>' where t: "test m' \<Gamma>' Q" by blast
  have "\<forall>m \<Gamma>. test m \<Gamma> Q"
  proof (intro allI)
    fix m \<Gamma>
    have "test m \<Gamma> Q = test m' \<Gamma>' Q" using test_vars_det[of Q m m' \<Gamma> \<Gamma>'] assms by auto
    thus "test m \<Gamma> Q" using t by auto
  qed
  then show ?thesis using that by (auto simp: equiv_def)
next
  case False
  then show ?thesis using that by (auto simp: equiv_def)
qed

lemma equiv_trans [trans]:
  shows "P1 =\<^sub>p P2 \<Longrightarrow> P2 =\<^sub>p P3 \<Longrightarrow> P1 =\<^sub>p P3"
  unfolding equiv_def by metis

lemma entail_conj [intro]:
  "A \<turnstile>\<^sub>p B \<Longrightarrow> A \<turnstile>\<^sub>p C \<Longrightarrow> A \<turnstile>\<^sub>p B \<and>\<^sub>p C"
  by (auto simp: entail_def)

lemma entail_imp [intro]:
  "A \<and>\<^sub>p B \<turnstile>\<^sub>p C \<Longrightarrow> A \<turnstile>\<^sub>p (B \<longrightarrow>\<^sub>p C)"
  by (auto simp: entail_def)

lemma entail_true [intro]:
  "A \<turnstile>\<^sub>p Pb True"
  by (auto simp: entail_def)

lemma entail_imp_pres[intro]:
  "A \<turnstile>\<^sub>p B \<Longrightarrow> (C \<longrightarrow>\<^sub>p A) \<turnstile>\<^sub>p (C \<longrightarrow>\<^sub>p B)"
  by (auto simp: entail_def)

primrec foldi :: "nat \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
  fold_Nil:  "foldi n f [] = id" |
  fold_Cons: "foldi n f (x # xs) = foldi (Suc n) f xs \<circ> f n x"

definition index_assert
  where "index_assert x i P \<equiv> foldi 0 (\<lambda>j v Q. Q \<and>\<^sub>p (PCmp (=) i (Const j) \<longrightarrow>\<^sub>p P v)) x (Pb True)"

definition list\<^sub>e
  where "list\<^sub>e x i \<equiv> foldi 0 (\<lambda>j v. Ternary (Const j) i (Var v)) x (Const 0)"

definition list\<^sub>t
  where "list\<^sub>t x i f \<equiv> foldi 0 (\<lambda>j v. PTer (Const j) i (f v)) x (Pb False)"

text \<open>Show that liste is equivalent to evaluating a list read for values\<close>
lemma eval_foldi_nop [simp]:
  assumes "eval m i < k"
  shows "eval m (foldi k (\<lambda>y v. Ternary (Const y) i (Q v)) x q) = eval m q"
  using assms
proof (induct x arbitrary: k q)
  case (Cons a x)
  thus ?case using Cons(1)[of "Suc k" "Ternary (Const k) i (Q a) q"] by simp
qed simp

lemma list\<^sub>e [simp]:
  assumes "eval m i < length x"
  shows "eval m (list\<^sub>e x i) = m (x ! eval m i)"
proof -
  have "\<And>k Q. k \<le> eval m i \<Longrightarrow> eval m i - k < length x \<Longrightarrow> eval m (foldi k (\<lambda>j v. Ternary (Const j) i (Var v)) x Q) = m (x ! (eval m i - k))"
  proof (induct x)
    case (Cons a x)
    then show ?case
    proof (cases "eval m i = k")
      case False
      have "eval m (foldi (Suc k) (\<lambda>j v. Ternary (Const j) i (Var v)) x (Ternary (Const k) i (Var a) Q)) = m (x ! (eval m i - Suc k))"
        using False Cons(2,3) by (intro Cons(1)) auto
      thus ?thesis using False Cons(2) by simp
    qed auto
  qed simp
  thus ?thesis using assms by (auto simp: list\<^sub>e_def)
qed

text \<open>Show that liste is equivalent to evaluating a list read for types\<close>
lemma test_foldi_nop [simp]:
  assumes "eval m i < k"
  shows "test m \<Gamma> (foldi k (\<lambda>y v. PTer (Const y) i (Q v)) x q) = test m \<Gamma> q"
  using assms
proof (induct x arbitrary: k q)
  case (Cons a x)
  thus ?case using Cons(1)[of "Suc k" "PTer (Const k) i (Q a) q"] by simp
qed simp

lemma list\<^sub>t [simp]:
  assumes "eval m i < length x"
  shows "test m \<Gamma> (list\<^sub>t x i f) = test m \<Gamma> (f (x ! eval m i))"
proof -
  have "\<And>k Q. k \<le> eval m i \<Longrightarrow> eval m i - k < length x \<Longrightarrow> test m \<Gamma> (foldi k (\<lambda>j v. PTer (Const j) i (f v)) x Q) = test m \<Gamma> (f (x ! (eval m i - k)))"
  proof (induct x)
    case Nil
    then show ?case by simp
  next
    case (Cons a x)
    then show ?case
    proof (cases "eval m i = k")
      case False
      have "test m \<Gamma> (foldi (Suc k) (\<lambda>j v. PTer (Const j) i (f v)) x (PTer (Const k) i (f a) Q)) = test m \<Gamma> (f  (x ! (eval m i - Suc k)))"
        using False Cons(2,3) by (intro Cons(1)) auto
      thus ?thesis using False Cons(2) by simp
    qed auto
  qed
  thus ?thesis using assms by (auto simp: list\<^sub>t_def)
qed

text \<open>Show that index_assert is equivalent to asserting a property for a particular index\<close>
lemma test_foldi_nop_conj [simp]:
  assumes "eval m i < k"
  shows "test m \<Gamma> (foldi ( k) (\<lambda>j v Q. Q \<and>\<^sub>p (PCmp (=) i (Const j) \<longrightarrow>\<^sub>p P v)) x Q) = test m \<Gamma> Q"
  using assms by (induct x arbitrary: k Q) auto

lemma test_index [simp]:
  assumes "eval m i < length x"
  shows "test m \<Gamma> (index_assert x i P) = test m \<Gamma> (P (x ! eval m i))"
proof -
  have "\<And>k Q. k \<le> eval m i \<Longrightarrow> eval m i - k < length x \<Longrightarrow> test m \<Gamma> (foldi k (\<lambda>j v Q. Q \<and>\<^sub>p (PCmp (=) i (Const j) \<longrightarrow>\<^sub>p P v)) x Q) = test m \<Gamma> (P (x ! (eval m i - k)) \<and>\<^sub>p Q)"
  proof (induct x)
    case (Cons a x)
    then show ?case
    proof (cases "eval m i = k")
      case False
      have "test m \<Gamma> (foldi (Suc k) (\<lambda>j v Q. Q \<and>\<^sub>p (PCmp (=) i (Const j) \<longrightarrow>\<^sub>p P v)) x (Q \<and>\<^sub>p (PCmp (=) i (Const k) \<longrightarrow>\<^sub>p P a))) =
            test m \<Gamma> (P (x ! (eval m i - (Suc k))) \<and>\<^sub>p (Q \<and>\<^sub>p (PCmp (=) i (Const k) \<longrightarrow>\<^sub>p P a)))"
        using False Cons(2,3) by (intro Cons(1)) auto
      then show ?thesis using False Cons(2) by simp
    qed auto
  qed simp
  thus ?thesis using assms by (auto simp: index_assert_def)
qed

end


(*  Title:      ZF/Coind/Map.thy
    Author:     Jacob Frost, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge

Some sample proofs of inclusions for the final coalgebra "U" (by lcp).
*)

theory Map imports Main begin

definition
  TMap :: "[i,i] => i"  where
   "TMap(A,B) == {m \<in> Pow(A*\<Union>(B)).\<forall>a \<in> A. m``{a} \<in> B}"

definition
  PMap :: "[i,i] => i"  where
   "PMap(A,B) == TMap(A,cons(0,B))"

(* Note: 0 \<in> B ==> TMap(A,B) = PMap(A,B) *)

definition
  map_emp :: i  where
   "map_emp == 0"

definition
  map_owr :: "[i,i,i]=>i"  where
   "map_owr(m,a,b) == \<Sum>x \<in> {a} \<union> domain(m). if x=a then b else m``{x}"

definition
  map_app :: "[i,i]=>i"  where
   "map_app(m,a) == m``{a}"

lemma "{0,1} \<subseteq> {1} \<union> TMap(I, {0,1})"
by (unfold TMap_def, blast)

lemma "{0} \<union> TMap(I,1) \<subseteq> {1} \<union> TMap(I, {0} \<union> TMap(I,1))"
by (unfold TMap_def, blast)

lemma "{0,1} \<union> TMap(I,2) \<subseteq> {1} \<union> TMap(I, {0,1} \<union> TMap(I,2))"
by (unfold TMap_def, blast)

(*A bit too slow.
lemma "{0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2) \<subseteq>
       {1} \<union> TMap(I, {0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2))"
by (unfold TMap_def, blast)
*)

(* ############################################################ *)
(* Lemmas                                                       *)
(* ############################################################ *)

lemma qbeta_if: "Sigma(A,B)``{a} = (if a \<in> A then B(a) else 0)"
by auto

lemma qbeta: "a \<in> A ==> Sigma(A,B)``{a} = B(a)"
by fast

lemma qbeta_emp: "a\<notin>A ==> Sigma(A,B)``{a} = 0"
by fast

lemma image_Sigma1: "a \<notin> A ==> Sigma(A,B)``{a}=0"
by fast

(* ############################################################ *)
(* Inclusion in Quine Universes                                 *)
(* ############################################################ *)

(* Lemmas *)

lemma MapQU_lemma:
    "A \<subseteq> univ(X) ==> Pow(A * \<Union>(quniv(X))) \<subseteq> quniv(X)"
apply (unfold quniv_def)
apply (rule Pow_mono)
apply (rule subset_trans [OF Sigma_mono product_univ])
apply (erule subset_trans)
apply (rule arg_subset_eclose [THEN univ_mono])
apply (simp add: Union_Pow_eq)
done

(* Theorems *)

lemma mapQU:
  "[| m \<in> PMap(A,quniv(B)); !!x. x \<in> A ==> x \<in> univ(B) |] ==> m \<in> quniv(B)"
apply (unfold PMap_def TMap_def)
apply (blast intro!: MapQU_lemma [THEN subsetD])
done

(* ############################################################ *)
(* Monotonicity                                                 *)
(* ############################################################ *)

lemma PMap_mono: "B \<subseteq> C ==> PMap(A,B)<=PMap(A,C)"
by (unfold PMap_def TMap_def, blast)

(* ############################################################ *)
(* Introduction Rules                                           *)
(* ############################################################ *)

(** map_emp **)

lemma pmap_empI: "map_emp \<in> PMap(A,B)"
by (unfold map_emp_def PMap_def TMap_def, auto)

(** map_owr **)

lemma pmap_owrI:
  "[| m \<in> PMap(A,B); a \<in> A; b \<in> B |]  ==> map_owr(m,a,b):PMap(A,B)"
apply (unfold map_owr_def PMap_def TMap_def, safe)
apply (simp_all add: if_iff, auto)
(*Remaining subgoal*)
apply (rule excluded_middle [THEN disjE])
apply (erule image_Sigma1)
apply (drule_tac psi = "uu \<notin> B" for uu in asm_rl)
apply (auto simp add: qbeta)
done

(** map_app **)

lemma tmap_app_notempty:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> map_app(m,a) \<noteq>0"
by (unfold TMap_def map_app_def, blast)

lemma tmap_appI:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> map_app(m,a):B"
by (unfold TMap_def map_app_def domain_def, blast)

lemma pmap_appI:
  "[| m \<in> PMap(A,B); a \<in> domain(m) |] ==> map_app(m,a):B"
apply (unfold PMap_def)
apply (frule tmap_app_notempty, assumption)
apply (drule tmap_appI, auto)
done

(** domain **)

lemma tmap_domainD:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> a \<in> A"
by (unfold TMap_def, blast)

lemma pmap_domainD:
  "[| m \<in> PMap(A,B); a \<in> domain(m) |] ==> a \<in> A"
by (unfold PMap_def TMap_def, blast)

(* ############################################################ *)
(* Equalities                                                   *)
(* ############################################################ *)

(** Domain **)

(* Lemmas *)

lemma domain_UN: "domain(\<Union>x \<in> A. B(x)) = (\<Union>x \<in> A. domain(B(x)))"
by fast

lemma domain_Sigma: "domain(Sigma(A,B)) = {x \<in> A. \<exists>y. y \<in> B(x)}"
by blast

(* Theorems *)

lemma map_domain_emp: "domain(map_emp) = 0"
by (unfold map_emp_def, blast)

lemma map_domain_owr:
  "b \<noteq> 0 ==> domain(map_owr(f,a,b)) = {a} \<union> domain(f)"
apply (unfold map_owr_def)
apply (auto simp add: domain_Sigma)
done

(** Application **)

lemma map_app_owr:
  "map_app(map_owr(f,a,b),c) = (if c=a then b else map_app(f,c))"
by (simp add: qbeta_if  map_app_def map_owr_def, blast)

lemma map_app_owr1: "map_app(map_owr(f,a,b),a) = b"
by (simp add: map_app_owr)

lemma map_app_owr2: "c \<noteq> a ==> map_app(map_owr(f,a,b),c)= map_app(f,c)"
by (simp add: map_app_owr)

end


theory SparseArray
  imports "HOL-Data_Structures.Tries_Binary" "HOL.Parity"
  "HOL-Library.Adhoc_Overloading"
begin

(* typeclass for data we can convert to binary
   for use with radix *)

class rx_key =
  fixes rx_serialize ::
    "'a \<Rightarrow> bool list"

  assumes serialize_distinct :
  "\<And> (x :: 'a) (x' :: 'a) . rx_serialize x = rx_serialize x' \<Longrightarrow> x = x'"
begin
end

value "divide_int_inst.divide_int (3 :: int)  2"

fun nat_to_bool_list :: "nat \<Rightarrow> bool list" where
"nat_to_bool_list i =
  (if i = 0 then []
   else
    (if (i mod 2) = 0 then False else True) #
    nat_to_bool_list (i div 2))"

lemma nat_to_bool_list_distinct :
  assumes H : "nat_to_bool_list i = nat_to_bool_list i'"
  shows "i = i'" using assms
  sorry
(*
proof(induction i arbitrary: i' rule: Nat.nat_less_induct)
  case (1 n)
  show ?case
  proof(cases n)
    case 0
    then show ?thesis using "1.prems" by(cases i'; auto)
  next
    case (Suc nat)

    obtain i'p where I' : "i' = Suc i'p"
      using "1.prems" Suc by(cases i'; auto)

    show ?thesis
    proof(cases "(n mod 2) = 0")
      case True : True
      then show ?thesis
      proof(cases "(i' mod 2) = 0")
        case True' : True

        have Next: "nat_to_bool_list (n div 2) =
              nat_to_bool_list (i' div 2)"
          using "1.prems" True True' Suc I'
          by(simp)

        have LeqN : "n div 2 < n" using Suc by auto

        have LeqI : "i' div 2 < i'" using I' by auto

        have Conc' : "n div 2 = i' div 2"
          using Next spec[OF "1.IH", of "n div 2"] LeqN LeqI
          apply(clarify)
          apply(drule_tac x = "i' div 2" in spec)
          apply(clarify)
          done

        then show ?thesis using True True' "1.prems" Suc I'
          apply(simp)

      next
  case False
  then show ?thesis sorry
qed

      next
      case False
      then show ?thesis sorry
    qed

      using "1.prems"
  qed
    apply(cases n) apply(simp)
    apply(cases i') apply(simp) apply(simp)
qed
  case (stable a)
  have 0: "a = 0" using stable(1)
    by(cases a; auto)
  hence 1: "i' = 0" using stable(2)
    by(cases i'; auto)
  show ?case using 0 1 by auto
next
  case (rec a b)
  show ?case
  proof(cases a)
    case 0
    then show ?thesis sorry
  next
    case (Suc nat)
    then show ?thesis sorry
  qed

  proof(cases b)
    case True
    then show ?thesis using  "rec"(1) apply(simp)
  next
    case False
    then show ?thesis sorry
  qed

qed
  case (1 i)
  show ?case
  proof(cases "i < 0")
    case True
    then show ?thesis
    proof(cases "i' < 0")
      case True' : True
      then show ?thesis
      proof(cases "(i mod 2) = 0")
        case True'' : True
        then show ?thesis using True True' True'' "1.prems" "1.IH"
          apply(auto)
      next
        case False
        then show ?thesis sorry
      qed
    next
      case False
      then show ?thesis sorry
    qed
  next
    case False
    then show ?thesis sorry
  qed
qed
  case (1 i)
  then show ?case
qed
  sorry
*)

instantiation nat :: rx_key begin
definition nat_rx_serialize :
"rx_serialize i = nat_to_bool_list i"

instance proof
  fix x x' :: nat
  assume H: "rx_serialize x = rx_serialize x'"
  then show "x = x'"
    unfolding nat_rx_serialize
    using nat_to_bool_list_distinct [of x x']
    by(simp)
qed

end

fun rx_trie_put ::

(*
 * pseudo typeclass for sparse arrays
 *)

consts sa_get ::
  "'t \<Rightarrow> 'k \<Rightarrow> 'v"

consts sa_put ::
  "'t \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 't"

end


(*<*)
theory v2_isar
  imports Main "../QML_S5"
begin
(*>*)

text \<open>
@{text "Compossibility\<^sub>2'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be originally made from matter @{term z} according to plan @{term u},
then it is also possible for table @{term x} to be originally made from matter @{term y} and in
addition some table or other @{term x'} to be originally made from matter @{term z}
according to plan @{term u}.
\<close>

text \<open>
@{text "Origin Uniqueness\<^sub>1'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.
\<close>

text \<open>
@{text "Sufficiency\<^sub>2'"}: If it is possible that a table @{term x'} is originally made from matter @{term z}
according to plan @{term u}, then necessarily any table originally made from matter @{term z}
according to plan @{term u} is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>2'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not originally made from any non-overlapping matter according to any plan.
\<close>

consts makeTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" ("T")
consts planTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" ("P") (* (P x y p) \<equiv> x made from y according to p *)

abbreviation overlap ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("O")
  where "O x y \<equiv> x \<^bold>=\<^sup>L y"

lemma self_identity: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<box>(x \<^bold>=\<^sup>L x) \<rfloor>" by auto
lemma necessity_of_identity: "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(x\<^bold>=\<^sup>Ly) \<^bold>\<rightarrow> \<^bold>\<box>(x\<^bold>=\<^sup>Ly))\<rfloor>" by auto
lemma necessity_of_distinctness: "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<not>\<^bold>\<diamond>(x\<^bold>=\<^sup>Ly) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x\<^bold>=\<^sup>Ly)))\<rfloor>" by auto

lemma
assumes compossibilty2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))\<rfloor>"
assumes origin_uniqueness2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))\<rfloor>"
assumes sufficiency2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<diamond>(P x y p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' y p) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)))\<rfloor>"
shows origin_essentialism2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p')))\<rfloor>"
proof (rule allI)
  fix w (* for the outer \<lfloor> \<rfloor> *)
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
  proof (rule allI)
    fix x (* for table x *)
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
    proof (rule allI)
      fix y (* for material y *)
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
      proof (rule allI)
        fix z (* for material z *)
        show "(\<^bold>\<forall>p. \<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
        proof (rule allI)
          fix p (* for plan p *)
          show "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
          proof (rule impI)
            assume antecedent:  "(\<^bold>\<diamond>(\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w"
            show  "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
              proof (rule notI)
                assume "((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
                from antecedent obtain w where w: "((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (P x y p)) w"
                  by (rule exE) (* Expanding \<diamond> in the same world *)
                then have non_overlapping: "\<not>(y \<^bold>=\<^sup>L z) w" by (rule conjE)
                have table_x_from_y: "(P x y p w)"
                  using `((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (P x y p)) w` by (rule conjE)
                have compossibilty2_ante: "((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) w"
                  using table_x_from_y and `((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w` and non_overlapping by auto

                have "((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w" using `((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w` by simp
                then obtain v where v: "((\<^bold>\<forall>p'. P x z p')) v" by (rule exE)
                then have sufficiency2_ante: "(\<^bold>\<diamond>(P x z p)) w" by auto

                from compossibilty2 have "((\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w"..
                then have "((\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w" by (rule allE)
                then have "((\<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w" by (rule allE)
                then have "((\<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w" by (rule allE)
                then have "(((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p)))) w" by (rule allE)
                then have "\<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))) w" using compossibilty2_ante by (rule mp)
                then obtain u where u: "(P x y p u  \<and> (\<exists>x'. P x' z p u)) " by (rule exE)
                then have "(\<exists>x'. P x' z p u)" by (rule conjE)
                then obtain x' where x': "P x' z p u" by (rule exE)

                from sufficiency2 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<diamond>(P x y p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t y p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<diamond>(P x y p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t y p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<diamond>(P x z p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<diamond>(P x z p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<box>(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" using sufficiency2_ante by (rule mp)
                then have "(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx)) u" by (rule allE)
                then have "((P x' z p) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)) u" by (rule allE)
                then have "(x' \<^bold>=\<^sup>L x) u" using `P x' z p u` by (rule mp)
                then have "(P x z p) u" using `(P x' z p) u` by auto
                moreover from u have "(P x y p) u" by simp
                then have "(P x y p) u \<and> (P x z p) u" using `(P x z p) u` by (rule conjI)
                then have conj_existence: "(P x y p \<^bold>\<and> P x z p) u" by simp
                then have impossible_arg: "(P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                  using non_overlapping by auto

               from origin_uniqueness2 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                 by simp
               then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p.\<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<forall>p. \<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<not>\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "(\<^bold>\<box>(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by auto
               then have "(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" by (rule allE)
               then have "\<not>((P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u))" by simp
               then show "False" using impossible_arg by (rule notE)
              qed
            qed
          qed
        qed
      qed
    qed
  qed

(*<*)
end
(*>*)


theory Taylor_Models_Misc
  imports
    "HOL-Library.Float"
    "HOL-Library.Function_Algebras"
    "HOL-Decision_Procs.Approximation"
    "Affine_Arithmetic.Floatarith_Expression"
begin

text \<open>This theory contains anything that doesn't belong anywhere else.\<close>

lemma of_nat_real_float_equiv: "(of_nat n :: real) = (of_nat n :: float)"
  by (induction n, simp_all add: of_nat_def)

lemma fact_real_float_equiv: "(fact n :: float) = (fact n :: real)"
  by (induction n) simp_all

lemma Some_those_length:
  "those ys = Some xs \<Longrightarrow> length xs = length ys"
  by (induction ys arbitrary: xs) (auto split: option.splits)

lemma those_eq_None_iff: "those ys = None \<longleftrightarrow> None \<in> set ys"
  by (induction ys) (auto simp: split: option.splits)

lemma those_eq_Some_iff: "those ys = (Some xs) \<longleftrightarrow> (ys = map Some xs)"
  by (induction ys arbitrary: xs) (auto simp: split: option.splits)

lemma Some_those_nth:
  assumes "those ys = Some xs"
  assumes "i < length xs"
  shows "Some (xs!i) = ys!i"
  using Some_those_length[OF assms(1)] assms
  by (induction xs ys arbitrary: i rule: list_induct2)
    (auto split: option.splits nat.splits simp: nth_Cons)

lemma fun_pow: "f^n = (\<lambda>x. (f x)^n)"
by (induction n, simp_all)

context includes floatarith_notation begin

text \<open>Translate floatarith expressions by a vector of floats.\<close>
fun fa_translate :: "float list \<Rightarrow> floatarith \<Rightarrow> floatarith"
where "fa_translate v (Add a b) = Add (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Minus a) = Minus (fa_translate v a)"
    | "fa_translate v (Mult a b) = Mult (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Inverse a) = Inverse (fa_translate v a)"
    | "fa_translate v (Cos a) = Cos (fa_translate v a)"
    | "fa_translate v (Arctan a) = Arctan (fa_translate v a)"
    | "fa_translate v (Min a b) = Min (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Max a b) = Max (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Abs a) = Abs (fa_translate v a)"
    | "fa_translate v (Sqrt a) = Sqrt (fa_translate v a)"
    | "fa_translate v (Exp a) = Exp (fa_translate v a)"
    | "fa_translate v (Ln a) = Ln (fa_translate v a)"
    | "fa_translate v (Var n) = Add (Var n) (Num (v!n))"
    | "fa_translate v (Power a n) = Power (fa_translate v a) n"
    | "fa_translate v (Powr a b) = Powr (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Floor x) = Floor (fa_translate v x)"
    | "fa_translate v (Num c) = Num c"
    | "fa_translate v Pi = Pi"

lemma fa_translate_correct:
  assumes "max_Var_floatarith f \<le> length I"
  assumes "length v = length I"
  shows "interpret_floatarith (fa_translate v f) I = interpret_floatarith f (map2 (+) I v)"
  using assms
  by (induction f, simp_all)

primrec vars_floatarith where
  "vars_floatarith (Add a b) = (vars_floatarith a) \<union> (vars_floatarith b)"
| "vars_floatarith (Mult a b) = (vars_floatarith a) \<union> (vars_floatarith b)"
| "vars_floatarith (Inverse a) = vars_floatarith a"
| "vars_floatarith (Minus a) = vars_floatarith a"
| "vars_floatarith (Num a) = {}"
| "vars_floatarith (Var i) = {i}"
| "vars_floatarith (Cos a) = vars_floatarith a"
| "vars_floatarith (Arctan a) = vars_floatarith a"
| "vars_floatarith (Abs a) = vars_floatarith a"
| "vars_floatarith (Max a b) = (vars_floatarith a) \<union> (vars_floatarith b)"
| "vars_floatarith (Min a b) = (vars_floatarith a) \<union> (vars_floatarith b)"
| "vars_floatarith (Pi) = {}"
| "vars_floatarith (Sqrt a) = vars_floatarith a"
| "vars_floatarith (Exp a) = vars_floatarith a"
| "vars_floatarith (Powr a b) = (vars_floatarith a) \<union> (vars_floatarith b)"
| "vars_floatarith (Ln a) = vars_floatarith a"
| "vars_floatarith (Power a n) = vars_floatarith a"
| "vars_floatarith (Floor a) = vars_floatarith a"

end

lemma max_Var_floatarith_eq_Max_vars_floatarith:
  "max_Var_floatarith fa = (if vars_floatarith fa = {} then 0 else Suc (Max (vars_floatarith fa)))"
  by (induction fa) (auto split: if_splits simp: Max_Un Max_eq_iff max_def)

end


theory Exercises2_08
  imports Main
begin

(*---------------- Exercise 2.8----------------*)
(* intersperse function *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a Nil = Nil" |
"intersperse a [x] = [x]" |
"intersperse a (Cons x xs) = [x,a]@(intersperse a xs)"

theorem map_intersperse : "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs rule: intersperse.induct)
  apply(auto)
  done

end


theory Fib
  imports "../Refine_Imperative_HOL/Sepref"
    "Imperative_HOL_Time.RBTree_Impl" "NREST.RefineMonadicVCG"
begin
hide_const R B

definition "op_zero = SPECT [(0::nat) \<mapsto> 1]"

definition "op_one = SPECT [1::nat \<mapsto> 1]"

definition op_plus :: "nat \<Rightarrow> nat \<Rightarrow> nat nrest" where
  "op_plus a b = SPECT [a+b \<mapsto> 1]"

definition myfun :: "nat \<Rightarrow> nat nrest" where
      "myfun n = RECT (\<lambda>fw n. if n = 0
                                       then op_zero
                                   else
                                    (if n = 1
                                        then op_one
                                        else do { a \<leftarrow> fw (n-2); b \<leftarrow> fw (n-1); RETURNT (a + b) } )) n"

lemma myfun_simps:
  "myfun 0              = op_zero"
  "myfun (Suc 0)        = op_one"
  "myfun (Suc (Suc n))  = do { a \<leftarrow> myfun (n); b \<leftarrow> myfun (n+1); RETURNT (a + b) }"
  unfolding myfun_def by (subst RECT_unfold, refine_mono, auto split: nat.split)+

fun fib where
  "fib 0 = 0"
|  "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib n + fib (Suc n)"

fun fib_time :: "nat \<Rightarrow> nat" where
  "fib_time 0 = 1"
| "fib_time (Suc 0) = 1"
| "fib_time (Suc (Suc n)) = fib_time n + fib_time (Suc n) + 1"

definition "fib_SPEC n \<equiv> SPECT [fib n \<mapsto> fib_time n]"

lemma spec: "myfun n \<le> fib_SPEC n"
proof (induction n rule: fib.induct)
  case (3 n)
  note IH = 3[unfolded fib_SPEC_def, THEN T_specifies_rev, THEN T_conseq4]
  show ?case
    apply(simp add: fib_SPEC_def myfun_simps)
    apply(rule T_specifies_I)
    apply(vcg' \<open>-\<close> rules: IH )
    by (auto split: if_splits)
qed (auto simp: fib_SPEC_def myfun_simps one_enat_def op_zero_def
                     op_one_def)

lemma hn_refine_op_plus[sepref_fr_rules]: " hn_refine
     (hn_val nat_rel y' y * hn_val nat_rel x' x)
     (ureturn (y + x))
     (hn_val nat_rel y' y * hn_val nat_rel x' x)
     (pure nat_rel) ( (op_plus $ y' $ x'))"
  unfolding hn_refine_def apply (auto simp: op_plus_def mult.assoc  execute_ureturn pure_def hn_ctxt_def )
   apply(rule exI[where x=0]) by (auto simp: top_assn_rule zero_enat_def one_enat_def relH_def  elim: pureD )

lemma hn_refine_zero[sepref_fr_rules]: " hn_refine
     (emp)
     (ureturn (0))
     (emp)
     (pure nat_rel) ( (op_zero))"
  unfolding hn_refine_def
  using models_in_range top_assn_rule
  by (auto simp: execute_ureturn pure_def op_zero_def one_enat_def relH_def
              elim: pureD )

lemma hn_refine_one[sepref_fr_rules]: " hn_refine
     (emp)
     (ureturn (1))
     (emp)
     (pure nat_rel) ( (op_one))"
  unfolding hn_refine_def
  using models_in_range top_assn_rule
  by (auto simp: execute_ureturn pure_def op_one_def one_enat_def relH_def
              elim: pureD )

context
  fixes n::"nat"
  notes [[sepref_register_adhoc n]]
  notes [sepref_import_param] = IdI[of n]
begin

schematic_goal synth_myfun: "hn_refine emp (?C::nat Heap) ?\<Gamma>' ?R (myfun n)"
  using [[goals_limit = 3]]
  unfolding myfun_def
  by sepref

concrete_definition myfun_impl uses synth_myfun is "hn_refine _ (?c n) _ _ _"

lemma "<$ (fib_time n)>
         myfun_impl n
       <\<lambda>r. (\<exists>\<^sub>Ara. id_assn ra r * \<up> (ra \<in> dom [fib n \<mapsto> enat (fib_time n)]))>\<^sub>t"
  unfolding myfun_impl_def
  apply(rule extract_cost_ub'[where Cost_ub="fib_time n", OF hnr_refine[OF spec synth_myfun, unfolded fib_SPEC_def]])
  by sep_auto+

end

end


(*  Title:      HOL/ex/Coherent.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Marc Bezem, Institutt for Informatikk, Universitetet i Bergen
*)

section \<open>Coherent Logic Problems\<close>

theory Coherent
imports Main
begin

subsection \<open>Equivalence of two versions of Pappus' Axiom\<close>

no_notation
  comp (infixl "o" 55) and
  relcomp (infixr "O" 75)

lemma p1p2:
  assumes "col a b c l \<and> col d e f m"
    and "col b f g n \<and> col c e g o"
    and "col b d h p \<and> col a e h q"
    and "col c d i r \<and> col a f i s"
    and "el n o \<Longrightarrow> goal"
    and "el p q \<Longrightarrow> goal"
    and "el s r \<Longrightarrow> goal"
    and "\<And>A. el A A \<Longrightarrow> pl g A \<Longrightarrow> pl h A \<Longrightarrow> pl i A \<Longrightarrow> goal"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl A D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl B D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl C D"
    and "\<And>A B. pl A B \<Longrightarrow> ep A A"
    and "\<And>A B. ep A B \<Longrightarrow> ep B A"
    and "\<And>A B C. ep A B \<Longrightarrow> ep B C \<Longrightarrow> ep A C"
    and "\<And>A B. pl A B \<Longrightarrow> el B B"
    and "\<And>A B. el A B \<Longrightarrow> el B A"
    and "\<And>A B C. el A B \<Longrightarrow> el B C \<Longrightarrow> el A C"
    and "\<And>A B C. ep A B \<Longrightarrow> pl B C \<Longrightarrow> pl A C"
    and "\<And>A B C. pl A B \<Longrightarrow> el B C \<Longrightarrow> pl A C"
    and "\<And>A B C D E F G H I J K L M N O P Q.
           col A B C D \<Longrightarrow> col E F G H \<Longrightarrow> col B G I J \<Longrightarrow> col C F I K \<Longrightarrow>
           col B E L M \<Longrightarrow> col A F L N \<Longrightarrow> col C E O P \<Longrightarrow> col A G O Q \<Longrightarrow>
           (\<exists> R. col I L O R) \<or> pl A H \<or> pl B H \<or> pl C H \<or> pl E D \<or> pl F D \<or> pl G D"
    and "\<And>A B C D. pl A B \<Longrightarrow> pl A C \<Longrightarrow> pl D B \<Longrightarrow> pl D C \<Longrightarrow> ep A D \<or> el B C"
    and "\<And>A B. ep A A \<Longrightarrow> ep B B \<Longrightarrow> \<exists>C. pl A C \<and> pl B C"
  shows goal using assms
  by coherent

lemma p2p1:
  assumes "col a b c l \<and> col d e f m"
    and "col b f g n \<and> col c e g o"
    and "col b d h p \<and> col a e h q"
    and "col c d i r \<and> col a f i s"
    and "pl a m \<Longrightarrow> goal"
    and "pl b m \<Longrightarrow> goal"
    and "pl c m \<Longrightarrow> goal"
    and "pl d l \<Longrightarrow> goal"
    and "pl e l \<Longrightarrow> goal"
    and "pl f l \<Longrightarrow> goal"
    and "\<And>A. pl g A \<Longrightarrow> pl h A \<Longrightarrow> pl i A \<Longrightarrow> goal"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl A D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl B D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl C D"
    and "\<And>A B. pl A B \<Longrightarrow> ep A A"
    and "\<And>A B. ep A B \<Longrightarrow> ep B A"
    and "\<And>A B C. ep A B \<Longrightarrow> ep B C \<Longrightarrow> ep A C"
    and "\<And>A B. pl A B \<Longrightarrow> el B B"
    and "\<And>A B. el A B \<Longrightarrow> el B A"
    and "\<And>A B C. el A B \<Longrightarrow> el B C \<Longrightarrow> el A C"
    and "\<And>A B C. ep A B \<Longrightarrow> pl B C \<Longrightarrow> pl A C"
    and "\<And>A B C. pl A B \<Longrightarrow> el B C \<Longrightarrow> pl A C"
    and "\<And>A B C D E F G H I J K L M N O P Q.
           col A B C J \<Longrightarrow> col D E F K \<Longrightarrow> col B F G L \<Longrightarrow> col C E G M \<Longrightarrow>
           col B D H N \<Longrightarrow> col A E H O \<Longrightarrow> col C D I P \<Longrightarrow> col A F I Q \<Longrightarrow>
           (\<exists> R. col G H I R) \<or> el L M \<or> el N O \<or> el P Q"
    and "\<And>A B C D. pl C A \<Longrightarrow> pl C B \<Longrightarrow> pl D A \<Longrightarrow> pl D B \<Longrightarrow> ep C D \<or> el A B"
    and "\<And>A B C. ep A A \<Longrightarrow> ep B B \<Longrightarrow> \<exists>C. pl A C \<and> pl B C"
  shows goal using assms
  by coherent

subsection \<open>Preservation of the Diamond Property under reflexive closure\<close>

lemma diamond:
  assumes "reflexive_rewrite a b" "reflexive_rewrite a c"
    and "\<And>A. reflexive_rewrite b A \<Longrightarrow> reflexive_rewrite c A \<Longrightarrow> goal"
    and "\<And>A. equalish A A"
    and "\<And>A B. equalish A B \<Longrightarrow> equalish B A"
    and "\<And>A B C. equalish A B \<Longrightarrow> reflexive_rewrite B C \<Longrightarrow> reflexive_rewrite A C"
    and "\<And>A B. equalish A B \<Longrightarrow> reflexive_rewrite A B"
    and "\<And>A B. rewrite A B \<Longrightarrow> reflexive_rewrite A B"
    and "\<And>A B. reflexive_rewrite A B \<Longrightarrow> equalish A B \<or> rewrite A B"
    and "\<And>A B C. rewrite A B \<Longrightarrow> rewrite A C \<Longrightarrow> \<exists>D. rewrite B D \<and> rewrite C D"
  shows goal using assms
  by coherent

end