header {* Rewriting LTL formulas *}
(* Author: Alexander Schimpf *)
theory LTL_Rewrite
imports
  LTL
begin

context begin interpretation LTL_Syntax .

inductive_set ltln_pure_eventual_frmls :: "'a ltln set"
where
  "\<diamondsuit>\<^sub>n \<phi> \<in> ltln_pure_eventual_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_eventual_frmls; \<mu> \<in> ltln_pure_eventual_frmls \<rbrakk>
      \<Longrightarrow> \<nu> and\<^sub>n \<mu> \<in> ltln_pure_eventual_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_eventual_frmls; \<mu> \<in> ltln_pure_eventual_frmls \<rbrakk>
      \<Longrightarrow> \<nu> or\<^sub>n \<mu> \<in> ltln_pure_eventual_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_eventual_frmls; \<mu> \<in> ltln_pure_eventual_frmls \<rbrakk>
      \<Longrightarrow> \<nu> U\<^sub>n \<mu> \<in> ltln_pure_eventual_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_eventual_frmls; \<mu> \<in> ltln_pure_eventual_frmls \<rbrakk>
      \<Longrightarrow> \<nu> V\<^sub>n \<mu> \<in> ltln_pure_eventual_frmls"

theorem ltln_pure_eventual_frmls_equiv:
  assumes "\<psi> \<in> ltln_pure_eventual_frmls"
  shows "\<xi> \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
using assms proof (induct \<psi> arbitrary:\<xi> \<phi>)
  case goal1
  thus ?case
    by (auto, metis comm_semiring_1_class.normalizing_semiring_rules(5)
      less_nat_zero_code)
next
  case (goal2 _ _ \<xi> \<phi>) show ?case using goal2(2)[of \<xi> \<phi>] goal2(4)[of \<xi> \<phi>]
    by (auto, metis less_nat_zero_code suffix_0)
next
  case (goal3 _ _ \<xi>) show ?case
    using goal3(2)[of \<xi> \<phi>] goal3(4)[of \<xi> \<phi>] by auto
next
  case (goal4 \<nu> \<mu> \<xi>)
    let ?\<psi> = "\<nu> U\<^sub>n \<mu>"
    { assume "\<xi> \<Turnstile>\<^sub>n \<phi> U\<^sub>n ?\<psi>"
      then obtain i where "suffix i \<xi> \<Turnstile>\<^sub>n ?\<psi>" and "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n \<phi>"
        by auto
      moreover with goal4(4)[of "suffix i \<xi>" \<nu>] have "suffix i \<xi> \<Turnstile>\<^sub>n \<mu>"
        by auto
      ultimately have "\<xi> \<Turnstile>\<^sub>n ?\<psi>" using goal4(4)[of \<xi> \<phi>] goal4(4)[of \<xi> \<nu>]
        by auto }
    moreover
    { assume "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
      with goal4 have "\<xi> \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<mu>" by auto
      then obtain i where "suffix i \<xi> \<Turnstile>\<^sub>n \<mu>" and "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n \<phi>"
        by auto
      moreover with goal4(4)[of "suffix i \<xi>" \<nu>] have "suffix i \<xi> \<Turnstile>\<^sub>n \<nu> U\<^sub>n \<mu>"
        by auto
      ultimately have "\<xi> \<Turnstile>\<^sub>n \<phi> U\<^sub>n ?\<psi>" by auto }
    ultimately show ?case by fast
next
  case (goal5 \<nu> \<mu>)
    let ?\<psi> = "\<nu> V\<^sub>n \<mu>"
    { assume "\<xi> \<Turnstile>\<^sub>n \<phi> U\<^sub>n ?\<psi>"
      then obtain i where
        V_suf_i: "suffix i \<xi> \<Turnstile>\<^sub>n \<nu> V\<^sub>n \<mu>"
        and phi_all_less_i: "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n \<phi>"
        unfolding ltln_Release_alterdef[symmetric] by auto
      hence \<mu>_suf_i: "suffix i \<xi> \<Turnstile>\<^sub>n \<mu>"
        by (metis ltln_expand_Release ltln_semantics.simps(5))
      have \<mu>_less_i: "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n \<mu>"
      proof(clarify)
        fix k
        assume "k<i"
        hence "suffix (i-k) (suffix k \<xi>) \<Turnstile>\<^sub>n \<mu>"
          and "\<forall>j<i-k. suffix j (suffix k \<xi>) \<Turnstile>\<^sub>n \<phi>"
        using V_suf_i phi_all_less_i \<mu>_suf_i by auto
        thus "suffix k \<xi> \<Turnstile>\<^sub>n \<mu>" using goal5(4)[of "suffix k \<xi>" \<phi>] by auto
      qed
      have "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
      proof -
        { fix i'
          { assume "i' < i"
            hence "suffix i' \<xi> \<Turnstile>\<^sub>n \<mu>" using \<mu>_less_i by auto }
          moreover
          { assume "i' \<ge> i"
            then obtain i'' where i'_eq: "i' = i + i''" and "i'\<ge>i''"
              by (metis Nat.diff_le_self le_add_diff_inverse2 add.commute)
            hence "suffix i' \<xi> \<Turnstile>\<^sub>n \<mu> \<or> (\<exists>j<i'. suffix j \<xi> \<Turnstile>\<^sub>n \<nu>)"
              using V_suf_i by auto }
          ultimately have "suffix i' \<xi> \<Turnstile>\<^sub>n \<mu> \<or> (\<exists>j<i'. suffix j \<xi> \<Turnstile>\<^sub>n \<nu>)"
            by (metis linorder_not_less) }
        thus ?thesis by auto
      qed }
    moreover
    { assume "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
      hence "suffix 0 \<xi> \<Turnstile>\<^sub>n ?\<psi> \<and> (\<forall>j<0. suffix j \<xi> \<Turnstile>\<^sub>n \<phi>)" by auto
      hence "\<xi> \<Turnstile>\<^sub>n \<phi> U\<^sub>n ?\<psi>" unfolding ltln_semantics.simps by blast }
    ultimately show ?case by fast
qed

corollary ltln_pure_eventual_frmls_equiv_diamond:
  assumes "\<psi> \<in> ltln_pure_eventual_frmls"
  shows "\<xi> \<Turnstile>\<^sub>n \<diamondsuit>\<^sub>n \<psi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
by (rule ltln_pure_eventual_frmls_equiv[OF assms])

inductive_set ltln_pure_universal_frmls :: "'a ltln set"
where
  "\<box>\<^sub>n \<phi> \<in> ltln_pure_universal_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_universal_frmls; \<mu> \<in> ltln_pure_universal_frmls \<rbrakk>
      \<Longrightarrow> \<nu> and\<^sub>n \<mu> \<in> ltln_pure_universal_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_universal_frmls; \<mu> \<in> ltln_pure_universal_frmls \<rbrakk>
      \<Longrightarrow> \<nu> or\<^sub>n \<mu> \<in> ltln_pure_universal_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_universal_frmls; \<mu> \<in> ltln_pure_universal_frmls \<rbrakk>
      \<Longrightarrow> \<nu> U\<^sub>n \<mu> \<in> ltln_pure_universal_frmls"
| "\<lbrakk> \<nu> \<in> ltln_pure_universal_frmls; \<mu> \<in> ltln_pure_universal_frmls \<rbrakk>
      \<Longrightarrow> \<nu> V\<^sub>n \<mu> \<in> ltln_pure_universal_frmls"

theorem ltln_pure_universal_frmls_equiv:
  assumes "\<psi> \<in> ltln_pure_universal_frmls"
  shows "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n \<psi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
using assms proof (induct \<psi> arbitrary:\<xi> \<phi>)
  case goal1
  thus ?case
    by (auto, metis comm_semiring_1_class.normalizing_semiring_rules(5)
      less_nat_zero_code)
next
  case (goal2 _ _ \<xi> \<phi>)
  show ?case
    using goal2(2)[of \<xi> \<phi>] goal2(4)[of \<xi> \<phi>] by auto
next
  case (goal3 _ _ \<xi>) show ?case
    using goal3(2)[of \<xi> \<phi>] goal3(4)[of \<xi> \<phi>]
    by (auto, metis less_nat_zero_code suffix_0)
next
  case (goal4 \<nu> \<mu> \<xi>)
    let ?\<psi> = "\<nu> U\<^sub>n \<mu>"
    { assume assm: "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>"
      { assume "\<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n ?\<psi>"
        hence "suffix 0 \<xi> \<Turnstile>\<^sub>n ?\<psi>"
          by (metis ltln_semantics.simps(9) ltln_semantics.simps(2))
        hence "\<xi> \<Turnstile>\<^sub>n ?\<psi>" by auto }
      moreover
      { assume "\<not> \<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n ?\<psi>"
        hence  "\<xi> \<Turnstile>\<^sub>n ?\<psi> U\<^sub>n (\<phi> and\<^sub>n ?\<psi>)"
          using assm ltln_Release_alterdef[of \<xi> \<phi> ?\<psi>]
          by (metis ltln_semantics.simps(6))
        then obtain i
          where "suffix i \<xi> \<Turnstile>\<^sub>n \<phi> and\<^sub>n ?\<psi>" and "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n ?\<psi>"
          by auto
        hence "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
          by (cases "i=0") (metis suffix_0 ltln_semantics.simps(5)
            neq0_conv suffix_0)+ }
      ultimately have "\<xi> \<Turnstile>\<^sub>n ?\<psi>" by fast }
    moreover
    { assume "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
      then obtain i where
        \<mu>_suf_i: "suffix i \<xi> \<Turnstile>\<^sub>n \<mu>"
        and \<nu>_less_i: "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n \<nu>"
        by auto
      with goal4(4)[of "suffix i \<xi>"] \<mu>_suf_i
      have "suffix i \<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n \<mu> or\<^sub>n (\<mu> U\<^sub>n (\<phi> and\<^sub>n \<mu>))"
        using ltln_Release_alterdef[of "suffix i \<xi>" \<phi> \<mu>] by auto
      moreover
      { assume "suffix i \<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n \<mu>"
        hence \<psi>_suf_i: "suffix i \<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>"
          by auto (metis ac_simps ltln_expand_Until ltln_semantics.simps)
        from \<nu>_less_i have \<psi>_less_i: "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n ?\<psi>"
        proof(clarify)
          case (goal1 j)
            then obtain j' where "i = j + j'" by (metis less_imp_add_positive)
            hence "suffix j' (suffix j \<xi>) \<Turnstile>\<^sub>n \<mu>"
              and "\<forall>k<j'. suffix k (suffix j \<xi>) \<Turnstile>\<^sub>n \<nu>"
            using \<mu>_suf_i by auto (metis \<nu>_less_i `i = j + j'`
              add_less_cancel_right add.commute)
            thus ?case by auto
        qed
        have "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>"
        proof -
          { fix k
            { assume "k < i"
              with \<psi>_less_i have "suffix k \<xi> \<Turnstile>\<^sub>n ?\<psi>" by auto }
            moreover
            { assume "k \<ge> i"
              then obtain i' where "k = i + i'" by (metis Nat.le_iff_add)
              with \<psi>_suf_i have "suffix k \<xi> \<Turnstile>\<^sub>n ?\<psi> \<or> (\<exists>j<k. suffix j \<xi> \<Turnstile>\<^sub>n \<phi>)"
                by auto }
            ultimately have "suffix k \<xi> \<Turnstile>\<^sub>n ?\<psi> \<or> (\<exists>j<k. suffix j \<xi> \<Turnstile>\<^sub>n \<phi>)"
              by (metis linorder_not_less) }
          thus ?thesis by auto
        qed }
      moreover
      { assume "suffix i \<xi> \<Turnstile>\<^sub>n \<mu> U\<^sub>n (\<phi> and\<^sub>n \<mu>)"
        then obtain k where "suffix (i+k) \<xi> \<Turnstile>\<^sub>n \<phi>"
                        and "suffix (i+k) \<xi> \<Turnstile>\<^sub>n \<mu>"
                        and "\<forall>j<k. suffix j (suffix i \<xi>) \<Turnstile>\<^sub>n \<mu>" by auto
        hence "\<forall>j\<le>i+k. suffix j \<xi> \<Turnstile>\<^sub>n ?\<psi>"
        proof(clarify)
          case (goal1 j)
            { assume "j < i"
              then obtain j' where "i = j + j'" by (metis less_imp_add_positive)
              with \<mu>_suf_i \<nu>_less_i have ?case by auto }
            moreover
            { assume "j \<ge> i"
              then obtain i' where "j = i + i'" by (metis Nat.le_iff_add)
              with goal1 have ?case
                by (auto, metis (full_types) add.comm_neutral add_Suc_right
                  le_neq_implies_less less_nat_zero_code) }
            ultimately show ?case by (metis less_or_eq_imp_le linorder_neqE_nat)
        qed
        with `suffix (i+k) \<xi> \<Turnstile>\<^sub>n \<phi>` have "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>"
          by (auto, metis linorder_not_less) }
      ultimately have "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>" by auto }
    ultimately show ?case by fast
next
  case (goal5 \<nu> \<mu> \<xi>)
    let ?\<psi> = "\<nu> V\<^sub>n \<mu>"
    { assume "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>"
      moreover
      { assume "\<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n ?\<psi>"
        hence "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
          by (metis goal5(4) ltln_semantics.simps(2) ltln_semantics.simps(9)) }
      moreover
      { assume "\<xi> \<Turnstile>\<^sub>n ?\<psi> U\<^sub>n (\<phi> and\<^sub>n ?\<psi>)"
        then obtain i where "suffix i \<xi> \<Turnstile>\<^sub>n ?\<psi>" and "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n ?\<psi>"
          by auto
        hence "\<xi> \<Turnstile>\<^sub>n ?\<psi>" by (cases "i=0") (auto, metis suffix_0 suffix_suffix) }
      ultimately have "\<xi> \<Turnstile>\<^sub>n ?\<psi>" using ltln_Release_alterdef[of \<xi> \<phi> ?\<psi>] by auto }
    moreover
    { assume "\<xi> \<Turnstile>\<^sub>n ?\<psi>"
      { assume "\<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n \<mu>"
        hence "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>" by auto }
      moreover
      { assume assm: "\<not> \<xi> \<Turnstile>\<^sub>n \<box>\<^sub>n \<mu>"
        hence "\<xi> \<Turnstile>\<^sub>n \<mu> U\<^sub>n (\<nu> and\<^sub>n \<mu>)"
          using ltln_Release_alterdef[of \<xi> \<nu> \<mu>] `\<xi> \<Turnstile>\<^sub>n ?\<psi>` by auto
        hence "\<xi> \<Turnstile>\<^sub>n \<mu>" using `\<xi> \<Turnstile>\<^sub>n ?\<psi>`  by (auto, metis calculation(1) goal5(4))
        with goal5(4)[of \<xi> \<phi>] have "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n \<mu>" by auto
        hence "\<xi> \<Turnstile>\<^sub>n \<mu> U\<^sub>n (\<phi> and\<^sub>n \<mu>)"
          using assm ltln_Release_alterdef[of \<xi> \<phi> \<mu>] by auto
        then obtain i
          where "suffix i \<xi> \<Turnstile>\<^sub>n \<phi> and\<^sub>n \<mu>" and "\<forall>j<i. suffix j \<xi> \<Turnstile>\<^sub>n \<mu>"
          by auto
        moreover hence "\<forall>j\<le>i. suffix j \<xi> \<Turnstile>\<^sub>n \<nu> V\<^sub>n \<mu>"
          by (metis `\<xi> \<Turnstile>\<^sub>n \<mu>` assm goal5(4))
        ultimately have "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>" by (auto, metis linorder_not_le) }
      ultimately have "\<xi> \<Turnstile>\<^sub>n \<phi> V\<^sub>n ?\<psi>" by fast }
    ultimately show ?case by fast
qed

text{* Some simple rewrite rules *}

fun ltln_rewrite_step :: "'a ltln \<Rightarrow> 'a ltln"
where
  "ltln_rewrite_step (_ U\<^sub>n true\<^sub>n) = true\<^sub>n"
| "ltln_rewrite_step (_ V\<^sub>n false\<^sub>n) = false\<^sub>n"
| "ltln_rewrite_step (true\<^sub>n U\<^sub>n (_ U\<^sub>n \<mu>)) = true\<^sub>n U\<^sub>n \<mu>"
| "ltln_rewrite_step (false\<^sub>n V\<^sub>n (_ V\<^sub>n \<mu>)) = false\<^sub>n V\<^sub>n \<mu>"
| "ltln_rewrite_step \<psi> = (case \<psi> of
    \<phi> U\<^sub>n \<phi>' \<Rightarrow>
      if \<phi> = \<phi>' then \<phi>
      else if \<phi>' \<in> ltln_pure_eventual_frmls then \<phi>'
      else \<psi>
  | \<phi> V\<^sub>n \<phi>' \<Rightarrow>
      if \<phi> = \<phi>' then \<phi>
      else if \<phi>' \<in> ltln_pure_universal_frmls then \<phi>'
      else \<psi>
  | (\<phi> U\<^sub>n \<mu>) and\<^sub>n (\<nu> U\<^sub>n \<mu>') \<Rightarrow> if \<mu> = \<mu>' then (\<phi> and\<^sub>n \<nu>) U\<^sub>n \<mu> else \<psi>
  | (\<phi> U\<^sub>n \<nu>) or\<^sub>n (\<phi>' U\<^sub>n \<mu>) \<Rightarrow> if \<phi> = \<phi>' then \<phi> U\<^sub>n (\<nu> or\<^sub>n \<mu>) else \<psi>
  | (\<phi> V\<^sub>n \<nu>) and\<^sub>n (\<phi>' V\<^sub>n \<mu>) \<Rightarrow> if \<phi> = \<phi>' then \<phi> V\<^sub>n (\<nu> and\<^sub>n \<mu>) else \<psi>
  | (\<phi> V\<^sub>n \<mu>) or\<^sub>n (\<nu> V\<^sub>n \<mu>') \<Rightarrow> if \<mu> = \<mu>' then (\<phi> or\<^sub>n \<nu>) V\<^sub>n \<mu> else \<psi>
  | _ \<Rightarrow> \<psi>) "

lemma ltln_rewrite_step__size_less:
  assumes "ltln_rewrite_step \<psi> \<noteq> \<psi>"
  shows "size (ltln_rewrite_step \<psi>) < size \<psi>"
  using assms proof (cases \<psi>)
  case (goal8 \<nu> \<mu>)
  thus ?case
    by (cases \<mu>, cases \<nu>) (auto split:ltln.split,
      metis+, cases \<nu>, auto split:ltln.split, metis+)
next
  case (goal9 \<nu> \<mu>)
  thus ?case
    by (cases \<mu>, cases \<nu>) (auto split:ltln.split,
      metis+, cases \<nu>, auto split:ltln.split, metis+)
qed (auto split:ltln.split)

lemma ltln_rewrite_step__size_leq:
  "size (ltln_rewrite_step \<psi>) \<le> size \<psi>"
  using ltln_rewrite_step__size_less[of \<psi>]
  by (cases "ltln_rewrite_step \<psi> = \<psi>") auto

theorem ltln_rewrite_step__equiv:
  "\<xi> \<Turnstile>\<^sub>n ltln_rewrite_step \<psi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
proof (cases \<psi>)
  case (goal5 \<nu> \<mu>) thus ?case
  proof (cases \<nu>)
    case goal8 thus ?case
    proof (cases \<mu>)
      case goal8 thus ?case by (auto, metis nat_neq_iff order_less_trans)
    qed auto
  qed (auto split:ltln.split)
next
  case (goal6 \<nu> \<mu>) thus ?case
  proof (cases \<nu>)
    case goal9 thus ?case
    proof (cases \<mu>)
      case goal9 thus ?case by (auto, metis nat_neq_iff order_less_trans)
    qed auto
  qed (auto split:ltln.split)
next
  case (goal8 \<nu> \<mu>) thus ?case
  proof(cases "\<mu> \<noteq> true\<^sub>n \<and> \<not> (\<nu> = true\<^sub>n \<and> (\<exists>\<nu>' \<mu>'. \<mu> = \<nu>' U\<^sub>n \<mu>')) \<and> \<nu> \<noteq> \<mu>")
    case goal1
      hence "\<xi> \<Turnstile>\<^sub>n (if \<mu> \<in> ltln_pure_eventual_frmls then \<mu> else \<psi>) \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
      using ltln_pure_eventual_frmls_equiv by auto
      thus ?case using goal1 by (cases \<mu>) (cases \<nu>, auto split:ltln.split)+
  next
    case goal2
    thus ?case
      by (cases \<mu>, auto split:ltln.split) (metis less_nat_zero_code neq0_conv
        suffix_0 add.comm_neutral add_0)+
  qed
next
  case (goal9 \<nu> \<mu>) thus ?case
  proof(cases "\<mu> \<noteq> false\<^sub>n \<and> \<not> (\<nu> = false\<^sub>n \<and> (\<exists>\<nu>' \<mu>'. \<mu> = \<nu>' V\<^sub>n \<mu>')) \<and> \<nu> \<noteq> \<mu>")
    case goal1
      hence "\<xi> \<Turnstile>\<^sub>n (if \<mu> \<in> ltln_pure_universal_frmls then \<mu> else \<psi>) \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
      using ltln_pure_universal_frmls_equiv by auto
      thus ?case using goal1 by (cases \<mu>) (cases \<nu>, auto split:ltln.split)+
  next
    case goal2
    thus ?case
      by (cases \<mu>, auto split:ltln.split) (metis less_nat_zero_code neq0_conv
        suffix_0 add.comm_neutral add_0)+
  qed
qed (auto split:ltln.split)

function ltln_rewrite_rec
where
  "ltln_rewrite_rec \<psi> = (case ltln_rewrite_step \<psi> of
    \<nu> and\<^sub>n \<mu> \<Rightarrow> (ltln_rewrite_rec \<nu>) and\<^sub>n (ltln_rewrite_rec \<mu>)
  | \<nu> or\<^sub>n \<mu> \<Rightarrow> (ltln_rewrite_rec \<nu>) or\<^sub>n (ltln_rewrite_rec \<mu>)
  | X\<^sub>n \<nu> \<Rightarrow> X\<^sub>n (ltln_rewrite_rec \<nu>)
  | \<nu> U\<^sub>n \<mu> \<Rightarrow> (ltln_rewrite_rec \<nu>) U\<^sub>n (ltln_rewrite_rec \<mu>)
  | \<nu> V\<^sub>n \<mu> \<Rightarrow> (ltln_rewrite_rec \<nu>) V\<^sub>n (ltln_rewrite_rec \<mu>)
  | \<phi> \<Rightarrow> \<phi>)"
by pat_completeness auto
termination proof -
  {
    fix \<psi> \<phi> :: "'a ltln" and thesis
    assume "ltln_rewrite_step \<psi> = \<phi>"
    thm ltln_rewrite_step__size_leq
    moreover assume "\<lbrakk>ltln_rewrite_step \<psi> = \<phi>;
      size (local.ltln_rewrite_step \<psi>) \<le> size \<psi>\<rbrakk> \<Longrightarrow> thesis"
    ultimately have thesis using ltln_rewrite_step__size_leq[of \<psi>]
      by blast
  } note AUX=this
  show ?thesis
    apply (relation "inv_image less_than size")
    apply simp_all
    apply (erule AUX, simp)+
    done
qed

declare ltln_rewrite_rec.simps [simp del]

lemma ltln_rewrite_rec__size_less:
  assumes "ltln_rewrite_rec \<psi> \<noteq> \<psi>"
  shows "size (ltln_rewrite_rec \<psi>) < size \<psi>"
using assms proof (induct "ltln_rewrite_rec \<psi>" arbitrary:\<psi>)
  case goal1 thus ?case
    using ltln_rewrite_step__size_less[of \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal2 thus ?case
    using ltln_rewrite_step__size_less[of \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal3 thus ?case
    using ltln_rewrite_step__size_less[of \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal4 thus ?case
    using ltln_rewrite_step__size_less[of \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case (goal5 \<nu> \<mu>) thus ?case using ltln_rewrite_step__size_less[of \<psi>]
  proof (cases "ltln_rewrite_step \<psi>")
    case (goal5 \<nu>' \<mu>') thus ?case
      unfolding goal5(6) ltln_rewrite_rec.simps[of \<psi>]
      apply (cases "\<nu>' and\<^sub>n \<mu>' = \<psi>")
      by fastforce+
  qed (auto simp add: ltln_rewrite_rec.simps[of \<psi>])
next
  case (goal6 \<nu> \<mu>) thus ?case using ltln_rewrite_step__size_less[of \<psi>]
  proof (cases "ltln_rewrite_step \<psi>")
    case (goal6 \<nu>' \<mu>') thus ?case
      unfolding goal6(6) ltln_rewrite_rec.simps[of \<psi>]
      by (cases "\<nu>' or\<^sub>n \<mu>' = \<psi>") (fastforce+)
  qed (auto simp add: ltln_rewrite_rec.simps[of \<psi>])
next
  case (goal7 \<nu>) thus ?case using ltln_rewrite_step__size_less[of \<psi>]
  proof (cases "ltln_rewrite_step \<psi>")
    case (goal7 \<nu>') thus ?case unfolding goal7(5) ltln_rewrite_rec.simps[of \<psi>]
      by (cases "X\<^sub>n \<nu>' = \<psi>") (fastforce+)
  qed (auto simp add: ltln_rewrite_rec.simps[of \<psi>])
next
  case (goal8 \<nu> \<mu>) thus ?case using ltln_rewrite_step__size_less[of \<psi>]
  proof (cases "ltln_rewrite_step \<psi>")
    case (goal8 \<nu>' \<mu>')
    thus ?case unfolding goal8(6) ltln_rewrite_rec.simps[of \<psi>]
      by (cases "\<nu>' U\<^sub>n \<mu>' = \<psi>") (fastforce+)
  qed (auto simp add: ltln_rewrite_rec.simps[of \<psi>])
next
  case (goal9 \<nu> \<mu>) thus ?case using ltln_rewrite_step__size_less[of \<psi>]
  proof (cases "ltln_rewrite_step \<psi>")
    case (goal9 \<nu>' \<mu>')
    thus ?case unfolding goal9(6) ltln_rewrite_rec.simps[of \<psi>]
      by (cases "\<nu>' V\<^sub>n \<mu>' = \<psi>") (fastforce+)
  qed (auto simp add: ltln_rewrite_rec.simps[of \<psi>])
qed

lemma ltln_rewrite_rec__size_leq:
  "size (ltln_rewrite_rec \<psi>) \<le> size \<psi>"
using ltln_rewrite_rec__size_less[of \<psi>] by (cases "ltln_rewrite_rec \<psi> = \<psi>") auto

theorem ltln_rewrite_rec__equiv:
  "\<xi> \<Turnstile>\<^sub>n ltln_rewrite_rec \<psi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
proof (induct "ltln_rewrite_rec \<psi>" arbitrary:\<xi> \<psi>)
  case goal1
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal2
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal3
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal4
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal5
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal6
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal7
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal8
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
next
  case goal9
    thus ?case
      using ltln_rewrite_step__equiv[of _ \<psi>] ltln_rewrite_rec.simps[of \<psi>]
    by (cases "ltln_rewrite_step \<psi>") auto
qed

function ltln_rewrite
where
  "ltln_rewrite \<psi>
    = (let \<phi> = ltln_rewrite_rec \<psi> in
         if \<phi> \<noteq> \<psi> then ltln_rewrite \<phi> else \<psi>)"
by pat_completeness auto
termination
proof(relation "inv_image less_than size")
  case goal1 thus ?case by auto
next
  case (goal2 \<psi>) thus ?case using ltln_rewrite_rec__size_less[of \<psi>] by auto
qed

declare ltln_rewrite.simps [simp del]

lemma ltln_rewrite__size_less:
  assumes "ltln_rewrite \<psi> \<noteq> \<psi>"
  shows "size (ltln_rewrite \<psi>) < size \<psi>"
using assms proof (induct \<psi> rule: ltln_rewrite.induct)
  case (goal1 \<psi>)
    { assume "ltln_rewrite_rec \<psi> = \<psi>"
      hence ?case using goal1(2) unfolding ltln_rewrite.simps[of \<psi>] by auto }
    moreover
    { assume assm: "ltln_rewrite_rec \<psi> \<noteq> \<psi>"
      hence rw_\<psi>_eq: "ltln_rewrite \<psi> = ltln_rewrite (ltln_rewrite_rec \<psi>)"
        unfolding ltln_rewrite.simps[of \<psi>] by auto
      from goal1(1)[OF refl assm, folded rw_\<psi>_eq]
        and ltln_rewrite_rec__size_less[OF assm]
      have ?case by (cases "ltln_rewrite \<psi> = ltln_rewrite_rec \<psi>") auto }
    ultimately show ?case by fast
qed

lemma ltln_rewrite__size_leq:
  "size (ltln_rewrite \<psi>) \<le> size \<psi>"
using ltln_rewrite__size_less[of \<psi>] by (cases "ltln_rewrite \<psi> = \<psi>") auto

lemma ltln_rewrite__equiv:
  "\<xi> \<Turnstile>\<^sub>n ltln_rewrite \<psi> \<longleftrightarrow> \<xi> \<Turnstile>\<^sub>n \<psi>"
proof (induct \<psi> rule: ltln_rewrite.induct)
  case (goal1 \<psi>)
    show ?case using goal1[OF refl] ltln_rewrite_rec__equiv[of \<xi> \<psi>]
    unfolding ltln_rewrite.simps[of \<psi>] by (cases "ltln_rewrite_rec \<psi> = \<psi>") auto
qed

fun ltln_pure_eventual_frmls_impl
where
  "ltln_pure_eventual_frmls_impl (\<diamondsuit>\<^sub>n \<phi>) = True"
| "ltln_pure_eventual_frmls_impl (\<nu> and\<^sub>n \<mu>)
  = (ltln_pure_eventual_frmls_impl \<nu> \<and> ltln_pure_eventual_frmls_impl \<mu>)"
| "ltln_pure_eventual_frmls_impl (\<nu> or\<^sub>n \<mu>)
  = (ltln_pure_eventual_frmls_impl \<nu> \<and> ltln_pure_eventual_frmls_impl \<mu>)"
| "ltln_pure_eventual_frmls_impl (\<nu> U\<^sub>n \<mu>)
  = (ltln_pure_eventual_frmls_impl \<nu> \<and> ltln_pure_eventual_frmls_impl \<mu>)"
| "ltln_pure_eventual_frmls_impl (\<nu> V\<^sub>n \<mu>)
  = (ltln_pure_eventual_frmls_impl \<nu> \<and> ltln_pure_eventual_frmls_impl \<mu>)"
| "ltln_pure_eventual_frmls_impl _ = False"

lemma ltln_pure_eventual_frmls_unfold[code_unfold]:
  "\<phi> \<in> ltln_pure_eventual_frmls \<longleftrightarrow> ltln_pure_eventual_frmls_impl \<phi>"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  thus ?rhs
  proof (induct rule: ltln_pure_eventual_frmls.induct)
    case goal4 thus ?case by (cases "\<nu> = true\<^sub>n") (cases \<nu>, auto)+
  qed auto
next
  assume ?rhs
  thus ?lhs
  proof (induct \<phi>)
    case (goal8 \<nu> \<mu>)
    thus ?case
      by (cases "\<nu> = true\<^sub>n") (cases \<nu>,
        auto intro: ltln_pure_eventual_frmls.intros)+
  qed (auto intro: ltln_pure_eventual_frmls.intros)
qed

fun ltln_pure_universal_frmls_impl
where
  "ltln_pure_universal_frmls_impl (\<box>\<^sub>n \<phi>) = True"
| "ltln_pure_universal_frmls_impl (\<nu> and\<^sub>n \<mu>)
  = (ltln_pure_universal_frmls_impl \<nu> \<and> ltln_pure_universal_frmls_impl \<mu>)"
| "ltln_pure_universal_frmls_impl (\<nu> or\<^sub>n \<mu>)
  = (ltln_pure_universal_frmls_impl \<nu> \<and> ltln_pure_universal_frmls_impl \<mu>)"
| "ltln_pure_universal_frmls_impl (\<nu> U\<^sub>n \<mu>)
  = (ltln_pure_universal_frmls_impl \<nu> \<and> ltln_pure_universal_frmls_impl \<mu>)"
| "ltln_pure_universal_frmls_impl (\<nu> V\<^sub>n \<mu>)
  = (ltln_pure_universal_frmls_impl \<nu> \<and> ltln_pure_universal_frmls_impl \<mu>)"
| "ltln_pure_universal_frmls_impl _ = False"

lemma ltln_pure_universal_frmls_unfold[code_unfold]:
  "\<phi> \<in> ltln_pure_universal_frmls \<longleftrightarrow> ltln_pure_universal_frmls_impl \<phi>"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  thus ?rhs
  proof (induct rule: ltln_pure_universal_frmls.induct)
    case goal5 thus ?case by (cases "\<nu> = false\<^sub>n") (cases \<nu>, auto)+
  qed auto
next
  assume ?rhs
  thus ?lhs
  proof (induct \<phi>)
    case (goal9 \<nu> \<mu>)
    thus ?case
      by (cases "\<nu> = false\<^sub>n") (cases \<nu>,
        auto intro: ltln_pure_universal_frmls.intros)+
  qed (auto intro: ltln_pure_universal_frmls.intros)
qed

definition
  "ltln_rewrite_step_impl \<psi> \<equiv> case \<psi> of
    \<nu> U\<^sub>n \<mu> \<Rightarrow> if \<mu> = true\<^sub>n then true\<^sub>n
              else (
                case (\<nu>, \<mu>) of
                  (true\<^sub>n, _ U\<^sub>n \<mu>') \<Rightarrow> true\<^sub>n U\<^sub>n \<mu>'
                | _ \<Rightarrow> if \<nu> = \<mu> then \<nu>
                       else if \<mu>\<in>ltln_pure_eventual_frmls then \<mu>
                       else \<psi>)
  | \<nu> V\<^sub>n \<mu> \<Rightarrow> if \<mu> = false\<^sub>n then false\<^sub>n
              else (
                case (\<nu>, \<mu>) of
                  (false\<^sub>n, _ V\<^sub>n \<mu>') \<Rightarrow> false\<^sub>n V\<^sub>n \<mu>'
                | _ \<Rightarrow> if \<nu> = \<mu> then \<nu>
                       else if \<mu>\<in>ltln_pure_universal_frmls then \<mu>
                       else \<psi>)
  | \<psi>1 and\<^sub>n \<psi>2 \<Rightarrow> (
      case (\<psi>1, \<psi>2) of
        (\<phi> U\<^sub>n \<mu>, \<nu> U\<^sub>n \<mu>') \<Rightarrow> if \<mu> = \<mu>' then (\<phi> and\<^sub>n \<nu>) U\<^sub>n \<mu> else \<psi>
      | (\<phi> V\<^sub>n \<nu>, \<phi>' V\<^sub>n \<mu>) \<Rightarrow> if \<phi> = \<phi>' then \<phi> V\<^sub>n (\<nu> and\<^sub>n \<mu>) else \<psi>
      | _ \<Rightarrow> \<psi>)
  | \<psi>1 or\<^sub>n \<psi>2 \<Rightarrow> (
      case (\<psi>1, \<psi>2) of
        (\<phi> U\<^sub>n \<nu>, \<phi>' U\<^sub>n \<mu>) \<Rightarrow> if \<phi> = \<phi>' then \<phi> U\<^sub>n (\<nu> or\<^sub>n \<mu>) else \<psi>
      | (\<phi> V\<^sub>n \<mu>, \<nu> V\<^sub>n \<mu>') \<Rightarrow> if \<mu> = \<mu>' then (\<phi> or\<^sub>n \<nu>) V\<^sub>n \<mu> else \<psi>
      | _ \<Rightarrow> \<psi>)
  | _ \<Rightarrow> \<psi>"

lemma ltln_rewrite_step_unfold[code_unfold]:
  "ltln_rewrite_step = ltln_rewrite_step_impl"
proof -
  { fix \<psi> :: "'a ltln"
    have "ltln_rewrite_step \<psi> = ltln_rewrite_step_impl \<psi>"
    unfolding ltln_rewrite_step_impl_def by (cases \<psi>) (auto split:ltln.split) }
  thus ?thesis by auto
qed

end

end


(*  Title:      POPLmark/POPLmarkRecordCtxt.thy
    Author:     Stefan Berghofer, TU Muenchen, 2005
*)

theory POPLmarkRecordCtxt
imports POPLmarkRecord
begin

section {* Evaluation contexts *}

text {*
\label{sec:evaluation-ctxt}
In this section, we present a different way of formalizing the evaluation relation.
Rather than using additional congruence rules, we first formalize a set @{text ctxt}
of evaluation contexts, describing the locations in a term where reductions
can occur. We have chosen a higher-order formalization of evaluation contexts as
functions from terms to terms. We define simultaneously a set @{text rctxt}
of evaluation contexts for records represented as functions from terms to lists
of fields.
*}

inductive_set
  ctxt :: "(trm \<Rightarrow> trm) set"
  and rctxt :: "(trm \<Rightarrow> rcd) set"
where
  C_Hole: "(\<lambda>t. t) \<in> ctxt"
| C_App1: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. E t \<bullet> u) \<in> ctxt"
| C_App2: "v \<in> value \<Longrightarrow> E \<in> ctxt \<Longrightarrow> (\<lambda>t. v \<bullet> E t) \<in> ctxt"
| C_TApp: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. E t \<bullet>\<^sub>\<tau> T) \<in> ctxt"
| C_Proj: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. E t..l) \<in> ctxt"
| C_Rcd: "E \<in> rctxt \<Longrightarrow> (\<lambda>t. Rcd (E t)) \<in> ctxt"
| C_Let: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. LET p = E t IN u) \<in> ctxt"
| C_hd: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. (l, E t) \<Colon> fs) \<in> rctxt"
| C_tl: "v \<in> value \<Longrightarrow> E \<in> rctxt \<Longrightarrow> (\<lambda>t. (l, v) \<Colon> E t) \<in> rctxt"

lemmas rctxt_induct = ctxt_rctxt.inducts(2)
  [of _ "\<lambda>x. True", simplified True_simps, consumes 1, case_names C_hd C_tl]

lemma rctxt_labels:
  assumes H: "E \<in> rctxt"
  shows "E t\<langle>l\<rangle>\<^sub>? = \<bottom> \<Longrightarrow> E t'\<langle>l\<rangle>\<^sub>? = \<bottom>" using H
  by (induct rule: rctxt_induct) auto

text {*
The evaluation relation @{text "t \<longmapsto>\<^sub>c t'"} is now characterized by the rule @{text E_Ctxt},
which allows reductions in arbitrary contexts, as well as the rules @{text E_Abs},
@{text E_TAbs}, @{text E_LetV}, and @{text E_ProjRcd} describing the ``immediate''
reductions, which have already been presented in \secref{sec:evaluation} and
\secref{sec:evaluation-rcd}.
*}

inductive
  eval :: "trm \<Rightarrow> trm \<Rightarrow> bool"  (infixl "\<longmapsto>\<^sub>c" 50)
where
  E_Ctxt: "t \<longmapsto>\<^sub>c t' \<Longrightarrow> E \<in> ctxt \<Longrightarrow> E t \<longmapsto>\<^sub>c E t'"
| E_Abs: "v\<^sub>2 \<in> value \<Longrightarrow> (\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> v\<^sub>2 \<longmapsto>\<^sub>c t\<^sub>1\<^sub>2[0 \<mapsto> v\<^sub>2]"
| E_TAbs: "(\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto>\<^sub>c t\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]"
| E_LetV: "v \<in> value \<Longrightarrow> \<turnstile> p \<rhd> v \<Rightarrow> ts \<Longrightarrow> (LET p = v IN t) \<longmapsto>\<^sub>c t[0 \<mapsto>\<^sub>s ts]"
| E_ProjRcd: "fs\<langle>l\<rangle>\<^sub>? = \<lfloor>v\<rfloor> \<Longrightarrow> v \<in> value \<Longrightarrow> Rcd fs..l \<longmapsto>\<^sub>c v"

text {*
In the proof of the preservation theorem, the case corresponding to the rule @{text E_Ctxt}
requires a lemma stating that replacing
a term @{term t} in a well-typed term of the form @{term "E t"}, where @{term E} is
a context, by a term @{term t'} of the same type does not change the type of the
resulting term @{term "E t'"}.
The proof is by mutual induction on the typing derivations for terms and records.
*}

lemma context_typing: -- {* A.18 *}
  "\<Gamma> \<turnstile> u : T \<Longrightarrow> E \<in> ctxt \<Longrightarrow> u = E t \<Longrightarrow>
     (\<And>T\<^sub>0. \<Gamma> \<turnstile> t : T\<^sub>0 \<Longrightarrow> \<Gamma> \<turnstile> t' : T\<^sub>0) \<Longrightarrow> \<Gamma> \<turnstile> E t' : T"
  "\<Gamma> \<turnstile> fs [:] fTs \<Longrightarrow> E\<^sub>r \<in> rctxt \<Longrightarrow> fs = E\<^sub>r t \<Longrightarrow>
     (\<And>T\<^sub>0. \<Gamma> \<turnstile> t : T\<^sub>0 \<Longrightarrow> \<Gamma> \<turnstile> t' : T\<^sub>0) \<Longrightarrow> \<Gamma> \<turnstile> E\<^sub>r t' [:] fTs"
proof (induct arbitrary: E t t' and E\<^sub>r t t' set: typing typings)
  case (T_Var \<Gamma> i U T E t t')
  from `E \<in> ctxt`
  have "E = (\<lambda>t. t)" using T_Var by cases simp_all
  with T_Var show ?case by (blast intro: typing_typings.intros)
next
  case (T_Abs T\<^sub>1 T\<^sub>2 \<Gamma> t\<^sub>2 E t t')
  from `E \<in> ctxt`
  have "E = (\<lambda>t. t)" using T_Abs by cases simp_all
  with T_Abs show ?case by (blast intro: typing_typings.intros)
next
  case (T_App \<Gamma> t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2 E t t')
  from `E \<in> ctxt`
  show ?case using T_App
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_TAbs T\<^sub>1 \<Gamma> t\<^sub>2 T\<^sub>2 E t t')
  from `E \<in> ctxt`
  have "E = (\<lambda>t. t)" using T_TAbs by cases simp_all
  with T_TAbs show ?case by (blast intro: typing_typings.intros)
next
  case (T_TApp \<Gamma> t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 E t t')
  from `E \<in> ctxt`
  show ?case using T_TApp
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Sub \<Gamma> t S T E ta t')
  thus ?case by (blast intro: typing_typings.intros)
next
  case (T_Let \<Gamma> t\<^sub>1 T\<^sub>1 p \<Delta> t\<^sub>2 T\<^sub>2 E t t')
  from `E \<in> ctxt`
  show ?case using T_Let
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Rcd \<Gamma> fs fTs E t t')
  from `E \<in> ctxt`
  show ?case using T_Rcd
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Proj \<Gamma> t fTs l T E ta t')
  from `E \<in> ctxt`
  show ?case using T_Proj
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Nil \<Gamma> E t t')
  from `E \<in> rctxt`
  show ?case using T_Nil
    by cases simp_all
next
  case (T_Cons \<Gamma> t T fs fTs l E ta t')
  from `E \<in> rctxt`
  show ?case using T_Cons
    by cases (blast intro: typing_typings.intros rctxt_labels)+
qed

text {*
The fact that immediate reduction preserves the types of terms is
proved in several parts. The proof of each statement is by induction
on the typing derivation.
*}

theorem Abs_preservation: -- {* A.19(1) *}
  assumes H: "\<Gamma> \<turnstile> (\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> t\<^sub>2 : T"
  shows "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto> t\<^sub>2] : T"
  using H
proof (induct \<Gamma> "(\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> t\<^sub>2" T arbitrary: T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 t\<^sub>2 rule: typing_induct)
  case (T_App \<Gamma> T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2 T\<^sub>1\<^sub>1' t\<^sub>1\<^sub>2)
  from `\<Gamma> \<turnstile> (\<lambda>:T\<^sub>1\<^sub>1'. t\<^sub>1\<^sub>2) : T\<^sub>1\<^sub>1 \<rightarrow> T\<^sub>1\<^sub>2`
  obtain S'
    where T\<^sub>1\<^sub>1: "\<Gamma> \<turnstile> T\<^sub>1\<^sub>1 <: T\<^sub>1\<^sub>1'"
    and t\<^sub>1\<^sub>2: "VarB T\<^sub>1\<^sub>1' \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : S'"
    and S': "\<Gamma> \<turnstile> S'[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau> <: T\<^sub>1\<^sub>2" by (rule Abs_type' [simplified]) blast
  from `\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1`
  have "\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1'" using T\<^sub>1\<^sub>1 by (rule T_Sub)
  with t\<^sub>1\<^sub>2 have "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto> t\<^sub>2] : S'[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>"
    by (rule subst_type [where \<Delta>="[]", simplified])
  then show ?case using S' by (rule T_Sub)
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem TAbs_preservation: -- {* A.19(2) *}
  assumes H: "\<Gamma> \<turnstile> (\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2 : T"
  shows "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2] : T"
  using H
proof (induct \<Gamma> "(\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2" T arbitrary: T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 T\<^sub>2 rule: typing_induct)
  case (T_TApp \<Gamma> T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 T\<^sub>1\<^sub>1' t\<^sub>1\<^sub>2)
  from `\<Gamma> \<turnstile> (\<lambda><:T\<^sub>1\<^sub>1'. t\<^sub>1\<^sub>2) : (\<forall><:T\<^sub>1\<^sub>1. T\<^sub>1\<^sub>2)`
  obtain S'
    where "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : S'"
    and "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> S' <: T\<^sub>1\<^sub>2" by (rule TAbs_type') blast
  hence "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : T\<^sub>1\<^sub>2" by (rule T_Sub)
  then show ?case using `\<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>1\<^sub>1`
    by (rule substT_type [where \<Delta>="[]", simplified])
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem Let_preservation: -- {* A.19(3) *}
  assumes H: "\<Gamma> \<turnstile> (LET p = t\<^sub>1 IN t\<^sub>2) : T"
  shows "\<turnstile> p \<rhd> t\<^sub>1 \<Rightarrow> ts \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>2[0 \<mapsto>\<^sub>s ts] : T"
  using H
proof (induct \<Gamma> "LET p = t\<^sub>1 IN t\<^sub>2" T arbitrary: p t\<^sub>1 t\<^sub>2 ts rule: typing_induct)
  case (T_Let \<Gamma> t\<^sub>1 T\<^sub>1 p \<Delta> t\<^sub>2 T\<^sub>2 ts)
  from `\<turnstile> p : T\<^sub>1 \<Rightarrow> \<Delta>` `\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1` `\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2` `\<turnstile> p \<rhd> t\<^sub>1 \<Rightarrow> ts`
  show ?case
    by (rule match_type(1) [of _ _ _ _ _ "[]", simplified])
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem Proj_preservation: -- {* A.19(4) *}
  assumes H: "\<Gamma> \<turnstile> Rcd fs..l : T"
  shows "fs\<langle>l\<rangle>\<^sub>? = \<lfloor>v\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile> v : T"
  using H
proof (induct \<Gamma> "Rcd fs..l" T arbitrary: fs l v rule: typing_induct)
  case (T_Proj \<Gamma> fTs l T fs v)
  from `\<Gamma> \<turnstile> Rcd fs : RcdT fTs`
  have "\<forall>(l, U)\<in>set fTs. \<exists>u. fs\<langle>l\<rangle>\<^sub>? = \<lfloor>u\<rfloor> \<and> \<Gamma> \<turnstile> u : U"
    by (rule Rcd_type1')
  with T_Proj show ?case by (fastforce dest: assoc_set)
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem preservation: -- {* A.20 *}
  assumes H: "t \<longmapsto>\<^sub>c t'"
  shows "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> t' : T" using H
proof (induct arbitrary: \<Gamma> T)
  case (E_Ctxt t t' E \<Gamma> T)
  from E_Ctxt(4,3) refl E_Ctxt(2)
  show ?case by (rule context_typing)
next
  case (E_Abs v\<^sub>2 T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 \<Gamma> T)
  from E_Abs(2)
  show ?case by (rule Abs_preservation)
next
  case (E_TAbs T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 T\<^sub>2 \<Gamma> T)
  thus ?case by (rule TAbs_preservation)
next
  case (E_LetV v p ts t \<Gamma> T)
  from E_LetV(3,2)
  show ?case by (rule Let_preservation)
next
  case (E_ProjRcd fs l v \<Gamma> T)
  from E_ProjRcd(3,1)
  show ?case by (rule Proj_preservation)
qed

text {*
For the proof of the progress theorem, we need a lemma stating that each well-typed,
closed term @{term t} is either a canonical value, or can be decomposed into an
evaluation context @{term E} and a term @{term "t\<^sub>0"} such that @{term "t\<^sub>0"} is a redex.
The proof of this result, which is called the {\it decomposition lemma}, is again
by induction on the typing derivation.
A similar property is also needed for records.
*}

theorem context_decomp: -- {* A.15 *}
  "[] \<turnstile> t : T \<Longrightarrow>
     t \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')"
  "[] \<turnstile> fs [:] fTs \<Longrightarrow>
     (\<forall>(l, t) \<in> set fs. t \<in> value) \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> rctxt \<and> fs = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')"
proof (induct "[]::env" t T and "[]::env" fs fTs set: typing typings)
  case T_Var
  thus ?case by simp
next
  case T_Abs
  from value.Abs show ?case ..
next
  case (T_App t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2)
  from `t\<^sub>1 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')`
  show ?case
  proof
    assume t\<^sub>1_val: "t\<^sub>1 \<in> value"
    with T_App obtain t S where t\<^sub>1: "t\<^sub>1 = (\<lambda>:S. t)"
      by (auto dest!: Fun_canonical)
    from `t\<^sub>2 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>2 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')`
    show ?thesis
    proof
      assume "t\<^sub>2 \<in> value"
      with t\<^sub>1 have "t\<^sub>1 \<bullet> t\<^sub>2 \<longmapsto>\<^sub>c t[0 \<mapsto> t\<^sub>2]"
        by simp (rule eval.intros)
      thus ?thesis by (iprover intro: C_Hole)
    next
      assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>2 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
      with t\<^sub>1_val show ?thesis by (iprover intro: ctxt_rctxt.intros)
    qed
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?thesis by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case T_TAbs
  from value.TAbs show ?case ..
next
  case (T_TApp t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2)
  from `t\<^sub>1 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')`
  show ?case
  proof
    assume "t\<^sub>1 \<in> value"
    with T_TApp obtain t S where "t\<^sub>1 = (\<lambda><:S. t)"
      by (auto dest!: TyAll_canonical)
    hence "t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto>\<^sub>c t[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]" by simp (rule eval.intros)
    thus ?thesis by (iprover intro: C_Hole)
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?thesis by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case (T_Sub t S T)
  show ?case by (rule T_Sub)
next
  case (T_Let t\<^sub>1 T\<^sub>1 p \<Delta> t\<^sub>2 T\<^sub>2)
  from `t\<^sub>1 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')`
  show ?case
  proof
    assume t\<^sub>1: "t\<^sub>1 \<in> value"
    with T_Let have "\<exists>ts. \<turnstile> p \<rhd> t\<^sub>1 \<Rightarrow> ts"
      by (auto intro: ptyping_match)
    with t\<^sub>1 show ?thesis by (iprover intro: eval.intros C_Hole)
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?thesis by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case (T_Rcd fs fTs)
  thus ?case by (blast intro: value.intros eval.intros ctxt_rctxt.intros)
next
  case (T_Proj t fTs l T)
  from `t \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')`
  show ?case
  proof
    assume tv: "t \<in> value"
    with T_Proj obtain fs where
      t: "t = Rcd fs" and fs: "\<forall>(l, t) \<in> set fs. t \<in> value"
      by (auto dest: RcdT_canonical)
    with T_Proj have "[] \<turnstile> Rcd fs : RcdT fTs" by simp
    hence "\<forall>(l, U)\<in>set fTs. \<exists>u. fs\<langle>l\<rangle>\<^sub>? = \<lfloor>u\<rfloor> \<and> [] \<turnstile> u : U"
      by (rule Rcd_type1')
    with T_Proj obtain u where u: "fs\<langle>l\<rangle>\<^sub>? = \<lfloor>u\<rfloor>" by (blast dest: assoc_set)
    with fs have "u \<in> value" by (blast dest: assoc_set)
    with u t show ?thesis by (iprover intro: eval.intros C_Hole)
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?case by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case T_Nil
  show ?case by simp
next
  case (T_Cons t T fs fTs l)
  thus ?case by (auto intro: ctxt_rctxt.intros)
qed

theorem progress: -- {* A.16 *}
  assumes H: "[] \<turnstile> t : T"
  shows "t \<in> value \<or> (\<exists>t'. t \<longmapsto>\<^sub>c t')"
proof -
  from H have "t \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')"
    by (rule context_decomp)
  thus ?thesis by (iprover intro: eval.intros)
qed

text {*
Finally, we prove that the two definitions of the evaluation relation
are equivalent. The proof that @{term "t \<longmapsto>\<^sub>c t'"} implies @{term "t \<longmapsto> t'"}
requires a lemma stating that @{text "\<longmapsto>"} is compatible with evaluation contexts.
*}

lemma ctxt_imp_eval:
  "E \<in> ctxt \<Longrightarrow> t \<longmapsto> t' \<Longrightarrow> E t \<longmapsto> E t'"
  "E\<^sub>r \<in> rctxt \<Longrightarrow> t \<longmapsto> t' \<Longrightarrow> E\<^sub>r t [\<longmapsto>] E\<^sub>r t'"
  by (induct rule: ctxt_rctxt.inducts) (auto intro: eval_evals.intros)

lemma eval_evalc_eq: "(t \<longmapsto> t') = (t \<longmapsto>\<^sub>c t')"
proof
  fix ts ts'
  have r: "t \<longmapsto> t' \<Longrightarrow> t \<longmapsto>\<^sub>c t'" and
    "ts [\<longmapsto>] ts' \<Longrightarrow> \<exists>E t t'. E \<in> rctxt \<and> ts = E t \<and> ts' = E t' \<and> t \<longmapsto>\<^sub>c t'"
    by (induct rule: eval_evals.inducts) (iprover intro: ctxt_rctxt.intros eval.intros)+
  assume "t \<longmapsto> t'"
  thus "t \<longmapsto>\<^sub>c t'" by (rule r)
next
  assume "t \<longmapsto>\<^sub>c t'"
  thus "t \<longmapsto> t'"
    by induct (auto intro: eval_evals.intros ctxt_imp_eval)
qed

end


theory NF_Impl
  imports NF
    Type_Instances_Impl
begin

subsubsection \<open>Implementation of normal form construction\<close>
(* Implementation *)
fun supteq_list :: "('f, 'v) Term.term \<Rightarrow> ('f, 'v) Term.term list"
where
  "supteq_list (Var x) = [Var x]" |
  "supteq_list (Fun f ts) = Fun f ts # concat (map supteq_list ts)"

fun supt_list :: "('f, 'v) Term.term \<Rightarrow> ('f, 'v) Term.term list"
where
  "supt_list (Var x) = []" |
  "supt_list (Fun f ts) = concat (map supteq_list ts)"

lemma supteq_list [simp]:
  "set (supteq_list t) = {s. t \<unrhd> s}"
proof (rule set_eqI, simp)
  fix s
  show "s \<in> set(supteq_list t) = (t \<unrhd> s)"
  proof (induct t, simp add: supteq_var_imp_eq)
    case (Fun f ss)
    show ?case
    proof (cases "Fun f ss = s", (auto)[1])
      case False
      show ?thesis
      proof
        assume "Fun f ss \<unrhd> s"
        with False have sup: "Fun f ss \<rhd> s" using supteq_supt_conv by auto
        obtain C where "C \<noteq> \<box>" and "Fun f ss = C\<langle>s\<rangle>" using sup by auto
        then obtain b D a where "Fun f ss = Fun f (b @ D\<langle>s\<rangle> # a)" by (cases C, auto)
        then have D: "D\<langle>s\<rangle> \<in> set ss" by auto
        with Fun[OF D] ctxt_imp_supteq[of D s] obtain t where "t \<in> set ss" and "s \<in> set (supteq_list t)" by auto
        then show "s \<in> set (supteq_list (Fun f ss))" by auto
      next
        assume "s \<in> set (supteq_list (Fun f ss))"
        with False obtain t where t: "t \<in> set ss" and "s \<in> set (supteq_list t)" by auto
        with Fun[OF t] have "t \<unrhd> s" by auto
        with t show "Fun f ss \<unrhd> s" by auto
      qed
    qed
  qed
qed

lemma supt_list_sound [simp]:
  "set (supt_list t) = {s. t \<rhd> s}"
  by (cases t) auto

fun mergeP_impl where
  "mergeP_impl Bot t = True"
| "mergeP_impl t Bot = True"
| "mergeP_impl (BFun f ss) (BFun g ts) =
  (if f = g \<and> length ss = length ts then list_all (\<lambda> (x, y). mergeP_impl x y) (zip ss ts)  else False)"

lemma [simp]: "mergeP_impl s t \<longleftrightarrow> (s, t) \<in> mergeP" (is "?LS = ?RS")
proof
  show "?LS \<Longrightarrow> ?RS"
    by (induct rule: mergeP_impl.induct, auto split: if_splits intro!: step)
      (smt length_zip list_all_length mergeP.step min_less_iff_conj nth_mem nth_zip old.prod.case)
next
  show "?RS \<Longrightarrow> ?LS" by (induct rule: mergeP.induct, auto simp add: list_all_length)
qed

fun bless_eq_impl where
  "bless_eq_impl Bot t = True"
| "bless_eq_impl (BFun f ss) (BFun g ts) =
  (if f = g \<and> length ss = length ts then list_all (\<lambda> (x, y). bless_eq_impl x y) (zip ss ts) else False)"
| "bless_eq_impl _ _ = False"

lemma [simp]: "bless_eq_impl s t \<longleftrightarrow> (s, t) \<in> bless_eq" (is "?RS = ?LS")
proof
  show "?LS \<Longrightarrow> ?RS" by (induct rule: bless_eq.induct, auto simp add: list_all_length)
next
  show "?RS \<Longrightarrow> ?LS"
    by (induct rule: bless_eq_impl.induct, auto split: if_splits intro!: bless_eq.step)
      (metis (full_types) length_zip list_all_length min_less_iff_conj nth_mem nth_zip old.prod.case)
qed

definition "psubt_bot_impl R \<equiv> remdups (map term_to_bot_term (concat (map supt_list R)))"
lemma psubt_bot_impl[simp]: "set (psubt_bot_impl R) = psubt_lhs_bot (set R)"
  by (induct R, auto simp: psubt_bot_impl_def)

definition "states_impl R = List.insert Bot (map the (removeAll None
    (closure_impl (lift_f_total mergeP_impl (\<up>)) (map Some (psubt_bot_impl R)))))"

lemma states_impl [simp]: "set (states_impl R) = states (set R)"
proof -
  have [simp]: "lift_f_total mergeP_impl (\<up>) = lift_f_total (\<lambda> x y. mergeP_impl x y) (\<up>)" by blast
  show ?thesis unfolding states_impl_def states_def
    using lift_total.cl.closure_impl
    by (simp add: lift_total.cl.pred_closure_lift_closure)
qed

abbreviation check_intance_lhs where
  "check_intance_lhs qs f R \<equiv> list_all (\<lambda> u. \<not> bless_eq_impl u (BFun f qs)) R"

definition min_elem where
  "min_elem s ss = (let ts = filter (\<lambda> x. bless_eq_impl x s) ss in
      foldr (\<up>) ts Bot)"

lemma bound_impl [simp, code]:
  "bound_max s (set ss) = min_elem s ss"
proof -
  have [simp]: "{y. lift_total.lifted_less_eq y (Some s) \<and> y \<in> Some ` set ss} = Some ` {x \<in> set ss. x \<le>\<^sub>b s}"
    by auto
  then show ?thesis
    using lift_total.supremum_impl[of "filter (\<lambda> x. bless_eq_impl x s) ss"]
    using lift_total.supremum_smaller_exists_unique[of "set ss" s]
    by (auto simp: min_elem_def Let_def lift_total.lift_ord.smaller_subset_def)
qed

definition nf_rule_impl where
  "nf_rule_impl S R SR h = (let (f, n) = h in
     let states = List.n_lists n S in
     let nlhs_inst = filter (\<lambda> qs. check_intance_lhs qs f R) states in
     map (\<lambda> qs. TA_rule f qs (min_elem (BFun f qs) SR)) nlhs_inst)"

abbreviation nf_rules_impl where
  "nf_rules_impl R \<F> \<equiv> concat (map (nf_rule_impl (states_impl R) (map term_to_bot_term R) (psubt_bot_impl R)) \<F>)"

(* Section proves that the implementation constructs the same rule set *)

lemma nf_rules_in_impl:
  assumes "TA_rule f qs q |\<in>| nf_rules (fset_of_list R) (fset_of_list \<F>)"
  shows "TA_rule f qs q |\<in>| fset_of_list (nf_rules_impl R \<F>)"
proof -
  have funas: "(f, length qs) \<in> set \<F>" and st: "fset_of_list qs |\<subseteq>| fstates (fset_of_list R)"
   and nlhs: "\<not>(\<exists> s \<in> (set R). s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
   and min: "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
    using assms by (auto simp add: nf_rules_fmember simp flip: fset_of_list_elem fmember_iff_member_fset)
  then have st_impl: "qs |\<in>| fset_of_list (List.n_lists (length qs) (states_impl R))"
    by (auto simp add: fset_of_list_elem subset_code(1) set_n_lists
        fset_of_list.rep_eq less_eq_fset.rep_eq fstates.rep_eq)
  from nlhs have nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
    by (auto simp: list.pred_set)
  have min_impl: "q = min_elem (BFun f qs) (psubt_bot_impl R)"
    using bound_impl min
    by (auto simp flip: psubt_bot_impl)
  then show ?thesis using funas nlhs_impl funas st_impl unfolding nf_rule_impl_def
    by (auto simp: fset_of_list_elem)
qed

lemma nf_rules_impl_in_rules:
  assumes "TA_rule f qs q |\<in>| fset_of_list (nf_rules_impl R \<F>)"
  shows "TA_rule f qs q |\<in>| nf_rules (fset_of_list R) (fset_of_list \<F>)"
proof -
  have funas: "(f, length qs) \<in> set \<F>"
   and st_impl: "qs |\<in>| fset_of_list (List.n_lists (length qs) (states_impl R))"
   and nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
   and min: "q = min_elem (BFun f qs) (psubt_bot_impl R)" using assms
    by (auto simp add: set_n_lists nf_rule_impl_def fset_of_list_elem)
  from st_impl have st: "fset_of_list qs |\<subseteq>| fstates (fset_of_list R)"
    by (force simp: set_n_lists fset_of_list_elem fstates.rep_eq fmember_iff_member_fset fset_of_list.rep_eq)
  from nlhs_impl have nlhs: "\<not>(\<exists> l \<in> (set R). l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
    by auto (metis (no_types, lifting) Ball_set_list_all in_set_idx length_map nth_map nth_mem)
  have "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
    using bound_impl min
    by (auto simp flip: psubt_bot_impl)
  then show ?thesis using funas st nlhs
    by (auto simp add: nf_rules_fmember fset_of_list_elem fset_of_list.rep_eq)
qed

lemma rule_set_eq:
  shows "nf_rules (fset_of_list R) (fset_of_list \<F>) = fset_of_list (nf_rules_impl R \<F>)" (is "?Ls = ?Rs")
proof -
  {fix r assume "r |\<in>| ?Ls" then have "r |\<in>| ?Rs"
      using nf_rules_in_impl[where ?R = R and ?\<F> = \<F>]
      by (cases r) auto}
  moreover
  {fix r assume "r |\<in>| ?Rs" then have "r |\<in>| ?Ls"
      using nf_rules_impl_in_rules[where ?R = R and ?\<F> = \<F>]
      by (cases r) auto}
  ultimately show ?thesis by blast
qed

(* Code equation for normal form TA *)

lemma fstates_code[code]:
  "fstates R = fset_of_list (states_impl (sorted_list_of_fset R))"
  by (auto simp: fmember_iff_member_fset fstates.rep_eq fset_of_list.rep_eq)

lemma nf_ta_code [code]:
  "nf_ta R \<F> = TA (fset_of_list (nf_rules_impl (sorted_list_of_fset R) (sorted_list_of_fset \<F>))) {||}"
  unfolding nf_ta_def using rule_set_eq[of "sorted_list_of_fset R" "sorted_list_of_fset \<F>"]
  by (intro TA_equalityI) auto

(*
export_code nf_ta in Haskell
*)

end


theory ArityAnalysisCorrDenotational
imports ArityAnalysisSpec Launchbury.Denotational ArityTransform
begin

context ArityAnalysisLetSafe
begin

inductive eq :: "Arity \<Rightarrow> Value \<Rightarrow> Value \<Rightarrow> bool" where
   "eq 0 v v"
 |  "(\<And> v. eq n (v1 \<down>Fn v) (v2 \<down>Fn v)) \<Longrightarrow> eq (inc\<cdot>n) v1 v2"

lemma eq_inc_simp:
  "eq (inc\<cdot>n) v1 v2 \<longleftrightarrow> (\<forall> v . eq n (v1 \<down>Fn v) (v2 \<down>Fn v))"
  by (auto elim: eq.cases intro: eq.intros)

lemma eq_FnI:
  "(\<And> v. eq (pred\<cdot>n) (f1\<cdot>v) (f2\<cdot>v)) \<Longrightarrow> eq n (Fn\<cdot>f1) (Fn\<cdot>f2)"
  by (induction n rule: Arity_ind) (auto intro: eq.intros cfun_eqI)

lemma eq_refl[simp]: "eq a v v"
  by (induction a arbitrary: v rule: Arity_ind) (auto intro!: eq.intros)

lemma eq_trans[trans]: "eq a v1 v2 \<Longrightarrow> eq a v2 v3 \<Longrightarrow> eq a v1 v3"
  apply (induction a arbitrary: v1 v2 v3 rule: Arity_ind)
  apply (auto elim!: eq.cases intro!: eq.intros)
  apply blast
  done

lemma eq_Fn: "eq a v1 v2 \<Longrightarrow> eq (pred\<cdot>a) (v1 \<down>Fn v) (v2 \<down>Fn v)"
apply (induction a  rule: Arity_ind[case_names 0 inc])
apply (auto simp add: eq_inc_simp)
done

lemma eq_inc_same: "eq a v1 v2 \<Longrightarrow> eq (inc\<cdot>a) v1 v2"
by (induction a  arbitrary: v1 v2 rule: Arity_ind[case_names 0 inc])  (auto simp add: eq_inc_simp)

lemma eq_mono: "a \<sqsubseteq> a' \<Longrightarrow> eq a' v1 v2 \<Longrightarrow> eq a v1 v2"
proof (induction a  rule: Arity_ind[case_names 0 inc])
  case 0 thus ?case by auto
next
  case (inc a)
  show "eq (inc\<cdot>a) v1 v2"
  proof (cases "inc\<cdot>a = a'")
    case True with inc show ?thesis by simp
  next
    case False with \<open>inc\<cdot>a \<sqsubseteq> a'\<close> have "a \<sqsubseteq> a'"
      by (simp add: inc_def)(transfer, simp)
    from this inc.prems(2)
    have "eq a v1 v2" by (rule inc.IH)
    thus ?thesis by (rule eq_inc_same)
  qed
qed

lemma eq_join[simp]: "eq (a \<squnion> a') v1 v2 \<longleftrightarrow> eq a v1 v2 \<and> eq a' v1 v2"
  using Arity_total[of a a']
  apply (auto elim!: eq_mono[OF join_above1] eq_mono[OF join_above2])
  apply (metis join_self_below(2))
  apply (metis join_self_below(1))
  done

lemma eq_adm: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda> x. eq a (f x) (g x))"
proof (induction a arbitrary: f g rule: Arity_ind[case_names 0 inc])
  case 0 thus ?case by simp
next
  case inc
  show ?case
  apply (subst eq_inc_simp)
  apply (rule adm_all)
  apply (rule inc)
  apply (intro cont2cont inc(2,3))+
  done
qed

inductive eq\<rho> :: "AEnv \<Rightarrow> (var \<Rightarrow> Value) \<Rightarrow> (var \<Rightarrow> Value) \<Rightarrow> bool" where
 eq\<rho>I: "(\<And> x a. ae x = up\<cdot>a \<Longrightarrow> eq a (\<rho>1 x) (\<rho>2 x)) \<Longrightarrow> eq\<rho> ae \<rho>1 \<rho>2"

lemma eq\<rho>E: "eq\<rho> ae \<rho>1 \<rho>2 \<Longrightarrow> ae x = up\<cdot>a \<Longrightarrow> eq a (\<rho>1 x) (\<rho>2 x)"
  by (auto simp add: eq\<rho>.simps)

lemma eq\<rho>_refl[simp]: "eq\<rho> ae \<rho> \<rho>"
  by (simp add: eq\<rho>.simps)

lemma eq_esing_up[simp]: "eq\<rho> (esing x\<cdot>(up\<cdot>a)) \<rho>1 \<rho>2 \<longleftrightarrow> eq a (\<rho>1 x) (\<rho>2 x)"
  by (auto simp add: eq\<rho>.simps)

lemma eq\<rho>_mono:
  assumes "ae \<sqsubseteq> ae'"
  assumes "eq\<rho> ae' \<rho>1 \<rho>2"
  shows "eq\<rho> ae \<rho>1 \<rho>2"
proof (rule eq\<rho>I)
  fix x a
  assume "ae x = up\<cdot>a"
  with \<open>ae \<sqsubseteq> ae'\<close> have "up\<cdot>a \<sqsubseteq> ae' x" by (metis fun_belowD)
  then obtain a' where "ae' x = up\<cdot>a'" by (metis Exh_Up below_antisym minimal)
  with \<open>eq\<rho> ae' \<rho>1 \<rho>2\<close>
  have "eq a' (\<rho>1 x) (\<rho>2 x)" by (auto simp add: eq\<rho>.simps)
  with \<open>up\<cdot>a \<sqsubseteq> ae' x\<close> and \<open>ae' x = up\<cdot>a'\<close>
  show "eq a (\<rho>1 x) (\<rho>2 x)" by (metis eq_mono up_below)
qed

lemma eq\<rho>_adm: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda> x. eq\<rho> a (f x) (g x))"
  apply (simp add: eq\<rho>.simps)
  apply (intro adm_lemmas eq_adm)
  apply (erule cont2cont_fun)+
  done

lemma up_join_eq_up[simp]: "up\<cdot>(n::'a::Finite_Join_cpo) \<squnion> up\<cdot>n' = up\<cdot>(n \<squnion> n')"
  apply (rule lub_is_join)
  apply (auto simp add: is_lub_def )
  apply (case_tac u)
  apply auto
  done

lemma eq\<rho>_join[simp]: "eq\<rho> (ae \<squnion> ae') \<rho>1 \<rho>2 \<longleftrightarrow> eq\<rho> ae \<rho>1 \<rho>2 \<and> eq\<rho> ae' \<rho>1 \<rho>2"
  apply (auto elim!: eq\<rho>_mono[OF join_above1] eq\<rho>_mono[OF join_above2])
  apply (auto intro!: eq\<rho>I)
  apply (case_tac "ae x", auto elim: eq\<rho>E)
  apply (case_tac "ae' x", auto elim: eq\<rho>E)
  done

lemma eq\<rho>_override[simp]:
  "eq\<rho> ae (\<rho>1 ++\<^bsub>S\<^esub> \<rho>2) (\<rho>1' ++\<^bsub>S\<^esub>\<rho>2') \<longleftrightarrow> eq\<rho> ae (\<rho>1 f|` (- S)) (\<rho>1' f|` (- S)) \<and>  eq\<rho> ae (\<rho>2 f|` S) (\<rho>2' f|` S)"
  by (auto simp add: lookup_env_restr_eq eq\<rho>.simps lookup_override_on_eq)

lemma Aexp_heap_below_Aheap:
  assumes "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>a'"
  assumes "map_of \<Gamma> x = Some e'"
  shows "Aexp e'\<cdot>a' \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a"
proof-
  from assms(1)
  have "Aexp e'\<cdot>a' = ABind x e'\<cdot>(Aheap \<Gamma> e\<cdot>a)"
    by (simp del: join_comm fun_meet_simp)
  also have "\<dots> \<sqsubseteq> ABinds \<Gamma>\<cdot>(Aheap \<Gamma> e\<cdot>a)"
    by (rule monofun_cfun_fun[OF ABind_below_ABinds[OF \<open>map_of _ _ = _\<close>]])
  also have "\<dots> \<sqsubseteq> ABinds \<Gamma>\<cdot>(Aheap \<Gamma> e\<cdot>a) \<squnion>  Aexp e\<cdot>a"
    by simp
  also note Aexp_Let
  finally
  show ?thesis by this simp_all
qed

lemma Aexp_body_below_Aheap:
  shows "Aexp e\<cdot>a \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a"
  by (rule below_trans[OF join_above2 Aexp_Let])

lemma Aexp_correct: "eq\<rho> (Aexp e\<cdot>a) \<rho>1 \<rho>2 \<Longrightarrow> eq a (\<lbrakk>e\<rbrakk>\<^bsub>\<rho>1\<^esub>) (\<lbrakk>e\<rbrakk>\<^bsub>\<rho>2\<^esub>)"
proof(induction a e arbitrary: \<rho>1 \<rho>2 rule: transform.induct[case_names App Lam Var Let Bool IfThenElse])
  case (Var a x)
  from \<open>eq\<rho> (Aexp (Var x)\<cdot>a) \<rho>1 \<rho>2\<close>
  have "eq\<rho> (esing x\<cdot>(up\<cdot>a)) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_Var_singleton])
  thus ?case by simp
next
  case (App a e x)
  from \<open>eq\<rho> (Aexp (App e x)\<cdot>a) \<rho>1 \<rho>2\<close>
  have "eq\<rho> (Aexp e\<cdot>(inc\<cdot>a) \<squnion> esing x\<cdot>(up\<cdot>0)) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_App])
  hence "eq\<rho> (Aexp e\<cdot>(inc\<cdot>a)) \<rho>1 \<rho>2" and "\<rho>1 x = \<rho>2 x" by simp_all
  from App(1)[OF this(1)] this(2)
  show ?case by (auto elim: eq.cases)
next
  case (Lam a x e)
  from  \<open>eq\<rho> (Aexp (Lam [x]. e)\<cdot>a) \<rho>1 \<rho>2\<close>
  have "eq\<rho> (env_delete x (Aexp e\<cdot>(pred\<cdot>a))) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_Lam])
  hence "\<And> v. eq\<rho> (Aexp e\<cdot>(pred\<cdot>a)) (\<rho>1(x := v)) (\<rho>2(x := v))"  by (auto intro!: eq\<rho>I elim!: eq\<rho>E)
  from Lam(1)[OF this]
  show ?case by (auto intro: eq_FnI simp del: fun_upd_apply)
next
  case (Bool b)
  show ?case by simp
next
  case (IfThenElse a scrut e\<^sub>1 e\<^sub>2)
  from \<open>eq\<rho> (Aexp (scrut ? e\<^sub>1 : e\<^sub>2)\<cdot>a) \<rho>1 \<rho>2\<close>
  have "eq\<rho> (Aexp scrut\<cdot>0 \<squnion> Aexp e\<^sub>1\<cdot>a \<squnion> Aexp e\<^sub>2\<cdot>a) \<rho>1 \<rho>2" by (rule eq\<rho>_mono[OF Aexp_IfThenElse])
  hence "eq\<rho> (Aexp scrut\<cdot>0) \<rho>1 \<rho>2"
  and   "eq\<rho> (Aexp e\<^sub>1\<cdot>a) \<rho>1 \<rho>2"
  and   "eq\<rho> (Aexp e\<^sub>2\<cdot>a) \<rho>1 \<rho>2" by simp_all
  from IfThenElse(1)[OF this(1)] IfThenElse(2)[OF this(2)] IfThenElse(3)[OF this(3)]
  show ?case
    by (cases "\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>2\<^esub>") auto
next
  case (Let a \<Gamma> e)

  have "eq\<rho> (Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) (\<lbrace>\<Gamma>\<rbrace>\<rho>1) (\<lbrace>\<Gamma>\<rbrace>\<rho>2)"
  proof(induction rule: parallel_HSem_ind[case_names adm bottom step])
    case adm thus ?case by (intro eq\<rho>_adm cont2cont)
  next
    case bottom show ?case by simp
  next
    case (step \<rho>1' \<rho>2')
    show ?case
    proof (rule eq\<rho>I)
      fix x a'
      assume ass: "(Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) x = up\<cdot>a'"
      show "eq a' ((\<rho>1 ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>1'\<^esub>) x) ((\<rho>2 ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>2'\<^esub>) x)"
      proof(cases "x \<in> domA \<Gamma>")
        case [simp]: True
        then obtain e' where [simp]: "map_of \<Gamma> x = Some e'" by (metis domA_map_of_Some_the)
        have "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>a'" using ass by simp
        hence "Aexp e'\<cdot>a' \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a" using \<open>map_of _ _ = _\<close> by (rule Aexp_heap_below_Aheap)
        hence "eq\<rho> (Aexp e'\<cdot>a') \<rho>1' \<rho>2'" using step(1) by (rule eq\<rho>_mono)
        hence "eq a' (\<lbrakk> e' \<rbrakk>\<^bsub>\<rho>1'\<^esub>) (\<lbrakk> e' \<rbrakk>\<^bsub>\<rho>2'\<^esub>)"
          by (rule Let(1)[OF map_of_SomeD[OF \<open>map_of _ _ = _\<close>]])
        thus ?thesis by (simp add: lookupEvalHeap')
      next
        case [simp]: False
        with edom_Aheap have "x \<notin> edom (Aheap \<Gamma> e\<cdot>a)" by blast
        hence "(Aexp (Let \<Gamma> e)\<cdot>a) x = up\<cdot>a'" using ass by (simp add: edomIff)
        with \<open>eq\<rho> (Aexp (Let \<Gamma> e)\<cdot>a) \<rho>1 \<rho>2\<close>
        have "eq a' (\<rho>1 x) (\<rho>2 x)" by (auto elim: eq\<rho>E)
        thus ?thesis by simp
      qed
    qed
  qed
  hence "eq\<rho> (Aexp e\<cdot>a) (\<lbrace>\<Gamma>\<rbrace>\<rho>1) (\<lbrace>\<Gamma>\<rbrace>\<rho>2)" by (rule eq\<rho>_mono[OF Aexp_body_below_Aheap])
  hence "eq a (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>1\<^esub>) (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>2\<^esub>)" by (rule Let(2)[simplified])
  thus ?case by simp
qed

lemma ESem_ignores_fresh[simp]: "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(fresh_var e := v)\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>"
  by (metis ESem_fresh_cong env_restr_fun_upd_other fresh_var_not_free)

lemma eq_Aeta_expand: "eq a (\<lbrakk> Aeta_expand a e \<rbrakk>\<^bsub>\<rho>\<^esub>) (\<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>)"
  apply (induction a arbitrary: e \<rho>  rule: Arity_ind[case_names 0 inc])
  apply simp
  apply (fastforce simp add: eq_inc_simp elim: eq_trans)
  done

lemma Arity_transformation_correct: "eq a (\<lbrakk> \<T>\<^bsub>a\<^esub> e \<rbrakk>\<^bsub>\<rho>\<^esub>) (\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)"
proof(induction a e arbitrary: \<rho> rule: transform.induct[case_names App Lam Var Let Bool IfThenElse])
  case Var
  show ?case by simp
next
  case (App a e x)
  from this[where \<rho> =\<rho> ]
  show ?case
    by (auto elim: eq.cases)
next
  case (Lam x e)
  thus ?case
    by (auto intro: eq_FnI)
next
  case (Bool b)
  show ?case by simp
next
  case (IfThenElse a e e\<^sub>1 e\<^sub>2)
  thus ?case by (cases "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>") auto
next
  case (Let a \<Gamma> e)

  have "eq a (\<lbrakk> transform a (Let \<Gamma> e) \<rbrakk>\<^bsub>\<rho>\<^esub>) (\<lbrakk> transform a e \<rbrakk>\<^bsub>\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>\<^esub>)"
    by simp
  also have "eq a \<dots> (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>\<^esub>)"
    using Let(2) by simp
  also have "eq a \<dots> (\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)"
  proof (rule Aexp_correct)
    have "eq\<rho> (Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) (\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>) (\<lbrace>\<Gamma>\<rbrace>\<rho>)"
    proof(induction rule: parallel_HSem_ind[case_names adm bottom step])
      case adm thus ?case by (intro eq\<rho>_adm cont2cont)
    next
      case bottom show ?case by simp
    next
      case (step \<rho>1 \<rho>2)
      have "eq\<rho> (Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) (\<^bold>\<lbrakk> map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>) \<^bold>\<rbrakk>\<^bsub>\<rho>1\<^esub>) (\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>2\<^esub>)"
      proof(rule eq\<rho>I)
        fix x a'
        assume ass: "(Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a) x = up\<cdot>a'"
        show "eq a' ((\<^bold>\<lbrakk> map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>) \<^bold>\<rbrakk>\<^bsub>\<rho>1\<^esub>) x) ((\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>2\<^esub>) x)"
        proof(cases "x \<in> domA \<Gamma>")
          case [simp]: True
          then obtain e' where [simp]: "map_of \<Gamma> x = Some e'" by (metis domA_map_of_Some_the)
          from ass have ass': "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>a'" by simp

          have "(\<^bold>\<lbrakk> map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>) \<^bold>\<rbrakk>\<^bsub>\<rho>1\<^esub>) x =
            \<lbrakk>Aeta_expand a' (transform a' e')\<rbrakk>\<^bsub>\<rho>1\<^esub>"
           by (simp add: lookupEvalHeap' map_of_map_transform ass')
          also have "eq a' \<dots> (\<lbrakk>transform a' e'\<rbrakk>\<^bsub>\<rho>1\<^esub>)"
            by (rule eq_Aeta_expand)
          also have "eq a' \<dots> (\<lbrakk>e'\<rbrakk>\<^bsub>\<rho>1\<^esub>)"
            by (rule Let(1)[OF map_of_SomeD[OF \<open>map_of _ _ = _\<close>]])
          also have "eq a' \<dots> (\<lbrakk>e'\<rbrakk>\<^bsub>\<rho>2\<^esub>)"
          proof (rule Aexp_correct)
            from ass' \<open>map_of _ _ = _\<close>
            have "Aexp e'\<cdot>a' \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a" by (rule Aexp_heap_below_Aheap)
            thus "eq\<rho> (Aexp e'\<cdot>a') \<rho>1 \<rho>2" using step by (rule eq\<rho>_mono)
          qed
          also have "\<dots> = (\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>2\<^esub>) x"
           by (simp add: lookupEvalHeap')
          finally
          show ?thesis.
        next
          case False thus ?thesis by simp
        qed
      qed
      thus ?case
        by (simp add: env_restr_useless  order_trans[OF  edom_evalHeap_subset] del: fun_meet_simp eq\<rho>_join)
    qed
    thus "eq\<rho> (Aexp e\<cdot>a) (\<lbrace>map_transform Aeta_expand (Aheap \<Gamma> e\<cdot>a) (map_transform transform (Aheap \<Gamma> e\<cdot>a) \<Gamma>)\<rbrace>\<rho>) (\<lbrace>\<Gamma>\<rbrace>\<rho>)"
        by (rule eq\<rho>_mono[OF Aexp_body_below_Aheap])
  qed
  also have "\<dots> = \<lbrakk> Let \<Gamma> e \<rbrakk>\<^bsub>\<rho>\<^esub>"
    by simp
  finally show ?case.
qed

corollary Arity_transformation_correct':
  "\<lbrakk> \<T>\<^bsub>0\<^esub> e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>"
  using Arity_transformation_correct[where a = 0] by simp

end
end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Transformation Theorem for while Loops\<close>

theory FolkTheorem
  imports Conway_Tests KAT DRAT
begin

text \<open>
  We prove Kozen's transformation theorem for while loops \cite{Kozen97} in a weak setting that unifies
  previous proofs in Kleene algebra with tests, demonic refinement algebras and a variant of probabilistic
  Kleene algebra.
\<close>

context test_pre_conway
begin

abbreviation pres :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "pres x y \<equiv> y \<cdot> x = y \<cdot> x \<cdot> y"

lemma pres_comp: "pres y z \<Longrightarrow> pres x z \<Longrightarrow> pres (x \<cdot> y) z"
  by (metis mult_assoc)

lemma test_pres1: "test p \<Longrightarrow> test q \<Longrightarrow> pres p q"
  by (simp add: local.test_mult_comm_var mult_assoc)

lemma test_pres2: "test p \<Longrightarrow> test q \<Longrightarrow> pres x q \<Longrightarrow> pres (p \<cdot> x) q"
  using pres_comp test_pres1 by blast

lemma cond_helper1:
assumes "test p" and "pres x p"
shows "p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<cdot> (p \<cdot> z + !p \<cdot> w) = p \<cdot> x\<^sup>\<dagger> \<cdot> z"
proof -
  have "p \<cdot> (p \<cdot> z + !p \<cdot> w) = p \<cdot> z"
    by (metis assms(1) local.add_zerol local.annil local.join.sup_commute local.n_left_distrib_var local.test_comp_mult2 local.test_mult_idem_var mult_assoc)
  hence "p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<cdot> (p \<cdot> z + !p \<cdot> w) = (p \<cdot> x)\<^sup>\<dagger> \<cdot> p \<cdot> z"
    using assms(1) assms(2) local.test_preserve1 mult_assoc by auto
  thus ?thesis
   using assms(1) assms(2) local.test_preserve mult_assoc by auto
qed

lemma cond_helper2:
assumes "test p" and "pres y (!p)"
shows "!p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<cdot> (p \<cdot> z + !p \<cdot> w) = !p \<cdot> y\<^sup>\<dagger> \<cdot> w"
proof -
  have "!p \<cdot> (!p \<cdot> y + !(!p) \<cdot> x)\<^sup>\<dagger> \<cdot> (!p \<cdot> w + !(!p) \<cdot> z) = !p \<cdot> y\<^sup>\<dagger> \<cdot> w"
    using assms(1) local.test_comp_closed assms(2) cond_helper1 by blast
  thus ?thesis
    using add_commute assms(1) by auto
qed

lemma cond_distr_var:
  assumes "test p" and "test q" and "test r"
  shows "(q \<cdot> p + r \<cdot> !p) \<cdot> (p \<cdot> x + !p \<cdot> y) = q \<cdot> p \<cdot> x + r \<cdot> !p \<cdot> y"
proof -
  have "(q \<cdot> p + r \<cdot> !p) \<cdot> (p \<cdot> x + !p \<cdot> y) = q \<cdot> p \<cdot> p \<cdot> x + q \<cdot> p \<cdot> !p \<cdot> y + r \<cdot> !p \<cdot> p \<cdot> x + r \<cdot> !p \<cdot> !p \<cdot> y"
    using assms(1) assms(2) assms(3) local.distrib_right' local.join.sup_assoc local.n_left_distrib_var local.test_comp_closed mult_assoc by presburger
  also have "... = q \<cdot> p \<cdot> x + q \<cdot> 0 \<cdot> y + r \<cdot> 0 \<cdot> x + r \<cdot> !p  \<cdot> y"
    by (simp add: assms(1) mult_assoc)
  finally show ?thesis
    by (metis assms(2) assms(3) local.add_zerol local.annil local.join.sup_commute local.test_mult_comm_var local.test_zero_var)
qed

theorem conditional:
assumes "test p" and "test q" and "test r1" and "test r2"
and "pres x1 q" and "pres y1 q" and "pres x2 (!q)" and "pres y2 (!q)"
shows "(p \<cdot> q + !p \<cdot> !q) \<cdot> (q \<cdot> x1 + !q \<cdot> x2) \<cdot> ((q \<cdot> r1 + !q \<cdot> r2) \<cdot> (q \<cdot> y1 + !q \<cdot> y2))\<^sup>\<dagger> \<cdot> !(q \<cdot> r1 + !q \<cdot> r2) =
(p \<cdot> q + !p \<cdot> !q) \<cdot> (p \<cdot> x1 \<cdot> (r1 \<cdot> y1)\<^sup>\<dagger> \<cdot> !r1 + !p \<cdot> x2 \<cdot> (r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> !r2)"
proof -
  have a: "p \<cdot> q \<cdot> x1 \<cdot> q \<cdot> (q \<cdot> r1 \<cdot> y1 + !q \<cdot> r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> (q \<cdot> !r1 + !q \<cdot> !r2) = p \<cdot> q \<cdot> x1 \<cdot> q \<cdot> (r1 \<cdot> y1)\<^sup>\<dagger> \<cdot> !r1"
    by (metis assms(2) assms(3)  assms(6) cond_helper1 mult_assoc test_pres2)
  have b: "!q \<cdot> (q \<cdot> r1 \<cdot> y1 + !q \<cdot> r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> (q \<cdot> !r1 + !q \<cdot> !r2) = !q \<cdot> (r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> !r2"
    by (metis assms(2) assms(4) assms(8) local.test_comp_closed cond_helper2 mult_assoc test_pres2)
  have "(p \<cdot> q + !p \<cdot> !q) \<cdot> (q \<cdot> x1 + !q \<cdot> x2) \<cdot> ((q \<cdot> r1 + !q \<cdot> r2) \<cdot> (q \<cdot> y1 + !q \<cdot> y2))\<^sup>\<dagger> \<cdot> !(q \<cdot> r1 + !q \<cdot> r2) =
        p \<cdot> q \<cdot> x1 \<cdot> q \<cdot> (q \<cdot> r1 \<cdot> y1 + !q \<cdot> r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> (q \<cdot> !r1 + !q \<cdot> !r2) + !p \<cdot> !q \<cdot> x2 \<cdot> !q \<cdot> (q \<cdot> r1 \<cdot> y1 + !q \<cdot> r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> (q \<cdot> !r1 + !q \<cdot> !r2)"
    using assms(1) assms(2) assms(3) assms(4) assms(5) assms(7) cond_distr cond_distr_var local.test_dist_var2 mult_assoc by auto
  also have "... =  p \<cdot> q \<cdot> x1 \<cdot> (r1 \<cdot> y1)\<^sup>\<dagger> \<cdot> !r1 + !p \<cdot> !q \<cdot>  x2 \<cdot> (r2 \<cdot> y2)\<^sup>\<dagger> \<cdot> !r2"
    by (metis a assms(5) assms(7) b mult_assoc)
  finally show ?thesis
    using assms(1) assms(2) cond_distr mult_assoc by auto
qed

theorem nested_loops:
  assumes "test p" and "test q"
  shows "p \<cdot> x \<cdot> ((p + q) \<cdot> (q \<cdot> y + !q \<cdot> x))\<^sup>\<dagger> \<cdot> !(p + q) + !p = (p \<cdot> x \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> !q)\<^sup>\<dagger> \<cdot> !p"
proof -
  have "p \<cdot> x \<cdot> ((p + q) \<cdot> (q \<cdot> y + !q \<cdot> x))\<^sup>\<dagger> \<cdot> !(p + q) + !p = p \<cdot> x \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> (!q \<cdot> p \<cdot> x \<cdot> (q \<cdot> y)\<^sup>\<dagger>)\<^sup>\<dagger> \<cdot> !q \<cdot> !p + !p"
    using assms(1) assms(2) local.dagger_denest2 local.test_distrib mult_assoc test_mult_comm_var by auto
  also have "... =  p \<cdot> x \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> !q \<cdot> (p \<cdot> x \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> !q)\<^sup>\<dagger>  \<cdot> !p + !p"
    by (metis local.dagger_slide mult_assoc)
  finally show ?thesis
    using add_commute by force
qed

lemma postcomputation:
  assumes "test p" and "pres y (!p)"
  shows "!p \<cdot> y + p \<cdot> (p \<cdot> x \<cdot> (!p \<cdot> y + p))\<^sup>\<dagger> \<cdot> !p = (p \<cdot> x)\<^sup>\<dagger> \<cdot> !p \<cdot> y"
proof -
  have "p \<cdot> (p \<cdot> x \<cdot> (!p \<cdot> y + p))\<^sup>\<dagger> \<cdot> !p = p \<cdot> (1 + p \<cdot> x \<cdot> ((!p \<cdot> y + p) \<cdot> p \<cdot> x)\<^sup>\<dagger> \<cdot> (!p \<cdot> y + p)) \<cdot> !p"
    by (metis dagger_prod_unfold mult.assoc)
  also have "... = (p + p \<cdot> p \<cdot> x \<cdot> ((!p \<cdot> y + p) \<cdot> p \<cdot> x)\<^sup>\<dagger> \<cdot> (!p \<cdot> y + p)) \<cdot> !p"
    using assms(1) local.mult_oner local.n_left_distrib_var mult_assoc by presburger
  also have "... = p \<cdot> x \<cdot> (!p \<cdot> y \<cdot> p \<cdot> x + p \<cdot> x)\<^sup>\<dagger> \<cdot> !p \<cdot> y \<cdot> !p"
    by (simp add: assms(1) mult_assoc)
  also have "... = p \<cdot> x \<cdot> (!p \<cdot> y \<cdot> 0 + p \<cdot> x)\<^sup>\<dagger> \<cdot> !p \<cdot> y"
    by (metis assms(1) assms(2) local.annil local.test_comp_mult1 mult_assoc)
  also have "... = p \<cdot> x  \<cdot> (p  \<cdot> x)\<^sup>\<dagger> \<cdot> (!p \<cdot> y \<cdot> 0 \<cdot> (p \<cdot> x)\<^sup>\<dagger>)\<^sup>\<dagger> \<cdot> !p \<cdot> y"
    by (metis mult.assoc add.commute dagger_denest2)
  finally have "p \<cdot> (p \<cdot> x \<cdot> (!p \<cdot> y + p))\<^sup>\<dagger> \<cdot> !p = p \<cdot> x \<cdot> (p \<cdot> x)\<^sup>\<dagger> \<cdot> !p \<cdot> y"
    by (metis local.add_zeror local.annil local.dagger_prod_unfold local.dagger_slide local.mult_oner mult_assoc)
  thus ?thesis
    by (metis dagger_unfoldl_distr mult.assoc)
qed

lemma composition_helper:
  assumes "test p" and "test q"
  and "pres x p"
  shows "p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<cdot> !q \<cdot> p = p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<cdot> !q"
proof (rule antisym)
  show "p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<cdot> !q \<cdot> p \<le> p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<cdot> !q"
    by (simp add: assms(1) local.test_restrictr)
next
  have "p \<cdot> q \<cdot> x \<le> q \<cdot> x \<cdot> p"
    by (metis assms(1) assms(2) assms(3) local.test_kat_2 mult_assoc test_pres2)
  hence "p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<le> (q \<cdot> x)\<^sup>\<dagger> \<cdot> p"
    by (simp add: local.dagger_simr mult_assoc)
  thus "p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<cdot> !q \<le> p \<cdot> (q \<cdot> x)\<^sup>\<dagger> \<cdot> !q \<cdot> p"
    by (metis assms(1) assms(2) local.eq_iff local.test_comp_closed local.test_kat_2 local.test_mult_comm_var mult_assoc)
qed

theorem composition:
  assumes "test p" and "test q"
  and "pres y p" and "pres y (!p)"
  shows "(p \<cdot> x)\<^sup>\<dagger> \<cdot> !p \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> !q = !p \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> !q + p \<cdot> (p \<cdot> x \<cdot> (!p \<cdot> (q \<cdot> y)\<^sup>\<dagger> \<cdot> !q + p))\<^sup>\<dagger> \<cdot> !p"
    by (metis assms(1) assms(2) assms(4) composition_helper local.test_comp_closed mult_assoc postcomputation)
end

text \<open>
  Kleene algebras with tests form pre-Conway algebras, therefore the transformation theorem is valid for KAT as well.
\<close>

sublocale kat \<subseteq> pre_conway star ..

text \<open>
  Demonic refinement algebras form pre-Conway algebras, therefore the transformation theorem is valid for DRA as well.
\<close>
sublocale drat \<subseteq> pre_conway strong_iteration
  apply standard
  apply (simp add: local.iteration_denest local.iteration_slide)
  apply (metis local.iteration_prod_unfold)
  by (simp add: local.iteration_sim)

text \<open>
  We do not currently consider an expansion of probabilistic Kleene algebra.
\<close>

end