theory MuHO1_Semantics_Kleene
  imports MuHO1_Semantics_Tarski
begin

section "Algorithmic Semantics"

context ctx
begin

function approx_tm0 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm0 \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
and approx_tm1 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm1 \<Rightarrow> name \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a)"
and sem_tm0_k :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm0 \<Rightarrow> 'a"
and sem_tm1_k :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm1 \<Rightarrow> ('a \<Rightarrow> 'a)"
  where
"approx_tm0 \<eta>0 \<eta>1 \<phi> x init 0 = init" |
"approx_tm0 \<eta>0 \<eta>1 \<phi> x init (Suc n) =
    sem_tm0_k (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x init n)) \<eta>1 \<phi>" |

"approx_tm1 \<eta>0 \<eta>1 \<phi> x init 0 = init" |
"approx_tm1 \<eta>0 \<eta>1 \<phi> x init (Suc n) = sem_tm1_k \<eta>0 (\<eta>1(x := approx_tm1 \<eta>0 \<eta>1 \<phi> x init n)) \<phi>" |

"sem_tm0_k \<eta>0 \<eta>1 (Var0 x) = (\<eta>0 x)" |
"sem_tm0_k \<eta>0 \<eta>1 (Func0 f) = abs_func0 f" |
"sem_tm0_k \<eta>0 \<eta>1 (App \<phi> \<psi>) = (sem_tm1_k \<eta>0 \<eta>1 \<phi>) (sem_tm0_k \<eta>0 \<eta>1 \<psi>)" |
"sem_tm0_k \<eta>0 \<eta>1 (Mu0 X \<phi>) = approx_tm0 \<eta>0 \<eta>1 \<phi> X \<bottom> (card (UNIV::'a set))" |

"sem_tm1_k \<eta>0 \<eta>1 (Var1 x) = (\<eta>1 x)" |
"sem_tm1_k \<eta>0 \<eta>1 (Func1 f) = abs_func1 f" |
"sem_tm1_k \<eta>0 \<eta>1 (Lam x \<phi>) = (\<lambda>d. sem_tm0_k (\<eta>0(x := d)) \<eta>1 \<phi>)" |
"sem_tm1_k \<eta>0 \<eta>1 (Mu1 X \<phi>) = approx_tm1 \<eta>0 \<eta>1 \<phi> X (\<lambda>_. \<bottom>) (card (UNIV::('a\<Rightarrow>'a) set))"
  by pat_completeness auto
termination
  by size_change

lemma approx_tm0_mono:
  "\<lbrakk>\<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.

   \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
     \<forall>f z. \<eta>1 f z \<le> \<eta>1' f z;
     \<forall>f. mono (\<eta>1 f);
     \<forall>f. mono (\<eta>1' f) \<rbrakk>
   \<Longrightarrow> sem_tm0_k \<eta>0 \<eta>1 \<phi> \<le> sem_tm0_k \<eta>0' \<eta>1' \<phi>;

    \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> approx_tm0 \<eta>0' \<eta>1' \<phi> x \<bottom> n"
  by (induction n) auto

lemma approx_tm1_mono:
  "\<lbrakk> \<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.

   \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
     \<forall>f z. \<eta>1 f z \<le> \<eta>1' f z;
     \<forall>f. mono (\<eta>1 f);
     \<forall>f. mono (\<eta>1' f) \<rbrakk>
   \<Longrightarrow> sem_tm1_k \<eta>0 \<eta>1 \<phi>' \<le> sem_tm1_k \<eta>0' \<eta>1' \<phi>'
       \<and> mono (sem_tm1_k \<eta>0 \<eta>1 \<phi>')
       \<and> mono (sem_tm1_k \<eta>0' \<eta>1' \<phi>');

    \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi>' x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0' \<eta>1' \<phi>' x (\<lambda>_. \<bottom>) n
      \<and> mono (approx_tm1 \<eta>0 \<eta>1 \<phi>' x (\<lambda>_. \<bottom>) n)
      \<and> mono (approx_tm1 \<eta>0' \<eta>1' \<phi>' x (\<lambda>_. \<bottom>) n)"
proof (induction n)
  case 0
  then show ?case
    by (simp add: monoI)
next
  case (Suc n)
  then show ?case
    by (smt (verit, ccfv_SIG) approx_tm1.simps(2) fun_upd_apply le_funD)
qed

theorem sem_k_mono:
  "\<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.
  \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> sem_tm0_k \<eta>0 \<eta>1 \<phi> \<le> sem_tm0_k \<eta>0' \<eta>1' \<phi>"

  "\<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.
  \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> sem_tm1_k \<eta>0 \<eta>1 \<phi>' \<le> sem_tm1_k \<eta>0' \<eta>1' \<phi>'
      \<and> mono (sem_tm1_k \<eta>0 \<eta>1 \<phi>') \<and> mono (sem_tm1_k \<eta>0' \<eta>1' \<phi>')"
proof (induction \<phi> and \<phi>')
  case (Var0 x)
  then show ?case
    by simp
next
  case (Func0 f)
  then show ?case
    by simp
next
  case (App x1 x2)
  have 1: "sem_tm0_k \<eta>0 \<eta>1 x2 \<le> sem_tm0_k \<eta>0' \<eta>1' x2"
    using App.IH(2) App.prems by simp

  have 2: "sem_tm1_k \<eta>0 \<eta>1 x1 \<le> sem_tm1_k \<eta>0' \<eta>1' x1"
     using App.IH(1) App.prems by simp

  with 1 have "(sem_tm1_k \<eta>0 \<eta>1 x1) (sem_tm0_k \<eta>0 \<eta>1 x2) \<le>
            (sem_tm1_k \<eta>0 \<eta>1 x1) (sem_tm0_k \<eta>0' \<eta>1' x2)"
    using App.IH(1) App.prems(3) monoD by blast
  with 2 have "(sem_tm1_k \<eta>0 \<eta>1 x1) (sem_tm0_k \<eta>0 \<eta>1 x2) \<le>
            (sem_tm1_k \<eta>0' \<eta>1' x1) (sem_tm0_k \<eta>0' \<eta>1' x2)"
    by (metis dual_order.trans le_fun_def)
  then show ?case by simp
next
  case (Mu0 x1a \<phi>)
  then show ?case
    by (simp add: approx_tm0_mono abs_func1_mono)
next
  case (Var1 x)
  then show ?case
    by (simp add: le_fun_def)
next
  case (Func1 f)
  then show ?case
    by (simp add: abs_func1_mono monoI)
next
  case (Lam x1 x2)
  then show ?case
    by (smt (verit, ccfv_threshold) dual_order.eq_iff fun_upd_apply
        le_funI monoI sem_tm1_k.simps(3))
next
  case (Mu1 x1a \<phi>)
  then show ?case
    by (simp add: approx_tm1_mono)
qed

lemma sem_tm1_k_fun_upd_mono: "\<lbrakk> \<forall>f. mono (\<eta>1 f); z \<le> z'; mono z; mono z' \<rbrakk>
  \<Longrightarrow> sem_tm1_k \<eta>0 (\<eta>1(x := z)) \<phi> \<le> sem_tm1_k \<eta>0 (\<eta>1(x := z')) \<phi>"
  by (smt (verit) dual_order.eq_iff fun_upd_apply le_funE sem_k_mono(2))

section "Equivalence of Algorithmic and Denotational Semantics"

lemma approx_tm0_mono_min:
  "\<forall>f. mono (\<eta>1 f)
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)" for n
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case
    using sem_k_mono(1) by simp
qed

lemma approx_tm0_mono_min2:
  "\<lbrakk> \<forall>f. mono (\<eta>1 f); m \<ge> n \<rbrakk>
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m"
proof (induction m)
  case 0
  then show ?case
    by (simp add: approx_tm0_mono)
next
  case (Suc m)
  then show ?case
    by (metis approx_tm0_mono_min lift_Suc_mono_le)
qed

lemma approx_tm1_mono_min:
  "\<forall>f. mono (\<eta>1 f)
    \<Longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n)"
proof (induction n)
  case 0
  then show ?case
    by (simp add: le_fun_def)
next
  case (Suc n)
  have 0: "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n) =
            sem_tm1_k \<eta>0 (\<eta>1(x := approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n)) \<phi>"
    by simp

  have 1: "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc (Suc n)) =
          sem_tm1_k \<eta>0 (\<eta>1(x := approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n))) \<phi>"
    by simp

  from 0 1 show ?case
    by (smt (verit) Suc.IH Suc.prems approx_tm1_mono sem_tm1_k_fun_upd_mono
        dual_order.eq_iff sem_k_mono(2))
qed

lemma approx_tm1_mono_min2:
  "\<lbrakk> \<forall>f. mono (\<eta>1 f); m \<ge> n \<rbrakk>
  \<Longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m"
proof (induction m)
  case 0
  then show ?case
    by simp
next
  case (Suc m)
  then show ?case
    by (metis approx_tm1_mono_min lift_Suc_mono_le)
qed

lemma approx_tm0_stays_stable:
  assumes "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)"
    and "m \<ge> n"
    and "\<forall>f. mono (\<eta>1 f)"
    shows "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n"
proof (rule order.antisym)
  show "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m \<ge> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n"
    by (simp add: approx_tm0_mono_min2 assms(2) assms(3))

  show "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m \<le> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n"
  proof (induction m)
    case 0
    then show ?case by simp
  next
    case (Suc m)
    then show ?case
    by (metis (no_types, lifting) dual_order.eq_iff approx_tm0_mono_min2
        assms(1) assms(3) le_SucE approx_tm0.simps(2) nat_le_linear)
  qed
qed

lemma inj_func_card:
  assumes "\<forall>i \<le> card S + 1. \<forall>i' \<le> card S + 1.
           i \<noteq> i' \<longrightarrow> f i \<noteq> f i'"
  shows "n \<le> card S + 1 \<longrightarrow> n \<le> card (\<Union>i\<le>n. {f i})"
proof (rule impI, induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  have "\<forall>i\<le>n. \<forall>i'\<le>n. i \<noteq> i' \<longrightarrow> {f i} \<noteq> {f i'}"
    using Suc.prems assms by auto
  then have "\<forall>i\<le>n. {f i} \<noteq> {f (Suc n)}"
    using Suc.prems assms by auto
  then have 0: "\<not> ({f (Suc n)} \<subseteq> (\<Union>i\<le>n. {f i}))"
    by auto

  have "(\<Union>i\<le>Suc n. {f i}) = (\<Union>i\<le>n. {f i}) \<union> {f (Suc n)}"
    by (simp add: atMost_Suc)
  then have "card (\<Union>i\<le>Suc n. {f i}) = card ((\<Union>i\<le>n. {f i}) \<union> {f (Suc n)})"
    by auto
  with 0 have 1: "\<dots> = card (\<Union>i\<le>n. {f i}) + card ({f (Suc n)})"
    by simp

  have "Suc n \<le> card (\<Union>i\<le>n. {f i}) + 1"
    using Suc.IH Suc.prems by auto
  also have "\<dots> \<le> card ((\<Union>i\<le>n. {f i}) \<union> {f (Suc n)})"
    using 1 by auto
  also have "\<dots> \<le> card ((\<Union>i\<le>Suc n. {f i}))"
    by (simp add: atMost_Suc)
  finally show ?case by simp
qed

lemma approx_tm0_eventually_stable:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "\<exists>n \<le> card (UNIV::'a set).
      approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)"
proof (rule ccontr)
  assume 0: "\<not> (\<exists>n\<le>(card (UNIV::'a set)).
      approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n))"
  then have 1: "\<forall>m\<le>(card (UNIV::'a set)).
      approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m < approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc m)"
    using approx_tm0_mono_min assms order_less_le by blast

    let ?A = "\<Union>i\<le>(card (UNIV::'a set) + 1).
                {(approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i)}"

  have 2: "?A \<subseteq> (UNIV::'a set)"
    by auto

  from 0 1 have "\<forall>i\<le>(card (UNIV::'a set) + 1).
                 \<forall>i'\<le>(card (UNIV::'a set) + 1).
    i' \<noteq> i \<longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i \<noteq> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i'"
    using approx_tm0_mono_min approx_tm0_mono_min2 assms
    by (metis Suc_eq_plus1 antisym not_less_eq_eq)

  then have "\<forall>n\<le>(card (UNIV::'a set) + 1).
             n \<le> card (\<Union>i\<le>n. {(approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i)})"
    using inj_func_card by metis
  then have 3: "card ?A > (card (UNIV::'a set))"
    by auto

  from 2 3 show False
    by (meson card_mono finite_UNIV leD)
qed

lemma approx_tm0_mu_final: "\<forall>f. mono (\<eta>1 f)
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (card (UNIV ::'a::finite_lattice set))
      = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc (card (UNIV ::'a set)))"
  by (metis approx_tm0_eventually_stable approx_tm0_stays_stable le_SucI)

lemma approx_tm1_stays_stable:
  assumes "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n)"
    and "m \<ge> n"
    and "\<forall>f. mono (\<eta>1 f)"
  shows "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n"
proof (rule order.antisym)
  show "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m"
    by (simp add: approx_tm1_mono_min2 assms(2) assms(3))

  show "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n"
  proof (induction m)
    case 0
    then show ?case
      by (simp add: le_fun_def)
  next
    case (Suc m)
    then show ?case
      by (metis (no_types, lifting) approx_tm1.simps(2) approx_tm1_mono_min2
          assms(1) assms(3) dual_order.eq_iff le_SucE nat_le_linear)
  qed
qed

lemma approx_tm1_eventually_stable:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "\<exists>n \<le> card (UNIV::('a\<Rightarrow>'a) set).
  approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n)"
proof (rule ccontr)
  assume 0: "\<not> (\<exists>n\<le>card (UNIV::('a\<Rightarrow>'a) set).
            approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n))"
  then have 1: "\<forall>m\<le>card (UNIV::('a\<Rightarrow>'a) set).
                approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m < approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc m)"
    using approx_tm1_mono_min assms order_le_imp_less_or_eq by blast

  let ?A = "\<Union>i\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1). {(approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i)}"

  have 2: "?A \<subseteq> (UNIV::('a\<Rightarrow>'a::finite_lattice) set)"
    by auto

  from 0 1 have "\<forall>i\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1). \<forall>i'\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1).
    i < i' \<longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i < approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i'"
    using approx_tm1_mono_min2 assms
    by (smt (verit, del_insts) Suc_eq_plus1 dual_order.eq_iff le_funI not_less_eq_eq order_less_le)

  then have "\<forall>i\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1). \<forall>i'\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1).
    i \<noteq> i' \<longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i \<noteq> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i'"
    using approx_tm1_mono_min2 assms
    by (metis linorder_neq_iff order_less_irrefl)

  then have "\<forall>n\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1).
              n \<le> card (\<Union>i\<le>n. {(approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i)})"
    by (metis inj_func_card)
  then have 3: "card ?A > (card (UNIV::('a\<Rightarrow>'a) set))"
    by auto
  then have 4: "card ?A \<le> card (UNIV::('a\<Rightarrow>'a) set)"
    using card_mono finite_UNIV by blast

  from 3 4 show False  by simp
qed

lemma approx_tm1_mu_final: "\<forall>f. mono (\<eta>1 f) \<Longrightarrow>
      approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (card (UNIV::('a\<Rightarrow>'a::finite_lattice) set))
      = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc (card (UNIV::('a\<Rightarrow>'a::finite_lattice) set)))"
      by (metis approx_tm1.simps(2) approx_tm1_eventually_stable approx_tm1_stays_stable)

lemma unfold_mu0:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>)
            = sem_tm0 (\<eta>0(x1a := sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>))) \<eta>1 \<phi>"
    (is "?l = ?r")
proof -
  have 0: "sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>) =
             \<Sqinter>{d. sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d}"
    by simp

  have 1: "sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d \<longrightarrow> ?l \<le> d" for d
    by (simp add: Inf_lower)
  then have 2: "(sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d)
        \<longrightarrow> (\<eta>0(x1a := ?l)) x \<le> (\<eta>0(x1a := d)) x" for x d
    by simp
  then have "sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d
        \<longrightarrow> ?r \<le> sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi>" for d
    by (simp add: assms sem_mono(1))
  then have "sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d \<longrightarrow> ?r \<le> d" for d
    using dual_order.trans by blast
  then have 3: "?r \<le> \<Sqinter>{d. sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d}"
    by (simp add: le_Inf_iff)
  with 1 2 have "sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>)
    \<le> sem_tm0 (\<eta>0(x1a := sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>))) \<eta>1 \<phi>"
    using assms sem_mono(1) by auto
  with 3 show ?thesis by simp
qed

lemma unfold_mu1:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>) = sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
    (is "?l = ?r")
proof -
  have 0: "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>) = \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}"
    by simp

  have 1: "mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> ?l \<le> d" for d
    by (simp add: Inf_lower)
  then have " mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> (\<eta>1(x1a := ?l)) x \<le> (\<eta>1(x1a := d)) x" for x d
    by auto
  with 1 have "mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> ?r \<le> (sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi>)" for d
    by (meson dual_order.refl assms sem_mono(2) sem_tm_fun_upd_mono)
  then have "mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> ?r \<le> d" for d
    using dual_order.trans by blast

  then have 2: "?r \<le> \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}"
    by (simp add: le_Inf_iff)
  with 0 1 have 3: "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>)
                  \<le> sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
    using sem_mono(2) assms
    by (smt (verit) dual_order.eq_iff fun_upd_apply le_fun_def)

  from 2 3 show ?thesis by simp
qed

theorem sem_k_eq_sem:
"\<And>\<eta>0 \<eta>1. \<forall>f. mono (\<eta>1 f) \<Longrightarrow> sem_tm0_k \<eta>0 \<eta>1 \<phi> = sem_tm0 \<eta>0 \<eta>1 \<phi>"

"\<And>\<eta>0 \<eta>1. \<forall>f. mono (\<eta>1 f) \<Longrightarrow> sem_tm1_k \<eta>0 \<eta>1 \<phi>' = sem_tm1 \<eta>0 \<eta>1 \<phi>'"
proof (induction \<phi> and \<phi>')
  case (Mu0 x \<phi>)

  have 1: "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n
            \<le> \<Sqinter>{d. sem_tm0 (\<eta>0(x := d)) \<eta>1 \<phi> \<le> d}" for n
  proof (induction n)
    case 0
    then show ?case
      by simp
  next
    case (Suc n)
    have 0: "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)
            = sem_tm0_k (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n)) \<eta>1 \<phi>"
      by simp
    then have 1: "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)
            = sem_tm0 (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n)) \<eta>1 \<phi>"
      using Mu0.IH Mu0.prems by fastforce
    then have "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>)"
      by (simp add: Suc)
    then have 2: "sem_tm0 (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n)) \<eta>1 \<phi>
                  \<le> sem_tm0 (\<eta>0(x := sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>))) \<eta>1 \<phi>"
      using Mu0.prems sem_mono(1) by auto

   have "sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>) =
              sem_tm0 (\<eta>0(x := sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>))) \<eta>1 \<phi>"
      using Mu0.prems unfold_mu0 by blast
   with 0 1 2 show ?case
     by (metis sem_tm0.simps(4))
  qed

  let ?t = "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (card (UNIV::'a set))"

  have "sem_tm0 (\<eta>0(x := ?t)) \<eta>1 \<phi> \<le> ?t"
    by (metis approx_tm0.simps(2) approx_tm0_mu_final
        dual_order.eq_iff Mu0.IH Mu0.prems)
  then have 2: "?t \<ge> \<Sqinter>{d. sem_tm0 (\<eta>0(x := d)) \<eta>1 \<phi> \<le> d}"
    by (simp add: Inf_lower)

  from 1 2 show ?case
    by (simp add: order.antisym)
next
  case (Lam x \<phi>)
  then have "(\<lambda>d'. sem_tm0 (\<eta>0(x := d')) \<eta>1 \<phi>) d =
      (\<lambda>d'. sem_tm0_k (\<eta>0(x := d')) \<eta>1 \<phi>) d" for d
    by fastforce
  then show ?case
    by simp
next
  case (Mu1 x1a \<phi>)
  have 1: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n
    \<le> \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}" for n
  proof (induction n)
    case 0
    then show ?case
      by (simp add: le_fun_def)
  next
    case (Suc n)
    have 0: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) (Suc n)
            = sem_tm1_k \<eta>0 (\<eta>1(x1a := approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n)) \<phi>"
      by simp
    then have 1: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) (Suc n)
            = sem_tm1 \<eta>0 (\<eta>1(x1a := approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n)) \<phi>"
      using Mu1.IH Mu1.prems
      by (smt (verit, best) approx_tm1_mono dual_order.eq_iff fun_upd_apply sem_k_mono(2))
    then have "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n \<le> sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>)"
      by (simp add: Suc)
    then have 2: "sem_tm1 \<eta>0 (\<eta>1(x1a := approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_.\<bottom>) n)) \<phi>
                  \<le> sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
      by (smt (verit) Mu1.prems approx_tm1_mono dual_order.eq_iff sem_tm_fun_upd_mono
          ctx_axioms sem_k_mono(2) sem_mono(2))

    have "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>) =
              sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
      using Mu1.prems unfold_mu1 by blast
    with 0 1 2 show ?case
      by (metis sem_tm1.simps(4))
  qed

  let ?t = "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_.\<bottom>) (card (UNIV::('a\<Rightarrow>'a) set))"

  have "?t = approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>)(Suc (card (UNIV::('a\<Rightarrow>'a) set)))"
    using Mu1.prems approx_tm1_mu_final by blast
  then have "sem_tm1 \<eta>0 (\<eta>1(x1a := ?t)) \<phi> \<le> ?t"
    by (smt (verit, best) dual_order.eq_iff approx_tm1_mono fun_upd_apply
        Mu1.IH Mu1.prems approx_tm1.simps(2) sem_k_mono(2))

  then have 2: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) (card (UNIV::('a\<Rightarrow>'a) set))
               \<ge> \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}"
    by (smt (verit, best) Inf_lower Mu1.prems approx_tm1_mono dual_order.eq_iff
        mem_Collect_eq sem_k_mono(2))

  from 1 2 show ?case
    by (metis dual_order.eq_iff sem_tm1.simps(4) sem_tm1_k.simps(4))
qed auto

end end


subsection\<open>The reduction from \<open>3CNF-SAT\<close> To \<open>Set Cover\<close> is polynomial\<close>

theory TC_To_ChrN_Poly
  imports "../Polynomial_Reductions" "TC_To_ChrN"
begin

definition "size_NodesOf3C = (\<lambda>(E). card (\<Union>E))"
definition "size_chrN = (\<lambda>(E,k). card E)"
definition "mop_set_empty_set = REST [ {} \<mapsto> 1]"
definition "mop_amount_nodes E = SPECT [ card (\<Union>(E))+3 \<mapsto> 1 ]"

definition "translateGraph E S=
  SPECT [ S \<union> {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<mapsto> card (\<Union>E) * card (\<Union>E)]"

definition "add_completeGraph E S =
  SPECT [ S \<union> {{(0::nat,k),(0::nat,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'} \<mapsto>
          ((card (\<Union>E)) * ((card (\<Union>E))-1)) div 2]"

definition "connectGraphs E S =
  SPECT [ S \<union> {{(v1,0::nat),(0::nat,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} \<mapsto> card (\<Union>E) * card (\<Union>E)]"

definition threeColToChrNum ::
  "nat set set \<Rightarrow> (((nat \<times> nat) set set) \<times> nat) nrest" where
  "threeColToChrNum = (\<lambda>E. do {
      b \<leftarrow> SPECT [ ugraph E \<mapsto> 1];
      if b then
        do {
          k \<leftarrow> mop_amount_nodes E;
          S \<leftarrow> mop_set_empty_set;
          S \<leftarrow> translateGraph E S;
          S \<leftarrow> add_completeGraph E S;
          S \<leftarrow> connectGraphs E S;
          RETURNT (S,k)
        }
      else RETURNT (({},0))
    })"

definition "size_SAT xs = length xs"
definition "threeColToChrNum_time n =  1 + 1 + 1 + (n*n)+ (n*n) + (n*n)"
definition "threeColToChrNum_space n = (n*n)+ (n*n) + (n*n)"

lemma finite_chrn_split1:
"finite (\<Union>E) \<Longrightarrow> finite {{(v1, 0), (v2, 0)} |v1 v2. v1 \<in> \<Union> E \<and> v2 \<in> \<Union> E} "
proof -
  assume asms: "finite (\<Union>E)"
  let ?S = "(((\<Union>E)\<times>{0}) \<times> (\<Union> E\<times> {0}))"
  from asms show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma chro_part_sml_card: " (x::nat) * (x - 1) div 2 + x \<le> x* x"
  by (metis div_le_dividend le_square mult.comm_neutral
      ordered_cancel_comm_monoid_diff_class.le_diff_conv2 right_diff_distrib')

lemma threeColToChrNum_refines:
  "threeColToChrNum E \<le> SPEC (\<lambda>y. y = TC_chrN E) (\<lambda>_. enat (threeColToChrNum_time (size_NodesOf3C E)))"
  unfolding SPEC_def
  unfolding threeColToChrNum_time_def TC_chrN_def threeColToChrNum_def
       mop_amount_nodes_def mop_set_empty_set_def translateGraph_def add_completeGraph_def connectGraphs_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: T_SPEC )
  apply (auto simp: size_NodesOf3C_def one_enat_def ugraph_def)
  by (metis diff_le_self div_le_dividend le_trans right_diff_distrib')

lemma chrNgraph_size_eval:"size_chrN (TC_chrN E) \<le>card (\<Union> E) * card (\<Union> E) +
                                                        card (\<Union> E) * card (\<Union> E) +
                                                        card (\<Union> E) * card (\<Union> E)"
proof (cases "ugraph E")
  case T:True
  define E_trans where E_trans_def:"E_trans= {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E}"
  define connect where connect_def:"connect= {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
  define graph_complete where graph_complete_def:"graph_complete=
    {{(0::nat,k),(0,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'}"

  from T have size_split:"size_chrN (TC_chrN E) = card (
              E_trans \<union>
              connect \<union>
              graph_complete)"
    unfolding TC_chrN_def size_chrN_def graph_complete_def connect_def E_trans_def
    by simp

  from T have finiteNodes:"finite (\<Union>E)"
    unfolding ugraph_def
    using finite_Union by fastforce

  from T chromatik_finite1 have fin1: "finite E_trans"
    unfolding E_trans_def
    by blast

  from finiteNodes chromatik_finite2 have fin2: "finite connect"
    unfolding connect_def
    by blast

  from finiteNodes chromatik_finite3 have fin3: "finite graph_complete"
    unfolding graph_complete_def
    by blast

  from chromatik_card1 T have card1:"card E_trans = card E"
    unfolding E_trans_def
    by blast

  from chromatik_card3 finiteNodes have card2:"card connect = card (\<Union>E) * card (\<Union>E)"
    unfolding connect_def
    by blast

  from chromatik_card4 finiteNodes have card3:"card graph_complete = card (\<Union>E) * (card (\<Union>E)-1) div 2"
    unfolding graph_complete_def
    by blast

  have "\<And>e. e\<in>connect \<Longrightarrow> e\<notin> E_trans"
  proof -
    fix e
    assume "e\<in> connect"
    from this obtain k where k_def:"(0,k)\<in> e \<and> k \<in>{1..card (\<Union> E)} "
      unfolding connect_def
      by blast
    have "\<forall> e'\<in> E_trans. \<forall> a b. (a,b) \<in> e'  \<longrightarrow> b = 0"
      unfolding E_trans_def
      by blast
    from this k_def have "\<forall>e'\<in>E_trans. (0, k) \<notin> e'"
      by auto
    from k_def this show "e\<notin> E_trans"
      by blast
  qed

  from this have disjoint1:"E_trans \<inter> connect = {}"
    by blast

  have disjoint2:"E_trans \<inter> graph_complete = {}"
    unfolding E_trans_def graph_complete_def
    by fastforce

  have "\<And>e. e\<in>connect \<Longrightarrow> e\<notin> graph_complete"
  proof -
    fix e
    assume "e\<in> connect"
    from this obtain v where v_def:"(v,0)\<in> e \<and> v \<in> (\<Union> E) "
      unfolding connect_def
      by blast
    have "\<forall> e'\<in> graph_complete. \<forall> a b. (a,b) \<in> e'  \<longrightarrow> b \<in> {1..card (\<Union> E)}"
      unfolding graph_complete_def
      by blast
    from this v_def have "\<forall>e'\<in>graph_complete. (v, 0) \<notin> e'"
      by auto
    from v_def this show "e\<notin> graph_complete"
      by blast
  qed

  from this have disjoint3:"connect \<inter> graph_complete = {}"
    by blast

  from disjoint1 disjoint2 disjoint3 fin1 fin2 fin3 have
    " card (E_trans \<union> connect \<union> graph_complete) =
      card E_trans + card connect + card graph_complete"
    by (simp add: card_Un_disjoint inf_sup_distrib2)

  from this size_split card1 card2 card3 have split_card:
    "size_chrN (TC_chrN E) = card E +
                                   (card (\<Union> E) * card (\<Union> E)) +
                                   (card (\<Union> E) * (card (\<Union> E) - 1) div 2)"
    by presburger

  define E_complete where E_complete_def: "E_complete = {{(v1::nat,0::nat),(v2,0)}|v1 v2. v1\<in> \<Union>E \<and> v2\<in> \<Union>E}"

  have E_complete_card:"finite (\<Union> E) \<Longrightarrow> card E_complete = (card (\<Union>E) * (card (\<Union>E)-1) div 2) + card (\<Union>E)"
  unfolding E_complete_def
  proof (induction "card (\<Union>E)" arbitrary: E)
    case 0
    from this have "\<Union>E = {}"
      by simp
    show ?case
      by (simp add: \<open>\<Union> E = {}\<close>)
  next
    case (Suc x)
    from Suc(2) have "\<Union>E \<noteq> {}"
      by fastforce
    from this Suc(2) Suc(3) obtain E' v where E'_def:
      "\<Union>E = \<Union>E' \<union> {v} \<and> \<Union>E' \<inter> {v} = {}"
      unfolding ugraph_def
      by (metis Int_empty_right Int_insert_right_if0
          Un_empty_right Un_insert_right all_not_in_conv
          ccpo_Sup_singleton mk_disjoint_insert)
    from E'_def Suc(2) have E'_card:"card (\<Union>E') = x"
      using Suc.prems by auto
    from Suc(3) E'_def have finE':"finite (\<Union>E')"
      by simp
    define graph where graph_def: "graph = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E \<and> v2 \<in> \<Union> E}"
    define split1 where split1_def: "split1 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 \<in> \<Union> E'}"
    define split2 where split2_def: "split2 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 =v}"
    define split3 where split3_def: "split3 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 \<in> \<Union> E'}"
    define split4 where split4_def: "split4 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 = v}"

    from split2_def have split2_def': "split2 = {{(v1, 0::nat), (v, 0)} |v1. v1 \<in> \<Union> E'}"
      by fastforce
    from split3_def have split3_def': "split3 = {{(v, 0::nat), (v2, 0)} |v2. v2 \<in> \<Union> E'}"
      by fastforce
    from split2_def' split3_def' have sp2sp3_eq:"split2 = split3"
      by blast
    from split4_def have split4_def':"split4 = {{(v, 0::nat), (v, 0)}}"
      by blast

    define split_step where split_step_def:
      "split_step = {{(v1, 0::nat), (v2, 0)} |v1 v2. (v1 \<in> \<Union>E' \<or> v1 = v) \<and> (v2 \<in> \<Union>E' \<or> v2 = v)}"
    from E'_def have "{{(v1, 0), (v2, 0)} |v1 v2. v1 \<in> \<Union>E \<and> v2 \<in> \<Union>E} =
                  {{(v1, 0), (v2, 0)} |v1 v2. (v1 \<in> \<Union>E' \<or> v1 = v) \<and> (v2 \<in> \<Union>E' \<or> v2 = v)}"
      by auto
    from this have sp_1:" graph = split_step"
      unfolding split_step_def graph_def
      by blast

    have sp_2:"split_step =
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 \<in> \<Union> E'} \<union>
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 =v} \<union>
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 \<in> \<Union> E'} \<union>
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 = v}"
      unfolding split_step_def
      by fast

    from sp_1 sp_2 have "graph = split1 \<union> split2 \<union> split3 \<union> split4"
      by (simp add: split1_def split2_def split3_def split4_def)

    from this sp2sp3_eq have graph_split:
      "graph = split1 \<union> split2 \<union> split4"
      by auto

    from Suc(1)[where E= E'] finE' E'_card split1_def have card1:
      "card split1 = (card (\<Union>E') * (card (\<Union>E')-1) div 2) + card (\<Union>E')"
      by auto
    from split2_def' have card2: "card split2 = card (\<Union>E')"
      using card_one_para2 finE' sp2sp3_eq split3_def' by fastforce
    have card3: "card split4 = 1"
      unfolding split4_def
      by force
    from E'_def have vNotinE'nodes:"v\<notin> \<Union>E'"
      by blast
    have "\<And>e. e\<in>split2 \<Longrightarrow> e\<notin> split1"
    proof -
      fix e
      assume "e\<in> split2"
      from this have vIn_e:"(v,0)\<in> e"
        unfolding split2_def'
        by blast
      have "\<forall> e'\<in> split1. \<forall>v'.(v',0) \<in> e' \<longrightarrow> v'\<in>\<Union>E'"
        unfolding split1_def
        by blast
      from this vNotinE'nodes have "\<forall>e'\<in>split1. (v, 0) \<notin> e'"
        by blast
      from vIn_e this show "e\<notin> split1"
        by blast
    qed
    from this have disjoint1: "split1 \<inter> split2 = {}"
      by blast

    from vNotinE'nodes have disjoint2: "split1 \<inter> split4 = {}"
      unfolding split1_def split4_def'
      by simp

    from vNotinE'nodes have disjoint3: "split2 \<inter> split4 = {}"
      unfolding split2_def split4_def'
      by simp

    from finE' have fin1: "finite split1"
      unfolding split1_def
      using finite_chrn_split1
      by blast

    from finE' have fin2: "finite split2"
      unfolding split2_def'
    proof -
      have "\<forall>f N. finite {r. \<exists>n. (r::(nat \<times> nat) set) = f (n::nat) \<and> n \<in> N} \<or> infinite N"
        by force
      then show "finite {{(n, 0::nat), (v, 0)} |n. n \<in> \<Union> E'}"
        by (meson finE')
    qed

    have fin3: "finite split4"
      unfolding split4_def'
      by blast

    from graph_split disjoint1 disjoint2 disjoint3 fin1 fin2 fin3 have
      "card graph = card split1 + card split2 + card split4"
      by (simp add: card_Un_disjoint inf_sup_distrib2)

    from this card1 card2 card3 E'_card have "card graph = (x * (x-1) div 2 + x) + x + 1"
      by argo

    from this have card_graph:"card graph =  ((x * (x-1)) + 2 *x) div 2 + Suc x"
      by simp
    have "((x * (x-1)) + 2 *x) = x* (x +1)"
      by (auto simp : right_diff_distrib')
    from this card_graph have "card graph = ((Suc x) * (x)) div 2 + Suc x"
      by simp
    from this Suc(2) show ?case
      unfolding graph_def
      by (metis diff_Suc_1)
  qed

  have finE_complete:"finite E_complete"
    unfolding E_complete_def
    using finiteNodes finite_chrn_split1 by blast

  have subset1:"E_trans \<subseteq> E_complete"
    unfolding E_complete_def E_trans_def
    by blast

  from finiteNodes subset1 E_complete_card card1 have chrN_card_sml1:
    "card E \<le> card (\<Union> E) * (card (\<Union> E) - 1) div 2 + card (\<Union> E)"
  proof -
    from subset1 finE_complete have "card E_trans \<le> card E_complete"
      using Finite_Set.card_mono
      by blast
    from this card1 E_complete_card finiteNodes show ?thesis
      by metis
  qed

  have chrN_card_sml2:"card (\<Union> E) * (card (\<Union> E) - 1) div 2 + card (\<Union> E) \<le> card (\<Union> E)* card (\<Union> E) "
    using chro_part_sml_card
    by blast

  from chrN_card_sml1 chrN_card_sml2 have chrN_card_sml3:"card E \<le>  card (\<Union> E)* card (\<Union> E)"
    by linarith

  from split_card chrN_card_sml3 show ?thesis
    apply auto
    by (metis One_nat_def add_le_mono div_le_dividend mult.commute mult_eq_if trans_le_add2)
next
  case False
  from this have "size_chrN (TC_chrN E) = card {}"
    unfolding TC_chrN_def size_chrN_def
    by simp
  then show ?thesis
    by simp
qed

lemma threeColToChrNum_size:
  "size_chrN (TC_chrN E) \<le> threeColToChrNum_space (size_NodesOf3C E)"
  using chrNgraph_size_eval
  unfolding threeColToChrNum_space_def size_NodesOf3C_def
  by blast

theorem threeColToChrNum_ispolyred: "ispolyred threeColToChrNum three_colorability chromaticNumber size_NodesOf3C size_chrN"
  unfolding ispolyred_def
  apply(rule exI[where x=TC_chrN])
  apply(rule exI[where x=threeColToChrNum_time])
  apply(rule exI[where x=threeColToChrNum_space])
  apply(safe)
  subgoal using threeColToChrNum_refines
    by simp
  subgoal using threeColToChrNum_size
    by simp
  subgoal unfolding poly_def threeColToChrNum_time_def apply(rule exI[where x=2]) by auto
  subgoal unfolding poly_def threeColToChrNum_space_def apply(rule exI[where x=2]) by auto
  using is_reduction_threeC_chrN
  apply (simp add:is_reduction_def )
done

end


theory LRE_Beh_26122022_075805
imports "Z_Machines.Z_Machine"
begin

subsection \<open> Introduction \<close>

text \<open> This theory file is to model the LRE_Beh state machine in Z Machine notations.\<close>

notation undefined ("???")

subsection \<open> type definition \<close>

datatype ('s, 'e) tag =
  State (ofState: 's) | Event (ofEvent: 'e)

abbreviation "is_Event x \<equiv> \<not> is_State x"

type_synonym ('s, 'e) rctrace = "('s, 'e) tag list"

definition wf_rcstore :: "('s, 'e) rctrace \<Rightarrow> 's \<Rightarrow> 's option \<Rightarrow> bool" where
[z_defs]: "wf_rcstore tr st final = (
     length(tr) > 0
   \<and> tr ! ((length tr) -1) = State st
   \<and> (final \<noteq> None \<longrightarrow> (\<forall>i<length tr. tr ! i = State (the final) \<longrightarrow> i= (length tr) -1))
   \<and> (filter is_State tr) ! (length (filter is_State tr) -1) = State  st)"

enumtype St = OCM | MOM | HCM | CAM | initial
definition [z_defs]: "St = {OCM, MOM, HCM, CAM, initial}"

enumtype Evt = endTask | reqOCM | reqMOM | reqVel | advVel | position
definition "Evt = {endTask, reqOCM, reqMOM, reqVel, advVel, position}"

consts StaticObsDist :: "integer"
consts MinSafeDist :: "integer"
consts HCMVel :: "integer"
consts MOMVel :: "integer"
consts Obsts :: "(integer\<times>integer) list"
consts ReqV :: "(integer\<times>integer) set"

text \<open> function definition \<close>

consts setVel :: " (integer\<times>integer) \<times> integer \<Rightarrow>(integer\<times>integer)"
consts CDA :: " (integer\<times>integer) \<times> (integer\<times>integer) list \<times> (integer\<times>integer) \<Rightarrow>integer"
consts maneuv :: " (integer\<times>integer) \<Rightarrow> (integer\<times>integer)"
consts dist :: " (integer\<times>integer) \<times> (integer\<times>integer) list \<Rightarrow>integer"
consts inOPEZ :: " (integer\<times>integer) \<Rightarrow> bool"

subsection \<open> State Space \<close>

zstore LRE_Beh =
  pos :: "(integer\<times>integer)"
  vel :: "(integer\<times>integer)"
  reqV :: "(integer\<times>integer)"

  st::"St"
  tr :: "(St, Evt) tag list"
  triggers:: "Evt set"
  where inv:
    "wf_rcstore tr st (Some final)"

subsection \<open> Operations \<close>

zoperation InitialToOCM =
  over LRE_Beh
  pre "st= initial"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation OCMToMOM =
  over LRE_Beh
  pre "st= OCM \<and> ((vel.1 * vel.1) + (vel.2 * vel.2))\<le>(3 * 3) \<and> dist(pos, Obsts)>10 \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= MOM
          ,vel\<Zprime> =setVel(vel, MOMVel)
         ,tr\<Zprime> =tr @ [Event reqMOM]@ [Event advVel] @ [State MOM]
         ,triggers\<Zprime> = {reqOCM, endTask}
         ]"

zoperation MOMToOCM =
  over LRE_Beh
  pre "st= MOM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToOCM =
  over LRE_Beh
  pre "st= HCM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation MOMToHCM =
  over LRE_Beh
  pre "st= MOM \<and> ((vel.1 * vel.1) + (vel.2 * vel.2))>(3 * 3) \<and> dist(pos, Obsts)\<le>StaticObsDist \<and> CDA(pos, Obsts, vel)>MinSafeDist \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= HCM
          ,vel\<Zprime> =setVel(vel, HCMVel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State HCM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToOCM_1 =
  over LRE_Beh
  pre "st= MOM \<and> inOPEZ(pos) \<and> (CDA(pos, Obsts, vel)>MinSafeDist \<or> dist(pos, Obsts)>StaticObsDist)"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToOCM_1 =
  over LRE_Beh
  pre "st= HCM \<and> inOPEZ(pos) \<and> (CDA(pos, Obsts, vel)>MinSafeDist \<or> dist(pos, Obsts)>StaticObsDist)"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToMOM =
  over LRE_Beh
  pre "st= HCM \<and> dist(pos, Obsts)>StaticObsDist \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= MOM
          ,vel\<Zprime> =setVel(vel, MOMVel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State MOM]
         ,triggers\<Zprime> = {reqOCM, endTask}
         ]"

zoperation OCMToOCM =
  over LRE_Beh
  params reqV_input \<in> "ReqV"
  pre "st= OCM"
  update "[st\<Zprime>= OCM
         ,reqV\<Zprime> =reqV_input
         ,vel\<Zprime> = reqV_input
         ,tr\<Zprime> =tr @ [Event reqVel]@ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation MOMToOCM_2 =
  over LRE_Beh
  pre "st= MOM"
  update "[st\<Zprime>= OCM
         ,vel\<Zprime> = (0, 0)
         ,tr\<Zprime> =tr @ [Event endTask]@ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToCAM =
  over LRE_Beh
  pre "st= HCM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToCAM =
  over LRE_Beh
  pre "st= MOM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation CAMToOCM =
  over LRE_Beh
  pre "st= CAM \<and> CDA(pos, Obsts, vel)>MinSafeDist"
  update "[st\<Zprime>= OCM
         ,vel\<Zprime> = (0, 0)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation CAMToOCM_1 =
  over LRE_Beh
  pre "st= CAM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation CAMToCAM =
  over LRE_Beh
  pre "st= CAM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToCAM_1 =
  over LRE_Beh
  pre "st= MOM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation HCMToCAM_1 =
  over LRE_Beh
  pre "st= HCM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation CAMToCAM_1 =
  over LRE_Beh
  pre "st= CAM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

definition Init :: "LRE_Beh subst" where
  [z_defs]:
  "Init =
  [st\<leadsto> ,
   tr\<leadsto> ,
   triggers\<leadsto> ,
   ]"
(*To be filled in by user*)

zmachine LRE_BehMachine =
  init Init
  invariant LRE_Beh_inv
  operations  InitialToOCM OCMToMOM MOMToOCM HCMToOCM MOMToHCM MOMToOCM_1 HCMToOCM_1 HCMToMOM OCMToOCM MOMToOCM_2 HCMToCAM MOMToCAM CAMToOCM CAMToOCM_1 CAMToCAM MOMToCAM_1 HCMToCAM_1 CAMToCAM_1

subsection \<open> Structural Invariants \<close>

lemma Init_inv [hoare_lemmas]: "Init establishes LRE_Beh_inv"
  by zpog_full

lemma InitialToOCM_inv [hoare_lemmas]: "InitialToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma OCMToMOM_inv [hoare_lemmas]: "OCMToMOM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_inv [hoare_lemmas]: "MOMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToOCM_inv [hoare_lemmas]: "HCMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToHCM_inv [hoare_lemmas]: "MOMToHCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_1_inv [hoare_lemmas]: "MOMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToOCM_1_inv [hoare_lemmas]: "HCMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToMOM_inv [hoare_lemmas]: "HCMToMOM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma OCMToOCM_inv [hoare_lemmas]: "OCMToOCM (reqV) preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_2_inv [hoare_lemmas]: "MOMToOCM_2() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToCAM_inv [hoare_lemmas]: "HCMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToCAM_inv [hoare_lemmas]: "MOMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToOCM_inv [hoare_lemmas]: "CAMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToOCM_1_inv [hoare_lemmas]: "CAMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToCAM_inv [hoare_lemmas]: "CAMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToCAM_1_inv [hoare_lemmas]: "MOMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToCAM_1_inv [hoare_lemmas]: "HCMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToCAM_1_inv [hoare_lemmas]: "CAMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

subsection \<open> Safety Requirements \<close>

zexpr R1 is ""

lemma  "Init establishes R1"
  by zpog_full

lemma "InitialToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "OCMToMOM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToHCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToMOM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "OCMToOCM (reqV) preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM_2() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

definition [z_defs]: "LRE_Beh_axioms = ()"

lemma LRE_Beh_deadlock_free: "LRE_Beh_axioms  \<Longrightarrow> deadlock_free LRE_BehMachine"
  unfolding LRE_BehMachine_def
  by deadlock_free
end


(*
    File:        Length.thy
    Time-stamp:  <2016-01-06T17:48:20Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory Length imports Lambda dLambda begin

definition LLength :: "i=>i" where
"LLength(M) == LTerm_rec(%x. 0, %x m r. succ(r),
                         %m n rm rn. succ(rm Un rn), M)"

definition Length :: "i=>i" where
"Length(M) == THE n. n: (INT m: M. {LLength(m)})"

lemma LLength_eqns:
  "LLength(LVar(x)) = 0"
  "LLength(LLam(x, M)) = succ(LLength(M))"
  "LLength(LApp(M, N)) = succ(LLength(M) Un LLength(N))"
apply (unfold LLength_def)
apply simp_all
done

lemma LLength_type:
  "M: LTerm ==> LLength(M): nat"
apply (erule LTerm.induct)
apply (simp_all only: LLength_eqns)
apply (assumption | rule nat_succI nat_UnI nat_0I)+
done

lemma LSkeltonEq_imp_LLength_eq:
  assumes major: "LSkeltonEq(M, N)"
  shows "LLength(M) = LLength(N)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="N" in spec)
apply (rule major [THEN LSkeltonEqD1, THEN LTerm.induct])
apply (safe elim!: LSkeltonEq_LTermEs)
apply (simp_all add: LLength_eqns)
done

lemma Length_LAQ:
  "m: LTerm ==> Length(LAQ(m)) = LLength(m)"
apply (unfold Length_def)
apply (rule the_equality)
apply (rule INT_I)
apply (rule_tac [2] not_emptyI)
apply (erule_tac [2] LAQ_self)
apply (drule LAQ_D)
apply (drule LAlphaD1 [THEN LSkeltonEq_imp_LLength_eq])
apply blast
apply (drule INT_E)
apply (erule LAQ_self)
apply (erule singletonE)
apply assumption
done

lemma Length_type:
  "M: Term ==> Length(M): nat"
apply (erule TermE)
apply hypsubst
apply (simp only: Length_LAQ)
apply (erule LLength_type)
done

lemma Length_Var:
  "x: LVariable ==> Length(Var(x)) = 0"
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemma Length_Lam:
  "[| x: LVariable; M: Term |] ==>
        Length(Lam(x, M)) = succ(Length(M))"
apply (erule TermE)+
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemma Length_App:
  "[| M: Term; N: Term |] ==>
        Length(App(M, N)) = succ(Length(M) Un Length(N))"
apply (erule TermE)+
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemmas Length_eqns = Length_Var Length_Lam Length_App

lemma Length_induct:
  assumes major: "M: Term"
  and prem:
     "!!M. [| M: Term; ALL N: Term. Length(N) < Length(M) --> P(N) |]
           ==> P(M)"
  shows "P(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac P="Length(M) = Length(M)" in rev_mp)
apply (rule_tac [2] P="%x. Length(M) = Length(x) --> x : Term --> P(x)" in major [THEN [2] bspec])
apply (rule_tac [2] P="%n. ALL M: Term. n = Length(M) --> M: Term --> P(M)" in
         major [THEN Length_type, THEN complete_induct0])
apply (rule refl)
apply safe
apply (erule prem)
apply safe
apply (erule bspec [THEN bspec, THEN mp, THEN mp])
apply (erule ltD)
apply (assumption | rule refl)+
done

lemma Term_induct2:
  assumes major: "M: Term"
  and prem1: "X: Fin(LVariable)"
  and
     "!! x . x: LVariable ==> P(Var(x))"
  and
     "!! x M . [| x: LVariable; x ~: X; M: Term; P(M) |]
          ==> P(Lam(x, M))"
  and
     "!! M N . [| M: Term; P(M); N: Term; P(N) |] ==> P(App(M, N))"
  shows "P(M)"
apply (rule major [THEN Length_induct])
apply (erule Term_cases)
apply safe
apply (rule_tac [2] prem1 [THEN [3] Infinite_LVariable_Alpha_lemma2,
          THEN bexE])
apply (erule_tac [2] asm_rl)+
apply (erule_tac [2] bexE conjE)+
apply (rotate_tac [1] 1)
apply (rotate_tac [2] 1)
apply (rotate_tac [3] 1)
prefer 2 apply simp
apply (simp_all add: Length_eqns)
apply (rule_tac [3] assms)
apply (rule_tac [2] assms)
apply (rule_tac [1] assms)
prefer 5
prefer 6
prefer 8
apply assumption+
apply (erule_tac [3] bspec [THEN mp])
apply (erule_tac [2] bspec [THEN mp])
apply (erule_tac [1] bspec [THEN mp])
apply (assumption | rule nat_into_Ord le_refl Length_type
         Un_upper1_le Un_upper2_le)+
done

lemmas Term_typechecks = Term_intros subst_type Length_type
lemmas Term_simps = Term_free_iffs Length_eqns subst_eqns FV_eqns

declare Term_typechecks [TC]
declare Term_simps [simp]

end


theory C
  imports HHLProver.ContinuousInv
    HHLProver.BigStepParallel
    HHLProver.Complementlemma
begin

locale C =
  fixes Stop_point :: real    \<comment> \<open>64000\<close>
  fixes V_limit :: real       \<comment> \<open>100\<close>
  fixes Next_V_limit :: real  \<comment> \<open>40\<close>
  fixes Period :: real        \<comment> \<open>0.125\<close>
  fixes A_minus :: real       \<comment> \<open>1\<close>
  fixes A_plus :: real        \<comment> \<open>1\<close>
  assumes Period[simp]: "Period > 0"
  assumes Stop_point[simp]: "Stop_point > 0"
  assumes V_limit: "V_limit > 0"
  assumes Next_V_limit: "Next_V_limit > 0"
  assumes A_minus: "A_minus > 0"
  assumes A_plus: "A_plus > 0"
begin

definition "Pull_curve_max_d = V_limit * V_limit / (2 * A_minus)"
definition "Pull_curve_coeff = sqrt (2 * A_minus)"

lemma Pull_curve_coeff_ge_zero [simp]:
  "Pull_curve_coeff > 0"
  unfolding Pull_curve_coeff_def using A_minus by auto

lemma Pull_curve_max_d_ge_zero [simp]:
  "Pull_curve_max_d > 0"
  unfolding Pull_curve_max_d_def using V_limit A_minus by auto

text \<open>Variables\<close>

definition A :: char where "A = CHR ''a''"
definition V :: char where "V = CHR ''b''"
definition S :: char where "S = CHR ''c''"
definition T :: char where "T = CHR ''k''"
definition Command_a :: char where "Command_a = CHR ''n''"

lemma train_vars_distinct [simp]: "A \<noteq> V" "A \<noteq> S" "A \<noteq> T"
                                  "V \<noteq> A" "V \<noteq> S" "V \<noteq> T"
                                  "S \<noteq> A" "S \<noteq> V" "S \<noteq> T"
                                  "T \<noteq> A" "T \<noteq> V" "T \<noteq> S"
  unfolding A_def V_def S_def T_def by auto

definition Plant :: proc where
  "Plant =
      Cm (''P2C''[!](\<lambda>s. s V));
      Cm (''P2C''[!](\<lambda>s. s S));
      Cm (''C2P''[?]A);
      Rep (
      Interrupt
      (ODE ((\<lambda>_ _. 0)(S := (\<lambda>s. s V),
                      V := (\<lambda>s. s A))))(\<lambda> s. True)
      [(''P2C''[!](\<lambda>s. s V),
            Cm (''P2C''[!](\<lambda>s. s S));
            Cm (''C2P''[?]A))])"

fun Plant_inv :: "real \<times> real \<times> real \<Rightarrow> (real\<times>real)  list \<Rightarrow> tassn" where
  "Plant_inv (v0, s0, a0) [] = emp\<^sub>t"
| "Plant_inv (v0, s0, a0) ((T_t,a) # as) =
    WaitOut\<^sub>t T_t (\<lambda>t.  ((\<lambda>_. 0)(V := v0+a0*t, S := s0+v0*t+1/2*a0*t*t,
                                            A := a0))) ''P2C'' (\<lambda> s. s V) ({''P2C''},{})@\<^sub>t
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*T_t, S := s0+v0*T_t+1/2*a0*T_t*T_t, A := a0))) ''P2C'' (s0+v0*T_t+1/2*a0*T_t*T_t)) @\<^sub>t
    (In\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*T_t, S := s0+v0*T_t+1/2*a0*T_t*T_t, A := a0))) ''C2P'' a) @\<^sub>t
    Plant_inv (v0+a0*T_t, s0+v0*T_t+1/2*a0*T_t*T_t, a) (as)"

fun Plant_block :: "real \<times> real \<times> real \<Rightarrow> real \<Rightarrow> (real\<times>real)  list \<Rightarrow> tassn" where
"Plant_block (v0, s0, a00) a0 as =
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, A := a00))) ''P2C'' v0) @\<^sub>t
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, A := a00))) ''P2C'' s0) @\<^sub>t
    (In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, A := a00))) ''C2P'' a0) @\<^sub>t
    Plant_inv (v0, s0, a0) as"

fun Plant_end_state :: "real \<times> real \<times> real  \<Rightarrow> (real\<times>real)  list\<Rightarrow> state" where
  "Plant_end_state (v0, s0, a0) [] = ((\<lambda>_. 0)(V := v0, S := s0, A := a0))"
| "Plant_end_state (v0, s0, a0) ((T_t,a) # rest) =
   Plant_end_state (v0 + a0 * T_t, s0 + v0 * T_t +
                          1/2 * a0 * T_t * T_t, a) rest"

lemma Plant_end_state_rw:
  "(Plant_end_state (v0, s0, a0) xs) =
   (\<lambda>_. 0)(V := Plant_end_state (v0, s0, a0) xs V,
           S := Plant_end_state (v0, s0, a0) xs S,
           A := Plant_end_state (v0, s0, a0) xs A)"
  apply (induct xs arbitrary: v0 s0 a0) by auto

definition Plant_ode_state :: "state \<Rightarrow> real \<Rightarrow> state" where
  "Plant_ode_state s T_t = (\<lambda>_. 0)(V := s V + s A * T_t,
           S := s S + s V * T_t + s A * T_t * T_t / 2,
           A := s A)"

lemma Plant_end_state_snoc:
  "Plant_end_state (v0, s0, a0) (xs @ [(T_t,a)]) =
   (Plant_ode_state (Plant_end_state (v0, s0, a0) (xs)) T_t) (A := a)"
  apply (induct xs arbitrary: v0 s0 a0 ) unfolding Plant_ode_state_def by auto

lemma Plant_inv_snoc:
  "Plant_inv (v0, s0, a0) (xs @ [(T_t,a)]) =
   Plant_inv (v0, s0, a0) xs @\<^sub>t
   WaitOut\<^sub>t T_t (\<lambda>t.  Plant_ode_state(Plant_end_state (v0, s0, a0) xs) t) ''P2C'' (\<lambda> s. s V) ({''P2C''},{})@\<^sub>t
   Out\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''P2C'' (Plant_end_state (v0, s0, a0) xs S  +
            Plant_end_state (v0, s0, a0) xs V * T_t  +
            (Plant_end_state (v0, s0, a0) xs A) * T_t  * T_t / 2) @\<^sub>t
   In\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''C2P'' a
   "
proof (induct xs arbitrary: v0 s0 a0 )
  case Nil
  then show ?case
    unfolding Plant_ode_state_def apply (auto simp add: fun_upd_def)
    done
next
  case (Cons a xs)
  show ?case
    apply (cases a)
    subgoal for T_t' a'
      by (auto simp add: Cons join_assoc)
    done
qed

lemma Plant_block_snoc:
  "Plant_block (v0, s0, a00) a0 (xs @ [(T_t,a)]) =
   Plant_block (v0, s0, a00) a0  xs @\<^sub>t
   WaitOut\<^sub>t T_t (\<lambda>t.  Plant_ode_state(Plant_end_state (v0, s0, a0) xs) t) ''P2C'' (\<lambda> s. s V) ({''P2C''},{})@\<^sub>t
   Out\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''P2C'' (Plant_end_state (v0, s0, a0) xs S  +
            Plant_end_state (v0, s0, a0) xs V * T_t  +
            (Plant_end_state (v0, s0, a0) xs A) * T_t  * T_t / 2) @\<^sub>t
   In\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''C2P'' a
   "
  apply auto
  using Plant_inv_snoc[of v0 s0 a0 xs T_t a]
  by (auto simp add: join_assoc)

lemma Plant_prop:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, S := s0, A := a00) \<and> emp\<^sub>t tr}
      Plant
    {\<lambda>s tr. \<exists>a0 xs. s = Plant_end_state (v0, s0, a0) xs \<and>
                 Plant_block (v0, s0, a00) a0 xs tr}"
  unfolding Plant_def
  apply(rule Valid_seq)
   apply (rule Valid_send_sp_st)
  apply(rule Valid_seq)
   apply (rule Valid_send_sp_st)
apply(rule Valid_seq)
   apply (rule Valid_receive_sp_st)
  apply(rule Valid_ex_pre)
  subgoal for a0
    apply(rule Valid_ex_post)
    apply(rule exI[where x= "a0"])
    apply(rule Valid_weaken_pre)
     prefer 2
     apply(rule Valid_rep)
     prefer 2
    subgoal
     apply(auto simp add: entails_def)
      apply(rule exI[where x= "[]"])
      by (auto simp add: join_assoc)
    apply(rule Valid_ex_pre)
    subgoal for xs
      apply(rule Valid_ode_out_unique_solution[where p="\<lambda> t. Plant_ode_state(Plant_end_state (v0, s0, a0) xs) t"])
          apply(auto simp add:Plant_ode_state_def ODEsolInf_def has_vderiv_on_def)
      subgoal
        apply (rule exI[where x="1"])
        apply auto
        apply (rule has_vector_derivative_projI)
        apply (auto simp add: state2vec_def)
         subgoal
       apply (rule has_vector_derivative_eq_rhs)
        apply (fast intro!: derivative_intros) by simp
     subgoal
      apply (rule has_vector_derivative_eq_rhs)
        apply (fast intro!: derivative_intros) by simp
     subgoal premises pre for x i
   proof-
     have eq: "i \<noteq> S \<Longrightarrow>
           i \<noteq> V \<Longrightarrow>
           (\<lambda>t. if i = A then Plant_end_state (v0, s0, a0) xs A
                 else ((\<lambda>_. 0)(V := Plant_end_state (v0, s0, a0) xs V + Plant_end_state (v0, s0, a0) xs A * t,
                               S := Plant_end_state (v0, s0, a0) xs S + Plant_end_state (v0, s0, a0) xs V * t + Plant_end_state (v0, s0, a0) xs A * t * t / 2))
                       i) = (\<lambda>t. if i = A then Plant_end_state (v0, s0, a0) xs A else 0)"
       by auto
     have 1: ?thesis if "i = A"
       using eq that by auto
     have 2: ?thesis if "i \<noteq> A"
       using eq that pre by auto
     show ?thesis using 1 2 by linarith
       qed
       done
     subgoal using Plant_end_state_rw by auto
     subgoal
   proof-
    have bl:"bounded_linear (\<lambda>(v::vec) . \<chi> x. if x = V then (v$A) else if x = S then (v$V) else 0)"
      apply (rule bounded_linearI')
      using vec_lambda_unique by fastforce+
    show ?thesis
      unfolding state2vec_def vec2state_def fun_upd_def
      apply (rule c1_implies_local_lipschitz[where f'="(\<lambda>(t,v). Blinfun(\<lambda>(v::vec) . \<chi> x. if x = V then (v$A) else if x = S then (v$V) else 0))"])
         apply (auto simp add: bounded_linear_Blinfun_apply[OF bl])
      subgoal premises pre for t x
        unfolding has_derivative_def apply (auto simp add: bl)
        apply (rule vec_tendstoI)
        by (auto simp add: state2vec_def)
        done
    qed
    apply(rule Valid_ex_pre)
    subgoal for T_t
      apply(rule Valid_seq)
       apply (rule Valid_send_sp_st)
      apply(rule Valid_strengthen_post)
       prefer 2
       apply(rule Valid_receive_sp_st)
      apply(auto simp add:entails_def)
      subgoal for tr a
        apply(rule exI[where x="xs@[(T_t,a)]"])
        apply auto
        subgoal using Plant_end_state_snoc Plant_end_state_rw
          by(auto simp add: Plant_ode_state_def)
        using Plant_inv_snoc
        by(auto simp add: Plant_ode_state_def join_assoc)
      done
    done
  done
  done

definition fs :: "real \<Rightarrow> real" where
   "fs s =
      (let D = Stop_point - s in
        if D \<ge> Pull_curve_max_d then
          V_limit
        else if D \<ge> 0 then
          Pull_curve_coeff * sqrt(D)
        else 0)"

definition com_a :: "real \<Rightarrow> real \<Rightarrow> real" where
  "com_a s v =
      (let s1' = s + v * Period + A_plus * Period\<^sup>2 / 2 in
       let target_v1 = fs s1' in
         if v + A_plus * Period \<le> target_v1 then
           A_plus
         else let s2' = s + v * Period in
              let target_v2 = fs s2' in
                if v \<le> target_v2 then 0
                else -A_minus)"
lemma control_vars_distinct [simp]: "Command_a \<noteq> V" "Command_a \<noteq> S"
                                  "V \<noteq> Command_a" "V \<noteq> S"
                                  "S \<noteq> Command_a" "S \<noteq> V"
 unfolding Command_a_def V_def S_def by auto

definition Control :: proc where
  "Control =
      Cm (''P2C''[?]V);
      Cm (''P2C''[?]S);
      Command_a ::= (\<lambda>s. com_a (s S) (s V));
      Cm (''C2P''[!](\<lambda>s. s Command_a));
    Rep(
      Wait (\<lambda> s. Period);
      Cm (''P2C''[?]V);
      Cm (''P2C''[?]S);
      Command_a ::= (\<lambda>s. com_a (s S) (s V));
      Cm (''C2P''[!](\<lambda>s. s Command_a)))"

fun Control_inv :: "real \<times> real \<times> real  \<Rightarrow> (real \<times> real) list \<Rightarrow> tassn" where
  "Control_inv (v0, s0, a0) [] = emp\<^sub>t"
| "Control_inv (v0, s0, a0) ((v, s) # rest) =
    Wait\<^sub>t Period (\<lambda> t. (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0)))) ({},{}) @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0))) ''P2C'' v @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s0, Command_a := a0))) ''P2C'' s @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s, Command_a := com_a s v)))  ''C2P'' (com_a s v)  @\<^sub>t
    Control_inv (v,s,com_a s v) rest"

fun Control_block :: "real \<times> real \<times> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real \<times> real) list \<Rightarrow> tassn" where
  "Control_block (v0, s0, a0) v s rest  =
    In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0))) ''P2C'' v @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s0, Command_a := a0))) ''P2C'' s @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s, Command_a := com_a s v)))  ''C2P'' (com_a s v)  @\<^sub>t
    Control_inv (v,s,com_a s v) rest"

fun Control_end_state :: "real \<times> real \<times> real  \<Rightarrow> (real \<times> real) list \<Rightarrow> state" where
  "Control_end_state (v0, s0, a0) [] = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0))"
| "Control_end_state (v0, s0, a0) ((v, s) # rest) = Control_end_state (v, s, com_a s v) rest"

definition control_state :: "state \<Rightarrow> real \<Rightarrow> real \<Rightarrow> state" where
  "control_state state v s = state(V := v, S := s, Command_a := com_a s v)"

lemma Control_end_state_snoc:
  "Control_end_state (v0, s0, a0) (xs @ [(v, s)]) =
   control_state (Control_end_state (v0, s0, a0) xs) v s"
  apply (induct xs arbitrary: v0 s0 a0 )
  unfolding control_state_def by auto

lemma Control_end_state_rw:
  "Control_end_state (v0, s0, a0) xs =
   (\<lambda>_ . 0) (V := Control_end_state (v0, s0, a0) xs V,
             S := Control_end_state (v0, s0, a0) xs S,
             Command_a := Control_end_state (v0, s0, a0) xs Command_a)"
  apply (induct xs arbitrary: v0 s0 a0 )
  unfolding control_state_def by auto

lemma Control_state_end_state:
"control_state (Control_end_state (v0, s0, a0) xs) v s = (\<lambda>_ . 0) (V := v,
             S := s,
             Command_a := com_a s v)"
  apply(subst Control_end_state_rw[of v0 s0 a0 xs])
  unfolding control_state_def by auto

lemma Control_inv_snoc:
  "Control_inv (v0, s0, a0) (xs @ [(v, s)]) =
   Control_inv (v0, s0, a0) xs @\<^sub>t
   Wait\<^sub>t Period (\<lambda> t. (State ((Control_end_state (v0, s0, a0) xs)))) ({},{})@\<^sub>t
   In\<^sub>t (State ((Control_end_state (v0, s0, a0) xs))) ''P2C'' v @\<^sub>t
   In\<^sub>t (State ((Control_end_state (v0, s0, a0) xs)(V := v))) ''P2C'' s @\<^sub>t
   Out\<^sub>t (State (control_state (Control_end_state (v0, s0, a0) xs) v s)) ''C2P'' ((control_state (Control_end_state (v0, s0, a0) xs) v s) Command_a)"
  apply (induct xs arbitrary: v0 s0 a0 )
   apply (auto simp add: join_assoc Control_end_state_snoc control_state_def fun_upd_twist)[1]
  apply (auto simp add: join_assoc Control_end_state_snoc fun_upd_twist)
  done

lemma Control_prop:
  "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0)) \<and> emp\<^sub>t tr}
      Control
    {\<lambda>s tr. \<exists>v' s' xs. s = Control_end_state (v', s', com_a s' v') xs
                         \<and> Control_block (v0, s0, a0) v' s' xs tr}"
  unfolding Control_def
  apply(rule Valid_seq)
   apply(rule Valid_receive_sp_st)
  apply(rule Valid_ex_pre)
  subgoal for v'
    apply(rule Valid_seq)
     apply(rule Valid_receive_sp_st)
    apply(rule Valid_ex_pre)
    subgoal for s'
      apply(rule Valid_seq)
       apply(rule Valid_assign_sp_st)
      apply(rule Valid_seq)
       apply(rule Valid_send_sp_st)
      apply(rule Valid_weaken_pre)
       prefer 2
       apply(rule Valid_rep)
       prefer 2
      subgoal
        apply(auto simp add:entails_def)
        subgoal for tr
          apply(rule exI[where x="v'"])
          apply(rule exI[where x="s'"])
          apply(rule exI[where x="[]"])
          by (auto simp add:join_assoc fun_upd_twist)
        done
      apply(rule Valid_ex_pre)
      subgoal for v'
        apply(rule Valid_ex_pre)
        subgoal for s'
          apply(rule Valid_ex_pre)
          subgoal for xs
            apply(rule Valid_seq)
             apply(rule Valid_wait_sp_st)
            apply simp
            apply(rule Valid_seq)
             apply(rule Valid_receive_sp_st)
            apply(rule Valid_ex_pre)
            subgoal for v''
              apply(rule Valid_seq)
               apply(rule Valid_receive_sp_st)
              apply(rule Valid_ex_pre)
              subgoal for s''
                apply(rule Valid_seq)
                 apply(rule Valid_assign_sp_st)
                apply(rule Valid_strengthen_post)
                 prefer 2
                 apply(rule Valid_send_sp_st)
                apply(auto simp add:entails_def)
                apply(rule exI[where x="v'"])
                apply(rule exI[where x="s'"])
                apply(rule exI[where x="xs@[(v'',s'')]"])
                apply auto
                subgoal
                  using Control_end_state_snoc
                  apply(auto simp add:control_state_def)
                  done
                using Control_inv_snoc
                apply(auto simp add:control_state_def join_assoc)
                done
              done
            done
          done
        done
      done
    done
  done

lemma fs_at_least_zero:
  "fs s \<ge> 0"
  unfolding fs_def Let_def apply auto
  using V_limit apply auto
  using  Pull_curve_coeff_ge_zero
  by (simp add: dual_order.strict_implies_order)

lemma fs_at_most_limit:
  "fs s \<le> V_limit"
  unfolding fs_def Let_def
  apply auto
  subgoal premises pre
  proof-
    have "Stop_point - s < V_limit * V_limit / (2 * A_minus)"
        using pre unfolding Pull_curve_max_d_def Pull_curve_coeff_def by auto
      then have 31: "(Stop_point - s) * (2 * A_minus) < V_limit * V_limit"
        using A_minus
        by (metis lattice_ab_group_add_class.zero_less_double_add_iff_zero_less_single_add mult_2 pos_less_divide_eq)
      have 32: "sqrt (2 * A_minus) * sqrt (Stop_point - s) = sqrt ((Stop_point - s) * (2 * A_minus))"
        using A_minus pre by (simp add: real_sqrt_mult)
      have 33: "V_limit = sqrt (V_limit * V_limit)"
        using V_limit by auto
      show ?thesis
        unfolding Pull_curve_max_d_def Pull_curve_coeff_def 32
        apply (subst 33) using 31
        using real_sqrt_less_iff
        using less_eq_real_def by blast
    qed
    subgoal using V_limit by auto
    done

lemma fs_prop1:
  assumes "v \<le> fs(s)"
    and "v \<ge> 0"
    and "s \<le> Stop_point"
  shows "v^2 \<le> 2 * A_minus * (Stop_point - s)"
proof-
  have 1: "v^2 \<le> 2 * A_minus * (Stop_point - s)" if "Stop_point - s \<ge> Pull_curve_max_d"
  proof-
    have 11: "v\<le>V_limit"
      using assms(1) that unfolding fs_def Let_def by auto
    then have 12: "v^2\<le>V_limit^2"
      using assms(2) V_limit by simp
    have 13:" V_limit^2 \<le>2 * A_minus * (Stop_point - s)"
      using that A_minus unfolding Pull_curve_max_d_def
      by (auto simp add: power2_eq_square field_simps)
    then show ?thesis using 12 by auto
  qed
  have 2:"v^2 \<le> 2 * A_minus * (Stop_point - s)" if "Stop_point - s < Pull_curve_max_d"
  proof-
    have 21:"v \<le> Pull_curve_coeff * sqrt(Stop_point - s)"
      using assms that unfolding fs_def by auto
    then show ?thesis using assms A_minus unfolding Pull_curve_coeff_def
      by (metis power2_eq_square real_sqrt_le_iff real_sqrt_mult real_sqrt_pow2)
  qed
  show ?thesis using 1 2 assms
    by linarith
qed

fun loop_once :: "real \<times> real \<Rightarrow> real \<times> real" where
  "loop_once (s, v) =
    (let a = com_a s v in
     let v' = v + a * Period in
     let s' = s + v * Period + a * Period * Period / 2 in
      (s', v'))"

declare loop_once.simps[simp del]

lemma loop_once_invariant:
  assumes "v \<le> fs s \<and> s \<le> Stop_point"
    and "(s', v') = loop_once (s, v)"
  shows "v' \<le> fs s' \<and> s' \<le> Stop_point"
proof -
  have case1:"v' \<le> fs s' \<and> s' \<le> Stop_point" if cond1:"v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
  proof-
    have 1:"com_a s v = A_plus"
      using that unfolding com_a_def by auto
    have 2:"(s', v') = (s + v * Period + A_plus * Period\<^sup>2 / 2,v + A_plus * Period )"
      using assms 1  that loop_once.simps by (auto simp add: power2_eq_square)
    have 3:"v' \<le> fs s'"
      using that 2
      unfolding fs_def Let_def by auto
    have 4:"s' \<le> Stop_point"
    proof (cases "v' > 0")
      case True
      then show ?thesis
        using 3 2 that apply(simp add: fs_def Let_def) apply auto
        by (smt Pull_curve_max_d_ge_zero)
    next
      case False
      then show ?thesis
      proof-
        have "v + A_plus * Period \<le> 0"
          using False 2 by auto
        then have "(v + A_plus * Period)*Period \<le> 0"
          by (meson Period eucl_less_le_not_le mult_le_0_iff)
        then have "v * Period + A_plus * Period\<^sup>2 \<le>0"
          by(auto simp add:power2_eq_square algebra_simps)
        then have "v * Period + A_plus * Period\<^sup>2 - A_plus * Period*Period/2 \<le>0"
          apply(subgoal_tac "A_plus * Period*Period/2 > 0")
           prefer 2 using A_plus apply simp
          by linarith
        then have "v * Period + A_plus * Period\<^sup>2/2 \<le>0"
          by(auto simp add: power2_eq_square)
        then have "s + v * Period + A_plus * Period\<^sup>2/2 \<le> Stop_point"
          using assms by auto
        then show ?thesis using 2 apply auto done
      qed
    qed
     show ?thesis using 3 4 by auto
  qed
  have case2:"v' \<le> fs s' \<and>  s' \<le> Stop_point" if cond2:
    "\<not> v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
    "v \<le> fs (s + v * Period)"
  proof-
    have 1: "com_a s v = 0" using that unfolding com_a_def by auto
    have 2: "(s',v') = (s + v * Period, v)" using assms 1 loop_once.simps by auto
    have 3:"v' \<le> fs s'"
      using 2 that
      unfolding fs_def Let_def by auto
    have 4:"s' \<le> Stop_point"
    proof-
      have "v \<le> 0" if "s' > Stop_point"
        using 2 3 unfolding fs_def Let_def
        using Pull_curve_max_d_ge_zero assms(1) that by auto
      then have"s\<ge>s'" if "s' > Stop_point" using 2 that
        by (smt Period old.prod.inject zero_less_mult_pos2)
      then show ?thesis using assms
        using leI 2   by auto
    qed
    then show ?thesis using 3 4  by auto
  qed
  have case3:"v' \<le> fs s'  \<and> s' \<le> Stop_point" if cond3:
    "\<not> v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
    "\<not> v \<le> fs (s + v * Period)"
  proof-
    have 1: "com_a s v = -A_minus" using that unfolding com_a_def by auto
    have 2:"(s',v') = (s + v * Period - A_minus * Period\<^sup>2 / 2, v - A_minus  * Period)"
        using assms 1  cond3 loop_once.simps by (auto simp add: power2_eq_square)
    have 31:"s' \<le> Stop_point" if "v\<ge>0"
        using 2 apply auto
        subgoal premises pre
        proof-
          have "v^2 \<le> 2 * A_minus * (Stop_point - s)"
              using fs_prop1 assms that by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s) - 2 * A_minus * v * Period + A_minus^2 * Period^2"
            by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s - v * Period + 1/2 * A_minus * Period^2)"
            by (auto simp add: algebra_simps power2_eq_square)
          then have "(v - A_minus * Period)^2 \<le> 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))"
            by (auto simp add: algebra_simps power2_eq_square)
          then have " 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)) \<ge> 0"
            by (smt zero_le_power2)
          then have "(Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)) \<ge> 0"
            by (metis A_minus less_eq_real_def linordered_ab_group_add_class.double_add_le_zero_iff_single_add_le_zero mult_less_cancel_right not_one_le_zero not_real_square_gt_zero one_add_one zero_le_mult_iff zero_less_mult_iff)
          then show ?thesis by auto
            qed
            done
          have 32:"s' \<le> Stop_point" if "v<0"
            using 2 apply auto
            apply (subgoal_tac"s \<le> Stop_point")
             prefer 2 using assms apply auto
            apply (subgoal_tac"v * Period \<le> 0")
            prefer 2 using that Period
             apply (smt cond3(2) fs_at_least_zero)
            apply (subgoal_tac" A_minus * Period\<^sup>2 / 2 \<ge> 0")
             prefer 2
            subgoal
              using A_minus by(auto simp add:power2_eq_square)
            by linarith
       have 41:"v' \<le> fs s'" if "v\<ge>0"
        using 2
        unfolding fs_def Let_def apply auto
        subgoal using assms(1) fs_at_most_limit A_minus Period
          by (smt mult_diff_mult real_mult_less_iff1)
        subgoal premises pre
        proof-
          have "v^2 \<le> 2 * A_minus * (Stop_point - s)"
            using fs_prop1 assms that by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s) - 2 * A_minus * v * Period + A_minus^2 * Period^2"
            by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s - v * Period + 1/2 * A_minus * Period^2)"
            by (auto simp add: algebra_simps power2_eq_square)
          then have "(v - A_minus * Period)^2 \<le> 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))"
            by (auto simp add: algebra_simps power2_eq_square)
          then have a:"sqrt((v - A_minus * Period)^2) \<le> sqrt(2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)))"
            using real_sqrt_le_iff by blast
          have b:"(v - A_minus * Period) <= sqrt((v - A_minus * Period)^2)"
            by auto
          have c:"sqrt(2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))) = sqrt(2 * A_minus) * sqrt((Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)))"
            by (simp add: real_sqrt_mult)
          show ?thesis using a b c unfolding Pull_curve_coeff_def by auto
        qed
        subgoal using assms fs_at_most_limit A_minus Period
          using Pull_curve_max_d_ge_zero by linarith
        subgoal using 31 that by auto
        done
      have 42:"v' \<le> fs s'" if "v<0"
        using 2
        unfolding fs_def Let_def apply auto
        subgoal using assms(1) fs_at_most_limit A_minus Period
          by (smt mult_diff_mult real_mult_less_iff1)
        subgoal
          apply(subgoal_tac "s + v * Period - A_minus * Period\<^sup>2 / 2  \<le> s")
           prefer 2 subgoal
           apply (subgoal_tac"s \<le> Stop_point")
             prefer 2 using assms apply auto
            apply (subgoal_tac"v * Period \<le> 0")
            prefer 2 using that Period
             apply (smt cond3(2) fs_at_least_zero)
            apply (subgoal_tac" A_minus * Period\<^sup>2 / 2 \<ge> 0")
             prefer 2
            subgoal
              using A_minus by(auto simp add:power2_eq_square)
            apply linarith
            done
            apply(subgoal_tac" \<not> Pull_curve_max_d \<le> Stop_point - s")
             prefer 2
             apply simp
            apply(subgoal_tac"v \<le> Pull_curve_coeff * sqrt (Stop_point - s)")
            prefer 2
            subgoal using assms unfolding fs_def Let_def by auto
            apply(subgoal_tac"v - A_minus * Period \<le> v")
            prefer 2 subgoal using A_minus
              by (smt cond3(2) fs_at_least_zero that)
            apply(subgoal_tac"Pull_curve_coeff * sqrt (Stop_point - s)\<le>Pull_curve_coeff * sqrt (Stop_point - (s + v * Period - A_minus * Period\<^sup>2 / 2))")
             apply linarith
            by simp
          subgoal using assms fs_at_most_limit A_minus Period
            using Pull_curve_max_d_ge_zero by linarith
          subgoal using that A_minus
            using "32" by auto
          done
       show ?thesis using 31 32 41 42
         using leI by blast
    qed
  show ?thesis
    using case1 case2 case3
    by linarith
qed

fun loop_invariant :: "real \<times> real \<Rightarrow> bool" where
  "loop_invariant (s, v) \<longleftrightarrow> v \<le> fs s \<and> s \<le> Stop_point"

lemma loop_once_invariant':
  assumes "loop_invariant (s,v)"
    and "(s', v') = loop_once (s, v)"
  shows "loop_invariant (s',v')"
  using loop_once_invariant assms
  using loop_invariant.simps by blast

fun tot_inv :: "real \<times> real \<Rightarrow> nat \<Rightarrow> tassn" where
  "tot_inv (s0, v0) 0 = emp\<^sub>t"
| "tot_inv (s0, v0) (Suc n) =
   (\<up>(loop_invariant (s0, v0)) \<and>\<^sub>t Wait\<^sub>t (Period) (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0 + com_a s0 v0 * t, S := s0 + v0 * t + com_a s0 v0 * t * t / 2, A := com_a s0 v0)))
                    (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := com_a s0 v0)) )) ({''P2C''}, {})) @\<^sub>t
   IO\<^sub>t ''P2C'' (snd (loop_once (s0, v0))) @\<^sub>t
   IO\<^sub>t ''P2C'' (fst (loop_once (s0, v0))) @\<^sub>t
   IO\<^sub>t ''C2P'' (com_a (fst (loop_once (s0, v0))) (snd (loop_once (s0, v0)))) @\<^sub>t
   tot_inv (loop_once (s0, v0) ) n"

fun tot_block :: "real \<times> real \<Rightarrow> nat \<Rightarrow> tassn" where
"tot_block (s0, v0) n =
   IO\<^sub>t ''P2C'' v0 @\<^sub>t
   IO\<^sub>t ''P2C'' s0 @\<^sub>t
   IO\<^sub>t ''C2P'' (com_a s0 v0) @\<^sub>t tot_inv (s0, v0) n "

lemma combine0:
  "loop_invariant (s0, v0) \<Longrightarrow>
   combine_assn {''P2C'', ''C2P''}
     (Plant_inv (v0, s0, com_a s0 v0) as) (Control_inv (v0, s0, com_a s0 v0) vs)
      \<Longrightarrow>\<^sub>t  tot_inv (s0,v0) (length as)"
proof (induct as arbitrary: vs s0 v0)
case Nil
  then show ?case
  proof(cases vs)
    case Nil
    then show ?thesis
      by auto
  next
    case (Cons vsp vsrest)
    then show ?thesis
      apply auto
      subgoal
    proof (cases vsp)
      case (Pair v1 s1)
      then show ?thesis
        apply auto
        apply (rule entails_tassn_trans)
       apply (rule combine_assn_emp_wait)
        apply simp by (rule false_assn_entails)
    qed
    done
  qed
next
  case (Cons asp asrest)
  note Cons1 = Cons
  then show ?case
  proof (cases asp)
    case (Pair T1 a1)
    note Pair1 = Pair
    then show ?thesis
    proof (cases vs)
      case Nil
      then show ?thesis
        apply(auto simp add:Pair)
        apply (rule entails_tassn_trans)
       apply(rule combine_assn_waitout_emp)
         apply simp by (rule false_assn_entails)
next
  case (Cons vsp vsrest)
  then show ?thesis
    subgoal
proof (cases vsp)
  case (Pair v1' s1')
  then show ?thesis
    apply(auto simp add: Cons Pair1)
    apply (rule entails_tassn_trans)
      apply (rule combine_assn_waitout_wait)
       apply auto
    apply (rule entails_tassn_conj)
    subgoal
      using Cons1(2) apply (auto simp add: pure_assn_def entails_tassn_def)
      done
    apply (rule entails_tassn_cancel_left)
apply (rule entails_tassn_trans)
     apply (rule combine_assn_waitout_in)
      apply (auto simp add:loop_once.simps Let_def)
apply (rule entails_tassn_cancel_left)
    apply (rule entails_tassn_trans)
     apply (rule combine_assn_out_in)
    apply auto
    apply (rule entails_tassn_cancel_left)
 apply (rule entails_tassn_trans)
     apply (rule combine_assn_in_out)
     apply auto
    apply (rule entails_tassn_cancel_left)
    using Cons1(1)[of "s0 + v0 * Period + com_a s0 v0 * Period * Period / 2" "v0 + com_a s0 v0 * Period" "vsrest"] Cons1(2)
    using loop_once_invariant'[of s0 v0 "s0 + v0 * Period + com_a s0 v0 * Period * Period / 2" "v0 + com_a s0 v0 * Period"]
    by(auto simp add:loop_once.simps Let_def)
qed
  done
qed
  qed
qed

lemma combine:
  "loop_invariant (s0, v0) \<Longrightarrow>
   combine_assn {''P2C'', ''C2P''}
     (Plant_block (v0, s0, a00) a0 as) (Control_block (v00', s00', a00') v0' s0' vs)
      \<Longrightarrow>\<^sub>t  tot_block (s0,v0) (length as)"
  apply auto
apply (rule entails_tassn_trans)
     apply (rule combine_assn_out_in)
    apply auto
  apply (rule entails_tassn_cancel_left)
apply (rule entails_tassn_trans)
     apply (rule combine_assn_out_in)
    apply auto
  apply (rule entails_tassn_cancel_left)
apply (rule entails_tassn_trans)
     apply (rule combine_assn_in_out)
    apply auto
  apply (rule entails_tassn_cancel_left)
  apply(rule combine0)
  by auto

definition System :: pproc where
  "System = Parallel (Single Plant)
                     {''P2C'', ''C2P''}
                     (Single Control)"

lemma System_Prop:
  assumes "loop_invariant (s0, v0)"
  shows "\<Turnstile>\<^sub>p
    {pair_assn (\<lambda>s. s = ((\<lambda>_. 0)(V := v0, S := s0, A := a00)))
               (\<lambda>s. s = ((\<lambda>_. 0)(V := v00', S := s00', Command_a := a00')))}
      System
    {\<exists>\<^sub>g n. trace_gassn (tot_block (s0,v0) n)}"
unfolding System_def
  apply (rule ParValid_conseq')
    apply (rule ParValid_Parallel')
  apply (rule Plant_prop)
  apply (rule Control_prop)
  apply (auto simp add: sing_gassn_split sing_gassn_ex)
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_left)
  subgoal for a0 as
  apply (rule sync_gassn_ex_pre_right)
  apply (rule sync_gassn_ex_pre_right)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for v' s' vs
    unfolding sync_gassn_state_left sync_gassn_state_right
    apply (rule entails_ex_gassn)
    apply (rule exI[where x="length as"])
    apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
     apply (rule entails_tassn_trans)
      prefer 2 apply(rule combine[OF assms])
     apply (rule combine_assn_mono)
    by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done
  done

end
end