header {* Program statements, Hoare and refinement rules *}

theory Statements
imports Assertion_Algebra
begin

text {*In this section we introduce assume, if, and while program statements
as well as Hoare triples, and data refienment. We prove Hoare correctness
rules for the program statements and we prove some theorems linking Hoare
correctness statement to (data) refinement. Most of the theorems assume
a monotonic boolean transformers algebra. The theorem stating the
equivalence between a Hoare
correctness triple and a refinement statement holds under the
assumption that we have a monotonic boolean transformers algebra with
post condition statement.*}

definition
  "assume" :: "'a::mbt_algebra Assertion \<Rightarrow> 'a"  ("[\<cdot> _ ]" [0] 1000) where
  "[\<cdot>p] =  {\<cdot>p} ^ o"

lemma [simp]: "[\<cdot>p] * x \<squnion> {\<cdot>-p} * \<top> = [\<cdot>p] * x"
  by (simp add: assume_def  uminus_Assertion_def)

lemma [simp]: "{\<cdot>p} * \<top> \<squnion> [\<cdot>-p] * x = [\<cdot>-p] * x"
  by (simp add: assume_def  uminus_Assertion_def)

lemma assert_sup: "{\<cdot>p \<squnion> q} = {\<cdot>p} \<squnion> {\<cdot>q}"
  by (simp add: sup_Assertion_def)

lemma assert_inf: "{\<cdot>p \<sqinter> q} = {\<cdot>p} \<sqinter> {\<cdot>q}"
  by (simp add: inf_Assertion_def)

lemma assert_neg: "{\<cdot>-p} = neg_assert {\<cdot>p}"
  by (simp add: uminus_Assertion_def)

lemma assert_false [simp]: "{\<cdot>\<bottom>} = \<bottom>"
  by (simp add: bot_Assertion_def)

lemma if_Assertion_assumption: "({\<cdot>p} * x) \<squnion> ({\<cdot>-p} * y) = ([\<cdot>p] * x) \<sqinter> ([\<cdot>-p] * y)"
proof -
    have "({\<cdot>p} * x) \<squnion> {\<cdot>-p} * y = ({\<cdot>p} * \<top> \<sqinter> [\<cdot>p]) * x \<squnion> ({\<cdot>-p} * \<top> \<sqinter> [\<cdot>-p]) * y" by simp
    also have "\<dots> = ({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top> \<sqinter> ([\<cdot>-p] * y))" by (unfold inf_comp, simp)
    also have "\<dots> = (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ([\<cdot>-p] * y))" by (simp add: sup_inf_distrib)
    also have "\<dots> = (({\<cdot>p} * \<top>  \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (([\<cdot>p] * x))) \<sqinter> (([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y)))"
      by (simp add: sup_inf_distrib2)
    also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y))"
      apply (simp add: sup_comp [THEN sym] )
      by (simp add: assert_sup [THEN sym] inf_assoc sup_compl_top)
    also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y)"
      by (rule antisym, simp_all add: inf_assoc)
    finally show ?thesis .
  qed

definition
  "wp x p = abs_wpt (x * {\<cdot>p})"

lemma wp_assume: "wp [\<cdot>p] q = -p \<squnion> q"
  apply (simp add: wp_def abs_wpt_def)
  apply (rule assert_injective)
  apply simp
  by (simp add: assert_sup assert_neg assume_def wpt_dual_assertion_comp)

lemma assert_commute: "y \<in> conjunctive \<Longrightarrow> y * {\<cdot>p} = {\<cdot> wp y p } * y"
  apply (simp add: wp_def abs_wpt_def)
  by (rule assertion_commute, simp_all)

lemma wp_assert: "wp {\<cdot>p} q = p \<sqinter> q"
  by (simp add: wp_def assertion_inf_comp_eq [THEN sym] assert_inf [THEN sym])

lemma wp_mono [simp]: "mono (wp x)"
  apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
  apply (simp add: wpt_def, safe)
  apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
  apply (rule le_comp_right)
  by (rule le_comp, simp)

lemma wp_fun_mono [simp]: "mono wp"
  apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
  apply (simp add: wpt_def, safe)
  apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
  apply (rule le_comp_right)
  by (rule le_comp_right, simp)

lemma wp_fun_mono2: "x \<le> y \<Longrightarrow> wp x p \<le> wp y p"
  apply (cut_tac wp_fun_mono)
  apply (unfold mono_def)
  apply (simp add: le_fun_def)
  by blast

lemma wp_comp: "wp (x * y) p = wp x (wp y p)"
  apply (simp add: wp_def abs_wpt_def)
  by (unfold wpt_comp_2 [THEN sym] mult.assoc, simp)

lemma wp_choice: "wp (x \<sqinter> y) = wp x \<sqinter> wp y"
  apply (simp add: fun_eq_iff wp_def inf_fun_def inf_comp inf_Assertion_def abs_wpt_def)
  by (simp add: wpt_choice)

lemma [simp]: "wp 1 = id"
  apply (unfold fun_eq_iff, safe)
  apply (rule assert_injective)
  by (simp add: wp_def abs_wpt_def)

lemma wp_omega_fix: "wp (x ^ \<omega>) p = wp x (wp (x ^ \<omega>) p) \<sqinter> p"
  apply (subst omega_fix)
  by (simp add: wp_choice wp_comp)

lemma wp_omega_least: "(wp x r) \<sqinter> p \<le> r \<Longrightarrow> wp (x ^ \<omega>) p \<le> r"
  apply (simp add: wp_def abs_wpt_def inf_Assertion_def less_eq_Assertion_def)
  apply (simp add: wpt_def)
  apply (rule_tac y = "{\<cdot>r} * \<top> \<sqinter> 1" in order_trans)
  apply simp
  apply (rule_tac y = "x ^ \<omega> * {\<cdot> p } * \<top>" in order_trans, simp)
  apply (simp add: mult.assoc)
  apply (rule omega_least)
  apply (drule_tac z = \<top> in le_comp_right)
  apply (simp add: inf_comp mult.assoc [THEN sym])
  by (simp add: assertion_prop)

lemma Assertion_wp: "{\<cdot>wp x p} = (x * {\<cdot>p} * \<top>) \<sqinter> 1"
  apply (simp add: wp_def abs_wpt_def)
  by (simp add: wpt_def)

definition
  "hoare p S q = (p \<le> wp S q)"

definition
  "grd x = - (wp x \<bottom>)"

lemma grd_comp: "[\<cdot>grd x] * x = x"
  apply (simp add: grd_def wp_def uminus_Assertion_def assume_def neg_assert_def abs_wpt_def dual_sup sup_comp)
  apply (simp add: wpt_def dual_inf sup_comp dual_comp bot_Assertion_def)
  by (rule antisym, simp_all)

lemma assert_assume: "{\<cdot>p} * [\<cdot>p] = {\<cdot> p}"
  by (simp add: assume_def)

lemma dual_assume: "[\<cdot>p] ^ o = {\<cdot>p}"
  by (simp add: assume_def)

lemma assume_prop: "([\<cdot>p] * \<bottom>) \<squnion> 1 = [\<cdot>p]"
  by (simp add: assume_def dual_assertion_prop)

text{*An alternative definition of a Hoare triple*}

definition "hoare1 p S q = ([\<cdot> p ] * S * [\<cdot> -q ] = \<top>)"

lemma "hoare1  p S q = hoare p S q"
  apply (simp add: hoare1_def dual_inf dual_comp)
  apply (simp add: hoare_def wp_def less_eq_Assertion_def abs_wpt_def)
  apply (simp add: wpt_def)
  apply safe
  proof -
    assume A: "[\<cdot> p ] * S * [\<cdot> - q ] = \<top>"
    have "{\<cdot>p} \<le> {\<cdot>p} * \<top>" by simp
    also have "... \<le> {\<cdot>p} * \<top> * \<bottom>" by (unfold mult.assoc, simp)
    also have "... = {\<cdot>p} * [\<cdot> p ] * S * [\<cdot> - q ] * \<bottom>" by (subst A [THEN sym], simp add: mult.assoc)
    also have "... = {\<cdot>p} * S * [\<cdot> - q ] * \<bottom>" by (simp add: assert_assume)
    also have "... \<le> {\<cdot>p} * S * {\<cdot> q } * \<top>"
      apply (simp add: mult.assoc)
      apply (rule le_comp, rule le_comp)
      apply (simp add: assume_def uminus_Assertion_def)
      by (simp add: neg_assert_def dual_inf dual_comp sup_comp)
    also have "... \<le> S * {\<cdot> q } * \<top>" by (simp add: mult.assoc)
    finally show "{\<cdot>p} \<le> S * {\<cdot> q } * \<top>" .
  next
    assume A: "{\<cdot> p } \<le> S * {\<cdot> q } * \<top>"
    have "\<top> = ((S * {\<cdot>q}) ^ o) * \<bottom> \<squnion> S * {\<cdot>q} * \<top>" by simp
    also have "\<dots> \<le> [\<cdot>p] * \<bottom> \<squnion> S * {\<cdot>q} * \<top>"
      apply (simp del: dual_neg_top)
      apply (rule_tac y = "[\<cdot>p] * \<bottom>" in order_trans, simp_all)
      apply (subst dual_le)
      apply (simp add: dual_comp dual_assume)
      apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
      apply (rule A)
      by (simp add: mult.assoc)
    also have "\<dots> = [\<cdot>p] * S * ({\<cdot>q} * \<top>)"
      apply (subst (2) assume_prop [THEN sym])
      by (simp_all add: sup_comp mult.assoc)
    also have "\<dots> \<le> [\<cdot>p] * S * ({\<cdot>q} * \<top> \<squnion> 1)"
      by (rule le_comp, simp)
    also have "\<dots> = [\<cdot>p] * S * [\<cdot>-q]"
      apply (simp add: assume_def uminus_Assertion_def)
      by (simp add: neg_assert_def dual_inf dual_comp)
    finally show "[\<cdot>p] * S * [\<cdot> - q] = \<top>"
      by (rule_tac antisym, simp_all)
  qed

lemma hoare_choice: "hoare p (x \<sqinter> y) q = ((hoare p) x q & (hoare p y q))"
  apply (unfold hoare_def wp_choice inf_fun_def)
  by auto

definition
  if_stm:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(If (_)/ then (_)/ else (_))" [0, 0, 10] 10) where
  "if_stm b x y = (([\<cdot> b ] * x) \<sqinter> ([\<cdot> -b ] * y))"

lemma if_assertion: "(If p then x else y) = {\<cdot>p} * x \<squnion> {\<cdot> -p} * y"
  by (simp add: if_stm_def if_Assertion_assumption)

lemma (in boolean_algebra) sup_neg_inf:
  "(p \<le> q \<squnion> r) = (p \<sqinter> -q \<le> r)"
  apply (safe)
  apply(cut_tac a = p and c = "q \<squnion> r" and b = "-q" and d = "-q" in inf_mono)
  apply simp apply simp apply (simp add: inf_sup_distrib2 inf_compl_bot)
  apply(cut_tac b = "p \<sqinter> - q" and d = "r" and a = "q" and c = "q" in sup_mono)
  apply simp apply simp  by (simp add: sup_inf_distrib sup_compl_top)

lemma hoare_if: "hoare p (If b then x else y) q = (hoare (p \<sqinter> b) x q \<and> hoare (p \<sqinter> -b) y q)"
  by (simp add: hoare_def if_stm_def wp_choice inf_fun_def wp_comp wp_assume sup_neg_inf)

lemma hoare_comp: "hoare p (x * y) q = (\<exists> r . (hoare p x r) \<and> (hoare r y q))"
   apply (simp add: hoare_def wp_comp)
   apply safe
   apply (rule_tac x = "wp y q" in exI, simp)
   apply (rule_tac y = "wp x r" in order_trans, simp)
   apply (rule_tac f = "wp x" in monoD)
   by simp_all

lemma hoare_refinement: "hoare p S q = ({\<cdot>p} * (post {\<cdot>q}) \<le> S)"
  apply (simp add: hoare_def less_eq_Assertion_def Assertion_wp)
  proof
    assume A: "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>"
    have "{\<cdot>p} * post {\<cdot>q} = ({\<cdot>p} * \<top> \<sqinter> 1) * post {\<cdot>q}" by (simp add: assertion_prop)
    also have "\<dots> = {\<cdot>p} * \<top> \<sqinter> post {\<cdot>q}" by (simp add: inf_comp)
    also have "\<dots> \<le> S * {\<cdot>q} * \<top> \<sqinter> post {\<cdot>q}" apply simp
      apply (rule_tac y = "{\<cdot>p} * \<top>" in order_trans, simp_all)
      apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
      by (rule A, simp)
    also have "\<dots> \<le> S" by (simp add: post_2)
    finally show "{\<cdot>p} * post {\<cdot>q} \<le> S".
  next
    assume A: "{\<cdot>p} * post {\<cdot>q} \<le> S"
    have "{\<cdot>p} = {\<cdot>p} * \<top> \<sqinter> 1" by (simp add: assertion_prop)
    also have "\<dots> = {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>) \<sqinter> 1" by (simp add: post_1)
    also have "\<dots> \<le> {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>)" by simp
    also have "\<dots> \<le> S * {\<cdot>q} * \<top>"
      apply (cut_tac x = "{\<cdot>p} * post {\<cdot>q}" and y = S and z = "{\<cdot>q} * \<top>" in le_comp_right)
      apply (simp add: A)
      by (simp add: mult.assoc)
    finally show "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>" .
  qed

 theorem hoare_fixpoint_mbt:
  "F x = x
     \<Longrightarrow> (!! (w::'a::well_founded) f . (\<And>v. v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q)
     \<Longrightarrow> hoare (p u) x q"
  apply (rule less_induct1)
  proof -
    fix xa
    assume A: "\<And> w f. (\<And> v . v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q"
    assume B: "F x  = x"
    assume C: "\<And>y . y < xa \<Longrightarrow> hoare (p y) x q"
    have D: "hoare (p xa) (F x) q"
      apply (rule A)
      by (rule C, simp)
    show "hoare (p xa) x q"
      by (cut_tac D, simp add: B)
    qed

lemma hoare_Sup: "hoare (Sup P) x q = (\<forall> p \<in> P . hoare p x q)"
  apply (simp add: hoare_def)
  apply auto
  apply (rule_tac y = "Sup P" in order_trans, simp_all add: Sup_upper)
  apply (rule Sup_least)
  by simp

theorem hoare_fixpoint_complete_mbt:
  "F x = x
     \<Longrightarrow> (!! w f . hoare (Sup_less p w) f q \<Longrightarrow> hoare (p w) (F f) q)
     \<Longrightarrow> hoare (Sup (range p)) x q"
  apply (simp add: hoare_Sup Sup_less_def SUP_def del: Sup_image_eq, safe)
  apply (rule_tac F = F in hoare_fixpoint_mbt)
  by auto

definition
  while:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a" ("(While (_)/ do (_))" [0, 10] 10) where
  "while p x = ([\<cdot> p] * x) ^ \<omega> * [\<cdot> -p ]"

lemma while_false: "(While \<bottom> do x) = 1"
  apply (unfold while_def)
  apply (subst omega_fix)
  by (simp_all add: assume_def)

lemma while_true: "(While \<top> do 1) = \<bottom>"
  apply (unfold while_def)
  by (rule antisym, simp_all add: assume_def)

lemma hoare_wp [simp]: "hoare (wp x q) x q"
  by (simp add: hoare_def)

lemma hoare_comp_wp: "hoare p (x * y) q = hoare p x (wp y q)"
  apply (unfold hoare_comp, safe)
  apply (simp add: hoare_def)
  apply (rule_tac y = "wp x r" in order_trans, simp)
  apply (rule wp_mono2, simp)
  by (rule_tac x = "wp y q" in exI, simp)

lemma (in mbt_algebra) hoare_assume: "hoare p [\<cdot>b] q = (p \<sqinter> b \<le> q)"
  by (simp add: hoare_def wp_assume sup_neg_inf)

lemma hoare_while_mbt:
  "(\<forall> (w::'b::well_founded) r . (\<forall> v . v < w \<longrightarrow> p v \<le> r) \<longrightarrow> hoare ((p w) \<sqinter> b) x r) \<Longrightarrow>
       (\<forall> u . p u \<le> q) \<Longrightarrow> hoare  (p w) (While b do x) (q \<sqinter> -b)"
  apply (unfold while_def)
  apply (rule_tac F = "\<lambda>z. [\<cdot> b ] * x * z \<sqinter> [\<cdot> - b ]" in hoare_fixpoint_mbt)
  apply (simp add: mult.assoc [THEN sym])
  apply (simp add: omega_comp_fix)
  apply (unfold hoare_choice)
  apply safe
  apply (subst hoare_comp_wp)
  apply (subst hoare_assume_comp)
  apply (drule_tac x = w in spec)
  apply (drule_tac x = "wp f (q \<sqinter> - b)" in spec)
  apply (auto simp add: hoare_def) [1]
  apply (auto simp add: hoare_assume)
  apply (rule_tac y = "p w" in order_trans)
  by simp_all

lemma hoare_while_complete_mbt:
  "(\<forall> w::'b::well_founded . hoare ((p w) \<sqinter> b) x (Sup_less p w)) \<Longrightarrow>
       hoare  (Sup (range p)) (While b do x) ((Sup (range p)) \<sqinter> -b)"
  apply (simp add: hoare_Sup del: Sup_image_eq, safe)
  apply (rule hoare_while_mbt)
  apply safe
  apply (drule_tac x = w in spec)
  apply (simp add: hoare_def)
  apply (rule_tac y = "wp x (Sup_less p w)" in order_trans, simp_all)
  apply (rule wp_mono2)
  apply (simp add: Sup_less_def)
  apply (rule Sup_least, auto)
  by (rule SUP_upper, simp)

definition
  "datarefin S S1 D D1 = (D * S \<le> S1 * D1)"

lemma "hoare p S q \<Longrightarrow> datarefin S S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
  apply (simp add: hoare_def datarefin_def)
  apply (simp add: wp_comp [THEN sym] mult.assoc [THEN sym])
  apply (rule_tac y = "wp (D * S) q" in order_trans)
  apply (subst wp_comp)
  apply (rule monoD, simp_all)
  by (rule wp_fun_mono2, simp_all)

lemma "hoare p S q \<Longrightarrow> datarefin ({\<cdot>p} * S) S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
  apply (simp add: hoare_def datarefin_def)
  apply (rule_tac y = "wp (D * {\<cdot>p} * S) q" in order_trans)
  apply (simp add: mult.assoc)
  apply (subst wp_comp)
  apply (rule monoD, simp_all)
  apply (subst wp_comp)
  apply (unfold wp_assert, simp)
  apply (unfold wp_comp [THEN sym])
  apply (rule wp_fun_mono2)
  by (simp add: mult.assoc)

lemma inf_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> x \<sqinter> y \<in> conjunctive"
  apply (subst conjunctive_def, safe)
  apply (simp add: inf_comp conjunctiveD)
  by (metis (hide_lams, no_types) inf_assoc inf_left_commute)

lemma sup_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> x \<squnion> y \<in> disjunctive"
  apply (subst disjunctive_def, safe)
  apply (simp add: sup_comp disjunctiveD)
  by (metis (hide_lams, no_types) sup_assoc sup_left_commute)

lemma assumption_conjuncive [simp]: "[\<cdot>p] \<in> conjunctive"
  by (simp add: assume_def dual_disjunctive assertion_disjunctive)

lemma assumption_disjuncive [simp]: "[\<cdot>p] \<in> disjunctive"
  by (simp add: assume_def dual_conjunctive assertion_conjunctive)

lemma if_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> (If p then x else y) \<in> conjunctive"
  apply (unfold if_stm_def)
  by (simp add: inf_pres_conj comp_pres_conj)

lemma if_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> (If p then x else y) \<in> disjunctive"
  apply (unfold if_assertion)
  by (simp add: sup_pres_disj comp_pres_disj assertion_disjunctive)

lemma while_dual_star: "(While p do (x::'a::mbt_algebra)) = (({\<cdot> p} * x)^\<otimes> * {\<cdot> -p })"
  apply (simp add: while_def)
  apply (rule antisym)
  apply (rule omega_least)
   proof -
     have "([\<cdot> p] * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}) \<sqinter> [\<cdot>-p]) = ({\<cdot> p} * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p})) \<squnion> {\<cdot>-p}"
        apply (unfold mult.assoc)
        by (cut_tac p = p and x = "(x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> -p }))" and y = 1 in if_Assertion_assumption, simp)
     also have "\<dots> = ({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}"
        by (simp add: mult.assoc [THEN sym], simp add: dual_star_comp_fix [THEN sym])
     finally show "[\<cdot> p ] * x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }) \<sqinter> [\<cdot> - p ] \<le> ({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }" by simp
   next
     show "({\<cdot> p } * x)^\<otimes> * {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
       apply (rule dual_star_least)
       proof -
        have "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } = [\<cdot> p ] * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<sqinter> [\<cdot> - p ]"
        apply (unfold mult.assoc)
        by (cut_tac p = p and x = "(x * (([\<cdot>p] * x)^\<omega> * [\<cdot>-p]))" and y = 1 in if_Assertion_assumption, simp)
        also have "... = ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
          apply (simp add: mult.assoc [THEN sym])
          by (metis omega_comp_fix)
        finally show "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ] " by simp
     qed
   qed

lemma while_pres_disj: "(x::'a::mbt_algebra) \<in> disjunctive \<Longrightarrow> (While p do x) \<in> disjunctive"
  apply (unfold while_dual_star)
  apply (rule comp_pres_disj)
  apply (rule dual_star_pres_disj)
  by (rule comp_pres_disj, simp_all add: assertion_disjunctive)

lemma while_pres_conj: "(x::'a::mbt_algebra_fusion) \<in> conjunctive \<Longrightarrow> (While p do x) \<in> conjunctive"
  apply(unfold while_def)
  by (simp add: comp_pres_conj omega_pres_conj)

no_notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf (infixl "\<sqinter>" 70) and
  sup (infixl "\<squnion>" 65) and
  Inf ("\<Sqinter>_" [900] 900) and
  Sup ("\<Squnion>_" [900] 900)

no_syntax (xsymbols)
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

end


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

theory Internalize imports "ZF-Constructible.L_axioms" Eclose_Absolute begin

subsection\<open>Internalized Forms of Data Structuring Operators\<close>

subsubsection\<open>The Formula \<^term>\<open>is_Inl\<close>, Internalized\<close>

(*  is_Inl(M,a,z) == \<exists>zero[M]. empty(M,zero) & pair(M,zero,a,z) *)
definition
  Inl_fm :: "[i,i]=>i" where
    "Inl_fm(a,z) == Exists(And(empty_fm(0), pair_fm(0,succ(a),succ(z))))"

lemma Inl_type [TC]:
     "[| x \<in> nat; z \<in> nat |] ==> Inl_fm(x,z) \<in> formula"
by (simp add: Inl_fm_def)

lemma sats_Inl_fm [simp]:
   "[| x \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, Inl_fm(x,z), env) \<longleftrightarrow> is_Inl(##A, nth(x,env), nth(z,env))"
by (simp add: Inl_fm_def is_Inl_def)

lemma Inl_iff_sats:
      "[| nth(i,env) = x; nth(k,env) = z;
          i \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_Inl(##A, x, z) \<longleftrightarrow> sats(A, Inl_fm(i,k), env)"
by simp

theorem Inl_reflection:
     "REFLECTS[\<lambda>x. is_Inl(L,f(x),h(x)),
               \<lambda>i x. is_Inl(##Lset(i),f(x),h(x))]"
apply (simp only: is_Inl_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Formula \<^term>\<open>is_Inr\<close>, Internalized\<close>

(*  is_Inr(M,a,z) == \<exists>n1[M]. number1(M,n1) & pair(M,n1,a,z) *)
definition
  Inr_fm :: "[i,i]=>i" where
    "Inr_fm(a,z) == Exists(And(number1_fm(0), pair_fm(0,succ(a),succ(z))))"

lemma Inr_type [TC]:
     "[| x \<in> nat; z \<in> nat |] ==> Inr_fm(x,z) \<in> formula"
by (simp add: Inr_fm_def)

lemma sats_Inr_fm [simp]:
   "[| x \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, Inr_fm(x,z), env) \<longleftrightarrow> is_Inr(##A, nth(x,env), nth(z,env))"
by (simp add: Inr_fm_def is_Inr_def)

lemma Inr_iff_sats:
      "[| nth(i,env) = x; nth(k,env) = z;
          i \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_Inr(##A, x, z) \<longleftrightarrow> sats(A, Inr_fm(i,k), env)"
by simp

theorem Inr_reflection:
     "REFLECTS[\<lambda>x. is_Inr(L,f(x),h(x)),
               \<lambda>i x. is_Inr(##Lset(i),f(x),h(x))]"
apply (simp only: is_Inr_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Formula \<^term>\<open>is_Nil\<close>, Internalized\<close>

(* is_Nil(M,xs) == \<exists>zero[M]. empty(M,zero) & is_Inl(M,zero,xs) *)

definition
  Nil_fm :: "i=>i" where
    "Nil_fm(x) == Exists(And(empty_fm(0), Inl_fm(0,succ(x))))"

lemma Nil_type [TC]: "x \<in> nat ==> Nil_fm(x) \<in> formula"
by (simp add: Nil_fm_def)

lemma sats_Nil_fm [simp]:
   "[| x \<in> nat; env \<in> list(A)|]
    ==> sats(A, Nil_fm(x), env) \<longleftrightarrow> is_Nil(##A, nth(x,env))"
by (simp add: Nil_fm_def is_Nil_def)

lemma Nil_iff_sats:
      "[| nth(i,env) = x; i \<in> nat; env \<in> list(A)|]
       ==> is_Nil(##A, x) \<longleftrightarrow> sats(A, Nil_fm(i), env)"
by simp

theorem Nil_reflection:
     "REFLECTS[\<lambda>x. is_Nil(L,f(x)),
               \<lambda>i x. is_Nil(##Lset(i),f(x))]"
apply (simp only: is_Nil_def)
apply (intro FOL_reflections function_reflections Inl_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_Cons\<close>, Internalized\<close>

(*  "is_Cons(M,a,l,Z) == \<exists>p[M]. pair(M,a,l,p) & is_Inr(M,p,Z)" *)
definition
  Cons_fm :: "[i,i,i]=>i" where
    "Cons_fm(a,l,Z) ==
       Exists(And(pair_fm(succ(a),succ(l),0), Inr_fm(0,succ(Z))))"

lemma Cons_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> Cons_fm(x,y,z) \<in> formula"
by (simp add: Cons_fm_def)

lemma sats_Cons_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, Cons_fm(x,y,z), env) \<longleftrightarrow>
       is_Cons(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Cons_fm_def is_Cons_def)

lemma Cons_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==>is_Cons(##A, x, y, z) \<longleftrightarrow> sats(A, Cons_fm(i,j,k), env)"
by simp

theorem Cons_reflection:
     "REFLECTS[\<lambda>x. is_Cons(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Cons(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Cons_def)
apply (intro FOL_reflections pair_reflection Inr_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_quasilist\<close>, Internalized\<close>

(* is_quasilist(M,xs) == is_Nil(M,z) | (\<exists>x[M]. \<exists>l[M]. is_Cons(M,x,l,z))" *)

definition
  quasilist_fm :: "i=>i" where
    "quasilist_fm(x) ==
       Or(Nil_fm(x), Exists(Exists(Cons_fm(1,0,succ(succ(x))))))"

lemma quasilist_type [TC]: "x \<in> nat ==> quasilist_fm(x) \<in> formula"
by (simp add: quasilist_fm_def)

lemma sats_quasilist_fm [simp]:
   "[| x \<in> nat; env \<in> list(A)|]
    ==> sats(A, quasilist_fm(x), env) \<longleftrightarrow> is_quasilist(##A, nth(x,env))"
by (simp add: quasilist_fm_def is_quasilist_def)

lemma quasilist_iff_sats:
      "[| nth(i,env) = x; i \<in> nat; env \<in> list(A)|]
       ==> is_quasilist(##A, x) \<longleftrightarrow> sats(A, quasilist_fm(i), env)"
by simp

theorem quasilist_reflection:
     "REFLECTS[\<lambda>x. is_quasilist(L,f(x)),
               \<lambda>i x. is_quasilist(##Lset(i),f(x))]"
apply (simp only: is_quasilist_def)
apply (intro FOL_reflections Nil_reflection Cons_reflection)
done

subsection\<open>Absoluteness for the Function \<^term>\<open>nth\<close>\<close>

subsubsection\<open>The Formula \<^term>\<open>is_hd\<close>, Internalized\<close>

(*   "is_hd(M,xs,H) ==
       (is_Nil(M,xs) \<longrightarrow> empty(M,H)) &
       (\<forall>x[M]. \<forall>l[M]. ~ is_Cons(M,x,l,xs) | H=x) &
       (is_quasilist(M,xs) | empty(M,H))" *)
definition
  hd_fm :: "[i,i]=>i" where
    "hd_fm(xs,H) ==
       And(Implies(Nil_fm(xs), empty_fm(H)),
           And(Forall(Forall(Or(Neg(Cons_fm(1,0,xs#+2)), Equal(H#+2,1)))),
               Or(quasilist_fm(xs), empty_fm(H))))"

lemma hd_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> hd_fm(x,y) \<in> formula"
by (simp add: hd_fm_def)

lemma sats_hd_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, hd_fm(x,y), env) \<longleftrightarrow> is_hd(##A, nth(x,env), nth(y,env))"
by (simp add: hd_fm_def is_hd_def)

lemma hd_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_hd(##A, x, y) \<longleftrightarrow> sats(A, hd_fm(i,j), env)"
by simp

theorem hd_reflection:
     "REFLECTS[\<lambda>x. is_hd(L,f(x),g(x)),
               \<lambda>i x. is_hd(##Lset(i),f(x),g(x))]"
apply (simp only: is_hd_def)
apply (intro FOL_reflections Nil_reflection Cons_reflection
             quasilist_reflection empty_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_tl\<close>, Internalized\<close>

(*     "is_tl(M,xs,T) ==
       (is_Nil(M,xs) \<longrightarrow> T=xs) &
       (\<forall>x[M]. \<forall>l[M]. ~ is_Cons(M,x,l,xs) | T=l) &
       (is_quasilist(M,xs) | empty(M,T))" *)
definition
  tl_fm :: "[i,i]=>i" where
    "tl_fm(xs,T) ==
       And(Implies(Nil_fm(xs), Equal(T,xs)),
           And(Forall(Forall(Or(Neg(Cons_fm(1,0,xs#+2)), Equal(T#+2,0)))),
               Or(quasilist_fm(xs), empty_fm(T))))"

lemma tl_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> tl_fm(x,y) \<in> formula"
by (simp add: tl_fm_def)

lemma sats_tl_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, tl_fm(x,y), env) \<longleftrightarrow> is_tl(##A, nth(x,env), nth(y,env))"
by (simp add: tl_fm_def is_tl_def)

lemma tl_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_tl(##A, x, y) \<longleftrightarrow> sats(A, tl_fm(i,j), env)"
by simp

theorem tl_reflection:
     "REFLECTS[\<lambda>x. is_tl(L,f(x),g(x)),
               \<lambda>i x. is_tl(##Lset(i),f(x),g(x))]"
apply (simp only: is_tl_def)
apply (intro FOL_reflections Nil_reflection Cons_reflection
             quasilist_reflection empty_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_bool_of_o\<close>\<close>

(*   is_bool_of_o :: "[i=>o, o, i] => o"
   "is_bool_of_o(M,P,z) == (P & number1(M,z)) | (~P & empty(M,z))" *)

text\<open>The formula \<^term>\<open>p\<close> has no free variables.\<close>
definition
  bool_of_o_fm :: "[i, i]=>i" where
  "bool_of_o_fm(p,z) ==
    Or(And(p,number1_fm(z)),
       And(Neg(p),empty_fm(z)))"

lemma is_bool_of_o_type [TC]:
     "[| p \<in> formula; z \<in> nat |] ==> bool_of_o_fm(p,z) \<in> formula"
by (simp add: bool_of_o_fm_def)

lemma sats_bool_of_o_fm:
  assumes p_iff_sats: "P \<longleftrightarrow> sats(A, p, env)"
  shows
      "[|z \<in> nat; env \<in> list(A)|]
       ==> sats(A, bool_of_o_fm(p,z), env) \<longleftrightarrow>
           is_bool_of_o(##A, P, nth(z,env))"
by (simp add: bool_of_o_fm_def is_bool_of_o_def p_iff_sats [THEN iff_sym])

lemma is_bool_of_o_iff_sats:
  "[| P \<longleftrightarrow> sats(A, p, env); nth(k,env) = z; k \<in> nat; env \<in> list(A)|]
   ==> is_bool_of_o(##A, P, z) \<longleftrightarrow> sats(A, bool_of_o_fm(p,k), env)"
by (simp add: sats_bool_of_o_fm)

theorem bool_of_o_reflection:
     "REFLECTS [P(L), \<lambda>i. P(##Lset(i))] ==>
      REFLECTS[\<lambda>x. is_bool_of_o(L, P(L,x), f(x)),
               \<lambda>i x. is_bool_of_o(##Lset(i), P(##Lset(i),x), f(x))]"
apply (simp (no_asm) only: is_bool_of_o_def)
apply (intro FOL_reflections function_reflections, assumption+)
done

subsection\<open>More Internalizations\<close>

subsubsection\<open>The Operator \<^term>\<open>is_lambda\<close>\<close>

text\<open>The two arguments of \<^term>\<open>p\<close> are always 1, 0. Remember that
 \<^term>\<open>p\<close> will be enclosed by three quantifiers.\<close>

(* is_lambda :: "[i=>o, i, [i,i]=>o, i] => o"
    "is_lambda(M, A, is_b, z) ==
       \<forall>p[M]. p \<in> z \<longleftrightarrow>
        (\<exists>u[M]. \<exists>v[M]. u\<in>A & pair(M,u,v,p) & is_b(u,v))" *)
definition
  lambda_fm :: "[i, i, i]=>i" where
  "lambda_fm(p,A,z) ==
    Forall(Iff(Member(0,succ(z)),
            Exists(Exists(And(Member(1,A#+3),
                           And(pair_fm(1,0,2), p))))))"

text\<open>We call \<^term>\<open>p\<close> with arguments x, y by equating them with
  the corresponding quantified variables with de Bruijn indices 1, 0.\<close>

lemma is_lambda_type [TC]:
     "[| p \<in> formula; x \<in> nat; y \<in> nat |]
      ==> lambda_fm(p,x,y) \<in> formula"
by (simp add: lambda_fm_def)

lemma sats_lambda_fm:
  assumes is_b_iff_sats:
      "!!a0 a1 a2.
        [|a0\<in>A; a1\<in>A; a2\<in>A|]
        ==> is_b(a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,env))))"
  shows
      "[|x \<in> nat; y \<in> nat; env \<in> list(A)|]
       ==> sats(A, lambda_fm(p,x,y), env) \<longleftrightarrow>
           is_lambda(##A, nth(x,env), is_b, nth(y,env))"
by (simp add: lambda_fm_def is_lambda_def is_b_iff_sats [THEN iff_sym])

theorem is_lambda_reflection:
  assumes is_b_reflection:
    "!!f g h. REFLECTS[\<lambda>x. is_b(L, f(x), g(x), h(x)),
                     \<lambda>i x. is_b(##Lset(i), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_lambda(L, A(x), is_b(L,x), f(x)),
               \<lambda>i x. is_lambda(##Lset(i), A(x), is_b(##Lset(i),x), f(x))]"
apply (simp (no_asm_use) only: is_lambda_def)
apply (intro FOL_reflections is_b_reflection pair_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_Member\<close>, Internalized\<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)" *)
definition
  Member_fm :: "[i,i,i]=>i" where
    "Member_fm(x,y,Z) ==
       Exists(Exists(And(pair_fm(x#+2,y#+2,1),
                      And(Inl_fm(1,0), Inl_fm(0,Z#+2)))))"

lemma is_Member_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> Member_fm(x,y,z) \<in> formula"
by (simp add: Member_fm_def)

lemma sats_Member_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, Member_fm(x,y,z), env) \<longleftrightarrow>
        is_Member(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Member_fm_def is_Member_def)

lemma Member_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_Member(##A, x, y, z) \<longleftrightarrow> sats(A, Member_fm(i,j,k), env)"
by (simp)

theorem Member_reflection:
     "REFLECTS[\<lambda>x. is_Member(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Member(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Member_def)
apply (intro FOL_reflections pair_reflection Inl_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_Equal\<close>, Internalized\<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)" *)
definition
  Equal_fm :: "[i,i,i]=>i" where
    "Equal_fm(x,y,Z) ==
       Exists(Exists(And(pair_fm(x#+2,y#+2,1),
                      And(Inr_fm(1,0), Inl_fm(0,Z#+2)))))"

lemma is_Equal_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> Equal_fm(x,y,z) \<in> formula"
by (simp add: Equal_fm_def)

lemma sats_Equal_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, Equal_fm(x,y,z), env) \<longleftrightarrow>
        is_Equal(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Equal_fm_def is_Equal_def)

lemma Equal_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_Equal(##A, x, y, z) \<longleftrightarrow> sats(A, Equal_fm(i,j,k), env)"
by (simp)

theorem Equal_reflection:
     "REFLECTS[\<lambda>x. is_Equal(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Equal(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Equal_def)
apply (intro FOL_reflections pair_reflection Inl_reflection Inr_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_Nand\<close>, Internalized\<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)" *)
definition
  Nand_fm :: "[i,i,i]=>i" where
    "Nand_fm(x,y,Z) ==
       Exists(Exists(And(pair_fm(x#+2,y#+2,1),
                      And(Inl_fm(1,0), Inr_fm(0,Z#+2)))))"

lemma is_Nand_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> Nand_fm(x,y,z) \<in> formula"
by (simp add: Nand_fm_def)

lemma sats_Nand_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, Nand_fm(x,y,z), env) \<longleftrightarrow>
        is_Nand(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Nand_fm_def is_Nand_def)

lemma Nand_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_Nand(##A, x, y, z) \<longleftrightarrow> sats(A, Nand_fm(i,j,k), env)"
by (simp)

theorem Nand_reflection:
     "REFLECTS[\<lambda>x. is_Nand(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Nand(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Nand_def)
apply (intro FOL_reflections pair_reflection Inl_reflection Inr_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_Forall\<close>, Internalized\<close>

(* "is_Forall(M,p,Z) == \<exists>u[M]. is_Inr(M,p,u) & is_Inr(M,u,Z)" *)
definition
  Forall_fm :: "[i,i]=>i" where
    "Forall_fm(x,Z) ==
       Exists(And(Inr_fm(succ(x),0), Inr_fm(0,succ(Z))))"

lemma is_Forall_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> Forall_fm(x,y) \<in> formula"
by (simp add: Forall_fm_def)

lemma sats_Forall_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, Forall_fm(x,y), env) \<longleftrightarrow>
        is_Forall(##A, nth(x,env), nth(y,env))"
by (simp add: Forall_fm_def is_Forall_def)

lemma Forall_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_Forall(##A, x, y) \<longleftrightarrow> sats(A, Forall_fm(i,j), env)"
by (simp)

theorem Forall_reflection:
     "REFLECTS[\<lambda>x. is_Forall(L,f(x),g(x)),
               \<lambda>i x. is_Forall(##Lset(i),f(x),g(x))]"
apply (simp only: is_Forall_def)
apply (intro FOL_reflections pair_reflection Inr_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_and\<close>, Internalized\<close>

(* is_and(M,a,b,z) == (number1(M,a)  & z=b) |
                       (~number1(M,a) & empty(M,z)) *)
definition
  and_fm :: "[i,i,i]=>i" where
    "and_fm(a,b,z) ==
       Or(And(number1_fm(a), Equal(z,b)),
          And(Neg(number1_fm(a)),empty_fm(z)))"

lemma is_and_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> and_fm(x,y,z) \<in> formula"
by (simp add: and_fm_def)

lemma sats_and_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, and_fm(x,y,z), env) \<longleftrightarrow>
        is_and(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: and_fm_def is_and_def)

lemma is_and_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_and(##A, x, y, z) \<longleftrightarrow> sats(A, and_fm(i,j,k), env)"
by simp

theorem is_and_reflection:
     "REFLECTS[\<lambda>x. is_and(L,f(x),g(x),h(x)),
               \<lambda>i x. is_and(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_and_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Operator \<^term>\<open>is_or\<close>, Internalized\<close>

(* is_or(M,a,b,z) == (number1(M,a)  & number1(M,z)) |
                     (~number1(M,a) & z=b) *)

definition
  or_fm :: "[i,i,i]=>i" where
    "or_fm(a,b,z) ==
       Or(And(number1_fm(a), number1_fm(z)),
          And(Neg(number1_fm(a)), Equal(z,b)))"

lemma is_or_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> or_fm(x,y,z) \<in> formula"
by (simp add: or_fm_def)

lemma sats_or_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, or_fm(x,y,z), env) \<longleftrightarrow>
        is_or(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: or_fm_def is_or_def)

lemma is_or_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_or(##A, x, y, z) \<longleftrightarrow> sats(A, or_fm(i,j,k), env)"
by simp

theorem is_or_reflection:
     "REFLECTS[\<lambda>x. is_or(L,f(x),g(x),h(x)),
               \<lambda>i x. is_or(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_or_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Operator \<^term>\<open>is_not\<close>, Internalized\<close>

(* is_not(M,a,z) == (number1(M,a)  & empty(M,z)) |
                     (~number1(M,a) & number1(M,z)) *)
definition
  not_fm :: "[i,i]=>i" where
    "not_fm(a,z) ==
       Or(And(number1_fm(a), empty_fm(z)),
          And(Neg(number1_fm(a)), number1_fm(z)))"

lemma is_not_type [TC]:
     "[| x \<in> nat; z \<in> nat |] ==> not_fm(x,z) \<in> formula"
by (simp add: not_fm_def)

lemma sats_is_not_fm [simp]:
   "[| x \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, not_fm(x,z), env) \<longleftrightarrow> is_not(##A, nth(x,env), nth(z,env))"
by (simp add: not_fm_def is_not_def)

lemma is_not_iff_sats:
      "[| nth(i,env) = x; nth(k,env) = z;
          i \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_not(##A, x, z) \<longleftrightarrow> sats(A, not_fm(i,k), env)"
by simp

theorem is_not_reflection:
     "REFLECTS[\<lambda>x. is_not(L,f(x),g(x)),
               \<lambda>i x. is_not(##Lset(i),f(x),g(x))]"
apply (simp only: is_not_def)
apply (intro FOL_reflections function_reflections)
done

lemmas extra_reflections =
    Inl_reflection Inr_reflection Nil_reflection Cons_reflection
    quasilist_reflection hd_reflection tl_reflection bool_of_o_reflection
    is_lambda_reflection Member_reflection Equal_reflection Nand_reflection
    Forall_reflection is_and_reflection is_or_reflection is_not_reflection

subsection\<open>Well-Founded Recursion!\<close>

subsubsection\<open>The Operator \<^term>\<open>M_is_recfun\<close>\<close>

text\<open>Alternative definition, minimizing nesting of quantifiers around MH\<close>
lemma M_is_recfun_iff:
   "M_is_recfun(M,MH,r,a,f) \<longleftrightarrow>
    (\<forall>z[M]. z \<in> f \<longleftrightarrow>
     (\<exists>x[M]. \<exists>f_r_sx[M]. \<exists>y[M].
             MH(x, f_r_sx, y) & pair(M,x,y,z) &
             (\<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M].
                pair(M,x,a,xa) & upair(M,x,x,sx) &
               pre_image(M,r,sx,r_sx) & restriction(M,f,r_sx,f_r_sx) &
               xa \<in> r)))"
apply (simp add: M_is_recfun_def)
apply (rule rall_cong, blast)
done

(* M_is_recfun :: "[i=>o, [i,i,i]=>o, i, i, i] => o"
   "M_is_recfun(M,MH,r,a,f) ==
     \<forall>z[M]. z \<in> f \<longleftrightarrow>
               2      1           0
new def     (\<exists>x[M]. \<exists>f_r_sx[M]. \<exists>y[M].
             MH(x, f_r_sx, y) & pair(M,x,y,z) &
             (\<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M].
                pair(M,x,a,xa) & upair(M,x,x,sx) &
               pre_image(M,r,sx,r_sx) & restriction(M,f,r_sx,f_r_sx) &
               xa \<in> r)"
*)

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0 and z\<close>
definition
  is_recfun_fm :: "[i, i, i, i]=>i" where
  "is_recfun_fm(p,r,a,f) ==
   Forall(Iff(Member(0,succ(f)),
    Exists(Exists(Exists(
     And(p,
      And(pair_fm(2,0,3),
       Exists(Exists(Exists(
        And(pair_fm(5,a#+7,2),
         And(upair_fm(5,5,1),
          And(pre_image_fm(r#+7,1,0),
           And(restriction_fm(f#+7,0,4), Member(2,r#+7)))))))))))))))"

lemma is_recfun_type [TC]:
     "[| p \<in> formula; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> is_recfun_fm(p,x,y,z) \<in> formula"
by (simp add: is_recfun_fm_def)

lemma sats_is_recfun_fm:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,env)))))"
  shows
      "[|x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
       ==> sats(A, is_recfun_fm(p,x,y,z), env) \<longleftrightarrow>
           M_is_recfun(##A, MH, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: is_recfun_fm_def M_is_recfun_iff MH_iff_sats [THEN iff_sym])

lemma is_recfun_iff_sats:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,env)))))"
  shows
  "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
   ==> M_is_recfun(##A, MH, x, y, z) \<longleftrightarrow> sats(A, is_recfun_fm(p,i,j,k), env)"
by (simp add: sats_is_recfun_fm [OF MH_iff_sats])

text\<open>The additional variable in the premise, namely \<^term>\<open>f'\<close>, is essential.
It lets \<^term>\<open>MH\<close> depend upon \<^term>\<open>x\<close>, which seems often necessary.
The same thing occurs in \<open>is_wfrec_reflection\<close>.\<close>
theorem is_recfun_reflection:
  assumes MH_reflection:
    "!!f' f g h. REFLECTS[\<lambda>x. MH(L, f'(x), f(x), g(x), h(x)),
                     \<lambda>i x. MH(##Lset(i), f'(x), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. M_is_recfun(L, MH(L,x), f(x), g(x), h(x)),
             \<lambda>i x. M_is_recfun(##Lset(i), MH(##Lset(i),x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: M_is_recfun_def)
apply (intro FOL_reflections function_reflections
             restriction_reflection MH_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_wfrec\<close>\<close>

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0;
      \<^term>\<open>p\<close> is enclosed by 5 quantifiers.\<close>

(* is_wfrec :: "[i=>o, i, [i,i,i]=>o, i, i] => o"
    "is_wfrec(M,MH,r,a,z) ==
      \<exists>f[M]. M_is_recfun(M,MH,r,a,f) & MH(a,f,z)" *)
definition
  is_wfrec_fm :: "[i, i, i, i]=>i" where
  "is_wfrec_fm(p,r,a,z) ==
    Exists(And(is_recfun_fm(p, succ(r), succ(a), 0),
           Exists(Exists(Exists(Exists(
             And(Equal(2,a#+5), And(Equal(1,4), And(Equal(0,z#+5), p)))))))))"

text\<open>We call \<^term>\<open>p\<close> with arguments a, f, z by equating them with
  the corresponding quantified variables with de Bruijn indices 2, 1, 0.\<close>

text\<open>There's an additional existential quantifier to ensure that the
      environments in both calls to MH have the same length.\<close>

lemma is_wfrec_type [TC]:
     "[| p \<in> formula; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> is_wfrec_fm(p,x,y,z) \<in> formula"
by (simp add: is_wfrec_fm_def)

lemma sats_is_wfrec_fm:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
      "[|x \<in> nat; y < length(env); z < length(env); env \<in> list(A)|]
       ==> sats(A, is_wfrec_fm(p,x,y,z), env) \<longleftrightarrow>
           is_wfrec(##A, MH, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule lt_length_in_nat, assumption)
apply (simp add: is_wfrec_fm_def sats_is_recfun_fm is_wfrec_def MH_iff_sats [THEN iff_sym], blast)
done

lemma is_wfrec_iff_sats:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
  "[|nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j < length(env); k < length(env); env \<in> list(A)|]
   ==> is_wfrec(##A, MH, x, y, z) \<longleftrightarrow> sats(A, is_wfrec_fm(p,i,j,k), env)"
by (simp add: sats_is_wfrec_fm [OF MH_iff_sats])

theorem is_wfrec_reflection:
  assumes MH_reflection:
    "!!f' f g h. REFLECTS[\<lambda>x. MH(L, f'(x), f(x), g(x), h(x)),
                     \<lambda>i x. MH(##Lset(i), f'(x), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_wfrec(L, MH(L,x), f(x), g(x), h(x)),
               \<lambda>i x. is_wfrec(##Lset(i), MH(##Lset(i),x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_wfrec_def)
apply (intro FOL_reflections MH_reflection is_recfun_reflection)
done

subsection\<open>For Datatypes\<close>

subsubsection\<open>Binary Products, Internalized\<close>

definition
  cartprod_fm :: "[i,i,i]=>i" where
(* "cartprod(M,A,B,z) ==
        \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A & (\<exists>y[M]. y\<in>B & pair(M,x,y,u)))" *)
    "cartprod_fm(A,B,z) ==
       Forall(Iff(Member(0,succ(z)),
                  Exists(And(Member(0,succ(succ(A))),
                         Exists(And(Member(0,succ(succ(succ(B)))),
                                    pair_fm(1,0,2)))))))"

lemma cartprod_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> cartprod_fm(x,y,z) \<in> formula"
by (simp add: cartprod_fm_def)

lemma sats_cartprod_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, cartprod_fm(x,y,z), env) \<longleftrightarrow>
        cartprod(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: cartprod_fm_def cartprod_def)

lemma cartprod_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> cartprod(##A, x, y, z) \<longleftrightarrow> sats(A, cartprod_fm(i,j,k), env)"
by (simp)

theorem cartprod_reflection:
     "REFLECTS[\<lambda>x. cartprod(L,f(x),g(x),h(x)),
               \<lambda>i x. cartprod(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: cartprod_def)
apply (intro FOL_reflections pair_reflection)
done

subsubsection\<open>Binary Sums, Internalized\<close>

(* "is_sum(M,A,B,Z) ==
       \<exists>A0[M]. \<exists>n1[M]. \<exists>s1[M]. \<exists>B1[M].
         3      2       1        0
       number1(M,n1) & cartprod(M,n1,A,A0) & upair(M,n1,n1,s1) &
       cartprod(M,s1,B,B1) & union(M,A0,B1,Z)"  *)
definition
  sum_fm :: "[i,i,i]=>i" where
    "sum_fm(A,B,Z) ==
       Exists(Exists(Exists(Exists(
        And(number1_fm(2),
            And(cartprod_fm(2,A#+4,3),
                And(upair_fm(2,2,1),
                    And(cartprod_fm(1,B#+4,0), union_fm(3,0,Z#+4)))))))))"

lemma sum_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> sum_fm(x,y,z) \<in> formula"
by (simp add: sum_fm_def)

lemma sats_sum_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, sum_fm(x,y,z), env) \<longleftrightarrow>
        is_sum(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: sum_fm_def is_sum_def)

lemma sum_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_sum(##A, x, y, z) \<longleftrightarrow> sats(A, sum_fm(i,j,k), env)"
by simp

theorem sum_reflection:
     "REFLECTS[\<lambda>x. is_sum(L,f(x),g(x),h(x)),
               \<lambda>i x. is_sum(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_sum_def)
apply (intro FOL_reflections function_reflections cartprod_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>quasinat\<close>\<close>

(* "is_quasinat(M,z) == empty(M,z) | (\<exists>m[M]. successor(M,m,z))" *)
definition
  quasinat_fm :: "i=>i" where
    "quasinat_fm(z) == Or(empty_fm(z), Exists(succ_fm(0,succ(z))))"

lemma quasinat_type [TC]:
     "x \<in> nat ==> quasinat_fm(x) \<in> formula"
by (simp add: quasinat_fm_def)

lemma sats_quasinat_fm [simp]:
   "[| x \<in> nat; env \<in> list(A)|]
    ==> sats(A, quasinat_fm(x), env) \<longleftrightarrow> is_quasinat(##A, nth(x,env))"
by (simp add: quasinat_fm_def is_quasinat_def)

lemma quasinat_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; env \<in> list(A)|]
       ==> is_quasinat(##A, x) \<longleftrightarrow> sats(A, quasinat_fm(i), env)"
by simp

theorem quasinat_reflection:
     "REFLECTS[\<lambda>x. is_quasinat(L,f(x)),
               \<lambda>i x. is_quasinat(##Lset(i),f(x))]"
apply (simp only: is_quasinat_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Operator \<^term>\<open>is_nat_case\<close>\<close>
text\<open>I could not get it to work with the more natural assumption that
 \<^term>\<open>is_b\<close> takes two arguments.  Instead it must be a formula where 1 and 0
 stand for \<^term>\<open>m\<close> and \<^term>\<open>b\<close>, respectively.\<close>

(* is_nat_case :: "[i=>o, i, [i,i]=>o, i, i] => o"
    "is_nat_case(M, a, is_b, k, z) ==
       (empty(M,k) \<longrightarrow> z=a) &
       (\<forall>m[M]. successor(M,m,k) \<longrightarrow> is_b(m,z)) &
       (is_quasinat(M,k) | empty(M,z))" *)
text\<open>The formula \<^term>\<open>is_b\<close> has free variables 1 and 0.\<close>
definition
  is_nat_case_fm :: "[i, i, i, i]=>i" where
 "is_nat_case_fm(a,is_b,k,z) ==
    And(Implies(empty_fm(k), Equal(z,a)),
        And(Forall(Implies(succ_fm(0,succ(k)),
                   Forall(Implies(Equal(0,succ(succ(z))), is_b)))),
            Or(quasinat_fm(k), empty_fm(z))))"

lemma is_nat_case_type [TC]:
     "[| is_b \<in> formula;
         x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> is_nat_case_fm(x,is_b,y,z) \<in> formula"
by (simp add: is_nat_case_fm_def)

lemma sats_is_nat_case_fm:
  assumes is_b_iff_sats:
      "!!a. a \<in> A ==> is_b(a,nth(z, env)) \<longleftrightarrow>
                      sats(A, p, Cons(nth(z,env), Cons(a, env)))"
  shows
      "[|x \<in> nat; y \<in> nat; z < length(env); env \<in> list(A)|]
       ==> sats(A, is_nat_case_fm(x,p,y,z), env) \<longleftrightarrow>
           is_nat_case(##A, nth(x,env), is_b, nth(y,env), nth(z,env))"
apply (frule lt_length_in_nat, assumption)
apply (simp add: is_nat_case_fm_def is_nat_case_def is_b_iff_sats [THEN iff_sym])
done

lemma is_nat_case_iff_sats:
  "[| (!!a. a \<in> A ==> is_b(a,z) \<longleftrightarrow>
                      sats(A, p, Cons(z, Cons(a,env))));
      nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j \<in> nat; k < length(env); env \<in> list(A)|]
   ==> is_nat_case(##A, x, is_b, y, z) \<longleftrightarrow> sats(A, is_nat_case_fm(i,p,j,k), env)"
by (simp add: sats_is_nat_case_fm [of A is_b])

text\<open>The second argument of \<^term>\<open>is_b\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.  Without this
  argument, we cannot prove reflection for \<^term>\<open>iterates_MH\<close>.\<close>
theorem is_nat_case_reflection:
  assumes is_b_reflection:
    "!!h f g. REFLECTS[\<lambda>x. is_b(L, h(x), f(x), g(x)),
                     \<lambda>i x. is_b(##Lset(i), h(x), f(x), g(x))]"
  shows "REFLECTS[\<lambda>x. is_nat_case(L, f(x), is_b(L,x), g(x), h(x)),
               \<lambda>i x. is_nat_case(##Lset(i), f(x), is_b(##Lset(i), x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_nat_case_def)
apply (intro FOL_reflections function_reflections
             restriction_reflection is_b_reflection quasinat_reflection)
done

subsection\<open>The Operator \<^term>\<open>iterates_MH\<close>, Needed for Iteration\<close>

(*  iterates_MH :: "[i=>o, [i,i]=>o, i, i, i, i] => o"
   "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
  iterates_MH_fm :: "[i, i, i, i, i]=>i" where
 "iterates_MH_fm(isF,v,n,g,z) ==
    is_nat_case_fm(v,
      Exists(And(fun_apply_fm(succ(succ(succ(g))),2,0),
                     Forall(Implies(Equal(0,2), isF)))),
      n, z)"

lemma iterates_MH_type [TC]:
     "[| p \<in> formula;
         v \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> iterates_MH_fm(p,v,x,y,z) \<in> formula"
by (simp add: iterates_MH_fm_def)

lemma sats_iterates_MH_fm:
  assumes is_F_iff_sats:
      "!!a b c d. [| a \<in> A; b \<in> A; c \<in> A; d \<in> A|]
              ==> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d,env)))))"
  shows
      "[|v \<in> nat; x \<in> nat; y \<in> nat; z < length(env); env \<in> list(A)|]
       ==> sats(A, iterates_MH_fm(p,v,x,y,z), env) \<longleftrightarrow>
           iterates_MH(##A, is_F, nth(v,env), nth(x,env), nth(y,env), nth(z,env))"
apply (frule lt_length_in_nat, assumption)
apply (simp add: iterates_MH_fm_def iterates_MH_def sats_is_nat_case_fm
              is_F_iff_sats [symmetric])
apply (rule is_nat_case_cong)
apply (simp_all add: setclass_def)
done

lemma iterates_MH_iff_sats:
  assumes is_F_iff_sats:
      "!!a b c d. [| a \<in> A; b \<in> A; c \<in> A; d \<in> A|]
              ==> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d,env)))))"
  shows
  "[| nth(i',env) = v; nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i' \<in> nat; i \<in> nat; j \<in> nat; k < length(env); env \<in> list(A)|]
   ==> iterates_MH(##A, is_F, v, x, y, z) \<longleftrightarrow>
       sats(A, iterates_MH_fm(p,i',i,j,k), env)"
by (simp add: sats_iterates_MH_fm [OF is_F_iff_sats])

text\<open>The second argument of \<^term>\<open>p\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.  Without this
  argument, we cannot prove reflection for \<^term>\<open>list_N\<close>.\<close>
theorem iterates_MH_reflection:
  assumes p_reflection:
    "!!f g h. REFLECTS[\<lambda>x. p(L, h(x), f(x), g(x)),
                     \<lambda>i x. p(##Lset(i), h(x), f(x), g(x))]"
 shows "REFLECTS[\<lambda>x. iterates_MH(L, p(L,x), e(x), f(x), g(x), h(x)),
               \<lambda>i x. iterates_MH(##Lset(i), p(##Lset(i),x), e(x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: iterates_MH_def)
apply (intro FOL_reflections function_reflections is_nat_case_reflection
             restriction_reflection p_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_iterates\<close>\<close>

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0;
      \<^term>\<open>p\<close> is enclosed by 9 (??) quantifiers.\<close>

(*    "is_iterates(M,isF,v,n,Z) ==
      \<exists>sn[M]. \<exists>msn[M]. successor(M,n,sn) & membership(M,sn,msn) &
       1       0       is_wfrec(M, iterates_MH(M,isF,v), msn, n, Z)"*)

definition
  is_iterates_fm :: "[i, i, i, i]=>i" where
  "is_iterates_fm(p,v,n,Z) ==
     Exists(Exists(
      And(succ_fm(n#+2,1),
       And(Memrel_fm(1,0),
              is_wfrec_fm(iterates_MH_fm(p, v#+7, 2, 1, 0),
                          0, n#+2, Z#+2)))))"

text\<open>We call \<^term>\<open>p\<close> with arguments a, f, z by equating them with
  the corresponding quantified variables with de Bruijn indices 2, 1, 0.\<close>

lemma is_iterates_type [TC]:
     "[| p \<in> formula; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> is_iterates_fm(p,x,y,z) \<in> formula"
by (simp add: is_iterates_fm_def)

lemma sats_is_iterates_fm:
  assumes is_F_iff_sats:
      "!!a b c d e f g h i j k.
              [| a \<in> A; b \<in> A; c \<in> A; d \<in> A; e \<in> A; f \<in> A;
                 g \<in> A; h \<in> A; i \<in> A; j \<in> A; k \<in> A|]
              ==> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d, Cons(e, Cons(f,
                      Cons(g, Cons(h, Cons(i, Cons(j, Cons(k, env))))))))))))"
  shows
      "[|x \<in> nat; y < length(env); z < length(env); env \<in> list(A)|]
       ==> sats(A, is_iterates_fm(p,x,y,z), env) \<longleftrightarrow>
           is_iterates(##A, is_F, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule lt_length_in_nat, assumption)
apply (simp add: is_iterates_fm_def is_iterates_def sats_is_nat_case_fm
              is_F_iff_sats [symmetric] sats_is_wfrec_fm sats_iterates_MH_fm)
done

lemma is_iterates_iff_sats:
  assumes is_F_iff_sats:
      "!!a b c d e f g h i j k.
              [| a \<in> A; b \<in> A; c \<in> A; d \<in> A; e \<in> A; f \<in> A;
                 g \<in> A; h \<in> A; i \<in> A; j \<in> A; k \<in> A|]
              ==> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d, Cons(e, Cons(f,
                      Cons(g, Cons(h, Cons(i, Cons(j, Cons(k, env))))))))))))"
  shows
  "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j < length(env); k < length(env); env \<in> list(A)|]
   ==> is_iterates(##A, is_F, x, y, z) \<longleftrightarrow>
       sats(A, is_iterates_fm(p,i,j,k), env)"
by (simp add: sats_is_iterates_fm [OF is_F_iff_sats])

text\<open>The second argument of \<^term>\<open>p\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.  Without this
  argument, we cannot prove reflection for \<^term>\<open>list_N\<close>.\<close>
theorem is_iterates_reflection:
  assumes p_reflection:
    "!!f g h. REFLECTS[\<lambda>x. p(L, h(x), f(x), g(x)),
                     \<lambda>i x. p(##Lset(i), h(x), f(x), g(x))]"
 shows "REFLECTS[\<lambda>x. is_iterates(L, p(L,x), f(x), g(x), h(x)),
               \<lambda>i x. is_iterates(##Lset(i), p(##Lset(i),x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_iterates_def)
apply (intro FOL_reflections function_reflections p_reflection
             is_wfrec_reflection iterates_MH_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_eclose_n\<close>, Internalized\<close>

(* is_eclose_n(M,A,n,Z) == is_iterates(M, big_union(M), A, n, Z) *)

definition
  eclose_n_fm :: "[i,i,i]=>i" where
  "eclose_n_fm(A,n,Z) == is_iterates_fm(big_union_fm(1,0), A, n, Z)"

lemma eclose_n_fm_type [TC]:
 "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> eclose_n_fm(x,y,z) \<in> formula"
by (simp add: eclose_n_fm_def)

lemma sats_eclose_n_fm [simp]:
   "[| x \<in> nat; y < length(env); z < length(env); env \<in> list(A)|]
    ==> sats(A, eclose_n_fm(x,y,z), env) \<longleftrightarrow>
        is_eclose_n(##A, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: eclose_n_fm_def is_eclose_n_def
                 sats_is_iterates_fm)
done

lemma eclose_n_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j < length(env); k < length(env); env \<in> list(A)|]
       ==> is_eclose_n(##A, x, y, z) \<longleftrightarrow> sats(A, eclose_n_fm(i,j,k), env)"
by (simp)

theorem eclose_n_reflection:
     "REFLECTS[\<lambda>x. is_eclose_n(L, f(x), g(x), h(x)),
               \<lambda>i x. is_eclose_n(##Lset(i), f(x), g(x), h(x))]"
apply (simp only: is_eclose_n_def)
apply (intro FOL_reflections function_reflections is_iterates_reflection)
done

subsubsection\<open>Membership in \<^term>\<open>eclose(A)\<close>\<close>

(* 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
  mem_eclose_fm :: "[i,i]=>i" where
    "mem_eclose_fm(x,y) ==
       Exists(Exists(
         And(finite_ordinal_fm(1),
           And(eclose_n_fm(x#+2,1,0), Member(y#+2,0)))))"

lemma mem_eclose_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> mem_eclose_fm(x,y) \<in> formula"
by (simp add: mem_eclose_fm_def)

lemma sats_mem_eclose_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, mem_eclose_fm(x,y), env) \<longleftrightarrow> mem_eclose(##A, nth(x,env), nth(y,env))"
by (simp add: mem_eclose_fm_def mem_eclose_def)

lemma mem_eclose_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> mem_eclose(##A, x, y) \<longleftrightarrow> sats(A, mem_eclose_fm(i,j), env)"
by simp

theorem mem_eclose_reflection:
     "REFLECTS[\<lambda>x. mem_eclose(L,f(x),g(x)),
               \<lambda>i x. mem_eclose(##Lset(i),f(x),g(x))]"
apply (simp only: mem_eclose_def)
apply (intro FOL_reflections finite_ordinal_reflection eclose_n_reflection)
done

subsubsection\<open>The Predicate ``Is \<^term>\<open>eclose(A)\<close>''\<close>

(* is_eclose(M,A,Z) == \<forall>l[M]. l \<in> Z \<longleftrightarrow> mem_eclose(M,A,l) *)
definition
  is_eclose_fm :: "[i,i]=>i" where
    "is_eclose_fm(A,Z) ==
       Forall(Iff(Member(0,succ(Z)), mem_eclose_fm(succ(A),0)))"

lemma is_eclose_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> is_eclose_fm(x,y) \<in> formula"
by (simp add: is_eclose_fm_def)

lemma sats_is_eclose_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, is_eclose_fm(x,y), env) \<longleftrightarrow> is_eclose(##A, nth(x,env), nth(y,env))"
by (simp add: is_eclose_fm_def is_eclose_def)

lemma is_eclose_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_eclose(##A, x, y) \<longleftrightarrow> sats(A, is_eclose_fm(i,j), env)"
by simp

theorem is_eclose_reflection:
     "REFLECTS[\<lambda>x. is_eclose(L,f(x),g(x)),
               \<lambda>i x. is_eclose(##Lset(i),f(x),g(x))]"
apply (simp only: is_eclose_def)
apply (intro FOL_reflections mem_eclose_reflection)
done

subsubsection\<open>The List Functor, Internalized\<close>

definition
  list_functor_fm :: "[i,i,i]=>i" 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)" *)
    "list_functor_fm(A,X,Z) ==
       Exists(Exists(
        And(number1_fm(1),
            And(cartprod_fm(A#+2,X#+2,0), sum_fm(1,0,Z#+2)))))"

lemma list_functor_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> list_functor_fm(x,y,z) \<in> formula"
by (simp add: list_functor_fm_def)

lemma sats_list_functor_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, list_functor_fm(x,y,z), env) \<longleftrightarrow>
        is_list_functor(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: list_functor_fm_def is_list_functor_def)

lemma list_functor_iff_sats:
  "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
   ==> is_list_functor(##A, x, y, z) \<longleftrightarrow> sats(A, list_functor_fm(i,j,k), env)"
by simp

theorem list_functor_reflection:
     "REFLECTS[\<lambda>x. is_list_functor(L,f(x),g(x),h(x)),
               \<lambda>i x. is_list_functor(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_list_functor_def)
apply (intro FOL_reflections number1_reflection
             cartprod_reflection sum_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_list_N\<close>, Internalized\<close>

(* "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
  list_N_fm :: "[i,i,i]=>i" where
  "list_N_fm(A,n,Z) ==
     Exists(
       And(empty_fm(0),
           is_iterates_fm(list_functor_fm(A#+9#+3,1,0), 0, n#+1, Z#+1)))"

lemma list_N_fm_type [TC]:
 "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> list_N_fm(x,y,z) \<in> formula"
by (simp add: list_N_fm_def)

lemma sats_list_N_fm [simp]:
   "[| x \<in> nat; y < length(env); z < length(env); env \<in> list(A)|]
    ==> sats(A, list_N_fm(x,y,z), env) \<longleftrightarrow>
        is_list_N(##A, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: list_N_fm_def is_list_N_def sats_is_iterates_fm)
done

lemma list_N_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j < length(env); k < length(env); env \<in> list(A)|]
       ==> is_list_N(##A, x, y, z) \<longleftrightarrow> sats(A, list_N_fm(i,j,k), env)"
by (simp)

theorem list_N_reflection:
     "REFLECTS[\<lambda>x. is_list_N(L, f(x), g(x), h(x)),
               \<lambda>i x. is_list_N(##Lset(i), f(x), g(x), h(x))]"
apply (simp only: is_list_N_def)
apply (intro FOL_reflections function_reflections
             is_iterates_reflection list_functor_reflection)
done

subsubsection\<open>The Predicate ``Is A List''\<close>

(* 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
  mem_list_fm :: "[i,i]=>i" where
    "mem_list_fm(x,y) ==
       Exists(Exists(
         And(finite_ordinal_fm(1),
           And(list_N_fm(x#+2,1,0), Member(y#+2,0)))))"

lemma mem_list_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> mem_list_fm(x,y) \<in> formula"
by (simp add: mem_list_fm_def)

lemma sats_mem_list_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, mem_list_fm(x,y), env) \<longleftrightarrow> mem_list(##A, nth(x,env), nth(y,env))"
by (simp add: mem_list_fm_def mem_list_def)

lemma mem_list_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> mem_list(##A, x, y) \<longleftrightarrow> sats(A, mem_list_fm(i,j), env)"
by simp

theorem mem_list_reflection:
     "REFLECTS[\<lambda>x. mem_list(L,f(x),g(x)),
               \<lambda>i x. mem_list(##Lset(i),f(x),g(x))]"
apply (simp only: mem_list_def)
apply (intro FOL_reflections finite_ordinal_reflection list_N_reflection)
done

subsubsection\<open>The Predicate ``Is \<^term>\<open>list(A)\<close>''\<close>

(* is_list(M,A,Z) == \<forall>l[M]. l \<in> Z \<longleftrightarrow> mem_list(M,A,l) *)
definition
  is_list_fm :: "[i,i]=>i" where
    "is_list_fm(A,Z) ==
       Forall(Iff(Member(0,succ(Z)), mem_list_fm(succ(A),0)))"

lemma is_list_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> is_list_fm(x,y) \<in> formula"
by (simp add: is_list_fm_def)

lemma sats_is_list_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, is_list_fm(x,y), env) \<longleftrightarrow> is_list(##A, nth(x,env), nth(y,env))"
by (simp add: is_list_fm_def is_list_def)

lemma is_list_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_list(##A, x, y) \<longleftrightarrow> sats(A, is_list_fm(i,j), env)"
by simp

theorem is_list_reflection:
     "REFLECTS[\<lambda>x. is_list(L,f(x),g(x)),
               \<lambda>i x. is_list(##Lset(i),f(x),g(x))]"
apply (simp only: is_list_def)
apply (intro FOL_reflections mem_list_reflection)
done

subsubsection\<open>The Formula Functor, Internalized\<close>

definition formula_functor_fm :: "[i,i]=>i" where
(*     "is_formula_functor(M,X,Z) ==
        \<exists>nat'[M]. \<exists>natnat[M]. \<exists>natnatsum[M]. \<exists>XX[M]. \<exists>X3[M].
           4           3               2       1       0
          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)" *)
    "formula_functor_fm(X,Z) ==
       Exists(Exists(Exists(Exists(Exists(
        And(omega_fm(4),
         And(cartprod_fm(4,4,3),
          And(sum_fm(3,3,2),
           And(cartprod_fm(X#+5,X#+5,1),
            And(sum_fm(1,X#+5,0), sum_fm(2,0,Z#+5)))))))))))"

lemma formula_functor_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> formula_functor_fm(x,y) \<in> formula"
by (simp add: formula_functor_fm_def)

lemma sats_formula_functor_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, formula_functor_fm(x,y), env) \<longleftrightarrow>
        is_formula_functor(##A, nth(x,env), nth(y,env))"
by (simp add: formula_functor_fm_def is_formula_functor_def)

lemma formula_functor_iff_sats:
  "[| nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)|]
   ==> is_formula_functor(##A, x, y) \<longleftrightarrow> sats(A, formula_functor_fm(i,j), env)"
by simp

theorem formula_functor_reflection:
     "REFLECTS[\<lambda>x. is_formula_functor(L,f(x),g(x)),
               \<lambda>i x. is_formula_functor(##Lset(i),f(x),g(x))]"
apply (simp only: is_formula_functor_def)
apply (intro FOL_reflections omega_reflection
             cartprod_reflection sum_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_formula_N\<close>, Internalized\<close>

(*  "is_formula_N(M,n,Z) ==
      \<exists>zero[M]. empty(M,zero) &
                is_iterates(M, is_formula_functor(M), zero, n, Z)" *)
definition
  formula_N_fm :: "[i,i]=>i" where
  "formula_N_fm(n,Z) ==
     Exists(
       And(empty_fm(0),
           is_iterates_fm(formula_functor_fm(1,0), 0, n#+1, Z#+1)))"

lemma formula_N_fm_type [TC]:
 "[| x \<in> nat; y \<in> nat |] ==> formula_N_fm(x,y) \<in> formula"
by (simp add: formula_N_fm_def)

lemma sats_formula_N_fm [simp]:
   "[| x < length(env); y < length(env); env \<in> list(A)|]
    ==> sats(A, formula_N_fm(x,y), env) \<longleftrightarrow>
        is_formula_N(##A, nth(x,env), nth(y,env))"
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (frule lt_length_in_nat, assumption)
apply (simp add: formula_N_fm_def is_formula_N_def sats_is_iterates_fm)
done

lemma formula_N_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i < length(env); j < length(env); env \<in> list(A)|]
       ==> is_formula_N(##A, x, y) \<longleftrightarrow> sats(A, formula_N_fm(i,j), env)"
by (simp)

theorem formula_N_reflection:
     "REFLECTS[\<lambda>x. is_formula_N(L, f(x), g(x)),
               \<lambda>i x. is_formula_N(##Lset(i), f(x), g(x))]"
apply (simp only: is_formula_N_def)
apply (intro FOL_reflections function_reflections
             is_iterates_reflection formula_functor_reflection)
done

subsubsection\<open>The Predicate ``Is A Formula''\<close>

(*  mem_formula(M,p) ==
      \<exists>n[M]. \<exists>formn[M].
       finite_ordinal(M,n) & is_formula_N(M,n,formn) & p \<in> formn *)
definition
  mem_formula_fm :: "i=>i" where
    "mem_formula_fm(x) ==
       Exists(Exists(
         And(finite_ordinal_fm(1),
           And(formula_N_fm(1,0), Member(x#+2,0)))))"

lemma mem_formula_type [TC]:
     "x \<in> nat ==> mem_formula_fm(x) \<in> formula"
by (simp add: mem_formula_fm_def)

lemma sats_mem_formula_fm [simp]:
   "[| x \<in> nat; env \<in> list(A)|]
    ==> sats(A, mem_formula_fm(x), env) \<longleftrightarrow> mem_formula(##A, nth(x,env))"
by (simp add: mem_formula_fm_def mem_formula_def)

lemma mem_formula_iff_sats:
      "[| nth(i,env) = x; i \<in> nat; env \<in> list(A)|]
       ==> mem_formula(##A, x) \<longleftrightarrow> sats(A, mem_formula_fm(i), env)"
by simp

theorem mem_formula_reflection:
     "REFLECTS[\<lambda>x. mem_formula(L,f(x)),
               \<lambda>i x. mem_formula(##Lset(i),f(x))]"
apply (simp only: mem_formula_def)
apply (intro FOL_reflections finite_ordinal_reflection formula_N_reflection)
done

subsubsection\<open>The Predicate ``Is \<^term>\<open>formula\<close>''\<close>

(* is_formula(M,Z) == \<forall>p[M]. p \<in> Z \<longleftrightarrow> mem_formula(M,p) *)
definition
  is_formula_fm :: "i=>i" where
    "is_formula_fm(Z) == Forall(Iff(Member(0,succ(Z)), mem_formula_fm(0)))"

lemma is_formula_type [TC]:
     "x \<in> nat ==> is_formula_fm(x) \<in> formula"
by (simp add: is_formula_fm_def)

lemma sats_is_formula_fm [simp]:
   "[| x \<in> nat; env \<in> list(A)|]
    ==> sats(A, is_formula_fm(x), env) \<longleftrightarrow> is_formula(##A, nth(x,env))"
by (simp add: is_formula_fm_def is_formula_def)

lemma is_formula_iff_sats:
      "[| nth(i,env) = x; i \<in> nat; env \<in> list(A)|]
       ==> is_formula(##A, x) \<longleftrightarrow> sats(A, is_formula_fm(i), env)"
by simp

theorem is_formula_reflection:
     "REFLECTS[\<lambda>x. is_formula(L,f(x)),
               \<lambda>i x. is_formula(##Lset(i),f(x))]"
apply (simp only: is_formula_def)
apply (intro FOL_reflections mem_formula_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_transrec\<close>\<close>

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0.  It is buried
   within eight quantifiers!
   We call \<^term>\<open>p\<close> with arguments a, f, z by equating them with
  the corresponding quantified variables with de Bruijn indices 2, 1, 0.\<close>

(* is_transrec :: "[i=>o, [i,i,i]=>o, i, i] => o"
   "is_transrec(M,MH,a,z) ==
      \<exists>sa[M]. \<exists>esa[M]. \<exists>mesa[M].
       2       1         0
       upair(M,a,a,sa) & is_eclose(M,sa,esa) & membership(M,esa,mesa) &
       is_wfrec(M,MH,mesa,a,z)" *)
definition
  is_transrec_fm :: "[i, i, i]=>i" where
 "is_transrec_fm(p,a,z) ==
    Exists(Exists(Exists(
      And(upair_fm(a#+3,a#+3,2),
       And(is_eclose_fm(2,1),
        And(Memrel_fm(1,0), is_wfrec_fm(p,0,a#+3,z#+3)))))))"

lemma is_transrec_type [TC]:
     "[| p \<in> formula; x \<in> nat; z \<in> nat |]
      ==> is_transrec_fm(p,x,z) \<in> formula"
by (simp add: is_transrec_fm_def)

lemma sats_is_transrec_fm:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4 a5 a6 a7.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,env)))))))))"
  shows
      "[|x < length(env); z < length(env); env \<in> list(A)|]
       ==> sats(A, is_transrec_fm(p,x,z), env) \<longleftrightarrow>
           is_transrec(##A, MH, nth(x,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule_tac x=x in lt_length_in_nat, assumption)
apply (simp add: is_transrec_fm_def sats_is_wfrec_fm is_transrec_def MH_iff_sats [THEN iff_sym])
done

lemma is_transrec_iff_sats:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4 a5 a6 a7.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,env)))))))))"
  shows
  "[|nth(i,env) = x; nth(k,env) = z;
      i < length(env); k < length(env); env \<in> list(A)|]
   ==> is_transrec(##A, MH, x, z) \<longleftrightarrow> sats(A, is_transrec_fm(p,i,k), env)"
by (simp add: sats_is_transrec_fm [OF MH_iff_sats])

theorem is_transrec_reflection:
  assumes MH_reflection:
    "!!f' f g h. REFLECTS[\<lambda>x. MH(L, f'(x), f(x), g(x), h(x)),
                     \<lambda>i x. MH(##Lset(i), f'(x), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_transrec(L, MH(L,x), f(x), h(x)),
               \<lambda>i x. is_transrec(##Lset(i), MH(##Lset(i),x), f(x), h(x))]"
apply (simp (no_asm_use) only: is_transrec_def)
apply (intro FOL_reflections function_reflections MH_reflection
             is_wfrec_reflection is_eclose_reflection)
done

end


header {* Singly Linked List Segments *}
theory List_Seg
imports "../Sep_Main"
begin

subsection {* Nodes *}
text {*
  We define a node of a list to contain a data value and a next pointer.
  As Imperative HOL does not support null-pointers, we make the next-pointer
  an optional value, @{text "None"} representing a null pointer.

  Unfortunately, Imperative HOL requires some boilerplate code to define
  a datatype.
*}
setup {* Sign.add_const_constraint
  (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a\<Colon>type ref"}) *}

datatype 'a node = Node "'a" "'a node ref option"

setup {* Sign.add_const_constraint
  (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a\<Colon>heap ref"}) *}

setup {* Sign.add_const_constraint (@{const_name Node},
  SOME @{typ "'a\<Colon>heap \<Rightarrow> 'a node ref option \<Rightarrow> 'a node"}) *}

text {* Selector Functions *}
primrec val :: "'a::heap node \<Rightarrow> 'a" where
  [sep_dflt_simps]: "val (Node x _) = x"

primrec "next" :: "'a::heap node \<Rightarrow> 'a node ref option" where
  [sep_dflt_simps]: "next (Node _ r) = r"

text {* Encoding to natural numbers, as required by Imperative/HOL*}
fun
  node_encode :: "'a\<Colon>heap node \<Rightarrow> nat"
where
  "node_encode (Node x r) = to_nat (x, r)"

instance node :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "node_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

subsection {* List Segment Assertion *}
text {*
  Intuitively, @{text "lseg l p s"} describes a list starting at @{text "p"} and
  ending with a pointer @{text "s"}. The content of the list are @{text "l"}.
  Note that the pointer @{text "s"} may also occur earlier in the list, in which
  case it is handled as a usual next-pointer.
*}
fun lseg
  :: "'a::heap list \<Rightarrow> 'a node ref option \<Rightarrow> 'a node ref option \<Rightarrow> assn"
  where
  "lseg [] p s = \<up>(p=s)"
| "lseg (x#l) (Some p) s = (\<exists>\<^sub>Aq. p \<mapsto>\<^sub>r Node x q * lseg l q s)"
| "lseg (_#_) None _ = false"

lemma lseg_split_iff1[simp, sep_dflt_simps]:
  "lseg l None None = \<up>(l=[])"
  apply (cases l, simp_all)
  done

lemma lseg_split_iff2[simp, sep_dflt_simps]:
  "lseg (x#xs) p q
    = (\<exists>\<^sub>App n. pp \<mapsto>\<^sub>r (Node x n) * lseg xs n q * \<up>(p=Some pp))"
  apply (cases p, simp_all)
  (* TODO: One-point simproc for assertions! *)
  apply (rule ent_iffI)
  apply solve_entails
  apply solve_entails
  done

subsection {* Lemmas *}

subsubsection {* Concatenation *}
lemma lseg_prepend:
  "p\<mapsto>\<^sub>rNode x q * lseg l q s \<Longrightarrow>\<^sub>A lseg (x#l) (Some p) s"
  by sep_auto

lemma lseg_append:
  "lseg l p (Some s) * s\<mapsto>\<^sub>rNode x q \<Longrightarrow>\<^sub>A lseg (l@[x]) p q"
proof (induction l arbitrary: p)
  case Nil thus ?case by sep_auto
next
  case (Cons y l)
  show ?case
    apply (cases p)
    apply simp
    apply (sep_auto)
    apply (rule ent_frame_fwd[OF Cons.IH])
    apply frame_inference
    apply solve_entails
    done
qed

lemma lseg_conc: "lseg l1 p q * lseg l2 q r \<Longrightarrow>\<^sub>A lseg (l1@l2) p r"
proof (induct l1 arbitrary: p)
  case Nil thus ?case by simp
next
  case (Cons x l1)
  show ?case
    apply simp
    apply sep_auto
    apply (rule ent_frame_fwd[OF Cons.hyps])
    apply frame_inference
    apply solve_entails
    done
qed

subsubsection {* Splitting *}
lemma lseg_split:
  "lseg (l1@l2) p r \<Longrightarrow>\<^sub>A \<exists>\<^sub>Aq. lseg l1 p q * lseg l2 q r"
proof (induct l1 arbitrary: p)
  case Nil thus ?case by sep_auto
next
  case (Cons x l1)

  have "lseg ((x # l1) @ l2) p r
    \<Longrightarrow>\<^sub>A \<exists>\<^sub>App n. pp \<mapsto>\<^sub>r Node x n * lseg (l1 @ l2) n r * \<up> (p = Some pp)"
    by simp
  also have "\<dots> \<Longrightarrow>\<^sub>A
    \<exists>\<^sub>App n q. pp \<mapsto>\<^sub>r Node x n
      * lseg l1 n q
      * lseg l2 q r
      * \<up>(p = Some pp)"
    apply (intro ent_ex_preI)
    apply clarsimp
    apply (rule ent_frame_fwd[OF Cons.hyps])
    apply frame_inference
    apply sep_auto
    done
  also have "\<dots> \<Longrightarrow>\<^sub>A \<exists>\<^sub>Aq. lseg (x#l1) p q * lseg l2 q r"
    by sep_auto
  finally show ?case .
qed

subsubsection {* Precision*}
lemma lseg_prec1:
  "\<forall>l l'. (h\<Turnstile>
      (lseg l p (Some q) * q \<mapsto>\<^sub>r x * F1)
       \<and>\<^sub>A (lseg l' p (Some q) * q \<mapsto>\<^sub>r x * F2))
    \<longrightarrow> l=l'"
proof (intro allI)
  case goal1 thus ?case
  proof (induct l arbitrary: p l' F1 F2)
    case Nil thus ?case
      apply simp_all
      apply (cases l')
      apply simp
      apply (auto simp: mod_dist)
      done
  next
    case (Cons y l)
    from Cons.prems show ?case
      apply (cases l')
      apply (auto simp add: mod_dist) []
      apply (cases p)
      apply simp

      apply (clarsimp)

      apply (subgoal_tac "y=a \<and> na=n", simp)

      using Cons.hyps apply (erule prec_frame')
      apply frame_inference
      apply frame_inference

      apply (drule_tac p=aa in prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      done
  qed
qed

lemma lseg_prec2:
  "\<forall>l l'. (h\<Turnstile>
      (lseg l p None * F1) \<and>\<^sub>A (lseg l' p None * F2))
    \<longrightarrow> l=l'"
proof (intro allI)
  case goal1 thus ?case
  proof (induct l arbitrary: p l' F1 F2)
    case Nil thus ?case
      apply simp_all
      apply (cases l')
      apply simp
      apply (cases p)
      apply (auto simp: mod_dist)
      done
  next
    case (Cons y l)
    from Cons.prems show ?case
      apply (cases p)
      apply simp
      apply (cases l')
      apply (auto simp add: mod_dist) []

      apply (clarsimp)

      apply (subgoal_tac "y=aa \<and> na=n", simp)

      using Cons.hyps apply (erule prec_frame')
      apply frame_inference
      apply frame_inference

      apply (drule_tac p=a in prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      done
  qed
qed

lemma lseg_prec3:
  "\<forall>q q'. h \<Turnstile> (lseg l p q * F1) \<and>\<^sub>A (lseg l p q' * F2) \<longrightarrow> q=q'"
  apply (intro allI)
proof (induct l arbitrary: p F1 F2)
  case Nil thus ?case by auto
next
  case (Cons x l)
  show ?case
    apply auto

    apply (subgoal_tac "na=n")
    using Cons.hyps apply (erule prec_frame')
    apply frame_inference
    apply frame_inference

    apply (drule prec_frame[OF sngr_prec])
    apply frame_inference
    apply frame_inference
    apply simp
    done
qed

end


theory Validity imports Small_Step begin

section \<open>Validity of Program Specifications\<close>

subsection \<open>Perpetual Properties\<close>

text \<open>
  Similar to the language formalisation, we separate the syntax and the semantics of
  perpetual properties. Below is a @{command datatype} called @{text perpetual} that
  represents the syntax.
\<close>

datatype perpetual =
    Co ann ann          ("_ CO _" [20, 21] 20)
  | Stable ann          ("STABLE _" [21] 20)
  | Constant vname      ("CONSTANT _" [21] 20)
  | Invariant ann       ("INVARIANT _" [21] 20)
  | Transient ann       ("TRANSIENT _" [21] 20)
  | Ensure ann ann      ("_ EN _" [20, 21] 20)
  | Leads_to ann ann    ("_ \<mapsto> _" [20, 21] 20)

text \<open>
  @{term "reachable_sat P f s"} means that every reachable program and state starting from
  @{term "(f, s)"} satisfies @{term P}.
\<close>
definition reachable_sat :: "(com \<Rightarrow> state \<Rightarrow> bool) \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "reachable_sat P f s \<equiv> \<forall>f' s'. (f, s) \<rightarrow>* (f', s') \<longrightarrow> P f' s'"

subsubsection \<open>Safety Properties\<close>

text \<open>
  For any reachable program that starts from the initial program and state pair, if the program
  makes a step and @{term p} holds before, then @{term q} holds after the step.
\<close>
definition co :: "ann \<Rightarrow> ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "co p q f s \<equiv>
    reachable_sat
      (\<lambda>f' s'. \<forall>f'' s''. p s' \<and> (f', s') \<rightarrow> (f'', s'') \<longrightarrow> q s'') f s"

definition stable :: "ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "stable p \<equiv> co p p"

definition "constant" :: "vname \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "constant e f s \<equiv> \<forall>c. (stable (\<lambda>s. s e = s c)) f s"

definition invariant :: "ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "invariant p f s \<equiv> p s \<and> stable p f s"

subsubsection \<open>Progress Properties\<close>

text \<open>
  @{term "is_path P f s"} is true iff @{term P} is a valid path that starts from
  @{term "(f, s)"}. Here, paths are functions from indices (natural number) to configurations.
\<close>
definition is_path :: "(nat \<Rightarrow> com \<times> state) \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "is_path P f s \<equiv> P 0 = (f, s) \<and> (\<forall>n. P n \<rightarrow> P (n + 1))"

definition paths :: "com \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> com \<times> state) set" where
  "paths f s = {P. is_path P f s}"

text \<open>Example of a path for semi\_assign (defined in Small\_Step)\<close>
fun semi_assign_path :: "nat \<Rightarrow> com \<times> state" where
  "semi_assign_path 0 = (semi_assign, \<lambda>v. 0)"
| "semi_assign_path (Suc 0) = (semi_assign_sub, (\<lambda>v. 0)(x := 1))"
| "semi_assign_path _ = (DONE, (\<lambda>v. 0)(x := 1, y := 3))"

lemma semi_assign_path_legit:
  "semi_assign_path n \<rightarrow> semi_assign_path (Suc n)"
  apply (induction n rule: semi_assign_path.induct; simp)
    apply (simp add: semi_assign_def)
    apply (rule Semi1, rule Action; simp add: Assign_def true_def)
   apply (simp add: semi_assign_sub_def)
   apply (rule Action; simp add: Assign_def true_def ext)
  by (rule DoneR)

lemma "is_path semi_assign_path semi_assign (\<lambda>v. 0)"
  by (simp add: is_path_def semi_assign_path_legit)

fun has_terminated :: "com \<Rightarrow> bool" where
  "has_terminated DONE    = True"
| "has_terminated ABORTED = True"
| "has_terminated _       = False"

text \<open>A predicate over paths, is true if the execution in the path terminates\<close>
definition path_will_terminate :: "(nat \<Rightarrow> com \<times> state) \<Rightarrow> bool" where
  "path_will_terminate path \<equiv> \<exists>i f s. path i = (f, s) \<and> has_terminated f"

text \<open>
  We include the $post_f$ mentioned in the basis rule. The definition of transient
  becomes if @{term p} holds and @{term f} has not terminated, then eventually either @{term "not p"}
  holds or @{term f} terminates.
\<close>
definition transient :: "ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "transient p f s \<equiv>
    (\<forall>path\<in>paths f s.
      \<forall>i f s. path i = (f, s) \<and> p s \<and> \<not> has_terminated f \<longrightarrow>
        (\<exists>j f' s'. j \<ge> i \<and> path j = (f', s') \<and> ((not p) s' \<or> has_terminated f')))"

definition ensures :: "ann \<Rightarrow> ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "ensures p q f s \<equiv>
    (\<forall>path\<in>paths f s.
      \<forall>i f s. path i = (f, s) \<and> p s \<longrightarrow>
        ((not q) s \<longrightarrow> (\<exists>f' s'. path (Suc i) = (f', s') \<and> (p or q) s')) \<and>
        (\<exists>j f' s'. j \<ge> i \<and> path j = (f', s') \<and> (p s' \<and> has_terminated f' \<or> q s')))"

definition leads_to :: "ann \<Rightarrow> ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "leads_to p q f s \<equiv>
    (\<forall>path\<in>paths f s.
      \<forall>i f s. path i = (f, s) \<and> p s \<and> \<not> has_terminated f \<longrightarrow>
        (\<exists>j f' s'. j \<ge> i \<and> path j = (f', s') \<and> (q s' \<or> has_terminated f')))"

subsubsection \<open>Syntax to Semantics\<close>

primrec eval :: "perpetual \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "eval (p CO q) = co p q"
| "eval (STABLE p) = stable p"
| "eval (CONSTANT e) = constant e"
| "eval (INVARIANT i) = invariant i"
| "eval (TRANSIENT p) = transient p"
| "eval (p EN q) = ensures p q"
| "eval (p \<mapsto> q) = leads_to p q"

subsection \<open>Valid Specification\<close>

text \<open>
  The function @{term holds} checks if a state satisfies a predicate given that the program is
  not @{term ABORTED}.
\<close>
definition holds :: "ann \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" where
  "holds q f s \<equiv> q s \<and> f \<noteq> ABORTED"

text \<open>Valid Specification\<close>
definition
  valid_spec :: "ann \<Rightarrow> com \<Rightarrow> perpetual set \<Rightarrow> ann \<Rightarrow> bool" ("\<Turnstile> {_} _ {_ | _}" [0, 0, 0, 0] 61)
where
  "\<Turnstile> {r} f {Q | t} \<equiv>
    (\<forall>s. r s \<longrightarrow>
      reachable_sat (\<lambda>f' s'. has_terminated f' \<longrightarrow> holds t f' s') f s \<and>
      (\<forall>op \<in> Q. eval op f s))"

end