(*  Title:       New Fairness Proofs for the Given Clause Prover Architectures
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2020
*)

section \<open>New Fairness Proofs for the Given Clause Prover Architectures\<close>

theory Given_Clause_Architectures_Revisited
  imports Saturation_Framework.Given_Clause_Architectures
begin

text \<open>The given clause and lazy given clause procedures satisfy key invariants. This
provides an alternative way to prove fairness and hence saturation of the limit.\<close>

subsection \<open>Given Clause Procedure\<close>

context given_clause
begin

definition gc_invar :: "('f \<times> 'l) set llist \<Rightarrow> enat \<Rightarrow> bool" where
  "gc_invar Ns i \<longleftrightarrow>
   Inf_from (active_subset (Liminf_upto_llist Ns i)) \<subseteq> Sup_upto_llist (lmap Red_I_\<G> Ns) i"

lemma gc_invar_infinity:
  assumes
    nnil: "\<not> lnull Ns" and
    invar: "\<forall>i. enat i < llength Ns \<longrightarrow> gc_invar Ns (enat i)"
  shows "gc_invar Ns \<infinity>"
  unfolding gc_invar_def
proof (intro subsetI, unfold Liminf_upto_llist_infinity Sup_upto_llist_infinity)
  fix \<iota>
  assume \<iota>_inff: "\<iota> \<in> Inf_from (active_subset (Liminf_llist Ns))"

  define As where
    "As = lmap active_subset Ns"

  have act_ns: "active_subset (Liminf_llist Ns) = Liminf_llist As"
    unfolding As_def active_subset_def Liminf_set_filter_commute[symmetric] ..

  note \<iota>_inf = Inf_if_Inf_from[OF \<iota>_inff]
  note \<iota>_inff' = \<iota>_inff[unfolded act_ns]

  have "\<not> lnull As"
    unfolding As_def using nnil by auto
  moreover have "set (prems_of \<iota>) \<subseteq> Liminf_llist As"
    using \<iota>_inff'[unfolded Inf_from_def] by simp
  ultimately obtain i where
    i_lt_as: "enat i < llength As" and
    prems_sub_ge_i: "set (prems_of \<iota>) \<subseteq> (\<Inter>j \<in> {j. i \<le> j \<and> enat j < llength As}. lnth As j)"
    using finite_subset_Liminf_llist_imp_exists_index by blast

  note i_lt_ns = i_lt_as[unfolded As_def, simplified]

  have "set (prems_of \<iota>) \<subseteq> lnth As i"
    using prems_sub_ge_i i_lt_as by auto
  then have "\<iota> \<in> Inf_from (active_subset (lnth Ns i))"
    using i_lt_as \<iota>_inf unfolding Inf_from_def As_def by auto
  then have "\<iota> \<in> Sup_upto_llist (lmap Red_I_\<G> Ns) (enat i)"
    using nnil i_lt_ns invar[unfolded gc_invar_def] by auto
  then show "\<iota> \<in> Sup_llist (lmap Red_I_\<G> Ns)"
    using Sup_upto_llist_subset_Sup_llist by fastforce
qed

lemma gc_invar_gc_init:
  assumes
    "\<not> lnull Ns" and
    "active_subset (lhd Ns) = {}"
  shows "gc_invar Ns 0"
  using assms labeled_inf_have_prems unfolding gc_invar_def Inf_from_def by auto

lemma gc_invar_gc_step:
  assumes
    Si_lt: "enat (Suc i) < llength Ns" and
    invar: "gc_invar Ns i" and
    step: "lnth Ns i \<leadsto>GC lnth Ns (Suc i)"
  shows "gc_invar Ns (Suc i)"
  using step Si_lt invar
proof cases
  have i_lt: "enat i < llength Ns"
    using Si_lt Suc_ile_eq order.strict_implies_order by blast
  have lim_i: "Liminf_upto_llist Ns (enat i) = lnth Ns i"
    using i_lt by auto
  have lim_Si: "Liminf_upto_llist Ns (enat (Suc i)) = lnth Ns (Suc i)"
    using Si_lt by auto

  {
    case (process N M M')
    note ni = this(1) and nSi = this(2) and m'_pas = this(4)

    have "Inf_from (active_subset (N \<union> M')) \<subseteq> Inf_from (active_subset (N \<union> M))"
      using m'_pas by (simp add: Inf_from_mono)
    also have "\<dots> \<subseteq> Sup_upto_llist (lmap Red_I_\<G> Ns) (enat i)"
      using invar unfolding gc_invar_def lim_i ni by auto
    also have "\<dots> \<subseteq> Sup_upto_llist (lmap Red_I_\<G> Ns) (enat (Suc i))"
      by simp
    finally show ?thesis
      unfolding gc_invar_def lim_Si nSi .
  next
    case (infer N C L M)
    note ni = this(1) and nSi = this(2) and l_pas = this(3) and m_pas = this(4) and
      inff_red = this(5)

    {
      fix \<iota>
      assume \<iota>_inff: "\<iota> \<in> Inf_from (active_subset (N \<union> {(C, active)} \<union> M))"

      have \<iota>_inf: "\<iota> \<in> Inf_FL"
        using \<iota>_inff unfolding Inf_from_def by auto
      then have F\<iota>_inf: "to_F \<iota> \<in> Inf_F"
        using in_Inf_FL_imp_to_F_in_Inf_F by blast

      have "\<iota> \<in> Inf_from (active_subset N \<union> {(C, active)})"
        using \<iota>_inff m_pas by simp
      then have F\<iota>_inff:
        "to_F \<iota> \<in> no_labels.Inf_from (fst ` (active_subset N \<union> {(C, active)}))"
        using F\<iota>_inf unfolding to_F_def Inf_from_def no_labels.Inf_from_def by auto

      have "\<iota> \<in> Sup_upto_llist (lmap Red_I_\<G> Ns) (enat (Suc i))"
      proof (cases "to_F \<iota> \<in> no_labels.Inf_between (fst ` active_subset N) {C}")
        case True
        then have "to_F \<iota> \<in> no_labels.Red_I_\<G> (fst ` (N \<union> {(C, active)} \<union> M))"
          using inff_red by auto
        then have "\<iota> \<in> Red_I_\<G> (N \<union> {(C, active)} \<union> M)"
          by (subst labeled_red_inf_eq_red_inf[OF \<iota>_inf])
        then show ?thesis
          using Si_lt using nSi by auto
      next
        case False
        then have "to_F \<iota> \<in> no_labels.Inf_from (fst ` active_subset N)"
          using F\<iota>_inff unfolding no_labels.Inf_from_def no_labels.Inf_between_def by auto
        then have "\<iota> \<in> Inf_from (active_subset N)"
          using \<iota>_inf l_pas unfolding to_F_def Inf_from_def no_labels.Inf_from_def
          by clarsimp (smt \<iota>_inff[unfolded Inf_from_def] active_subset_def imageE image_subset_iff
              in_mono mem_Collect_eq prod.collapse)
        then show ?thesis
          using invar l_pas unfolding gc_invar_def lim_i ni by auto
      qed
    }
    then show ?thesis
      unfolding gc_invar_def lim_Si nSi by blast
  }
qed

lemma gc_invar_gc:
  assumes
    gc: "chain (\<leadsto>GC) Ns" and
    init: "active_subset (lhd Ns) = {}" and
    i_lt: "i < llength Ns"
  shows "gc_invar Ns i"
  using i_lt
proof (induct i)
  case (enat i)
  then show ?case
  proof (induct i)
    case 0
    then show ?case
      using gc_invar_gc_init[OF chain_not_lnull[OF gc] init] by (simp add: enat_0)
  next
    case (Suc i)
    note ih = this(1) and Si_lt = this(2)
    have i_lt: "enat i < llength Ns"
      using Si_lt Suc_ile_eq less_le by blast
    show ?case
      by (rule gc_invar_gc_step[OF Si_lt ih[OF i_lt] chain_lnth_rel[OF gc Si_lt]])
  qed
qed simp

lemma gc_fair_new_proof:
  assumes
    gc: "chain (\<leadsto>GC) Ns" and
    init: "active_subset (lhd Ns) = {}" and
    lim: "passive_subset (Liminf_llist Ns) = {}"
  shows "fair Ns"
  unfolding fair_def
proof -
  have "Inf_from (Liminf_llist Ns) \<subseteq> Inf_from (active_subset (Liminf_llist Ns))" (is "?lhs \<subseteq> _")
    using lim unfolding active_subset_def passive_subset_def
    by (metis (no_types, lifting) Inf_from_mono empty_Collect_eq mem_Collect_eq subsetI)
  also have "... \<subseteq> Sup_llist (lmap Red_I_\<G> Ns)" (is "_ \<subseteq> ?rhs")
    using gc_invar_infinity[OF chain_not_lnull[OF gc]] gc_invar_gc[OF gc init]
    unfolding gc_invar_def by fastforce
  finally show "?lhs \<subseteq> ?rhs"
    .
qed

end

subsection \<open>Lazy Given Clause\<close>

context lazy_given_clause
begin

definition from_F :: "'f inference \<Rightarrow> ('f \<times> 'l) inference set" where
  "from_F \<iota> = {\<iota>' \<in> Inf_FL. to_F \<iota>' = \<iota>}"

definition lgc_invar :: "('f inference set \<times> ('f \<times> 'l) set) llist \<Rightarrow> enat \<Rightarrow> bool" where
  "lgc_invar TNs i \<longleftrightarrow>
   Inf_from (active_subset (Liminf_upto_llist (lmap snd TNs) i))
   \<subseteq> \<Union> (from_F ` Liminf_upto_llist (lmap fst TNs) i) \<union> Sup_upto_llist (lmap (Red_I_\<G> \<circ> snd) TNs) i"

lemma lgc_invar_infinity:
  assumes
    nnil: "\<not> lnull TNs" and
    invar: "\<forall>i. enat i < llength TNs \<longrightarrow> lgc_invar TNs (enat i)"
  shows "lgc_invar TNs \<infinity>"
  unfolding lgc_invar_def
proof (intro subsetI, unfold Liminf_upto_llist_infinity Sup_upto_llist_infinity)
  fix \<iota>
  assume \<iota>_inff: "\<iota> \<in> Inf_from (active_subset (Liminf_llist (lmap snd TNs)))"

  define As where
    "As = lmap (active_subset \<circ> snd) TNs"

  have act_ns: "active_subset (Liminf_llist (lmap snd TNs)) = Liminf_llist As"
    unfolding As_def active_subset_def Liminf_set_filter_commute[symmetric] llist.map_comp ..

  note \<iota>_inf = Inf_if_Inf_from[OF \<iota>_inff]
  note \<iota>_inff' = \<iota>_inff[unfolded act_ns]

  show "\<iota> \<in> \<Union> (from_F ` Liminf_llist (lmap fst TNs)) \<union> Sup_llist (lmap (Red_I_\<G> \<circ> snd) TNs)"
  proof -
    {
      assume \<iota>_ni_lim: "\<iota> \<notin> \<Union> (from_F ` Liminf_llist (lmap fst TNs))"

      have "\<not> lnull As"
        unfolding As_def using nnil by auto
      moreover have "set (prems_of \<iota>) \<subseteq> Liminf_llist As"
        using \<iota>_inff'[unfolded Inf_from_def] by simp
      ultimately obtain i where
        i_lt_as: "enat i < llength As" and
        prems_sub_ge_i: "set (prems_of \<iota>) \<subseteq> (\<Inter>j \<in> {j. i \<le> j \<and> enat j < llength As}. lnth As j)"
        using finite_subset_Liminf_llist_imp_exists_index by blast

      have ts_nnil: "\<not> lnull (lmap fst TNs)"
        using As_def nnil by simp

      have F\<iota>_ni_lim: "to_F \<iota> \<notin> Liminf_llist (lmap fst TNs)"
        using \<iota>_inf \<iota>_ni_lim unfolding from_F_def by auto
      obtain i' where
        i_le_i': "i \<le> i'" and
        i'_lt_as: "enat i' < llength As" and
        F\<iota>_ni_i': "to_F \<iota> \<notin> lnth (lmap fst TNs) i'"
        using i_lt_as not_Liminf_llist_imp_exists_index[OF ts_nnil F\<iota>_ni_lim, of i] unfolding As_def
        by auto

      have \<iota>_ni_i': "\<iota> \<notin> \<Union> (from_F ` fst (lnth TNs i'))"
        using F\<iota>_ni_i' i'_lt_as[unfolded As_def] unfolding from_F_def by auto

      have "set (prems_of \<iota>) \<subseteq> (\<Inter>j \<in> {j. i' \<le> j \<and> enat j < llength As}. lnth As j)"
        using prems_sub_ge_i i_le_i' by auto
      then have "set (prems_of \<iota>) \<subseteq> lnth As i'"
        using i'_lt_as by auto
      then have "\<iota> \<in> Inf_from (active_subset (snd (lnth TNs i')))"
        using i'_lt_as \<iota>_inf unfolding Inf_from_def As_def by auto
      then have \<iota>_in_i': "\<iota> \<in> Sup_upto_llist (lmap (Red_I_\<G> \<circ> snd) TNs) (enat i')"
        using \<iota>_ni_i' i'_lt_as[unfolded As_def] invar[unfolded lgc_invar_def] by auto
      then have "\<iota> \<in> Sup_llist (lmap (Red_I_\<G> \<circ> snd) TNs)"
        using Sup_upto_llist_subset_Sup_llist by fastforce
    }
    then show ?thesis
      by blast
  qed
qed

lemma lgc_invar_lgc_init:
  assumes
    nnil: "\<not> lnull TNs" and
    n_init: "active_subset (snd (lhd TNs)) = {}" and
    t_init: "\<forall>\<iota> \<in> Inf_F. prems_of \<iota> = [] \<longrightarrow> \<iota> \<in> fst (lhd TNs)"
  shows "lgc_invar TNs 0"
  unfolding lgc_invar_def
proof -
  have "Inf_from (active_subset (Liminf_upto_llist (lmap snd TNs) 0)) =
    Inf_from {}" (is "?lhs = _")
    using nnil n_init by auto
  also have "... \<subseteq> \<Union> (from_F ` fst (lhd TNs))"
    using t_init Inf_FL_to_Inf_F unfolding Inf_from_def from_F_def to_F_def by force
  also have "... \<subseteq> \<Union> (from_F ` fst (lhd TNs)) \<union> Red_I_\<G> (snd (lhd TNs))"
    by fast
  also have "... = \<Union> (from_F ` Liminf_upto_llist (lmap fst TNs) 0)
    \<union> Sup_upto_llist (lmap (Red_I_\<G> \<circ> snd) TNs) 0" (is "_ = ?rhs")
    using nnil by auto
  finally show "?lhs \<subseteq> ?rhs"
    .
qed

lemma lgc_invar_lgc_step:
  assumes
    Si_lt: "enat (Suc i) < llength TNs" and
    invar: "lgc_invar TNs i" and
    step: "lnth TNs i \<leadsto>LGC lnth TNs (Suc i)"
  shows "lgc_invar TNs (Suc i)"
  using step Si_lt invar
proof cases
  let ?Sup_Red_i = "Sup_upto_llist (lmap (Red_I_\<G> \<circ> snd) TNs) (enat i)"
  let ?Sup_Red_Si = "Sup_upto_llist (lmap (Red_I_\<G> \<circ> snd) TNs) (enat (Suc i))"

  have i_lt: "enat i < llength TNs"
    using Si_lt Suc_ile_eq order.strict_implies_order by blast

  have lim_i:
    "Liminf_upto_llist (lmap fst TNs) (enat i) = lnth (lmap fst TNs) i"
    "Liminf_upto_llist (lmap snd TNs) (enat i) = lnth (lmap snd TNs) i"
    using i_lt by auto
  have lim_Si:
    "Liminf_upto_llist (lmap fst TNs) (enat (Suc i)) = lnth (lmap fst TNs) (Suc i)"
    "Liminf_upto_llist (lmap snd TNs) (enat (Suc i)) = lnth (lmap snd TNs) (Suc i)"
    using Si_lt by auto

  {
    case (process N1 N M N2 M' T)
    note tni = this(1) and tnSi = this(2) and n1 = this(3) and n2 = this(4) and m_red = this(5) and
      m'_pas = this(6)

    have ni: "lnth (lmap snd TNs) i = N \<union> M"
      by (simp add: i_lt n1 tni)
    have nSi: "lnth (lmap snd TNs) (Suc i) = N \<union> M'"
      by (simp add: Si_lt n2 tnSi)
    have ti: "lnth (lmap fst TNs) i = T"
      by (simp add: i_lt tni)
    have tSi: "lnth (lmap fst TNs) (Suc i) = T"
      by (simp add: Si_lt tnSi)

    have "Inf_from (active_subset (N \<union> M')) \<subseteq> Inf_from (active_subset (N \<union> M))"
      using m'_pas by (simp add: Inf_from_mono)
    also have "\<dots> \<subseteq> \<Union> (from_F ` T) \<union> ?Sup_Red_i"
      using invar unfolding lgc_invar_def lim_i ni ti .
    also have "\<dots> \<subseteq> \<Union> (from_F ` T) \<union> ?Sup_Red_Si"
      using Sup_upto_llist_mono by auto
    finally show ?thesis
      unfolding lgc_invar_def lim_Si nSi tSi .
  next
    case (schedule_infer T2 T1 T' N1 N C L N2)
    note tni = this(1) and tnSi = this(2) and t2 = this(3) and n1 = this(4) and n2 = this(5) and
      l_pas = this(6) and t' = this(7)

    have ni: "lnth (lmap snd TNs) i = N \<union> {(C, L)}"
      by (simp add: i_lt n1 tni)
    have nSi: "lnth (lmap snd TNs) (Suc i) = N \<union> {(C, active)}"
      by (simp add: Si_lt n2 tnSi)
    have ti: "lnth (lmap fst TNs) i = T1"
      by (simp add: i_lt tni)
    have tSi: "lnth (lmap fst TNs) (Suc i) = T1 \<union> T'"
      by (simp add: Si_lt t2 tnSi)

    {
      fix \<iota>
      assume \<iota>_inff: "\<iota> \<in> Inf_from (active_subset (N \<union> {(C, active)}))"

      have \<iota>_inf: "\<iota> \<in> Inf_FL"
        using \<iota>_inff unfolding Inf_from_def by auto
      then have F\<iota>_inf: "to_F \<iota> \<in> Inf_F"
        using in_Inf_FL_imp_to_F_in_Inf_F by blast

      have "\<iota> \<in> \<Union> (from_F ` (T1 \<union> T')) \<union> ?Sup_Red_Si"
      proof (cases "to_F \<iota> \<in> no_labels.Inf_between (fst ` active_subset N) {C}")
        case True
        then have "\<iota> \<in> \<Union> (from_F ` (T1 \<union> T'))"
          unfolding t' from_F_def using \<iota>_inf by auto
        then show ?thesis
          by blast
      next
        case False
        moreover have "to_F \<iota> \<in> no_labels.Inf_from (fst ` (active_subset N \<union> {(C, active)}))"
          using \<iota>_inff F\<iota>_inf unfolding to_F_def Inf_from_def no_labels.Inf_from_def by auto
        ultimately have "to_F \<iota> \<in> no_labels.Inf_from (fst ` active_subset N)"
          unfolding no_labels.Inf_from_def no_labels.Inf_between_def by auto
        then have "\<iota> \<in> Inf_from (active_subset N)"
          using \<iota>_inf unfolding to_F_def no_labels.Inf_from_def
          by clarsimp (smt Inf_from_def Un_insert_right \<iota>_inff active_subset_def
            boolean_algebra_cancel.sup0 imageE image_subset_iff insert_iff mem_Collect_eq
            prod.collapse snd_conv subset_iff)
        then have "\<iota> \<in> \<Union> (from_F ` (T1 \<union> T')) \<union> ?Sup_Red_i"
          using invar[unfolded lgc_invar_def] l_pas unfolding lim_i ni ti by auto
        then show ?thesis
          using Sup_upto_llist_mono by force
      qed
    }
    then show ?thesis
      unfolding lgc_invar_def lim_i lim_Si nSi tSi by fast
  next
    case (compute_infer T1 T2 \<iota>' N2 N1 M)
    note tni = this(1) and tnSi = this(2) and t1 = this(3) and n2 = this(4) and m_pas = this(5) and
      \<iota>'_red = this(6)

    have ni: "lnth (lmap snd TNs) i = N1"
      by (simp add: i_lt tni)
    have nSi: "lnth (lmap snd TNs) (Suc i) = N1 \<union> M"
      by (simp add: Si_lt n2 tnSi)
    have ti: "lnth (lmap fst TNs) i = T2 \<union> {\<iota>'}"
      by (simp add: i_lt t1 tni)
    have tSi: "lnth (lmap fst TNs) (Suc i) = T2"
      by (simp add: Si_lt tnSi)

    {
      fix \<iota>
      assume \<iota>_inff: "\<iota> \<in> Inf_from (active_subset (N1 \<union> M))"

      have \<iota>_bef: "\<iota> \<in> \<Union> (from_F ` (T2 \<union> {\<iota>'})) \<union> ?Sup_Red_i"
        using \<iota>_inff invar[unfolded lgc_invar_def lim_i ti ni] m_pas by auto
      have "\<iota> \<in> \<Union> (from_F ` T2) \<union> ?Sup_Red_Si"
      proof (cases "\<iota> \<in> from_F \<iota>'")
        case \<iota>_in_\<iota>': True
        then have "\<iota> \<in> Red_I_\<G> (N1 \<union> M)"
          using \<iota>'_red from_F_def labeled_red_inf_eq_red_inf by auto
        then have "\<iota> \<in> ?Sup_Red_Si"
          using Si_lt by (simp add: n2 tnSi)
        then show ?thesis
          by auto
      next
        case False
        then show ?thesis
          using \<iota>_bef by auto
      qed
    }
    then show ?thesis
      unfolding lgc_invar_def lim_Si tSi nSi by blast
  next
    case (delete_orphan_infers T1 T2 T' N)
    note tni = this(1) and tnSi = this(2) and t1 = this(3) and t'_orph = this(4)

    have ni: "lnth (lmap snd TNs) i = N"
      by (simp add: i_lt tni)
    have nSi: "lnth (lmap snd TNs) (Suc i) = N"
      by (simp add: Si_lt tnSi)
    have ti: "lnth (lmap fst TNs) i = T2 \<union> T'"
      by (simp add: i_lt t1 tni)
    have tSi: "lnth (lmap fst TNs) (Suc i) = T2"
      by (simp add: Si_lt tnSi)

    {
      fix \<iota>
      assume \<iota>_inff: "\<iota> \<in> Inf_from (active_subset N)"

      have "to_F \<iota> \<notin> T'"
        using t'_orph \<iota>_inff in_Inf_from_imp_to_F_in_Inf_from by blast
      hence "\<iota> \<notin> \<Union> (from_F ` T')"
        unfolding from_F_def by auto
      then have "\<iota> \<in> \<Union> (from_F ` T2) \<union> ?Sup_Red_Si"
        using \<iota>_inff invar unfolding lgc_invar_def lim_i ni ti by auto
    }
    then show ?thesis
      unfolding lgc_invar_def lim_Si tSi nSi by blast
  }
qed

lemma lgc_invar_lgc:
  assumes
    lgc: "chain (\<leadsto>LGC) TNs" and
    n_init: "active_subset (snd (lhd TNs)) = {}" and
    t_init: "\<forall>\<iota> \<in> Inf_F. prems_of \<iota> = [] \<longrightarrow> \<iota> \<in> fst (lhd TNs)" and
    i_lt: "i < llength TNs"
  shows "lgc_invar TNs i"
  using i_lt
proof (induct i)
  case (enat i)
  then show ?case
  proof (induct i)
    case 0
    then show ?case
      using lgc_invar_lgc_init[OF chain_not_lnull[OF lgc] n_init t_init] by (simp add: enat_0)
  next
    case (Suc i)
    note ih = this(1) and Si_lt = this(2)
    have i_lt: "enat i < llength TNs"
      using Si_lt Suc_ile_eq less_le by blast
    show ?case
      by (rule lgc_invar_lgc_step[OF Si_lt ih[OF i_lt] chain_lnth_rel[OF lgc Si_lt]])
  qed
qed simp

lemma lgc_fair_new_proof:
  assumes
    lgc: "chain (\<leadsto>LGC) TNs" and
    n_init: "active_subset (snd (lhd TNs)) = {}" and
    n_lim: "passive_subset (Liminf_llist (lmap snd TNs)) = {}" and
    t_init: "\<forall>\<iota> \<in> Inf_F. prems_of \<iota> = [] \<longrightarrow> \<iota> \<in> fst (lhd TNs)" and
    t_lim: "Liminf_llist (lmap fst TNs) = {}"
  shows "fair (lmap snd TNs)"
  unfolding fair_def llist.map_comp
proof -
  have "Inf_from (Liminf_llist (lmap snd TNs))
    \<subseteq> Inf_from (active_subset (Liminf_llist (lmap snd TNs)))" (is "?lhs \<subseteq> _")
    by (rule Inf_from_mono) (use n_lim passive_subset_def active_subset_def in blast)
  also have "... \<subseteq> \<Union> (from_F ` Liminf_upto_llist (lmap fst TNs) \<infinity>)
    \<union> Sup_llist (lmap (Red_I_\<G> \<circ> snd) TNs)"
    using lgc_invar_infinity[OF chain_not_lnull[OF lgc]] lgc_invar_lgc[OF lgc n_init t_init]
    unfolding lgc_invar_def by fastforce
  also have "... \<subseteq> Sup_llist (lmap (Red_I_\<G> \<circ> snd) TNs)" (is "_ \<subseteq> ?rhs")
    using t_lim by auto
  finally show "?lhs \<subseteq> ?rhs"
    .
qed

end

end


theory Contracts
imports SeparationLogic
begin

fun strip_prenex :: "form \<Rightarrow> (var set \<times> form)" where
  "strip_prenex (Exists x f) = (let (vs,f') = strip_prenex f in (insert x vs,f'))"
| "strip_prenex f = ({},f)"

fun strip_prenexl :: "form \<Rightarrow> (var list \<times> form)" where
  "strip_prenexl (Exists x f) = (let (vs,f') = strip_prenexl f in (x#vs,f'))"
| "strip_prenexl f = ([],f)"

lemma strip_set_list: "\<lbrakk>strip_prenex f = (vset,f'); strip_prenexl f = (vlist, f'')\<rbrakk>
  \<Longrightarrow> vset = set vlist \<and> f'=f''"
proof (induction f arbitrary: vset f' vlist f'')
  case (Exists x1 f)
  obtain vs2 f2 where step2: "strip_prenex f = (vs2,f2)" by fastforce
  obtain vs3 f3 where step3: "strip_prenexl f = (vs3,f3)" by fastforce
  have "strip_prenex (Exists x1 f) = (let (vs2,f2) = strip_prenex f in (insert x1 vs2,f2))" by simp
  with step2 Exists(2) have first: "vset = insert x1 vs2" "f' = f2" by auto
  have "strip_prenexl (Exists x1 f) = (let (vs2,f2) = strip_prenexl f in (x1#vs2,f2))" by simp
  with step3 Exists(3) have "vlist = x1#vs3" "f'' = f3" by auto
  with Exists(1)[OF step2 step3] first show ?case by auto
qed (auto)

fun add_prenex :: "var list \<Rightarrow> form \<Rightarrow> form" where
  "add_prenex [] f = f"
| "add_prenex (v#vs) f = Exists v (add_prenex vs f)"

lemma strip_add_prenexl:
  "\<lbrakk>strip_prenexl (add_prenex vs f) = (vs',f'); strip_prenexl f = (vs'', f'')\<rbrakk>
  \<Longrightarrow> vs'=vs@vs'' \<and> f'=f''"
proof (induction vs arbitrary: f vs' f' vs'' f'')
  case Nil
  then show ?case by auto
next
  case (Cons a vs)
  obtain vs2 f2 where IHaux: "strip_prenexl (add_prenex vs f) = (vs2,f2)" by fastforce
  have "add_prenex (a#vs) f = (Exists a (add_prenex vs f))" by simp
  then have "strip_prenexl (add_prenex (a#vs) f) =
    (let (vs2,f2) = strip_prenexl (add_prenex vs f) in (a#vs2,f2))" by simp
  with IHaux Cons(2) have "vs' = a#vs2" "f'=f2" by auto
  with Cons(1)[OF IHaux Cons(3)] have "vs' = a#vs@vs''" "f'=f''" by simp_all
  then show ?case by simp
qed

lemma strip_add_prenex:
  "\<lbrakk>strip_prenex (add_prenex vs f) = (vs',f'); strip_prenex f = (vs'', f'')\<rbrakk>
  \<Longrightarrow> vs'=set vs\<union>vs'' \<and> f'=f''"
  using strip_add_prenexl strip_set_list by (metis set_append surj_pair)

fun simplify_emp_sepconj :: "form \<Rightarrow> form" where
  "simplify_emp_sepconj (f1 \<^emph> f2) =
  (case simplify_emp_sepconj f1 of Emp \<Rightarrow> simplify_emp_sepconj f2
  | f1' \<Rightarrow> (case simplify_emp_sepconj f2 of Emp \<Rightarrow> f1'
  | f2' \<Rightarrow> f1' \<^emph> f2'))"
| "simplify_emp_sepconj (Disj f1 f2) = Disj (simplify_emp_sepconj f1) (simplify_emp_sepconj f2)"
| "simplify_emp_sepconj (Exists v f) = Exists v (simplify_emp_sepconj f)"
| "simplify_emp_sepconj P = P"

lemma simplification_sound: "separation_logic.form_semantics \<Lambda> d\<Lambda> (S,B,M) (simplify_emp_sepconj P) =
  separation_logic.form_semantics \<Lambda> d\<Lambda> (S,B,M) P" (is "?sem (S,B,M) (_ P) = ?sem (S,B,M) P")
proof
assume "?sem (S, B, M) (simplify_emp_sepconj P)"
then show "?sem (S, B, M) P" proof (induction P arbitrary: S B M)
  case (SepConj P1 P2)
  then show ?case proof (cases "simplify_emp_sepconj P1=Emp")
    case True
    then have "?sem (S,B,Map.empty) (simplify_emp_sepconj P1)"
      by (auto simp: separation_logic.form_semantics.simps)
    with SepConj have "?sem (S,B,Map.empty) P1" by simp
    moreover from True SepConj have "?sem (S,B,M) P2" by simp
    ultimately show ?thesis by (auto simp: separation_logic.form_semantics.simps) fastforce
  next
    case False
    then have P1: "simplify_emp_sepconj P1 \<noteq> Emp" .
    then show ?thesis proof (cases "simplify_emp_sepconj P2=Emp")
      case True
      then have "?sem (S,B,Map.empty) (simplify_emp_sepconj P2)"
        by (auto simp: separation_logic.form_semantics.simps)
      with SepConj have P2: "?sem (S,B,Map.empty) P2" by simp
      from True P1 have "simplify_emp_sepconj (P1 \<^emph> P2) = simplify_emp_sepconj P1"
        by (auto split: form.splits)
      with SepConj have "?sem (S,B,M) P1" by simp
      with P2 show ?thesis by (auto simp: separation_logic.form_semantics.simps) fastforce
    next
      case False
      with P1 have "simplify_emp_sepconj (P1 \<^emph> P2) = ((simplify_emp_sepconj P1)
        \<^emph> (simplify_emp_sepconj P2))" by (auto split: form.splits)
      from SepConj(3)[unfolded this] obtain M1 M2 where M: "dom M1 \<inter> dom M2 = {}" "M = M1 ++ M2"
        "?sem (S,B,M1) (simplify_emp_sepconj P1)" "?sem (S,B,M2) (simplify_emp_sepconj P2)"
        unfolding separation_logic.form_semantics.simps by auto
      with SepConj have "?sem (S,B,M1) P1" "?sem (S,B,M2) P2" by simp_all
      with M show ?thesis by (auto simp: separation_logic.form_semantics.simps)
    qed
  qed
next
  case (Disj P1 P2)
  then have "?sem (S,B,M) ((simplify_emp_sepconj P1) \<or>\<^sub>s (simplify_emp_sepconj P2))"
    by simp
  then have "(?sem (S,B,M) (simplify_emp_sepconj P1) \<or> ?sem (S,B,M) (simplify_emp_sepconj P2))"
    unfolding separation_logic.form_semantics.simps(5) .
  with Disj(1,2) show ?case unfolding separation_logic.form_semantics.simps(5) by auto
next
  case (Exists x1 P)
  then have "?sem (S, B, M) (Exists x1 (simplify_emp_sepconj P))" by simp
  then have "\<exists>v. ?sem (update_stack S x1 v,B,M) (simplify_emp_sepconj P)"
    unfolding separation_logic.form_semantics.simps(9) .
  with Exists(1) show ?case unfolding separation_logic.form_semantics.simps(9) by auto
qed (simp_all)
next
assume "?sem (S, B, M) P"
then show "?sem (S, B, M) (simplify_emp_sepconj P)" proof (induction P arbitrary: S B M)
  case (SepConj P1 P2)
  then obtain M1 M2 where M: "dom M1 \<inter> dom M2 = {}" "M = M1 ++ M2" "?sem (S,B,M1) P1" "?sem (S,B,M2) P2"
    by (auto simp: separation_logic.form_semantics.simps)
  then show ?case proof (cases "simplify_emp_sepconj P1=Emp")
    case True
    with SepConj(1)[OF M(3)] have "M1 = Map.empty" by (auto simp: separation_logic.form_semantics.simps)
    with M(2) have "M=M2" by simp
    with M(4) SepConj(2) have "?sem (S,B,M) (simplify_emp_sepconj P2)" by simp
    with True show ?thesis by simp
  next
    case False
    then have P1: "simplify_emp_sepconj P1 \<noteq> Emp" .
    then show ?thesis proof (cases "simplify_emp_sepconj P2=Emp")
      case True
      with SepConj(2)[OF M(4)] have "M2 = Map.empty" by (auto simp: separation_logic.form_semantics.simps)
      with M(2) have "M=M1" by simp
      with M(3) SepConj(1) have "?sem (S,B,M) (simplify_emp_sepconj P1)" by simp
      moreover from P1 True have "simplify_emp_sepconj (P1 \<^emph> P2) = simplify_emp_sepconj P1"
        by (auto split: form.splits)
      ultimately show ?thesis by simp
    next
      case False
      from M SepConj have "?sem (S,B,M1) (simplify_emp_sepconj P1)" "?sem (S,B,M2) (simplify_emp_sepconj P2)"
        by auto
      moreover from False P1 have "simplify_emp_sepconj (P1 \<^emph> P2) = ((simplify_emp_sepconj P1)
        \<^emph> (simplify_emp_sepconj P2))" by (auto split: form.splits)
      ultimately show ?thesis using M(1,2) by (auto simp: separation_logic.form_semantics.simps)
    qed
  qed
next
  case (Disj P1 P2)
  then show ?case by (auto simp: separation_logic.form_semantics.simps(5))
next
  case (Exists x1 P)
  then show ?case by (auto simp: separation_logic.form_semantics.simps(9))
qed (simp_all)
qed

context separation_logic begin
abbreviation star_disj :: "form list \<Rightarrow> form" where
  "star_disj Q \<equiv> fold (\<or>\<^sub>s) Q FalseF"
end

text \<open>The paper distinguishes program variables and logical variables.
  For the formalization, it suffices to know the arguments to a function
  to get the program variables, as the function can't use any other variables.
  Therefore, we do not use different types for these two kinds of variables but just different sets.
  We also use meta-variables wherever possible.\<close>

type_synonym pre_contract = "(form\<times>(form list)) list"

typedef contract = "{(cs, (f,args))::pre_contract\<times>func | cs args f.
  \<forall>(P,Q)\<in>set cs. quantifree_symb_heap P \<and> \<comment> \<open>P is a quantifier-free symbolic heap\<close>
  \<comment> \<open>Q is a disjunction of single formulas of the form \<open>\<exists>UQ. Qf \<^emph> Qeq\<close>\<close>
  list_all (\<lambda>q. case strip_prenex q of (UQ, Qf \<^emph> Qeq) \<Rightarrow>
    \<comment> \<open>The prenex variables are the logical ones in Qf and Qeq, that are not also in P.\<close>
    UQ = (free_vars Qf \<union> free_vars Qeq) - set args - free_vars P \<and>
    \<comment> \<open>Qf is a quantifier-free symbolic heap with only logical variables\<close>
    quantifree_symb_heap Qf \<and> free_vars Qf \<inter> set args = {} \<and>
    \<comment> \<open>Qeq is of the form \<open>x1=e1 \<^emph> ... \<^emph> xn=en \<^emph> Emp\<close> for arguments xi and some expressions e
      that only contain logical variables.\<close>
    (\<exists>eqs. Qeq = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip args eqs) Emp)
    \<and> list_all (\<lambda>e. free_vars e \<inter> set args = {}) eqs)
    | _ \<Rightarrow> False) Q \<and> Q \<noteq> []}" morphisms raw_contract Contract
  by (smt (z3) empty_iff mem_Collect_eq set_empty2)

setup_lifting type_definition_contract

lift_definition conjunctive :: "contract \<Rightarrow> bool" is
  "\<lambda>(cs, (f,args)). \<forall>(P,Qs) \<in> set cs. length Qs = 1" .

context program_logic
begin
lift_definition sound :: "contract \<Rightarrow> bool" is
  "\<lambda>(cs, (f,args)). \<forall>(P,Qs) \<in> set cs. \<forall>c c' F.
    (((c \<turnstile> (P\<^emph>F)) \<and> fun_semantics fs f c c' \<and> symbolic_heap F \<and> free_vars F \<inter> set args = {})
    \<longrightarrow> (c' \<turnstile> ((star_disj Qs) \<^emph> F)))" .
end

abbreviation single_stmt_cfg :: "func \<Rightarrow> command \<Rightarrow> cfg" where
  "single_stmt_cfg f cmd \<equiv> (f, {(entry,cmd,exit)})"

abbreviation single_fun_prog :: "func \<Rightarrow> command \<Rightarrow> prog" where
  "single_fun_prog f cmd \<equiv> (case f of (n,args) \<Rightarrow> [n\<mapsto>single_stmt_cfg f cmd])"

locale standard_prog = fixes x y z X Y Z u :: var
  assumes var_sep: "{x,y,z,u} \<inter> {X,Y,Z} = {}" and diff_var: "x\<noteq>y\<and>y\<noteq>z\<and>x\<noteq>z\<and>x\<noteq>u\<and>y\<noteq>u\<and>z\<noteq>u"
begin

definition assign :: prog where "assign \<equiv> single_fun_prog (''assign'',[x,y]) (AssignVar x y)"
definition assign_contract :: pre_contract where
  "assign_contract \<equiv> [(f_eq y Y,[Emp \<^emph> (f_eq x Y)\<^emph>(f_eq y Y)])]"
lift_definition assign_c :: contract is "(assign_contract, (''assign'',[x,y]))"
proof (auto simp: assign_contract_def)
  define eqs where "eqs = [VarE Y,VarE Y]"
  then have "(f_eq x Y \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x, y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs"
    using var_sep eqs_def by auto
  then show "\<exists>eqs. (f_eq x Y \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x, y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs" by auto
qed

definition const :: "val \<Rightarrow> prog" where "const k \<equiv> single_fun_prog (''const'',[x]) (AssignConst x k)"
definition const_contract :: "val \<Rightarrow> pre_contract" where
  "const_contract k \<equiv> [(Emp,[Emp \<^emph> (f_eq x k)])]"
lift_definition const_c :: "val \<Rightarrow> contract" is "\<lambda>k. (const_contract k, (''const'',[x]))"
proof (auto simp: const_contract_def)
  fix k :: val
  define eqs where "eqs = [ConstE k]"
  then have "(f_eq x (ConstE k)) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e) eqs"
    using var_sep eqs_def by auto
  then show "\<exists>eqs. (f_eq x (ConstE k)) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e) eqs" by auto
qed

definition load :: prog where "load \<equiv> single_fun_prog (''load'',[x,y]) (Load x y)"
definition load_contract :: pre_contract where
  "load_contract \<equiv> [((f_eq y Y)\<^emph>(Y\<mapsto>\<^sub>sz),[(Y\<mapsto>\<^sub>sz) \<^emph> (f_eq x z)\<^emph>(f_eq y Y)])]"
lift_definition load_c :: contract is "(load_contract, (''load'',[x,y]))"
  using var_sep[simplified]
proof (auto simp: load_contract_def diff_var)
  define eqs where "eqs = [VarE z, Y]"
  then have "(f_eq x z \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. (f_eq x z \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs" by auto
qed

definition store :: prog where "store \<equiv> single_fun_prog (''store'',[x,y]) (Store x y)"
definition store_contract :: pre_contract where
  "store_contract \<equiv> [((f_eq x X)\<^emph>(f_eq y Y)\<^emph>(X\<mapsto>\<^sub>sz),[(X\<mapsto>\<^sub>sY) \<^emph> (f_eq x X)\<^emph>(f_eq y Y)])]"
lift_definition store_c :: contract is "(store_contract, (''store'',[x,y]))"
  using var_sep[simplified]
proof (auto simp: store_contract_def)
  define eqs where "eqs = [VarE X, Y]"
  then have "(f_eq x X \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. (f_eq x X \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs" by auto
qed

definition malloc :: prog where "malloc \<equiv> single_fun_prog (''malloc'',[x,y]) (Malloc x y)"
definition malloc_contract :: pre_contract where
  "malloc_contract \<equiv> [((f_eq y Y),
    [Emp \<^emph> (f_eq x (null x))\<^emph>(f_eq y Y),
    Exists u (((u\<mapsto>\<top>[Y])\<^emph>(f_eq (Base u) u)\<^emph>(f_eq (Ende u) (e_add u Y))) \<^emph> (f_eq x u)\<^emph>(f_eq y Y))])]"
lift_definition malloc_c :: contract is "(malloc_contract, (''malloc'',[x,y]))"
  using var_sep[simplified] diff_var
proof (auto simp: malloc_contract_def)
  define eqs where "eqs = [ConstE (null x), Y]"
  then have "(f_eq x (null x) \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq (VarE x) e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. (f_eq x (null x) \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq (VarE x) e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs" by auto
next
  define eqs where "eqs = [VarE u, Y]"
  then have "(f_eq x u \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq (VarE x) e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. (f_eq x u \<^emph> f_eq y Y) = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq (VarE x) e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs" by auto
qed

definition free :: prog where "free \<equiv> single_fun_prog (''free'',[x]) (Free x)"
definition free_contract :: pre_contract where
  "free_contract \<equiv> [
  ((f_eq x X)\<^emph>(f_eq X null_loc), [(f_eq X null_loc) \<^emph> (f_eq x X)]),
  ((f_eq x X)\<^emph>(X\<mapsto>\<top>[y])\<^emph>(f_eq (Base X) X)\<^emph>(f_eq (Ende X) (e_add X y)),[Emp \<^emph> (f_eq x X)])]"
lift_definition free_c :: contract is "(free_contract, (''free'',[x]))"
  using var_sep[simplified]
proof (auto simp: free_contract_def)
  define eqs where "eqs = [VarE X]"
  then have "f_eq x X = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. f_eq x X = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e) eqs" by auto
  then show "\<exists>eqs. f_eq x X = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e) eqs" by auto
qed

definition assign_binop :: "binop \<Rightarrow> prog" where "assign_binop op \<equiv>
  single_fun_prog (''assign_binop'',[x,y,z]) (BinOp op x y z)"
definition binop_contract :: "binop \<Rightarrow> pre_contract" where
  "binop_contract op \<equiv> [((f_eq y Y)\<^emph>(f_eq z Z),[Emp \<^emph> (f_eq x (BinOpE op Y Z))\<^emph>(f_eq y Y)\<^emph>(f_eq z Z)])]"
lift_definition binop_c :: "binop \<Rightarrow> contract" is "\<lambda>op. (binop_contract op, (''assign_binop'',[x,y,z]))"
proof (auto simp: binop_contract_def)
  fix op :: binop
  define eqs where "eqs = [BinOpE op Y Z,Y,Z]"
  then have "f_eq x (BinOpE op Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. f_eq x (BinOpE op Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs" by auto
qed

definition assign_unop ::  "unop \<Rightarrow> prog" where "assign_unop op \<equiv>
  single_fun_prog (''assign_unop'',[x,y]) (UnOp op x y)"
definition unop_contract :: "unop \<Rightarrow> pre_contract" where
  "unop_contract op \<equiv> [((f_eq y Y),[Emp \<^emph> (f_eq x (UnOpE op Y))\<^emph>(f_eq y Y)])]"
lift_definition unop_c :: "unop \<Rightarrow> contract" is "\<lambda>op. (unop_contract op, (''assign_unop'',[x,y]))"
proof (auto simp: unop_contract_def)
  fix op :: unop
  define eqs where "eqs = [UnOpE op Y,Y]"
  then have "f_eq x (UnOpE op Y)\<^emph>f_eq y Y = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. f_eq x (UnOpE op Y)\<^emph>f_eq y Y = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e) eqs" by auto
qed

definition ptrplus :: prog where "ptrplus \<equiv> single_fun_prog (''ptrplus'',[x,y,z]) (PtrPlus x y z)"
abbreviation "ptrplus\<phi> \<equiv> (Atom Neq (Base Y) null_loc)\<^emph>(f_eq (Base Y) (Base (e_add Y Z)))\<^emph>
  (f_eq (Ende Y) (Ende (e_add Y Z)))"
abbreviation "ptrplus\<phi>2 \<equiv> (Atom Neq (Base Y) null_loc)\<^emph>(f_eq (e_add Y Z) (Ende Y))"
definition ptrplus_contract :: pre_contract where
  "ptrplus_contract \<equiv> [
  ((f_eq y Y)\<^emph>(f_eq z Z)\<^emph>ptrplus\<phi>,[ptrplus\<phi> \<^emph> (f_eq x (e_add Y Z))\<^emph>(f_eq y Y)\<^emph>(f_eq z Z)]),
  ((f_eq y Y)\<^emph>(f_eq z Z)\<^emph>ptrplus\<phi>2,[ptrplus\<phi>2 \<^emph> (f_eq x (e_add Y Z))\<^emph>(f_eq y Y)\<^emph>(f_eq z Z)])]"
lift_definition ptrplus_c :: contract is "(ptrplus_contract, (''ptrplus'',[x,y,z]))"
  using var_sep[simplified] diff_var
proof (auto simp: ptrplus_contract_def)
  fix op :: unop
  define eqs where "eqs = [e_add Y Z,Y,Z]"
  then have "f_eq x (e_add Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. f_eq x (e_add Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs" by auto
  then show "\<exists>eqs. f_eq x (e_add Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs" by auto
qed

definition ptrsub :: prog where "ptrsub \<equiv> single_fun_prog (''ptrsub'',[x,y,z]) (PtrSub x y z)"
definition ptrsub_contract :: pre_contract where
  "ptrsub_contract \<equiv> [((f_eq y Y)\<^emph>(f_eq z Z)\<^emph>(Atom Neq (Base Y) null_loc)\<^emph>(Atom Leq (Base Y) Z)\<^emph>(Atom Leq Z (Ende Y)),
  [Emp \<^emph> (f_eq x (BinOpE minus Y Z)\<^emph>(f_eq y Y)\<^emph>(f_eq z Z))])]"
lift_definition ptrsubs_c :: contract is "(ptrsub_contract, (''ptrsub'',[x,y,z]))"
proof (auto simp: ptrsub_contract_def)
  fix op :: unop
  define eqs where "eqs = [BinOpE Semantics.minus Y Z,Y,Z]"
  then have "f_eq x (BinOpE Semantics.minus Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs"
    using eqs_def var_sep diff_var by auto
  then show "\<exists>eqs. f_eq x (BinOpE Semantics.minus Y Z)\<^emph>f_eq y Y\<^emph>f_eq z Z = simplify_emp_sepconj (foldr (\<lambda>(x, e). (\<^emph>) (f_eq x e)) (zip [x,y,z] eqs) Emp)
    \<and> list_all (\<lambda>e. x \<notin> free_vars e \<and> y \<notin> free_vars e \<and> z \<notin> free_vars e) eqs" by auto
qed

definition memcpy :: prog where "memcpy \<equiv> single_fun_prog (''memcpy'',[x,y,z]) (Memcpy x y z)"

text \<open>The contracts for assume and assert don't follow the scheme, as the atomic conditions can't be
  part of either Qf (it can't talk about program variables) or Qeq (it already contains all equalities.\<close>
definition assume_f :: "condition \<Rightarrow> prog" where "assume_f c \<equiv> single_fun_prog (''assume'',[y,z]) (Assume c y z)"
definition assume_contract :: "condition \<Rightarrow> pre_contract" where
  "assume_contract c \<equiv> [((f_eq y Y)\<^emph>(f_eq z Z),[Atom c y z \<^emph> (f_eq y Y)\<^emph>(f_eq z Z)])]"
lift_definition assume_c :: "condition \<Rightarrow> contract" is "\<lambda>c. (assume_contract c, (''assume'',[y,z]))"
  oops

definition assert_f :: "condition \<Rightarrow> prog" where "assert_f c \<equiv> single_fun_prog (''assert'',[x,y]) (Assert c x y)"
definition assert_contract :: "condition \<Rightarrow> pre_contract" where
  "assert_contract c \<equiv> [(Atom c y z\<^emph>(f_eq y Y)\<^emph>(f_eq z Z),[Atom c y z \<^emph> (f_eq y Y)\<^emph>(f_eq z Z)])]"
lift_definition assert_c :: "condition \<Rightarrow> contract" is "\<lambda>c. (assert_contract c, (''assert'',[y,z]))"
  oops

definition standard_prog :: prog where "standard_prog \<equiv> assign++load++store++malloc++free
  ++ptrplus++ptrsub++memcpy"
end
end