(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Addition_Hoare
  imports VHDL_Hoare_Complete Bits_Int_Aux
begin

datatype sig = A | B | C

definition add :: "sig conc_stmt" where
  "add \<equiv> process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1"

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  shows "\<exists>len1>0. \<exists>len2>0. \<Gamma> A = Lty Uns len1 \<and> \<Gamma> B = Lty Uns len2 \<and> \<Gamma> C = Lty Uns (max len1 len2)
                         \<or> \<Gamma> A = Lty Sig len1 \<and> \<Gamma> B = Lty Sig len2 \<and> \<Gamma> C = Lty Sig (max len1 len2)"
proof (rule seq_wt_cases(4)[OF assms])
  assume "bexp_wt \<Gamma> (Badd (Bsig A) (Bsig B)) (\<Gamma> C)"
  obtain len1 len2 where " \<Gamma> A = Lty Uns len1 \<and> \<Gamma> B = Lty Uns len2 \<and> \<Gamma> C = Lty Uns (max len1 len2)
                              \<or> \<Gamma> A = Lty Sig len1 \<and> \<Gamma> B = Lty Sig len2 \<and> \<Gamma> C = Lty Sig (max len1 len2)"
          and "0 < len1" and "0 < len2"

    by (rule bexp_wt_cases_slice(4)[OF \<open>bexp_wt \<Gamma> (Badd (Bsig A) (Bsig B)) (\<Gamma> C)\<close>])(metis bexp_wt_cases_slice(2))+
  thus ?thesis
    by auto
qed

locale unsigned_addition =
  fixes \<Gamma> :: "sig tyenv"
  fixes len len1 len2 :: nat
  assumes len_def: "len = max len1 len2"
  assumes atype: "\<Gamma> A = Lty Uns len1" and btype: "\<Gamma> B = Lty Uns len2" and ctype: "\<Gamma> C = Lty Uns len"
  assumes len1: "0 < len1" and len2: "0 < len2"
begin

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  apply (rule seq_wt.intros(4))
  unfolding ctype len_def apply (rule bexp_wt.intros(15))
      apply (rule bexp_wt.intros(3))
      apply (rule atype[symmetric])
     apply (rule bexp_wt.intros(3))
  apply (rule btype[symmetric])
    apply (rule len1)
   apply (rule len2)
  apply (simp)
  done

abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

term "bin_to_bl len (bl_to_bin bs1 + bl_to_bin bs2)"

text \<open>Here we factor out common expression in both inv1 and inv2. It is parametrised by the index
we are interested with for C (first argument) and A (the second argument). Note that the index
we are interested with for A should be the same as the index for B.\<close>

definition property :: "nat \<Rightarrow> nat \<Rightarrow> sig assn2" where
  "property idxc idx =
      (\<lambda>tw. lof_wline tw C idxc =
                  bin_to_bl len (bl_to_bin (lof_wline tw A idx) + bl_to_bin (lof_wline tw B idx)))"

definition inv :: "sig assn2" where
  "inv tw \<equiv> (\<forall>i < fst tw. property (i + 1) i tw)"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> (disjnt {A, B} (event_of tw) \<longrightarrow> (\<forall>i \<ge> fst tw. property (i + 1) (fst tw) tw))"

abbreviation "next_world tw \<equiv> (next_time_world tw, snd tw)"

lemma inv_next_time:
  assumes "inv tw"
  assumes "beval_world_raw2 tw (Badd (Bsig A) (Bsig B)) v" and "type_of v = Lty Uns len"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. inv (j, snd tw')"
  unfolding inv_def
proof (rule, rule, rule)
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume "i < fst (j, snd tw')"
  hence "i < j"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff snd_conv snd_swap
    swap_simp tw'_def worldline_upd2_def)
  hence "i < fst tw \<or> fst tw \<le> i \<and> i < j - 1 \<or> i = j - 1"
    using \<open>i < j\<close> by linarith
  moreover
  { assume "i < fst tw"
    have "lof_wline tw' C (i + 1) = lof_wline tw C (i + 1)"
      by (metis \<open>i < get_time tw\<close> add_mono1 tw'_def worldline_upd2_before_dly)
    also have "... = bin_to_bl len (bl_to_bin (lof_wline tw A i) + bl_to_bin (lof_wline tw B i))"
      using assms(1) \<open>i < fst tw\<close> unfolding inv_def property_def by auto
    also have "... = bin_to_bl len (bl_to_bin (lof_wline tw' A i) + bl_to_bin (lof_wline tw' B i))"
      by (metis \<open>i < get_time tw\<close> add.commute trans_less_add2 tw'_def worldline_upd2_before_dly)
    finally have "property (i + 1) i (j, snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < j - 1"
    hence "fst tw \<le> i" and "i < j - 1"
      by auto
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (fst tw + 1)"
      using unchanged_until_next_time_world
      by (smt \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> dual_order.strict_trans1
      greaterThanAtMost_iff le_add1 less_diff_conv not_less prod.exhaust_sel prod.inject tw'_def
      worldline_upd2_def)
    moreover have "lof_wline tw' A i = lof_wline tw' A (fst tw)" and "lof_wline tw' B i = lof_wline tw' B (fst tw)"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) Pair_inject \<open>get_time tw \<le> i\<close> \<open>i < j\<close> \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> dual_order.strict_trans1 greaterThanAtMost_iff prod.exhaust_sel tw'_def worldline_upd2_def)+
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' C (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Uns (bin_to_bl_aux len (bl_to_bin (lof_wline tw A (fst tw)) + bl_to_bin (lof_wline tw B (fst tw))) [])"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule beval_cases)+
        unfolding state_of_world_def using atype btype
        apply (metis assms(3) bin_to_bl_def comp_def size_bin_to_bl ty.inject type_of.simps(2) val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Uns (bin_to_bl_aux len (bl_to_bin (lof_wline tw' A (fst tw)) + bl_to_bin (lof_wline tw' B (fst tw))) [])"
        by (metis Suc_eq_plus1 \<open>lval_of (wline_of tw' A i) = lval_of (wline_of tw' A (get_time tw))\<close>
        \<open>lval_of (wline_of tw' B i) = lval_of (wline_of tw' B (get_time tw))\<close> lessI tw'_def
        worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    ultimately have "property (i + 1) i (j, snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "i = j - 1"
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (next_time_world tw')"
      using \<open>i < j\<close>
      by (smt \<open>get_time tw < j\<close> add_diff_cancel_left' comp_apply discrete
      dual_order.order_iff_strict fst_conv leD le_add1 less_imp_Suc_add next_time_world_at_least
      plus_1_eq_Suc snd_conv tw'_def worldline_upd2_def worldline_upd_def)
    also have "... = lof_wline tw' C (fst tw + 1)"
      using \<open>fst tw < j\<close> unfolding tw'_def worldline_upd2_def
      worldline_upd_def
      by (smt Suc_lessI add.commute comp_apply fst_conv next_time_world_at_least order.asym
      plus_1_eq_Suc snd_conv)
    finally have "lof_wline tw' C (i + 1) = lof_wline tw' C (fst tw + 1)"
      by auto
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' C (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Uns (bin_to_bl_aux len (bl_to_bin (lof_wline tw A (fst tw)) + bl_to_bin (lof_wline tw B (fst tw))) [])"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule beval_cases)+
        unfolding state_of_world_def using atype btype
        apply (metis assms(3) bin_to_bl_def comp_def size_bin_to_bl ty.inject type_of.simps(2) val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Uns (bin_to_bl_aux len (bl_to_bin (lof_wline tw' A (fst tw)) + bl_to_bin (lof_wline tw' B (fst tw))) [])"
        by (metis less_add_one tw'_def worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    moreover have "lof_wline tw' A i = lof_wline tw' A (fst tw)" and "lof_wline tw' B i = lof_wline tw' B (fst tw)"
      using unchanged_until_next_time_world
      by (smt Pair_inject Suc_eq_plus1 Suc_lessI \<open>i < j\<close> \<open>i = j - 1\<close> \<open>j \<in> {get_time
      tw'<..next_time_world tw'}\<close> dual_order.strict_trans1 greaterThanAtMost_iff less_diff_conv
      less_or_eq_imp_le not_le prod.exhaust_sel tw'_def worldline_upd2_def)+
    ultimately have "property (i + 1) i (j, snd tw')"
      unfolding property_def by auto }
  ultimately show "property (i + 1) i (j, snd tw')"
    by auto
qed

lemma type_correctness_length:
  assumes "wityping \<Gamma> (snd tw)"
  assumes "beval_world_raw2 tw (Badd (Bsig A) (Bsig B)) v"
  shows   "type_of v = Lty Uns len"
proof -
  have "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
    using assms(2) unfolding beval_world_raw2_def by auto
  have "type_of (state_of_world (snd tw) (fst tw) A) = Lty Uns len1" and
       "type_of (state_of_world (snd tw) (fst tw) B) = Lty Uns len2"
    using assms(1) unfolding wityping_def
    by (simp add: atype btype state_of_world_def wtyping_def)+
  show ?thesis
    apply (rule beval_world_raw_cases[OF \<open>beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v\<close>])
    apply (erule beval_cases)
    apply (metis (no_types, lifting) \<open>type_of (state_of_world (snd tw) (get_time tw) A) = Lty Uns len1\<close> \<open>type_of (state_of_world (snd tw) (get_time tw) B) = Lty Uns len2\<close> add.right_neutral beval_cases(1) len_def list.size(3) size_bin_to_bl_aux ty.inject type_of.simps(2))
    apply (metis (no_types, lifting) \<open>type_of (state_of_world (snd tw) (get_time tw) A) = Lty Uns len1\<close> beval_cases(1) signedness.distinct(5) ty.inject type_of.simps(2))
    done
qed

lemma add_seq_hoare_next_time:
  "\<turnstile> [\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Badd (Bsig A) (Bsig B)) 1
     [\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2, simp)
  using inv_next_time type_correctness_length
  by (metis ctype snd_conv worldline_upd2_def worldline_upd_preserve_wityping)

lemma add_seq_hoare_next_time0:
  "\<turnstile> [\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Badd (Bsig A) (Bsig B)) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2)
  using next_time_world_at_least apply fastforce
  using inv_next_time type_correctness_length unfolding inv_def
  by (metis ctype gr_implies_not0 snd_conv worldline_upd2_def worldline_upd_preserve_wityping)

lemma add_conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw)"
proof (rule)
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j
  assume "j \<in> {fst tw <.. next_time_world tw}"
  assume "inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  { fix i
    assume "i < j"
    have "fst tw < next_time_world tw"
      by (simp add: next_time_world_at_least)
    have "i < fst tw \<or> fst tw \<le> i"
      by auto
    moreover
    { assume "i < fst tw"
      hence "property (i + 1) i tw"
        using \<open>inv tw\<close> unfolding inv_def by auto
      hence "property (i + 1) i (j, snd tw)"
        unfolding property_def by simp }
    moreover
    { assume "fst tw \<le> i"
      moreover have "\<forall>i \<ge> fst tw. property (i + 1) (fst tw) tw"
        using \<open>inv2 tw\<close> \<open>disjnt {A, B} (event_of tw)\<close> unfolding inv2_def
        by auto
      ultimately have "property (i + 1) (fst tw) tw"
        by auto
      hence "property (i + 1) i tw"
        unfolding property_def
        by (smt \<open>get_time tw \<le> i\<close> \<open>i < j\<close> \<open>j \<in> {get_time tw<..next_time_world tw}\<close>
        dual_order.strict_trans1 greaterThanAtMost_iff unchanged_until_next_time_world)
      hence "property (i + 1) i (j, snd tw)"
        unfolding property_def by auto }
    ultimately have "property (i + 1) i (j, snd tw)"
      by auto }
  thus "inv (j, snd tw)"
    unfolding inv_def by auto
qed

lemma add_conc_hoare2:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> \<forall>j \<in> {fst tw <.. next_time_world tw}. inv2 (j, snd tw)"
proof (rule)
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j :: nat
  assume "j \<in> {fst tw <.. next_time_world tw}"
  assume "inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  { assume "disjnt {A, B} (event_of (j, snd tw))"
    hence *: "lof_wline tw A j = lof_wline tw A (j - 1)" and **: "lof_wline tw B j = lof_wline tw B (j - 1)"
      unfolding event_of_alt_def
      by (smt comp_apply diff_0_eq_0 disjnt_insert1 fst_conv mem_Collect_eq snd_conv)+
    have "fst tw < j"
      using \<open>j \<in> {get_time tw<..next_time_world tw}\<close> greaterThanAtMost_iff by blast
    { fix i
      assume "j \<le> i"
      have "property (i + 1) (fst tw) tw"
        using \<open>inv2 tw\<close> \<open>disjnt {A, B} (event_of tw)\<close> unfolding inv2_def
        using \<open>fst tw < j\<close> \<open>j \<le> i\<close> by auto
      moreover have "lof_wline tw A (fst tw) = lof_wline tw A (j - 1)" and
                    "lof_wline tw B (fst tw) = lof_wline tw B (j - 1)"
        by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 \<open>j \<in> {get_time tw<..next_time_world
        tw}\<close> add_le_imp_le_diff diff_add discrete gr_implies_not0 greaterThanAtMost_iff
        not_less_iff_gr_or_eq unchanged_until_next_time_world)+
      ultimately have "property (i + 1) j (j, snd tw)"
        unfolding property_def using * **  by auto }
    hence "\<forall>i\<ge>j. property (i + 1) j (j, snd tw)"
      by auto }
  thus "inv2 (j, snd tw)"
    unfolding inv2_def by auto
qed

lemma inv2_next_time:
  fixes tw
  assumes "beval_world_raw2 tw (Badd (Bsig A) (Bsig B)) v" and "type_of v = Lty Uns len"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. inv2 (j, snd tw')"
  unfolding inv2_def
proof (rule)+
  fix j i
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume "disjnt {A, B} (event_of (j, snd tw'))"
  hence "A \<notin> event_of (j, snd tw')" and "B \<notin> event_of (j, snd tw')"
    by auto
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff prod.exhaust_sel
    prod.inject tw'_def worldline_upd2_def)
  have 0: "wline_of (j, snd tw') A j = wline_of tw A (fst tw)"
  proof -
    have "wline_of tw' A j = wline_of tw' A (j - 1)"
      using \<open>A \<notin> event_of (j, snd tw')\<close> unfolding event_of_alt_def
      using \<open>fst tw < j\<close> by auto
    also have " ... = wline_of tw' A (fst tw')"
      using unchanged_until_next_time_world
      by (metis (mono_tags, lifting) Suc_diff_1 \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close>
      gr_implies_not_zero greaterThanAtMost_iff le_0_eq less_Suc_eq_le not_less)
    also have "... = wline_of tw' A (fst tw)"
      by (simp add: tw'_def worldline_upd2_def)
    also have "... = wline_of tw A (fst tw)"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    finally show "wline_of (j, snd tw') A j = wline_of tw A (fst tw)"
      by auto
  qed
  have 1: "wline_of (j, snd tw') B j = wline_of tw B (fst tw)"
  proof -
    have "wline_of tw' B j = wline_of tw' B (j - 1)"
      using \<open>B \<notin> event_of (j, snd tw')\<close> unfolding event_of_alt_def
      using \<open>fst tw < j\<close> by auto
    also have " ... = wline_of tw' B (fst tw')"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) Suc_diff_1 \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close>
      dual_order.order_iff_strict greaterThanAtMost_iff le_0_eq less_Suc_eq_le not_less)
    also have "... = wline_of tw' B (fst tw)"
      by (simp add: tw'_def worldline_upd2_def)
    also have "... = wline_of tw B (fst tw)"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    finally show "wline_of (j, snd tw') B j = wline_of tw B (fst tw)"
      by auto
  qed
  have assm2: "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
    using assms(1) unfolding beval_world_raw2_def by auto
  have "wline_of (next_world tw') C (i + 1) = v"
  proof -
    have "wline_of tw' C (i + 1) = v"
      using `fst tw < j` \<open>j \<le> i\<close>
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    thus ?thesis
      by auto
  qed
  also have "lval_of ... = bin_to_bl len (bl_to_bin (lof_wline tw A (fst tw)) + bl_to_bin (lof_wline tw B (fst tw)))"
    apply (rule beval_world_raw_cases[OF assm2])
    apply (erule beval_cases)+
    apply (metis assms(2) beval_raw.intros(1) beval_world_raw.simps beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic bin_to_bl_def size_bin_to_bl ty.inject type_of.simps(2) val.sel(3))
    using assms(2) by auto
  finally have "property (i + 1) j (j, snd tw')"
    unfolding property_def using 0 1  by auto
  thus "property (i + 1) (get_time (j, snd tw')) (j, snd tw')"
    by auto
qed

lemma add_seq_hoare_next_time1:
  "\<turnstile> [\<lambda>tw. wityping \<Gamma> (snd tw)] Bassign_trans C (Badd (Bsig A) (Bsig B)) 1 [\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv2 (i, snd tw)]"
  apply (rule Assign2_altI)
  using inv2_next_time type_correctness_length by blast

lemma seq_wt_add:
  "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using well_typed by blast

lemma add_conc_hoare3:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. (\<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> inv2 (i, snd tw)) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  apply (rule Conj2)
  unfolding add_def
   apply (rule Single)
    apply(rule Conj_univ_qtfd[where Q="inv" and R="inv2"])
     apply (rule strengthen_precondition)
     apply (rule strengthen_precondition)
     apply (rule add_seq_hoare_next_time)
    apply (rule strengthen_precondition)
    apply (rule strengthen_precondition)
    apply (rule strengthen_precondition2)
    apply (rule add_seq_hoare_next_time1)
  using add_conc_hoare add_conc_hoare2 apply blast
  apply (rule strengthen_pre_conc_hoare[rotated])
  apply (rule single_conc_stmt_preserve_wityping_hoare)
   apply (rule seq_wt_add)
  by simp

lemma add_conc_hoare4:
  "\<turnstile> \<lbrace>\<lambda>tw. (local.inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add
       \<lbrace>\<lambda>tw. \<forall>i\<in>{get_time tw<..next_time_world tw}. (local.inv (i, snd tw) \<and> wityping \<Gamma> (snd tw)) \<and> inv2 (i, snd tw)\<rbrace>"
  apply (rule Conseq'[rotated])
  apply (rule add_conc_hoare3)
  by auto

lemma add_conc_sim':
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace>"
  apply (rule While)
  unfolding snd_conv
  apply (rule add_conc_hoare4)
  done

lemma add_conc_sim2:
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>inv\<rbrace>"
  using add_conc_sim' Conseq_sim by blast

lemma init_sat_add_inv:
  "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add (\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw))"
  unfolding add_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule Conj)
  unfolding snd_conv apply(rule add_seq_hoare_next_time0)
  apply (rule strengthen_precondition2)
  by (metis seq_stmt_preserve_wityping_hoare well_typed)

lemma init_sat_add_inv2:
  "init_sim_hoare (\<lambda>tw. wityping \<Gamma> (snd tw)) add inv2"
  unfolding add_def
  apply (rule AssignI)
  apply (rule SingleI)
  unfolding snd_conv
  apply (rule Conseq2[rotated])
    apply (rule add_seq_hoare_next_time1)
   apply (simp add: next_time_world_at_least)
  by auto

lemma init_sat_add_inv_comb:
  shows "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add  (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
  apply (rule ConjI_sim)
  apply (rule init_sat_add_inv)
  apply (rule ConseqI_sim[rotated])
  apply (rule init_sat_add_inv2)
  by blast+

lemma add_correctness:
  assumes "sim_fin w (i + 1) add tw'" and "wityping \<Gamma> w"
  shows   "property (i + 1) i tw'"
proof -
  obtain tw where "init_sim (0, w) add tw" and  "tw, i + 1, add \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf add"
    unfolding conc_stmt_wf_def add_def by auto
  moreover have "nonneg_delay_conc add"
    unfolding add_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_add_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_add_inv_comb
    init_sim_hoare_soundness add_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) add tw\<close> fst_conv assms(2) unfolding init_sim_valid_def
    by (metis snd_conv)
  hence "inv tw" and "inv2 tw" and "wityping \<Gamma> (snd tw)"
    by auto
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>inv\<rbrace>"
    using conc_sim_soundness[OF add_conc_sim2] \<open>conc_stmt_wf add\<close> \<open>nonneg_delay_conc add\<close>
    by auto
  ultimately have "inv tw'"
    using \<open>tw, i + 1, add \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
  with \<open>i + 1 = fst tw'\<close> show ?thesis
    unfolding inv_def  by (metis less_add_one)
qed

corollary add_correctness2:
  assumes "sim_fin w (i + 1) add tw'" and "wityping \<Gamma> w"
  defines "bsA \<equiv> lof_wline tw' A i"
  defines "bsB \<equiv> lof_wline tw' B i"
  defines "bsC \<equiv> lof_wline tw' C (i + 1)"
  shows   "(\<Sum>i = 0..<length bsC. (int \<circ> of_bool) (rev bsC ! i) * 2 ^ i) =
          ((\<Sum>i = 0..<length bsA. (int \<circ> of_bool) (rev bsA ! i) * 2 ^ i) +
           (\<Sum>i = 0..<length bsB. (int \<circ> of_bool) (rev bsB ! i) * 2 ^ i) ) mod 2 ^ len "
proof -
  have "property (i + 1) i tw'"
    using add_correctness[OF assms(1-2)] by auto
  hence "lof_wline tw' C (i + 1) =
                  bin_to_bl len (bl_to_bin (lof_wline tw' A i) + bl_to_bin (lof_wline tw' B i))"
    unfolding property_def by auto
  hence "bsC = bin_to_bl len (bl_to_bin bsA + bl_to_bin bsB)" (is "_ = ?rhs")
    unfolding bsA_def bsB_def bsC_def by auto
  hence "bl_to_bin bsC = bl_to_bin ?rhs"
    by auto
  also have "... = bintrunc len (bl_to_bin bsA + bl_to_bin bsB)"
    unfolding bin_bl_bin by auto
  also have "... = (bl_to_bin bsA + bl_to_bin bsB) mod 2 ^ len"
    unfolding bintrunc_mod2p by auto
  finally have "bl_to_bin bsC = (bl_to_bin bsA + bl_to_bin bsB) mod 2 ^ len"
    by auto
  thus ?thesis
    unfolding bl_to_bin_correctness by auto
qed

end

locale signed_addition =
  fixes \<Gamma> :: "sig tyenv"
  fixes len len1 len2 :: nat
  assumes len_def: "len = max len1 len2"
  assumes atype: "\<Gamma> A = Lty Sig len1" and btype: "\<Gamma> B = Lty Sig len2" and ctype: "\<Gamma> C = Lty Sig len"
  assumes len1 : "0 < len1" and len2: "0 < len2"
begin

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  apply (rule seq_wt.intros(4))
  apply (metis atype bexp_wt.intros(16) bexp_wt.intros(3) btype ctype len_def len1 len2)
  done

abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

text \<open>Here we factor out common expression in both inv1 and inv2. It is parametrised by the index
we are interested with for C (first argument) and A (the second argument). Note that the index
we are interested with for A should be the same as the index for B.\<close>

definition property :: "nat \<Rightarrow> nat \<Rightarrow> sig assn2" where
  "property idxc idx =
      (\<lambda>tw. lof_wline tw C idxc =
                  bin_to_bl len (sbl_to_bin (lof_wline tw A idx) + sbl_to_bin (lof_wline tw B idx)))"

definition inv :: "sig assn2" where
  "inv tw \<equiv> (\<forall>i < fst tw. property (i + 1) i tw)"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> (disjnt {A, B} (event_of tw) \<longrightarrow> (\<forall>i \<ge> fst tw. property (i + 1) (fst tw) tw))"

abbreviation "next_world tw \<equiv> (next_time_world tw, snd tw)"

lemma inv_next_time:
  assumes "inv tw"
  assumes "beval_world_raw2 tw (Badd (Bsig A) (Bsig B)) v" and "type_of v = Lty Sig len"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. inv (j, snd tw')"
  unfolding inv_def
proof (rule, rule, rule)
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume "i < fst (j, snd tw')"
  hence "i < j"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff snd_conv snd_swap
    swap_simp tw'_def worldline_upd2_def)
  hence "i < fst tw \<or> fst tw \<le> i \<and> i < j - 1 \<or> i = j - 1"
    using \<open>i < j\<close> by linarith
  moreover
  { assume "i < fst tw"
    have "lof_wline tw' C (i + 1) = lof_wline tw C (i + 1)"
      by (metis \<open>i < get_time tw\<close> add_mono1 tw'_def worldline_upd2_before_dly)
    also have "... = bin_to_bl len (sbl_to_bin (lof_wline tw A i) + sbl_to_bin (lof_wline tw B i))"
      using assms(1) \<open>i < fst tw\<close> unfolding inv_def property_def by auto
    also have "... = bin_to_bl len (sbl_to_bin (lof_wline tw' A i) + sbl_to_bin (lof_wline tw' B i))"
      by (metis \<open>i < get_time tw\<close> add.commute trans_less_add2 tw'_def worldline_upd2_before_dly)
    finally have "property (i + 1) i (j, snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < j - 1"
    hence "fst tw \<le> i" and "i < j - 1"
      by auto
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (fst tw + 1)"
      using unchanged_until_next_time_world
      by (smt Pair_inject \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> dual_order.strict_trans1
      greaterThanAtMost_iff le_add1 less_diff_conv not_less prod.exhaust_sel tw'_def
      worldline_upd2_def)
    moreover have "lof_wline tw' A i = lof_wline tw' A (fst tw)" and "lof_wline tw' B i = lof_wline tw' B (fst tw)"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) Pair_inject \<open>get_time tw \<le> i\<close> \<open>i < j\<close> \<open>j \<in> {get_time
      tw'<..next_time_world tw'}\<close> dual_order.strict_trans1 greaterThanAtMost_iff prod.exhaust_sel
      tw'_def worldline_upd2_def)+
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' C (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Sig (bin_to_bl_aux len (sbl_to_bin (lof_wline tw A (fst tw)) + sbl_to_bin (lof_wline tw B (fst tw))) [])"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule beval_cases)
        defer
        apply ( erule beval_cases)+
        unfolding state_of_world_def using atype btype
        apply (metis assms(3) bin_to_bl_def comp_apply size_bin_to_bl ty.inject type_of.simps(2) val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Sig (bin_to_bl_aux len (sbl_to_bin (lof_wline tw' A (fst tw)) + sbl_to_bin (lof_wline tw' B (fst tw))) [])"
        by (metis Suc_eq_plus1 \<open>lval_of (wline_of tw' A i) = lval_of (wline_of tw' A (get_time tw))\<close>
        \<open>lval_of (wline_of tw' B i) = lval_of (wline_of tw' B (get_time tw))\<close> lessI tw'_def
        worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    ultimately have "property (i + 1) i (j, snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "i = j - 1"
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (j)"
      using \<open>i < j\<close> by force
    also have "... = lof_wline tw' C (fst tw + 1)"
      using \<open>fst tw < j\<close> unfolding tw'_def worldline_upd2_def
      worldline_upd_def by auto
    finally have "lof_wline tw' C (i + 1) = lof_wline tw' C (fst tw + 1)"
      by auto
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' C (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Sig (bin_to_bl_aux len (sbl_to_bin (lof_wline tw A (fst tw)) + sbl_to_bin (lof_wline tw B (fst tw))) [])"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule beval_cases)
        defer
        apply ( erule beval_cases)+
        unfolding state_of_world_def using atype btype
        apply (metis assms(3) bin_to_bl_def comp_def size_bin_to_bl ty.inject type_of.simps(2) val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Sig (bin_to_bl_aux len (sbl_to_bin (lof_wline tw' A (fst tw)) + sbl_to_bin (lof_wline tw' B (fst tw))) [])"
        by (metis less_add_one tw'_def worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    moreover have "lof_wline tw' A i = lof_wline tw' A (fst tw)" and "lof_wline tw' B i = lof_wline tw' B (fst tw)"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) Suc_eq_plus1 Suc_lessI \<open>i < j\<close> \<open>i = j - 1\<close> \<open>j \<in> {get_time
      tw'<..next_time_world tw'}\<close> discrete greaterThanAtMost_iff less_diff_conv less_or_eq_imp_le
      not_less prod.exhaust_sel prod.inject tw'_def worldline_upd2_def)+
    ultimately have "property (i + 1) i (j, snd tw')"
      unfolding property_def by auto }
  ultimately show "property (i + 1) i (j, snd tw')"
    by auto
qed

lemma type_correctness_length:
  assumes "wityping \<Gamma> (snd tw)"
  assumes "beval_world_raw2 tw (Badd (Bsig A) (Bsig B)) v"
  shows   "type_of v = Lty Sig len"
proof -
  have "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
    using assms(2) unfolding beval_world_raw2_def by auto
  have "type_of (state_of_world (snd tw) (fst tw) A) = Lty Sig len1" and
       "type_of (state_of_world (snd tw) (fst tw) B) = Lty Sig len2"
    using assms(1) unfolding wityping_def
    by (simp add: atype btype state_of_world_def wtyping_def)+
  show ?thesis
    apply (rule beval_world_raw_cases[OF \<open>beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v\<close>])
    apply (erule beval_cases)
    apply (metis (no_types, hide_lams) \<open>type_of (state_of_world (snd tw) (get_time tw) A) = Lty Sig len1\<close> beval_cases(1) signedness.distinct(5) ty.inject type_of.simps(2))
    apply (metis \<open>type_of (state_of_world (snd tw) (get_time tw) A) = Lty Sig len1\<close> \<open>type_of (state_of_world (snd tw) (get_time tw) B) = Lty Sig len2\<close> beval_cases(1) bin_to_bl_def len_def size_bin_to_bl ty.inject type_of.simps(2) val.sel(3))
    done
qed

lemma add_seq_hoare_next_time:
  "\<turnstile> [\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Badd (Bsig A) (Bsig B)) 1
     [\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2, simp)
  using inv_next_time type_correctness_length
  by (metis ctype snd_conv worldline_upd2_def worldline_upd_preserve_wityping)

lemma add_seq_hoare_next_time0:
  "\<turnstile> [\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Badd (Bsig A) (Bsig B)) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2)
  apply (simp add: next_time_world_at_least)
  using inv_next_time type_correctness_length unfolding inv_def
  by (metis ctype gr_implies_not0 snd_conv worldline_upd2_def worldline_upd_preserve_wityping)

lemma add_conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw)"
proof (rule+)
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j
  assume "j \<in> {fst tw <.. next_time_world tw}"
  assume "inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  { fix i
    assume "i < j"
    have "fst tw < next_time_world tw"
      by (simp add: next_time_world_at_least)
    have "i < fst tw \<or> fst tw \<le> i"
      by auto
    moreover
    { assume "i < fst tw"
      hence "property (i + 1) i tw"
        using \<open>inv tw\<close> unfolding inv_def by auto
      hence "property (i + 1) i (j, snd tw)"
        unfolding property_def by simp }
    moreover
    { assume "fst tw \<le> i"
      moreover have "\<forall>i \<ge> fst tw. property (i + 1) (fst tw) tw"
        using \<open>inv2 tw\<close> \<open>disjnt {A, B} (event_of tw)\<close> unfolding inv2_def
        by auto
      ultimately have "property (i + 1) (fst tw) tw"
        by auto
      hence "property (i + 1) i tw"
        unfolding property_def
        by (smt \<open>get_time tw \<le> i\<close> \<open>i < j\<close> \<open>j \<in> {get_time tw<..next_time_world tw}\<close> dual_order.strict_trans1 greaterThanAtMost_iff unchanged_until_next_time_world)
      hence "property (i + 1) i (j, snd tw)"
        unfolding property_def by auto }
    ultimately have "property (i + 1) i (j, snd tw)"
      by auto }
  thus "inv (j, snd tw)"
    unfolding inv_def by auto
qed

lemma add_conc_hoare2:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> \<forall>j \<in> {fst tw <.. next_time_world tw}. inv2 (j, snd tw)"
proof (rule)
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j :: nat
  assume "j \<in> {fst tw <.. next_time_world tw}"
  assume "inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  { assume "disjnt {A, B} (event_of (j, snd tw))"
    hence *: "lof_wline tw A j = lof_wline tw A (j - 1)" and **: "lof_wline tw B j = lof_wline tw B (j - 1)"
      unfolding event_of_alt_def
      by (smt comp_apply diff_0_eq_0 disjnt_insert1 fst_conv mem_Collect_eq snd_conv)+
    have "fst tw < j"
      using \<open>j \<in> {get_time tw<..next_time_world tw}\<close> greaterThanAtMost_iff by blast
    { fix i
      assume "j \<le> i"
      have "property (i + 1) (fst tw) tw"
        using \<open>inv2 tw\<close> \<open>disjnt {A, B} (event_of tw)\<close> unfolding inv2_def
        using \<open>fst tw < j\<close> \<open>j \<le> i\<close> by auto
      moreover have "lof_wline tw A (fst tw) = lof_wline tw A (j - 1)" and
                    "lof_wline tw B (fst tw) = lof_wline tw B (j - 1)"
        by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 \<open>j \<in> {get_time tw<..next_time_world
        tw}\<close> add_le_imp_le_diff diff_add discrete gr_implies_not0 greaterThanAtMost_iff
        not_less_iff_gr_or_eq unchanged_until_next_time_world)+
      ultimately have "property (i + 1) j (j, snd tw)"
        unfolding property_def using * **  by auto }
    hence "\<forall>i\<ge>j. property (i + 1) j (j, snd tw)"
      by auto }
  thus "inv2 (j, snd tw)"
    unfolding inv2_def by auto
qed

lemma inv2_next_time:
  fixes tw
  assumes "beval_world_raw2 tw (Badd (Bsig A) (Bsig B)) v" and "type_of v = Lty Sig len"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. inv2 (j, snd tw')"
  unfolding inv2_def
proof (rule+)
  fix j i
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume "disjnt {A, B} (event_of (j, snd tw'))"
  hence "A \<notin> event_of (j, snd tw')" and "B \<notin> event_of (j, snd tw')"
    by auto
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff prod.exhaust_sel
    prod.inject tw'_def worldline_upd2_def)
  have 0: "wline_of (j, snd tw') A j = wline_of tw A (fst tw)"
  proof -
    have "wline_of tw' A j = wline_of tw' A (j - 1)"
      using \<open>A \<notin> event_of (j, snd tw')\<close> unfolding event_of_alt_def
      using \<open>fst tw < j\<close> by auto
    also have " ... = wline_of tw' A (fst tw')"
      using unchanged_until_next_time_world
      by (metis (mono_tags, lifting) Suc_diff_1 \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close>
      gr_implies_not_zero greaterThanAtMost_iff le_0_eq less_Suc_eq_le not_less)
    also have "... = wline_of tw' A (fst tw)"
      by (simp add: tw'_def worldline_upd2_def)
    also have "... = wline_of tw A (fst tw)"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    finally show "wline_of (j, snd tw') A j = wline_of tw A (fst tw)"
      by auto
  qed
  have 1: "wline_of (j, snd tw') B j = wline_of tw B (fst tw)"
  proof -
    have "wline_of tw' B j = wline_of tw' B (j - 1)"
      using \<open>B \<notin> event_of (j, snd tw')\<close> unfolding event_of_alt_def
      using \<open>fst tw < j\<close> by auto
    also have " ... = wline_of tw' B (fst tw')"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) Suc_diff_1 \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close>
      dual_order.order_iff_strict greaterThanAtMost_iff le_0_eq less_Suc_eq_le not_less)
    also have "... = wline_of tw' B (fst tw)"
      by (simp add: tw'_def worldline_upd2_def)
    also have "... = wline_of tw B (fst tw)"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    finally show "wline_of (j, snd tw') B j = wline_of tw B (fst tw)"
      by auto
  qed
  have assm2: "beval_world_raw (snd tw) (fst tw) (Badd (Bsig A) (Bsig B)) v"
    using assms(1) unfolding beval_world_raw2_def by auto
  have "wline_of (next_world tw') C (i + 1) = v"
  proof -
    have "wline_of tw' C (i + 1) = v"
      using `fst tw < j` \<open>j \<le> i\<close>
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    thus ?thesis
      by auto
  qed
  also have "lval_of ... = bin_to_bl len (sbl_to_bin (lof_wline tw A (fst tw)) + sbl_to_bin (lof_wline tw B (fst tw)))"
    apply (rule beval_world_raw_cases[OF assm2])
    apply (erule beval_cases)
    defer
    apply (metis (mono_tags, lifting) add.right_neutral assms(2) beval_cases(1) bin_to_bl_def comp_apply list.size(3) size_bin_to_bl_aux state_of_world_def ty.distinct(1) ty.inject type_of.elims val.sel(3))
    using assms(2) by auto
  finally have "property (i + 1) j (j, snd tw')"
    unfolding property_def using 0 1  by auto
  thus " property (i + 1) (get_time (j, snd tw')) (j, snd tw')"
    by auto
qed

lemma add_seq_hoare_next_time1:
  "\<turnstile> [\<lambda>tw. wityping \<Gamma> (snd tw)] Bassign_trans C (Badd (Bsig A) (Bsig B)) 1 [\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv2 (i, snd tw)]"
  apply (rule Assign2_altI)
  using inv2_next_time type_correctness_length by blast

lemma seq_wt_add:
  "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using well_typed by blast

lemma add_conc_hoare3:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. (\<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> inv2 (i, snd tw)) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  apply (rule Conj2)
  unfolding add_def
   apply (rule Single)
    apply(rule Conj_univ_qtfd[where Q="inv" and R="inv2"])
     apply (rule strengthen_precondition)
     apply (rule strengthen_precondition)
     apply (rule add_seq_hoare_next_time)
    apply (rule strengthen_precondition)
    apply (rule strengthen_precondition)
    apply (rule strengthen_precondition2)
    apply (rule add_seq_hoare_next_time1)
  using add_conc_hoare add_conc_hoare2 apply blast
  apply (rule strengthen_pre_conc_hoare[rotated])
  apply (rule single_conc_stmt_preserve_wityping_hoare)
   apply (rule seq_wt_add)
  by simp

lemma add_conc_hoare4:
  "\<turnstile> \<lbrace>\<lambda>tw. (local.inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add
       \<lbrace>\<lambda>tw. \<forall>i\<in>{get_time tw<..next_time_world tw}. (local.inv (i, snd tw) \<and> wityping \<Gamma> (snd tw)) \<and> inv2 (i, snd tw)\<rbrace>"
  apply (rule Conseq'[rotated])
  apply (rule add_conc_hoare3)
  by auto

lemma add_conc_sim':
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace>"
  apply (rule While)
  unfolding snd_conv
  apply (rule add_conc_hoare4)
  done

lemma add_conc_sim2:
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>inv\<rbrace>"
  using add_conc_sim' Conseq_sim by blast

lemma init_sat_add_inv:
  "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add (\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw))"
  unfolding add_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule Conj)
  unfolding snd_conv apply(rule add_seq_hoare_next_time0)
  apply (rule strengthen_precondition2)
  by (metis seq_stmt_preserve_wityping_hoare well_typed)

lemma init_sat_add_inv2:
  "init_sim_hoare (\<lambda>tw. wityping \<Gamma> (snd tw)) add inv2"
  unfolding add_def
  apply (rule AssignI)
  apply (rule SingleI)
  unfolding snd_conv
  apply (rule Conseq2[rotated])
    apply (rule add_seq_hoare_next_time1)
   apply (simp add: next_time_world_at_least)
  by auto

lemma init_sat_add_inv_comb:
  shows "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add  (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
  apply (rule ConjI_sim)
  apply (rule init_sat_add_inv)
  apply (rule ConseqI_sim[rotated])
  apply (rule init_sat_add_inv2)
  by blast+

lemma add_correctness:
  assumes "sim_fin w (i + 1) add tw'" and "wityping \<Gamma> w"
  shows   "property (i + 1) i tw'"
proof -
  obtain tw where "init_sim (0, w) add tw" and  "tw, i + 1, add \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf add"
    unfolding conc_stmt_wf_def add_def by auto
  moreover have "nonneg_delay_conc add"
    unfolding add_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_add_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_add_inv_comb
    init_sim_hoare_soundness add_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) add tw\<close> fst_conv assms(2) unfolding init_sim_valid_def
    by (metis snd_conv)
  hence "inv tw" and "inv2 tw" and "wityping \<Gamma> (snd tw)"
    by auto
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>inv\<rbrace>"
    using conc_sim_soundness[OF add_conc_sim2] \<open>conc_stmt_wf add\<close> \<open>nonneg_delay_conc add\<close>
    by auto
  ultimately have "inv tw'"
    using \<open>tw, i + 1, add \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
  with \<open>i + 1 = fst tw'\<close> show ?thesis
    unfolding inv_def by (metis less_add_one)
qed

lemma add_correctness2:
  assumes "sim_fin w (i + 1) add tw'" and "wityping \<Gamma> w"
  shows   "wityping \<Gamma> (snd tw')"
proof -
  obtain tw where "init_sim (0, w) add tw" and  "tw, i + 1, add \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf add"
    unfolding conc_stmt_wf_def add_def by auto
  moreover have "nonneg_delay_conc add"
    unfolding add_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) add (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_add_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_add_inv_comb
    init_sim_hoare_soundness add_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) add tw\<close> fst_conv assms(2) unfolding init_sim_valid_def
    by (metis snd_conv)
  hence "inv tw" and "inv2 tw" and "wityping \<Gamma> (snd tw)"
    by auto
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. wityping \<Gamma> (snd tw)\<rbrace>"
    using conc_sim_soundness[OF add_conc_sim'] \<open>conc_stmt_wf add\<close> \<open>nonneg_delay_conc add\<close>
    by (metis (no_types, lifting) sim_hoare_valid_def)
  ultimately show "wityping \<Gamma> (snd tw')"
    using \<open>tw, i + 1, add \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
qed

corollary add_correctness3:
  assumes "sim_fin w (i + 1) add tw'" and "wityping \<Gamma> w"
  defines "bsA \<equiv> lof_wline tw' A i"
  defines "bsB \<equiv> lof_wline tw' B i"
  defines "bsC \<equiv> lof_wline tw' C (i + 1)"
  assumes "0 < len1" and "0 < len2" \<comment> \<open>bit length of less than two is senseless for signed number\<close>
  shows   "sbl_to_bin bsC mod 2 ^  len = (sbl_to_bin bsA + sbl_to_bin bsB) mod 2 ^ len" and
          "length bsC = len" and "0 < length bsB" and  "length bsA = len1"
proof -
  have "property (i + 1) i tw'" and "wityping \<Gamma> (snd tw')"
    using add_correctness[OF assms(1-2)] add_correctness2[OF assms(1-2)] by auto
  hence "length bsA = len1" and "length bsB = len2"
    by (smt assms(3-4) atype btype o_apply ty.distinct(1) ty.inject type_of.elims val.sel(3)
    wityping_def wtyping_def)+
  hence "0 < length bsA" and "0 < length bsB"
    using assms by blast+
  hence "0 < len"
    using assms unfolding len_def by auto
  have "lof_wline tw' C (i + 1) =
                  bin_to_bl len (sbl_to_bin (lof_wline tw' A i) + sbl_to_bin (lof_wline tw' B i))"
    using \<open>property (i + 1) i tw'\<close> unfolding property_def by auto
  hence "bsC = bin_to_bl len (sbl_to_bin bsA + sbl_to_bin bsB)" (is "_ = ?rhs")
    unfolding bsA_def bsB_def bsC_def by auto
  hence "sbl_to_bin bsC = sbl_to_bin ?rhs"
    by auto
  hence "sbl_to_bin bsC mod 2 ^ len = sbl_to_bin ?rhs mod 2 ^ len"
    by auto
  also have "... = (sbl_to_bin bsA + sbl_to_bin bsB) mod 2 ^ len"
    using sbin_bl_bin' \<open>0 < len\<close> by auto
  finally show "sbl_to_bin bsC mod 2 ^ len = (sbl_to_bin bsA + sbl_to_bin bsB) mod 2 ^ len"
    by auto
  show "length bsC = len" and "0 < length bsB" and "length bsA = len1"
    using \<open>bsC = bin_to_bl len (sbl_to_bin bsA + sbl_to_bin bsB)\<close> size_bin_to_bl \<open>0 < length bsB\<close>
    \<open>length bsA = len1\<close> by blast+
qed

corollary add_correctness4:
  assumes "sim_fin w (i + 1) add tw'" and "wityping \<Gamma> w"
  defines "bsA \<equiv> lof_wline tw' A i"
  defines "bsB \<equiv> lof_wline tw' B i"
  defines "bsC \<equiv> lof_wline tw' C (i + 1)"
  assumes "0 < len1" and "0 < len2" \<comment> \<open>bit length of less than two is senseless for signed number\<close>
  defines "repA \<equiv> - (int \<circ> of_bool) (hd bsA) * 2 ^ (length bsA - 1) + (\<Sum>i = 0..<length bsA - 1. (int \<circ> of_bool) (rev (tl bsA) ! i) * 2 ^ i)"
  defines "repB \<equiv> - (int \<circ> of_bool) (hd bsB) * 2 ^ (length bsB - 1) + (\<Sum>i = 0..<length bsB - 1. (int \<circ> of_bool) (rev (tl bsB) ! i) * 2 ^ i)"
  defines "repC \<equiv> - (int \<circ> of_bool) (hd bsC) * 2 ^ (length bsC - 1) + (\<Sum>i = 0..<length bsC - 1. (int \<circ> of_bool) (rev (tl bsC) ! i) * 2 ^ i)"
  shows   "repC mod 2 ^ len = (repA + repB) mod 2 ^ len"
proof -
  have "sbl_to_bin bsC mod 2 ^ len =
       (sbl_to_bin bsA + sbl_to_bin bsB) mod 2 ^ len" and  "length bsC = len" and "0 < length bsB" and "length bsA = len1"
    using add_correctness3 assms by auto
  hence "0 < length bsC"
    unfolding len_def using \<open>0 < len1\<close> \<open>0 < len2\<close> by auto
  then obtain c bsC' where "bsC = c # bsC'" and "hd bsC = c" and "tl bsC = bsC'"
    using list.exhaust_sel by auto
  hence sC: "sbl_to_bin bsC = - (int \<circ> of_bool) (hd bsC) * 2 ^ (length bsC - 1) + (\<Sum>i = 0..<length bsC - 1. (int \<circ> of_bool) (rev (tl bsC) ! i) * 2 ^ i)"
    using sbl_to_bin_correctness by simp
  obtain b bsB' a bsA' where "bsA = a # bsA'" and "bsB = b # bsB'" and "hd bsA = a" and "tl bsA = bsA'"
    and "hd bsB = b" and "tl bsB = bsB'"
    by (metis \<open>0 < length bsB\<close> \<open>length bsA = len1\<close> assms(6) list.sel(1) list.sel(3)  list_exhaust_size_gt0 )
  hence sA: "sbl_to_bin bsA = - (int \<circ> of_bool) (hd bsA) * 2 ^ (length bsA - 1) + (\<Sum>i = 0..<length bsA - 1. (int \<circ> of_bool) (rev (tl bsA) ! i) * 2 ^ i)"
    and sB: "sbl_to_bin bsB = - (int \<circ> of_bool) (hd bsB) * 2 ^ (length bsB - 1) + (\<Sum>i = 0..<length bsB - 1. (int \<circ> of_bool) (rev (tl bsB) ! i) * 2 ^ i)"
    using sbl_to_bin_correctness by simp+
  show ?thesis
    using \<open>sbl_to_bin bsC mod 2 ^ len =
       (sbl_to_bin bsA + sbl_to_bin bsB) mod 2 ^ len\<close> unfolding sA sB sC repA_def repB_def repC_def
    by  metis
qed

end


section \<open>Priority Bag Interface\<close>
theory IICF_Prio_Bag
imports IICF_Multiset
begin
subsection \<open>Operations\<close>

  text \<open>We prove quite general parametricity lemmas, but restrict
    them to relations below identity when we register the operations.

    This restriction, although not strictly necessary, makes usage of the tool
    much simpler, as we do not need to handle different prio-functions for
    abstract and concrete types.
  \<close>

  context
    fixes prio:: "'a \<Rightarrow> 'b::linorder"
  begin
    definition "mop_prio_pop_min b = doN {ASSERT (b\<noteq>{#}); SPEC (\<lambda>(v,b').
        v \<in># b
      \<and> b'=b - {#v#}
      \<and> (\<forall>v'\<in>set_mset b. prio v \<le> prio v'))}"

    definition "mop_prio_peek_min b \<equiv> doN {ASSERT (b\<noteq>{#}); SPEC (\<lambda>v.
          v \<in># b
        \<and> (\<forall>v'\<in>set_mset b. prio v \<le> prio v'))}"

  end

  lemma param_mop_prio_pop_min[param]:
    assumes [param]: "(prio',prio) \<in> A \<rightarrow> B"
    assumes [param]: "((\<le>),(\<le>)) \<in> B \<rightarrow> B \<rightarrow> bool_rel"
    shows "(mop_prio_pop_min prio',mop_prio_pop_min prio) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A \<times>\<^sub>r \<langle>A\<rangle>mset_rel\<rangle>nres_rel"
    unfolding mop_prio_pop_min_def[abs_def]
    apply (clarsimp simp: mop_prio_pop_min_def nres_rel_def pw_le_iff refine_pw_simps)
    apply (safe; simp)
  proof goal_cases
    case (1 m n x)
    (*fix m n x*)
    assume "(m,n)\<in>\<langle>A\<rangle>mset_rel"
      and "x\<in>#m"
      and P': "\<forall>x'\<in>set_mset m. prio' x \<le> prio' x'"
    hence R: "rel_mset (rel2p A) m n" by (simp add: mset_rel_def p2rel_def)
    from multi_member_split[OF \<open>x\<in>#m\<close>] obtain m' where [simp]: "m=m'+{#x#}" by auto

    from msed_rel_invL[OF R[simplified]] obtain n' y where
      [simp]: "n=n'+{#y#}" and [param, simp]: "(x,y)\<in>A" and R': "(m',n')\<in>\<langle>A\<rangle>mset_rel"
      by (auto simp: rel2p_def mset_rel_def p2rel_def)
    have "\<forall>y'\<in>set_mset n. prio y \<le> prio y'"
    proof
      fix y' assume "y'\<in>set_mset n"
      then obtain x' where [param]: "(x',y')\<in>A" and "x'\<in>set_mset m"
        using R
        by (metis insert_DiffM msed_rel_invR rel2pD union_single_eq_member)
      with P' have "prio' x \<le> prio' x'" by blast
      moreover have "(prio' x \<le> prio' x', prio y \<le> prio y') \<in> bool_rel"
        by parametricity
      ultimately show "prio y \<le> prio y'" by simp
    qed
    thus
      "\<exists>a. (x, a) \<in> A \<and> (m - {#x#}, n - {#a#}) \<in> \<langle>A\<rangle>mset_rel \<and> a \<in># n \<and> (\<forall>v'\<in>set_mset n. prio a \<le> prio v')"
      using R' by (auto intro!: exI[where x=n'] exI[where x=y])
  qed

  lemma param_mop_prio_peek_min[param]:
    assumes [param]: "(prio',prio) \<in> A \<rightarrow> B"
    assumes [param]: "((\<le>),(\<le>)) \<in> B \<rightarrow> B \<rightarrow> bool_rel"
    shows "(mop_prio_peek_min prio',mop_prio_peek_min prio) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>nres_rel"
    unfolding mop_prio_peek_min_def[abs_def]
    apply (clarsimp
      simp: mop_prio_pop_min_def nres_rel_def pw_le_iff refine_pw_simps
      )
    apply (safe; simp?)
  proof -
    fix m n x
    assume "(m,n)\<in>\<langle>A\<rangle>mset_rel"
      and "x\<in>#m"
      and P': "\<forall>x'\<in>set_mset m. prio' x \<le> prio' x'"
    hence R: "rel_mset (rel2p A) m n" by (simp add: mset_rel_def p2rel_def)
    from multi_member_split[OF \<open>x\<in>#m\<close>] obtain m' where [simp]: "m=m'+{#x#}" by auto

    from msed_rel_invL[OF R[simplified]] obtain n' y where
      [simp]: "n=n'+{#y#}" and [param, simp]: "(x,y)\<in>A" and R': "(m',n')\<in>\<langle>A\<rangle>mset_rel"
      by (auto simp: rel2p_def mset_rel_def p2rel_def)

    have "\<forall>y'\<in>set_mset n. prio y \<le> prio y'"
    proof
      fix y' assume "y'\<in>set_mset n"
      then obtain x' where [param]: "(x',y')\<in>A" and "x'\<in>set_mset m"
        using R
        by (metis msed_rel_invR mset_contains_eq rel2pD union_mset_add_mset_left union_single_eq_member)
      with P' have "prio' x \<le> prio' x'" by blast
      moreover have "(prio' x \<le> prio' x', prio y \<le> prio y') \<in> bool_rel"
        by parametricity
      ultimately show "prio y \<le> prio y'" by simp
    qed
    thus "\<exists>y. (x, y) \<in> A \<and> y \<in># n \<and> (\<forall>v'\<in>set_mset n. prio y \<le> prio v')"
      using R' by (auto intro!: exI[where x=y])
  qed

  context fixes prio :: "'a \<Rightarrow> 'b::linorder" and A :: "('a\<times>'a) set" begin
    sepref_decl_op (no_def,no_mop) prio_pop_min:
      "PR_CONST (mop_prio_pop_min prio)" :: "\<langle>A\<rangle>mset_rel \<rightarrow>\<^sub>f \<langle>A \<times>\<^sub>r \<langle>A\<rangle>mset_rel\<rangle>nres_rel"
      where "IS_BELOW_ID A"
    proof goal_cases
      case 1
      hence [param]: "(prio,prio)\<in>A \<rightarrow> Id"
        by (auto simp: IS_BELOW_ID_def)
      show ?case
        apply (rule fref_ncI)
        apply parametricity
        by auto
    qed

    sepref_decl_op (no_def,no_mop) prio_peek_min:
      "PR_CONST (mop_prio_peek_min prio)" :: "\<langle>A\<rangle>mset_rel \<rightarrow>\<^sub>f \<langle>A\<rangle>nres_rel"
      where "IS_BELOW_ID A"
    proof goal_cases
      case 1
      hence [param]: "(prio,prio)\<in>A \<rightarrow> Id"
        by (auto simp: IS_BELOW_ID_def)
      show ?case
        apply (rule fref_ncI)
        apply parametricity
        by auto
    qed
  end

subsection \<open>Patterns\<close>

end


theory TheoremD12
imports TheoremD11
begin

context LocalLexing begin

lemma charslength_appendix_is_empty:
  "charslength (p@ts) = charslength p \<Longrightarrow> (\<And> t. t \<in> set ts \<Longrightarrow> chars_of_token t = [])"
proof (induct ts)
  case Nil then show ?case by auto
next
  case (Cons s ts)
    have "charslength (p @ s # ts) = charslength (p @ ts) + length (chars_of_token s)"
      by simp
    then have "charslength (p @ s # ts) = charslength p + charslength ts + length (chars_of_token s)"
      by simp
    with Cons.prems(1) have "charslength ts + length (chars_of_token s) = 0" by arith
    then show ?case using Cons.prems(2) charslength_0 by auto
qed

lemma empty_tokens_have_charslength_0:
  "(\<And> t. t \<in> set ts \<Longrightarrow> chars_of_token t = []) \<Longrightarrow> charslength ts = 0"
proof (induct ts)
  case Nil then show ?case by simp
next
  case (Cons t ts)
    then show ?case by auto
qed

lemma \<pi>_idempotent': "\<pi> k {} (\<pi> k T I) = \<pi> k T I"
  apply (simp add: \<pi>_no_tokens)
  by (simp add: Complete_\<pi>_fix Predict_\<pi>_fix fix_is_fix_of_limit)

theorem thmD12:
  assumes induct: "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u))"
  assumes induct_tokens: "\<T> k u = \<Z> k u"
  shows "items_le k (\<J> k (Suc u)) \<supseteq> Gen (paths_le k (\<P> k (Suc u)))"
proof -
  {
    fix x :: "('a, 'b) item"
    assume x_dom: "x \<in> Gen (paths_le k (\<P> k (Suc u)))"
    have "\<exists> q. pvalid q x \<and> q \<in> \<P> k (Suc u) \<and> charslength q \<le> k"
    proof -
      have "\<And>i I n. i \<in> I \<or> i \<notin> items_le n I"
        by (meson items_le_is_filter subsetCE)
      then show ?thesis
        by (metis Gen_implies_pvalid x_dom items_le_fix_D items_le_idempotent items_le_paths_le
          pvalid_item_end)
    qed
    then obtain q where q: "pvalid q x \<and> q \<in> \<P> k (Suc u) \<and> charslength q \<le> k" by blast
    have "q \<in> \<P> k u \<or> q \<notin> \<P> k u" by blast
    then have "x \<in> items_le k (\<J> k (Suc u))"
    proof (induct rule: disjCases2)
      case 1
        with q have "x \<in> Gen (paths_le k (\<P> k u))"
          apply (auto simp add: Gen_def)
          apply (rule_tac x=q in exI)
          by (simp add: paths_le_def)
        with induct have "x \<in> items_le k (\<J> k u)" by simp
        then show ?case
          using LocalLexing.items_le_def LocalLexing_axioms \<J>_subset_Suc_u by fastforce
    next
      case 2
        have q_is_limit: "q \<in> limit (Append (\<Y> (\<Z> k u) (\<P> k u) k) k) (\<P> k u)" using q by auto
        from limit_Append_path_nonelem_split[OF q_is_limit 2] obtain p ts where p_ts:
          "q = p @ ts \<and>
           p \<in> \<P> k u \<and>
           charslength p = k \<and>
           admissible (p @ ts) \<and>
           (\<forall>t\<in>set ts. t \<in> \<Y> (\<Z> k u) (\<P> k u) k) \<and> (\<forall>t\<in>set (butlast ts). chars_of_token t = [])"
           by blast
        then have ts_nonempty: "ts \<noteq> []" using 2 using self_append_conv by auto
        obtain T where T: "T = \<Y> (\<Z> k u) (\<P> k u) k" by blast
        obtain J where J: "J = \<pi> k T (Gen (paths_le k (\<P> k u)))" by blast
        from q p_ts have chars_of_token_is_empty: "\<And> t. t\<in>set ts \<Longrightarrow> chars_of_token t = []"
          using charslength_appendix_is_empty chars_append charslength.simps le_add1 le_imp_less_Suc
            le_neq_implies_less length_append not_less_eq by auto
        {
          fix sss :: "('a, 'b, 'c) token list"
          have "is_prefix sss ts \<Longrightarrow> pvalid (p @ sss) x \<Longrightarrow> x \<in> J"
          proof (induct "length sss" arbitrary: sss x rule: less_induct)
            case less
              have "sss = [] \<or> sss \<noteq> []" by blast
              then show ?case
              proof (induct rule: disjCases2)
                case 1
                  with less have pvalid_p_x: "pvalid p x" by auto
                  have charslength_p: "charslength p \<le> k" using p_ts by blast
                  with p_ts have "p \<in> paths_le k (\<P> k u)"
                    by (simp add: paths_le_def)
                  with pvalid_p_x have "x \<in> Gen (paths_le k (\<P> k u))"
                    using Gen_def mem_Collect_eq by blast
                  then have "x \<in> \<pi> k T (Gen (paths_le k (\<P> k u)))" using \<pi>_apply_setmonotone
                    by blast
                  then show "x \<in> J" using pvalid_item_end q J LocalLexing.items_le_def
                    LocalLexing_axioms charslength_p mem_Collect_eq pvalid_p_x by auto
              next
                case 2
                  then have "\<exists> a ss. sss = ss@[a]" using rev_exhaust by blast
                  then obtain a ss where snoc: "sss = ss@[a]" by blast
                  obtain p' where p': "p' = p @ ss" by auto
                  then have "pvalid_left (p'@[a]) x" using snoc less pvalid_left by simp
                  from iffD1[OF pvalid_left_def this] obtain r \<omega> where pvalid:
                    "wellformed_tokens (p' @ [a]) \<and>
                     wellformed_item x \<and>
                     r \<le> length (p' @ [a]) \<and>
                     charslength (p' @ [a]) = item_end x \<and>
                     charslength (take r (p' @ [a])) = item_origin x \<and>
                     is_leftderivation (terminals (take r (p' @ [a])) @ [item_nonterminal x] @ \<omega>) \<and>
                     leftderives (item_\<alpha> x) (terminals (drop r (p' @ [a])))" by blast
                  obtain q' where q': "q' = p'@[a]" by blast
                  have is_prefix_ss_ts: "is_prefix ss ts" using snoc less
                    by (simp add: is_prefix_append)
                  then have "is_prefix (p@ss) q" using p' snoc p_ts by simp
                  then have "is_prefix p' q" using p' by simp
                  then have h1: "p' \<in> \<PP>" using q \<PP>_covers_\<P> prefixes_are_paths' subsetCE by blast
                  have charslength_ss: "charslength ss = 0"
                    apply (rule empty_tokens_have_charslength_0)
                    by (metis is_prefix_ss_ts append_is_Nil_conv chars_append chars_of_token_is_empty
                      charslength.simps charslength_0 is_prefix_def length_greater_0_conv list.size(3))
                  then have h2: "charslength p' = k" using p' p_ts by auto
                  have a_in_ts: "a \<in> set ts"
                    by (metis in_set_dropD is_prefix_append is_prefix_cons list.set_intros(1)
                      snoc less(2))
                  then have h3: "a \<in> T" using T p_ts by blast
                  have h4: "T \<subseteq> \<X> k"
                    using LocalLexing.\<Z>.simps(2) LocalLexing_axioms T \<Z>_subset_\<X> by blast
                  note h5 = q'
                  obtain N where N: "N = item_nonterminal x" by blast
                  obtain \<alpha> where \<alpha>: "\<alpha> = item_\<alpha> x" by blast
                  obtain \<beta> where \<beta>: "\<beta> = item_\<beta> x" by blast
                  have item_rhs_x:"snd (item_rule x) = \<alpha>@\<beta>" using item_rhs_def \<alpha> \<beta> item_rhs_split by metis
                  have item_nonterminal_x:"fst (item_rule x) = N" using N item_nonterminal_def by metis
                  have item_rule_id: "item_rule x = (fst (item_rule x), snd(item_rule x))" by simp
                  with item_rhs_x item_nonterminal_x have item_rule_x:"item_rule x = (N, \<alpha>@\<beta>)" by simp
                  have "wellformed_item x" using pvalid by blast
                  then have h6: "(N, \<alpha>@\<beta>) \<in> \<RR>" using item_rule_x
                    by (simp add: wellformed_item_def)
                  have h7: "r \<le> length q'" using pvalid q' by blast
                  have h8: "leftderives [\<SS>] (terminals (take r q') @ [N] @ \<omega>)"
                    using N is_leftderivation_def pvalid q' by blast
                  have h9: "leftderives \<alpha> (terminals (drop r q'))" using \<alpha> pvalid q' by blast
                  have h10: "k = k + length (chars_of_token a)"
                    by (simp add: a_in_ts chars_of_token_is_empty)
                  have h11: "x = Item (N, \<alpha> @ \<beta>) (length \<alpha>) (charslength (take r q')) k"
                    by (metis \<alpha> charslength_ss a_in_ts append_Nil2 chars.simps(2) chars_append
                      chars_of_token_is_empty charslength.simps h2 item.collapse item_dot_is_\<alpha>_length
                      item_rule_x length_greater_0_conv list.size(3) pvalid q')
                  have x_dom: "x \<in> items_le k (\<pi> k {} (Scan T k (Gen (Prefixes p'))))"
                    using thmD11[OF h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11] by auto
                  {
                    fix y :: "('a, 'b) item"
                    fix toks :: "('a, 'b, 'c) token list"
                    assume pvalid_toks_y: "pvalid toks y"
                    assume is_prefix_toks_p': "is_prefix toks p'"
                    then have charslength_toks: "charslength toks \<le> k"
                      using charslength_of_prefix h2 by blast
                    then have item_end_y: "item_end y \<le> k" using pvalid_item_end pvalid_toks_y
                      by auto
                    have "is_prefix toks p \<or> (\<exists> ss'. is_prefix ss' ss \<and> toks = p@ss')"
                      using is_prefix_of_append is_prefix_toks_p' p' by auto
                    then have "y \<in> J"
                    proof (induct rule: disjCases2)
                      case 1
                        then have "toks \<in> \<P> k u" using p_ts prefixes_are_paths by blast
                        with charslength_toks have "toks \<in> paths_le k (\<P> k u)"
                          by (simp add: paths_le_def)
                        then have "y \<in> Gen (paths_le k (\<P> k u))" using pvalid_toks_y
                          Gen_def mem_Collect_eq by blast
                        then have "y \<in> \<pi> k T (Gen (paths_le k (\<P> k u)))" using \<pi>_apply_setmonotone
                          by blast
                        then show "y \<in> J" by (simp add: J items_le_def item_end_y)
                    next
                      case 2
                        then obtain ss' where ss': "is_prefix ss' ss \<and> toks = p@ss'" by blast
                        then have l1: "length ss' < length sss"
                          using append_eq_conv_conj append_self_conv is_prefix_length length_append
                            less_le_trans nat_neq_iff not_Cons_self2 not_add_less1 snoc by fastforce
                        have l2: "is_prefix ss' ts" using ss' is_prefix_ss_ts
                          by (metis append_dropped_prefix is_prefix_append)
                        have l3: "pvalid (p @ ss') y" using ss' pvalid_toks_y by simp
                        show ?case using less.hyps[OF l1 l2 l3] by blast
                    qed
                  }
                  then have "Gen (Prefixes p') \<subseteq> J"
                    by (meson Gen_implies_pvalid Prefixes_is_prefix subsetI)
                  with x_dom have r0: "x \<in> items_le k (\<pi> k {} (Scan T k J))"
                    by (metis (no_types, lifting) LocalLexing.items_le_def LocalLexing_axioms
                      mem_Collect_eq mono_Scan mono_\<pi> mono_subset_elem subsetI)
                  then have x_in_\<pi>: "x \<in> \<pi> k {} (Scan T k J)"
                    using LocalLexing.items_le_is_filter LocalLexing_axioms subsetCE by blast
                  have r1: "Scan T k J = J"
                    by (simp add: J Scan_\<pi>_fix)
                  have r2: "\<pi> k {} J = J" using \<pi>_idempotent' using J by blast
                  from x_in_\<pi> r1 r2 show "x \<in> J" by auto
              qed
          qed
        }
        note th = this
        have x_in_J: "x \<in> J"
          apply (rule th[of ts])
          apply (simp add: is_prefix_eq_proper_prefix)
          using p_ts q by blast
        have \<T>_eq_\<Z>: "\<T> k (Suc u) = \<Z> k (Suc u)"
          using induct induct_tokens \<T>_equals_\<Z>_induct_step by blast
        have T_alt: "T = \<T> k (Suc u)" using \<T>_eq_\<Z> T by simp
        have "J = \<pi> k T (items_le k (\<J> k u))" using induct J by simp
        then have "J \<subseteq> \<pi> k T (\<J> k u)" by (simp add: items_le_is_filter monoD mono_\<pi>)
        with T_alt have "J \<subseteq> \<J> k (Suc u)" using \<J>.simps(2) by blast
        with x_in_J have "x \<in> \<J> k (Suc u)" by blast
        then show ?case
          using LocalLexing.items_le_def LocalLexing_axioms pvalid_item_end q by fastforce
    qed
  }
  then show ?thesis by auto
qed

end

end


section \<open>Equivalence\<close>

theory WEquivalence imports Semantics WCFG begin

subsection \<open>From @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"} to\\
  @{term "c \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"} with @{term transfers} and @{term preds}\<close>

lemma Skip_WCFG_edge_Exit:
  "\<lbrakk>labels prog l Skip\<rbrakk> \<Longrightarrow> prog \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)"
proof(induct prog l Skip rule:labels.induct)
  case Labels_Base
  show ?case by(fastforce intro:WCFG_Skip)
next
  case (Labels_LAss V e)
  show ?case by(rule WCFG_LAssSkip)
next
  case (Labels_Seq2 c\<^sub>2 l c\<^sub>1)
  from \<open>c\<^sub>2 \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)\<close>
  have "c\<^sub>1;;c\<^sub>2 \<turnstile> (_ l _) \<oplus> #:c\<^sub>1 -\<Up>id\<rightarrow> (_Exit_) \<oplus> #:c\<^sub>1"
    by(fastforce intro:WCFG_SeqSecond)
  thus ?case by(simp del:id_apply)
next
  case (Labels_CondTrue c\<^sub>1 l b c\<^sub>2)
  from \<open>c\<^sub>1 \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)\<close>
  have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_ l _) \<oplus> 1 -\<Up>id\<rightarrow> (_Exit_) \<oplus> 1"
    by(fastforce intro:WCFG_CondThen)
  thus ?case by(simp del:id_apply)
next
  case (Labels_CondFalse c\<^sub>2 l b c\<^sub>1)
  from \<open>c\<^sub>2 \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)\<close>
  have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_ l _) \<oplus> (#:c\<^sub>1 + 1) -\<Up>id\<rightarrow> (_Exit_) \<oplus> (#:c\<^sub>1 + 1)"
    by(fastforce intro:WCFG_CondElse)
  thus ?case by(simp del:id_apply)
next
  case (Labels_WhileExit b c')
  show ?case by(rule WCFG_WhileFalseSkip)
qed

lemma step_WCFG_edge:
  assumes "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
  obtains et where "prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)" and "transfer et s = s'"
  and "pred et s"
proof -
  from \<open>prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>\<close>
  have "\<exists>et. prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _) \<and> transfer et s = s' \<and> pred et s"
  proof(induct rule:step.induct)
    case (StepLAss V e s)
    have "pred \<Up>(\<lambda>s. s(V:=(interpret e s))) s" by simp
    have "V:=e \<turnstile> (_0_) -\<Up>(\<lambda>s. s(V:=(interpret e s)))\<rightarrow> (_1_)"
      by(rule WCFG_LAss)
    have "transfer \<Up>(\<lambda>s. s(V:=(interpret e s))) s = s(V:=(interpret e s))" by simp
    with \<open>pred \<Up>(\<lambda>s. s(V:=(interpret e s))) s\<close>
      \<open>V:=e \<turnstile> (_0_) -\<Up>(\<lambda>s. s(V:=(interpret e s)))\<rightarrow> (_1_)\<close> show ?case by blast
  next
    case (StepSeq c\<^sub>1 c\<^sub>2 l s)
    from \<open>labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2)\<close> \<open>l < #:c\<^sub>1\<close> have "labels c\<^sub>1 l Skip"
      by(auto elim:labels.cases intro:Labels_Base)
    hence "c\<^sub>1 \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)"
      by(fastforce intro:Skip_WCFG_edge_Exit)
    hence "c\<^sub>1;;c\<^sub>2 \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_0_) \<oplus> #:c\<^sub>1"
      by(rule WCFG_SeqConnect,simp)
    thus ?case by auto
  next
    case (StepSeqWhile b cx l s)
    from \<open>labels (while (b) cx) l (Skip;;while (b) cx)\<close>
    obtain lx where "labels cx lx Skip"
      and [simp]:"l = lx + 2" by(auto elim:labels.cases)
    hence "cx \<turnstile> (_ lx _) -\<Up>id\<rightarrow> (_Exit_)"
      by(fastforce intro:Skip_WCFG_edge_Exit)
    hence "while (b) cx \<turnstile> (_ lx _) \<oplus> 2 -\<Up>id\<rightarrow> (_0_)"
      by(fastforce intro:WCFG_WhileBodyExit)
    thus ?case by auto
  next
    case (StepCondTrue b s c\<^sub>1 c\<^sub>2)
    from \<open>interpret b s = Some true\<close>
    have "pred (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s" by simp
    moreover
    have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> 1"
      by(rule WCFG_CondTrue)
    moreover
    have "transfer (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s = s" by simp
    ultimately show ?case by auto
  next
    case (StepCondFalse b s c\<^sub>1 c\<^sub>2)
    from \<open>interpret b s = Some false\<close>
    have "pred (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s" by simp
    moreover
    have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow>
                                   (_0_) \<oplus> (#:c\<^sub>1 + 1)"
      by(rule WCFG_CondFalse)
    moreover
    have "transfer (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s = s" by simp
    ultimately show ?case by auto
  next
    case (StepWhileTrue b s c)
    from \<open>interpret b s = Some true\<close>
    have "pred (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s" by simp
    moreover
    have "while (b) c \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> 2"
      by(rule WCFG_WhileTrue)
    moreover
    have "transfer (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s = s" by simp
    ultimately show ?case by(auto simp del:add_2_eq_Suc')
  next
    case (StepWhileFalse b s c)
    from \<open>interpret b s = Some false\<close>
    have "pred (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s" by simp
    moreover
    have "while (b) c \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_1_)"
      by(rule WCFG_WhileFalse)
    moreover
    have "transfer (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s = s" by simp
    ultimately show ?case by auto
  next
    case (StepRecSeq1 prog c s l c' s' l' c\<^sub>2)
    from \<open>\<exists>et. prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _) \<and> transfer et s = s' \<and> pred et s\<close>
    obtain et where "prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"
      and "transfer et s = s'" and "pred et s" by blast
    moreover
    from \<open>prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)\<close> have "prog;;c\<^sub>2 \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"
      by(fastforce intro:WCFG_SeqFirst)
    ultimately show ?case by blast
  next
    case (StepRecSeq2 prog c s l c' s' l' c\<^sub>1)
    from \<open>\<exists>et. prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _) \<and> transfer et s = s' \<and> pred et s\<close>
    obtain et where "prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"
      and "transfer et s = s'" and "pred et s" by blast
    moreover
    from \<open>prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)\<close>
    have "c\<^sub>1;;prog \<turnstile> (_ l _) \<oplus> #:c\<^sub>1 -et\<rightarrow> (_ l' _) \<oplus> #:c\<^sub>1"
      by(fastforce intro:WCFG_SeqSecond)
    ultimately show ?case by simp blast
  next
    case (StepRecCond1 prog c s l c' s' l' b c\<^sub>2)
    from \<open>\<exists>et. prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _) \<and> transfer et s = s' \<and> pred et s\<close>
    obtain et where "prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"
      and "transfer et s = s'" and "pred et s" by blast
    moreover
    from \<open>prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)\<close>
    have "if (b) prog else c\<^sub>2 \<turnstile> (_ l _) \<oplus> 1 -et\<rightarrow> (_ l' _) \<oplus> 1"
      by(fastforce intro:WCFG_CondThen)
    ultimately show ?case by simp blast
  next
    case (StepRecCond2 prog c s l c' s' l' b c\<^sub>1)
    from \<open>\<exists>et. prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _) \<and> transfer et s = s' \<and> pred et s\<close>
    obtain et where "prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"
      and "transfer et s = s'" and "pred et s" by blast
    moreover
    from \<open>prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)\<close>
    have "if (b) c\<^sub>1 else prog \<turnstile> (_ l _) \<oplus> (#:c\<^sub>1 + 1) -et\<rightarrow> (_ l' _) \<oplus> (#:c\<^sub>1 + 1)"
      by(fastforce intro:WCFG_CondElse)
    ultimately show ?case by simp blast
  next
    case (StepRecWhile cx c s l c' s' l' b)
    from \<open>\<exists>et. cx \<turnstile> (_ l _) -et\<rightarrow> (_ l' _) \<and> transfer et s = s' \<and> pred et s\<close>
    obtain et where "cx \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"
      and "transfer et s = s'" and "pred et s" by blast
    moreover
    hence "while (b) cx \<turnstile> (_ l _) \<oplus> 2 -et\<rightarrow> (_ l' _) \<oplus> 2"
      by(fastforce intro:WCFG_WhileBody)
    ultimately show ?case by simp blast
  qed
  with that show ?thesis by blast
qed

subsection \<open>From @{term "c \<turnstile> (_ l _) -et\<rightarrow> (_ l' _)"} with @{term transfers}
  and @{term preds} to\\
  @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"}\<close>

(*<*)declare One_nat_def [simp del] add_2_eq_Suc' [simp del](*>*)

lemma WCFG_edge_Exit_Skip:
  "\<lbrakk>prog \<turnstile> n -et\<rightarrow> (_Exit_); n \<noteq> (_Entry_)\<rbrakk>
  \<Longrightarrow> \<exists>l. n = (_ l _) \<and> labels prog l Skip \<and> et = \<Up>id"
proof(induct prog n et "(_Exit_)" rule:WCFG_induct)
  case WCFG_Skip show ?case by(fastforce intro:Labels_Base)
next
  case WCFG_LAssSkip show ?case by(fastforce intro:Labels_LAss)
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = \<open>\<lbrakk>n' = (_Exit_); n \<noteq> (_Entry_)\<rbrakk>
    \<Longrightarrow> \<exists>l. n = (_ l _) \<and> labels c\<^sub>2 l Skip \<and> et = \<Up>id\<close>
  from \<open>n' \<oplus> #:c\<^sub>1 = (_Exit_)\<close> have "n' = (_Exit_)" by(cases n') auto
  from IH[OF this \<open>n \<noteq> (_Entry_)\<close>] obtain l where [simp]:"n = (_ l _)" "et = \<Up>id"
    and "labels c\<^sub>2 l Skip" by blast
  hence "labels (c\<^sub>1;;c\<^sub>2) (l + #:c\<^sub>1) Skip" by(fastforce intro:Labels_Seq2)
  thus ?case by(fastforce simp:id_def)
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = \<open>\<lbrakk>n' = (_Exit_); n \<noteq> (_Entry_)\<rbrakk>
    \<Longrightarrow> \<exists>l. n = (_ l _) \<and> labels c\<^sub>1 l Skip \<and> et = \<Up>id\<close>
  from \<open>n' \<oplus> 1 = (_Exit_)\<close> have "n' = (_Exit_)" by(cases n') auto
  from IH[OF this \<open>n \<noteq> (_Entry_)\<close>] obtain l where [simp]:"n = (_ l _)" "et = \<Up>id"
    and "labels c\<^sub>1 l Skip" by blast
  hence "labels (if (b) c\<^sub>1 else c\<^sub>2) (l + 1) Skip"
    by(fastforce intro:Labels_CondTrue)
  thus ?case by(fastforce simp:id_def)
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = \<open>\<lbrakk>n' = (_Exit_); n \<noteq> (_Entry_)\<rbrakk>
    \<Longrightarrow> \<exists>l. n = (_ l _) \<and> labels c\<^sub>2 l Skip \<and> et = \<Up>id\<close>
  from \<open>n' \<oplus> #:c\<^sub>1 + 1 = (_Exit_)\<close> have "n' = (_Exit_)" by(cases n') auto
  from IH[OF this \<open>n \<noteq> (_Entry_)\<close>] obtain l where [simp]:"n = (_ l _)" "et = \<Up>id"
    and label:"labels c\<^sub>2 l Skip" by blast
  hence "labels (if (b) c\<^sub>1 else c\<^sub>2) (l + #:c\<^sub>1 + 1) Skip"
    by(fastforce intro:Labels_CondFalse)
  thus ?case by(fastforce simp:add.assoc id_def)
next
  case WCFG_WhileFalseSkip show ?case by(fastforce intro:Labels_WhileExit)
next
  case (WCFG_WhileBody c' n et n' b) thus ?case by(cases n') auto
qed simp_all

lemma WCFG_edge_step:
  "\<lbrakk>prog \<turnstile> (_ l _) -et\<rightarrow> (_ l' _); transfer et s = s'; pred et s\<rbrakk>
  \<Longrightarrow> \<exists>c c'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels prog l c \<and> labels prog l' c'"
proof(induct prog "(_ l _)" et "(_ l' _)" arbitrary:l l' rule:WCFG_induct)
  case (WCFG_LAss V e)
  from \<open>transfer \<Up>\<lambda>s. s(V:=(interpret e s)) s = s'\<close>
  have [simp]:"s' = s(V:=(interpret e s))" by(simp del:fun_upd_apply)
  have "labels (V:=e) 0 (V:=e)" by(fastforce intro:Labels_Base)
  moreover
  hence "labels (V:=e) 1 Skip" by(fastforce intro:Labels_LAss)
  ultimately show ?case
    apply(rule_tac x="V:=e" in exI)
    apply(rule_tac x="Skip" in exI)
    by(fastforce intro:StepLAss simp del:fun_upd_apply)
next
  case (WCFG_SeqFirst c\<^sub>1 et c\<^sub>2)
  note IH = \<open>\<lbrakk>transfer et s = s'; pred et s\<rbrakk>
    \<Longrightarrow> \<exists>c c'. c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>1 l c \<and> labels c\<^sub>1 l' c'\<close>
  from IH[OF \<open>transfer et s = s'\<close> \<open>pred et s\<close>]
  obtain c c' where "c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>1 l c" and "labels c\<^sub>1 l' c'" by blast
  from \<open>c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>\<close> have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c';;c\<^sub>2,s',l'\<rangle>"
    by(rule StepRecSeq1)
  moreover
  from \<open>labels c\<^sub>1 l c\<close> have "labels (c\<^sub>1;;c\<^sub>2) l (c;;c\<^sub>2)"
    by(fastforce intro:Labels_Seq1)
  moreover
  from \<open>labels c\<^sub>1 l' c'\<close> have "labels (c\<^sub>1;;c\<^sub>2) l' (c';;c\<^sub>2)"
    by(fastforce intro:Labels_Seq1)
  ultimately show ?case by blast
next
  case (WCFG_SeqConnect c\<^sub>1 et c\<^sub>2)
  from \<open>c\<^sub>1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)\<close>
  have "labels c\<^sub>1 l Skip" and [simp]:"et = \<Up>id"
    by(auto dest:WCFG_edge_Exit_Skip)
  from \<open>transfer et s = s'\<close> have [simp]:"s' = s" by simp
  have "labels c\<^sub>2 0 c\<^sub>2" by(fastforce intro:Labels_Base)
  hence "labels (c\<^sub>1;;c\<^sub>2) #:c\<^sub>1 c\<^sub>2" by(fastforce dest:Labels_Seq2)
  moreover
  from \<open>labels c\<^sub>1 l Skip\<close> have "labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2)"
    by(fastforce intro:Labels_Seq1)
  moreover
  from \<open>labels c\<^sub>1 l Skip\<close> have "l < #:c\<^sub>1" by(rule label_less_num_inner_nodes)
  ultimately
  have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1\<rangle>" by -(rule StepSeq)
  with \<open>labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2)\<close>
    \<open>labels (c\<^sub>1;;c\<^sub>2) #:c\<^sub>1 c\<^sub>2\<close> \<open>(_0_) \<oplus> #:c\<^sub>1 = (_ l' _)\<close> show ?case by simp blast
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = \<open>\<And>l l'. \<lbrakk>n = (_ l _); n' = (_ l' _); transfer et s = s'; pred et s\<rbrakk>
    \<Longrightarrow> \<exists>c c'. c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>2 l c \<and> labels c\<^sub>2 l' c'\<close>
  from \<open>n \<oplus> #:c\<^sub>1 = (_ l _)\<close> obtain lx where "n = (_ lx _)"
    and [simp]:"l = lx + #:c\<^sub>1"
    by(cases n) auto
  from \<open>n' \<oplus> #:c\<^sub>1 = (_ l' _)\<close> obtain lx' where "n' = (_ lx' _)"
    and [simp]:"l' = lx' + #:c\<^sub>1"
    by(cases n') auto
  from IH[OF \<open>n = (_ lx _)\<close> \<open>n' = (_ lx' _)\<close> \<open>transfer et s = s'\<close> \<open>pred et s\<close>]
  obtain c c' where "c\<^sub>2 \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>"
    and "labels c\<^sub>2 lx c" and "labels c\<^sub>2 lx' c'" by blast
  from \<open>c\<^sub>2 \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>\<close> have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    by(fastforce intro:StepRecSeq2)
  moreover
  from \<open>labels c\<^sub>2 lx c\<close> have "labels (c\<^sub>1;;c\<^sub>2) l c" by(fastforce intro:Labels_Seq2)
  moreover
  from \<open>labels c\<^sub>2 lx' c'\<close> have "labels (c\<^sub>1;;c\<^sub>2) l' c'" by(fastforce intro:Labels_Seq2)
  ultimately show ?case by blast
next
  case (WCFG_CondTrue b c\<^sub>1 c\<^sub>2)
  from \<open>(_0_) \<oplus> 1 = (_ l' _)\<close> have [simp]:"l' = 1" by simp
  from \<open>transfer (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s = s'\<close> have [simp]:"s' = s" by simp
  have "labels (if (b) c\<^sub>1 else c\<^sub>2) 0 (if (b) c\<^sub>1 else c\<^sub>2)"
    by(fastforce intro:Labels_Base)
  have "labels c\<^sub>1 0 c\<^sub>1" by(fastforce intro:Labels_Base)
  hence "labels (if (b) c\<^sub>1 else c\<^sub>2) 1 c\<^sub>1" by(fastforce dest:Labels_CondTrue)
  from \<open>pred (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s\<close>
  have "interpret b s = Some true" by simp
  hence "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>"
    by(rule StepCondTrue)
  with  \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) 0 (if (b) c\<^sub>1 else c\<^sub>2)\<close>
    \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) 1 c\<^sub>1\<close> show ?case by simp blast
next
  case (WCFG_CondFalse b c\<^sub>1 c\<^sub>2)
  from \<open>(_0_) \<oplus> #:c\<^sub>1 + 1 = (_ l' _)\<close> have [simp]:"l' = #:c\<^sub>1 + 1" by simp
  from \<open>transfer (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s = s'\<close> have [simp]:"s' = s"
    by simp
  have "labels (if (b) c\<^sub>1 else c\<^sub>2) 0 (if (b) c\<^sub>1 else c\<^sub>2)"
    by(fastforce intro:Labels_Base)
  have "labels c\<^sub>2 0 c\<^sub>2" by(fastforce intro:Labels_Base)
  hence "labels (if (b) c\<^sub>1 else c\<^sub>2) (#:c\<^sub>1 + 1) c\<^sub>2" by(fastforce dest:Labels_CondFalse)
  from \<open>pred (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s\<close>
  have "interpret b s = Some false" by simp
  hence "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>"
    by(rule StepCondFalse)
  with \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) 0 (if (b) c\<^sub>1 else c\<^sub>2)\<close>
    \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) (#:c\<^sub>1 + 1) c\<^sub>2\<close> show ?case by simp blast
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = \<open>\<And>l l'. \<lbrakk>n = (_ l _); n' = (_ l' _); transfer et s = s'; pred et s\<rbrakk>
    \<Longrightarrow> \<exists>c c'. c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>1 l c \<and> labels c\<^sub>1 l' c'\<close>
  from \<open>n \<oplus> 1 = (_ l _)\<close> obtain lx where "n = (_ lx _)" and [simp]:"l = lx + 1"
    by(cases n) auto
  from \<open>n' \<oplus> 1 = (_ l' _)\<close> obtain lx' where "n' = (_ lx' _)" and [simp]:"l' = lx' + 1"
    by(cases n') auto
  from IH[OF \<open>n = (_ lx _)\<close> \<open>n' = (_ lx' _)\<close> \<open>transfer et s = s'\<close> \<open>pred et s\<close>]
  obtain c c'  where "c\<^sub>1 \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>"
    and "labels c\<^sub>1 lx c" and "labels c\<^sub>1 lx' c'" by blast
  from \<open>c\<^sub>1 \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>\<close> have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    by(fastforce intro:StepRecCond1)
  moreover
  from \<open>labels c\<^sub>1 lx c\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l c"
    by(fastforce intro:Labels_CondTrue)
  moreover
  from \<open>labels c\<^sub>1 lx' c'\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l' c'"
    by(fastforce intro:Labels_CondTrue)
  ultimately show ?case by blast
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = \<open>\<And>l l'. \<lbrakk>n = (_ l _); n' = (_ l' _); transfer et s = s'; pred et s\<rbrakk>
    \<Longrightarrow> \<exists>c c'. c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>2 l c \<and> labels c\<^sub>2 l' c'\<close>
  from \<open>n \<oplus> #:c\<^sub>1 + 1 = (_ l _)\<close> obtain lx where "n = (_ lx _)"
    and [simp]:"l = lx + #:c\<^sub>1 + 1"
    by(cases n) auto
  from \<open>n' \<oplus> #:c\<^sub>1 + 1 = (_ l' _)\<close> obtain lx' where "n' = (_ lx' _)"
    and [simp]:"l' = lx' + #:c\<^sub>1 + 1"
    by(cases n') auto
  from IH[OF \<open>n = (_ lx _)\<close> \<open>n' = (_ lx' _)\<close> \<open>transfer et s = s'\<close> \<open>pred et s\<close>]
  obtain c c' where "c\<^sub>2 \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>"
    and "labels c\<^sub>2 lx c" and "labels c\<^sub>2 lx' c'" by blast
  from \<open>c\<^sub>2 \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>\<close> have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    by(fastforce intro:StepRecCond2)
  moreover
  from \<open>labels c\<^sub>2 lx c\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l c"
    by(fastforce intro:Labels_CondFalse)
  moreover
  from \<open>labels c\<^sub>2 lx' c'\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l' c'"
    by(fastforce intro:Labels_CondFalse)
  ultimately show ?case by blast
next
  case (WCFG_WhileTrue b cx)
  from \<open>(_0_) \<oplus> 2 = (_ l' _)\<close> have [simp]:"l' = 2" by simp
  from \<open>transfer (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s = s'\<close> have [simp]:"s' = s" by simp
  have "labels (while (b) cx) 0 (while (b) cx)"
    by(fastforce intro:Labels_Base)
  have "labels cx 0 cx" by(fastforce intro:Labels_Base)
  hence "labels (while (b) cx) 2 (cx;;while (b) cx)"
    by(fastforce dest:Labels_WhileBody)
  from \<open>pred (\<lambda>s. interpret b s = Some true)\<^sub>\<surd> s\<close> have "interpret b s = Some true" by simp
  hence "while (b) cx \<turnstile> \<langle>while (b) cx,s,0\<rangle> \<leadsto> \<langle>cx;;while (b) cx,s,2\<rangle>"
    by(rule StepWhileTrue)
  with \<open>labels (while (b) cx) 0 (while (b) cx)\<close>
    \<open>labels (while (b) cx) 2 (cx;;while (b) cx)\<close> show ?case by simp blast
next
  case (WCFG_WhileFalse b cx)
  from \<open>transfer (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s = s'\<close> have [simp]:"s' = s"
    by simp
  have "labels (while (b) cx) 0 (while (b) cx)" by(fastforce intro:Labels_Base)
  have "labels (while (b) cx) 1 Skip" by(fastforce intro:Labels_WhileExit)
  from \<open>pred (\<lambda>s. interpret b s = Some false)\<^sub>\<surd> s\<close> have "interpret b s = Some false"
    by simp
  hence "while (b) cx \<turnstile> \<langle>while (b) cx,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>"
    by(rule StepWhileFalse)
  with \<open>labels (while (b) cx) 0 (while (b) cx)\<close> \<open>labels (while (b) cx) 1 Skip\<close>
  show ?case by simp blast
next
  case (WCFG_WhileBody cx n et n' b)
  note IH = \<open>\<And>l l'. \<lbrakk>n = (_ l _); n' = (_ l' _); transfer et s = s'; pred et s\<rbrakk>
    \<Longrightarrow> \<exists>c c'. cx \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels cx l c \<and> labels cx l' c'\<close>
  from \<open>n \<oplus> 2 = (_ l _)\<close> obtain lx where "n = (_ lx _)" and [simp]:"l = lx + 2"
    by(cases n) auto
  from \<open>n' \<oplus> 2 = (_ l' _)\<close> obtain lx' where "n' = (_ lx' _)"
    and [simp]:"l' = lx' + 2" by(cases n') auto
  from IH[OF \<open>n = (_ lx _)\<close> \<open>n' = (_ lx' _)\<close> \<open>transfer et s = s'\<close> \<open>pred et s\<close>]
  obtain c c' where "cx \<turnstile> \<langle>c,s,lx\<rangle> \<leadsto> \<langle>c',s',lx'\<rangle>"
    and "labels cx lx c" and "labels cx lx' c'" by blast
  hence "while (b) cx \<turnstile> \<langle>c;;while (b) cx,s,l\<rangle> \<leadsto> \<langle>c';;while (b) cx,s',l'\<rangle>"
    by(fastforce intro:StepRecWhile)
  moreover
  from \<open>labels cx lx c\<close> have "labels (while (b) cx) l (c;;while (b) cx)"
    by(fastforce intro:Labels_WhileBody)
  moreover
  from \<open>labels cx lx' c'\<close> have "labels (while (b) cx) l' (c';;while (b) cx)"
    by(fastforce intro:Labels_WhileBody)
  ultimately show ?case by blast
next
  case (WCFG_WhileBodyExit cx n et b)
  from \<open>n \<oplus> 2 = (_ l _)\<close> obtain lx where [simp]:"n = (_ lx _)" and [simp]:"l = lx + 2"
    by(cases n) auto
  from \<open>cx \<turnstile> n -et\<rightarrow> (_Exit_)\<close> have "labels cx lx Skip" and [simp]:"et = \<Up>id"
    by(auto dest:WCFG_edge_Exit_Skip)
  from \<open>transfer et s = s'\<close> have [simp]:"s' = s" by simp
  from \<open>labels cx lx Skip\<close> have "labels (while (b) cx) l (Skip;;while (b) cx)"
    by(fastforce intro:Labels_WhileBody)
  hence "while (b) cx \<turnstile> \<langle>Skip;;while (b) cx,s,l\<rangle> \<leadsto> \<langle>while (b) cx,s,0\<rangle>"
    by(rule StepSeqWhile)
  moreover
  have "labels (while (b) cx) 0 (while (b) cx)"
    by(fastforce intro:Labels_Base)
  ultimately show ?case
    using \<open>labels (while (b) cx) l (Skip;;while (b) cx)\<close> by simp blast
qed

end