(*
 * 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 Mult_Hoare
  imports VHDL_Hoare_Complete Bits_Int_Aux
begin

datatype sig = A | B | C

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

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bassign_trans C (Bmult (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 (len1 + len2)
                   \<or> \<Gamma> A = Lty Sig len1 \<and> \<Gamma> B = Lty Sig len2 \<and> \<Gamma> C = Lty Sig (len1 + len2)"
proof (rule seq_wt_cases(4)[OF assms])
  assume "bexp_wt \<Gamma> (Bmult (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 (len1 + len2)
                              \<or> \<Gamma> A = Lty Sig len1 \<and> \<Gamma> B = Lty Sig len2 \<and> \<Gamma> C = Lty Sig (len1 + len2)"
    and "0 < len1" and "0 < len2"
    apply (rule bexp_wt_cases_slice(5)[OF \<open>bexp_wt \<Gamma> (Bmult (Bsig A) (Bsig B)) (\<Gamma> C)\<close>])
    by (metis bexp_wt_cases_slice(2))+
  thus ?thesis
    by auto
qed

locale unsigned_multiplication =
  fixes \<Gamma> :: "sig tyenv"
  fixes len len1 len2 :: nat
  assumes len_def: "len = 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 (Bmult (Bsig A) (Bsig B)) 1)"
  apply (rule seq_wt.intros(4))
  unfolding ctype len_def apply (rule bexp_wt.intros(17))
      apply (rule bexp_wt.intros(3))
      apply (rule atype[THEN sym])
      apply (rule bexp_wt.intros(3))
      apply (rule btype[THEN sym])
  using len1 len2 by auto

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 (Bmult (Bsig A) (Bsig B)) v" and "type_of v = Lty Uns len"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "inv (next_time_world tw', snd tw')"
  unfolding inv_def
proof (rule, rule)
  fix i
  assume "i < fst (next_world tw')"
  hence "i < next_time_world tw'"
    by auto
  have "fst tw' < next_time_world tw'"
    using next_time_world_at_least  using nat_less_le by blast
  moreover have "fst tw = fst tw'"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  ultimately have "fst tw < next_time_world tw'"
    by auto
  hence "i < fst tw \<or> fst tw \<le> i \<and> i < next_time_world tw' - 1 \<or> i = next_time_world tw' - 1"
    using \<open>i < next_time_world tw'\<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 (next_time_world tw', snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < next_time_world tw' - 1"
    hence "fst tw \<le> i" and "i < next_time_world tw' - 1"
      by auto
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (fst tw + 1)"
      using unchanged_until_next_time_world
      by (metis (mono_tags, lifting) Suc_eq_plus1 \<open>get_time tw = get_time tw'\<close> le_Suc_eq le_add1
          le_less_trans less_diff_conv)
    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 \<open>get_time tw = get_time tw'\<close> \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw'\<close>
      less_add_one tw'_def worldline_upd2_before_dly)+
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Bmult (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 (next_world tw')"
      unfolding property_def by auto }
  moreover
  { assume "i = next_time_world tw' - 1"
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (next_time_world tw')"
      using \<open>i < next_time_world tw'\<close> by force
    also have "... = lof_wline tw' C (fst tw + 1)"
      using \<open>fst tw < next_time_world tw'\<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) (Bmult (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 (metis \<open>get_time tw < next_time_world tw'\<close> \<open>get_time tw = get_time tw'\<close> \<open>i <
      next_time_world tw'\<close> \<open>i = next_time_world tw' - 1\<close> add_le_imp_le_diff discrete)+
    ultimately have "property (i + 1) i (next_world tw')"
      unfolding property_def by auto }
  ultimately show "property (i + 1) i (next_world tw')"
    by auto
qed

lemma type_correctness_length:
  assumes "wityping \<Gamma> (snd tw)"
  assumes "beval_world_raw2 tw (Bmult (Bsig A) (Bsig B)) v"
  shows   "type_of v = Lty Uns len"
proof -
  have "beval_world_raw (snd tw) (fst tw) (Bmult (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) (Bmult (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 seq_hoare_next_time:
  "\<turnstile> [\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Bmult (Bsig A) (Bsig B)) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_world 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 seq_hoare_next_time0:
  "\<turnstile> [\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Bmult (Bsig A) (Bsig B)) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_world tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2, simp)
  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 conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> inv (next_world tw)"
proof -
  fix 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 < next_time_world tw"
    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 (next_world 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 (metis \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw\<close> unchanged_until_next_time_world)
      hence "property (i + 1) i (next_world tw)"
        unfolding property_def by auto }
    ultimately have "property (i + 1) i (next_world tw)"
      by auto }
  thus "inv (next_world tw)"
    unfolding inv_def by auto
qed

lemma 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>get_time 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 (Bmult (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, rule, rule, rule)
  fix i j :: nat
  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
  hence "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> fst_conv greaterThanAtMost_iff 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 (no_types, 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>
      gr_implies_not_zero 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) (Bmult (Bsig A) (Bsig B)) v"
    using assms(1) unfolding beval_world_raw2_def by auto
  have "wline_of (j, snd 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 aux:
  "\<And>tw. inv (next_time_world tw, snd tw) \<Longrightarrow> \<forall>i\<in>{get_time tw<..next_time_world tw}. inv (i, snd tw)"
  unfolding inv_def  by (simp add: property_def)

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

lemma conc_hoare3:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>
        mult
     \<lbrace>\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> inv2 (i, snd tw)\<rbrace>"
  unfolding mult_def
  apply (rule Single)
   apply (rule Conj_univ_qtfd)
    apply (rule strengthen_precondition)
    apply (rule Conseq2[rotated])
      apply(rule seq_hoare_next_time)
     apply (simp add: aux)
    apply simp
   apply (rule Conseq2[rotated])
     apply (rule seq_hoare_next_time1)
    apply simp
   apply simp
  using conc_hoare conc_hoare2 aux  by blast

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

lemma conc_hoare4:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>
        mult
     \<lbrace>\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. (inv (j, snd tw) \<and> inv2 (j, snd tw)) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  apply (rule Conj2_univ_qtfd[where R="\<lambda>tw. wityping \<Gamma> (snd tw)", unfolded snd_conv])
   apply (rule weaken_post_conc_hoare[OF _ conc_hoare3], blast)
  apply (rule strengthen_pre_conc_hoare[rotated])
   apply (rule weaken_post_conc_hoare[rotated])
    apply (unfold mult_def, rule single_conc_stmt_preserve_wityping_hoare)
    apply (rule seq_wt)
  by auto

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

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

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

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

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

lemma correctness:
  assumes "sim_fin w (i + 1) mult tw'" and "wityping \<Gamma> w"
  shows   "property (i + 1) i tw'"
proof -
  obtain tw where "init_sim (0, w) mult tw" and  "tw, i + 1, mult \<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 mult"
    unfolding conc_stmt_wf_def mult_def by auto
  moreover have "nonneg_delay_conc mult"
    unfolding mult_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) mult (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_inv_comb
    init_sim_hoare_soundness mult_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) mult 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> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> mult \<lbrace>inv\<rbrace>"
    using conc_sim_soundness[OF conc_sim2] \<open>conc_stmt_wf mult\<close> \<open>nonneg_delay_conc mult\<close>
    by auto
  ultimately have "inv tw'"
    using \<open>tw, i + 1, mult \<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 correctness2:
  assumes "sim_fin w (i + 1) mult 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 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_mult =
  fixes \<Gamma> :: "sig tyenv"
  fixes len len1 len2 :: nat
  assumes len_def: "len = 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 (Bmult (Bsig A) (Bsig B)) 1)"
  by (rule seq_wt.intros(4))
     (metis atype bexp_wt.intros(18) bexp_wt.intros(3) btype ctype len_def len1 len2)

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 (Bmult (Bsig A) (Bsig B)) v" and "type_of v = Lty Sig len"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "inv (next_time_world tw', snd tw')"
  unfolding inv_def
proof (rule, rule)
  fix i
  assume "i < fst (next_world tw')"
  hence "i < next_time_world tw'"
    by auto
  have "fst tw' < next_time_world tw'"
    using next_time_world_at_least  using nat_less_le by blast
  moreover have "fst tw = fst tw'"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  ultimately have "fst tw < next_time_world tw'"
    by auto
  hence "i < fst tw \<or> fst tw \<le> i \<and> i < next_time_world tw' - 1 \<or> i = next_time_world tw' - 1"
    using \<open>i < next_time_world tw'\<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 (next_time_world tw', snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < next_time_world tw' - 1"
    hence "fst tw \<le> i" and "i < next_time_world tw' - 1"
      by auto
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (fst tw + 1)"
      using unchanged_until_next_time_world
      by (metis (mono_tags, lifting) Suc_eq_plus1 \<open>get_time tw = get_time tw'\<close> le_Suc_eq le_add1
          le_less_trans less_diff_conv)
    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 \<open>get_time tw = get_time tw'\<close> \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw'\<close>
      less_add_one tw'_def worldline_upd2_before_dly)+
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Bmult (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 (next_world tw')"
      unfolding property_def by auto }
  moreover
  { assume "i = next_time_world tw' - 1"
    hence "lof_wline tw' C (i + 1) = lof_wline tw' C (next_time_world tw')"
      using \<open>i < next_time_world tw'\<close> by force
    also have "... = lof_wline tw' C (fst tw + 1)"
      using \<open>fst tw < next_time_world tw'\<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) (Bmult (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 \<open>get_time tw < next_time_world tw'\<close> \<open>get_time tw = get_time tw'\<close> \<open>i <
      next_time_world tw'\<close> \<open>i = next_time_world tw' - 1\<close> add_le_imp_le_diff discrete)+
    ultimately have "property (i + 1) i (next_world tw')"
      unfolding property_def by auto }
  ultimately show "property (i + 1) i (next_world tw')"
    by auto
qed

lemma type_correctness_length:
  assumes "wityping \<Gamma> (snd tw)"
  assumes "beval_world_raw2 tw (Bmult (Bsig A) (Bsig B)) v"
  shows   "type_of v = Lty Sig len"
proof -
  have "beval_world_raw (snd tw) (fst tw) (Bmult (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) (Bmult (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 seq_hoare_next_time:
  "\<turnstile> [\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Bmult (Bsig A) (Bsig B)) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_world 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 seq_hoare_next_time0:
  "\<turnstile> [\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans C (Bmult (Bsig A) (Bsig B)) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_world tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2, simp)
  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 conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> inv (next_world tw)"
proof -
  fix 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 < next_time_world tw"
    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 (next_world 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 (metis \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw\<close> unchanged_until_next_time_world)
      hence "property (i + 1) i (next_world tw)"
        unfolding property_def by auto }
    ultimately have "property (i + 1) i (next_world tw)"
      by auto }
  thus "inv (next_world tw)"
    unfolding inv_def by auto
qed

lemma 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>get_time 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 (Bmult (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, rule, rule, rule)
  fix i j :: nat
  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
  hence "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> fst_conv greaterThanAtMost_iff 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 (no_types, 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>
      gr_implies_not_zero 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) (Bmult (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 aux:
  "\<And>tw. inv (next_time_world tw, snd tw) \<Longrightarrow> \<forall>i\<in>{get_time tw<..next_time_world tw}. inv (i, snd tw)"
  unfolding inv_def  by (simp add: property_def)

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

lemma conc_hoare3:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>
        mult
     \<lbrace>\<lambda>tw. \<forall>i \<in> {fst tw <.. next_time_world tw}. inv (i, snd tw) \<and> inv2 (i, snd tw)\<rbrace>"
  unfolding mult_def
  apply (rule Single)
   apply (rule Conj_univ_qtfd)
    apply (rule strengthen_precondition)
    apply (rule Conseq2[rotated])
      apply(rule seq_hoare_next_time)
     apply (simp add: aux)
    apply simp
   apply (rule Conseq2[rotated])
     apply (rule seq_hoare_next_time1)
    apply simp
   apply simp
  using conc_hoare conc_hoare2 aux  by blast

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

lemma conc_hoare4:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>
        mult
     \<lbrace>\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. (inv (j, snd tw) \<and> inv2 (j, snd tw)) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  apply (rule Conj2_univ_qtfd[where R="\<lambda>tw. wityping \<Gamma> (snd tw)", unfolded snd_conv])
   apply (rule weaken_post_conc_hoare[OF _ conc_hoare3], blast)
  apply (rule strengthen_pre_conc_hoare[rotated])
   apply (rule weaken_post_conc_hoare[rotated])
    apply (unfold mult_def, rule single_conc_stmt_preserve_wityping_hoare)
    apply (rule seq_wt)
  by auto

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

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

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

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

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

lemma correctness:
  assumes "sim_fin w (i + 1) mult tw'" and "wityping \<Gamma> w"
  shows   "property (i + 1) i tw'"
proof -
  obtain tw where "init_sim (0, w) mult tw" and  "tw, i + 1, mult \<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 mult"
    unfolding conc_stmt_wf_def mult_def by auto
  moreover have "nonneg_delay_conc mult"
    unfolding mult_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) mult (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_inv_comb
    init_sim_hoare_soundness mult_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) mult 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> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> mult \<lbrace>inv\<rbrace>"
    using conc_sim_soundness[OF conc_sim2] \<open>conc_stmt_wf mult\<close> \<open>nonneg_delay_conc mult\<close>
    by auto
  ultimately have "inv tw'"
    using \<open>tw, i + 1, mult \<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 correctness2:
  assumes "sim_fin w (i + 1) mult tw'" and "wityping \<Gamma> w"
  shows   "wityping \<Gamma> (snd tw')"
proof -
  obtain tw where "init_sim (0, w) mult tw" and  "tw, i + 1, mult \<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 mult"
    unfolding conc_stmt_wf_def mult_def by auto
  moreover have "nonneg_delay_conc mult"
    unfolding mult_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) mult (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_inv_comb
    init_sim_hoare_soundness mult_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) mult 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. (local.inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> mult \<lbrace>\<lambda>tw. (local.inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
    using conc_sim_soundness[OF conc_sim'] \<open>conc_stmt_wf mult\<close> \<open>nonneg_delay_conc mult\<close>
    by (metis (no_types, lifting) sim_hoare_valid_def)
  ultimately show "wityping \<Gamma> (snd tw')"
    using \<open>tw, i + 1, mult \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
qed

corollary correctness3:
  assumes "sim_fin w (i + 1) mult 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 correctness[OF assms(1-2)] 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
  thus "sbl_to_bin bsC mod 2 ^ len = (sbl_to_bin bsA * sbl_to_bin bsB) mod 2 ^ len"
    using sbin_bl_bin' \<open>0 < len\<close> 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 correctness4:
  assumes "sim_fin w (i + 1) mult 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"
  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)"
  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)"
  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 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


theory Env_list
  imports Env "HOL-Library.Library"
begin

subsection \<open>Generic lemmas\<close>

lemma map_of_filter:
  "x \<noteq> y \<Longrightarrow> map_of (filter (\<lambda>z. fst z \<noteq> y) zs) x = map_of zs x"
  by (induction zs) auto

subsection \<open>List-based implementation of environment\<close>

context
begin

qualified type_synonym ('key, 'val) t = "('key \<times> 'val) list"

qualified definition empty :: "('key, 'val) t" where
  "empty \<equiv> []"

qualified definition get :: "('key, 'val) t \<Rightarrow> 'key \<Rightarrow> 'val option" where
  "get \<equiv> map_of"

qualified definition add :: "('key, 'val) t \<Rightarrow> 'key \<Rightarrow> 'val \<Rightarrow> ('key, 'val) t" where
  "add e k v \<equiv> AList.update k v e"

term filter

qualified fun to_list :: "('key, 'val) t \<Rightarrow> ('key \<times> 'val) list" where
  "to_list [] = []" |
  "to_list (x # xs) = x # to_list (filter (\<lambda>(k, v). k \<noteq> fst x) xs)"

lemma get_empty: "get empty x = None"
  unfolding get_def empty_def
  by simp

lemma get_add_eq: "get (add e x v) x = Some v"
  unfolding get_def add_def
  by (simp add: update_Some_unfold)

lemma get_add_neq: "x \<noteq> y \<Longrightarrow> get (add e x v) y = get e y"
  unfolding get_def add_def
  by (simp add: update_conv')

lemma to_list_correct: "map_of (to_list e) = get e"
  unfolding get_def
proof (induction e rule: to_list.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs)
  show ?case
  proof (rule ext)
    fix k'
    show "map_of (to_list (x # xs)) k' = map_of (x # xs) k'"
      using "2.IH" map_of_filter
      by (auto simp add: case_prod_beta')
  qed
qed

lemma set_to_list: "set (to_list e) \<subseteq> set e"
  by (induction e rule: to_list.induct) auto

lemma to_list_distinct: "distinct (map fst (to_list e))"
proof (induction e rule: to_list.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs)
  then show ?case
    using set_to_list
    by fastforce
qed

end

global_interpretation env_list:
  env Env_list.empty Env_list.get Env_list.add Env_list.to_list
  defines
    singleton = env_list.singleton and
    add_list = env_list.add_list and
    from_list = env_list.from_list
  apply (unfold_locales)
  by (simp_all add: get_empty get_add_eq get_add_neq to_list_correct to_list_distinct)

export_code Env_list.empty Env_list.get Env_list.add Env_list.to_list singleton add_list from_list
  in SML module_name Env

end


subsection \<open> Liberation \<close>

theory Liberation
  imports Extension
begin

definition liberate :: "('s \<Rightarrow> bool) \<Rightarrow> 's scene \<Rightarrow> ('s \<Rightarrow> bool)" where
[expr_defs]: "liberate P x = (\<lambda> s. \<exists> s'. P (s \<oplus>\<^sub>S s' on x))"

syntax
  "_liberate" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\\" 80)

translations
  "_liberate P x" == "CONST liberate P x"
  "_liberate P x" <= "_liberate (P)\<^sub>e x"

expr_constructor liberate (0)

lemma liberate_lens [expr_simps]:
  "mwb_lens x \<Longrightarrow> P \\ $x = (\<lambda>s. \<exists>s'. P (s \<triangleleft>\<^bsub>x\<^esub> s'))"
  by (simp add: liberate_def)

lemma liberate_lens': "mwb_lens x \<Longrightarrow> P \\ $x = (\<lambda>s. \<exists>v. P (put\<^bsub>x\<^esub> s v))"
  by (auto simp add: liberate_def lens_defs fun_eq_iff)
     (metis mwb_lens_weak weak_lens.put_get)

lemma liberate_as_subst: "vwb_lens x \<Longrightarrow> e \\ $x = (\<exists> v. e\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)\<^sub>e"
  by (expr_simp, metis vwb_lens.put_eq)

lemma unrest_liberate: "a \<sharp> P \\ a"
  by (expr_simp)

lemma unrest_liberate_iff: "(a \<sharp> P) \<longleftrightarrow> (P \\ a = P)"
  by (expr_simp, metis (full_types) scene_override_overshadow_left)

lemma liberate_none [simp]: "P \\ \<emptyset> = P"
  by (expr_simp)

lemma liberate_idem [simp]: "P \\ a \\ a = P \\ a"
  by (expr_simp)

lemma liberate_commute [simp]: "a \<bowtie>\<^sub>S b \<Longrightarrow> P \\ a \\ b = P \\ b \\ a"
  using scene_override_commute_indep by (expr_auto, fastforce+)

lemma liberate_true [simp]: "(True)\<^sub>e \\ a = (True)\<^sub>e"
  by (expr_simp)

lemma liberate_false [simp]: "(False)\<^sub>e \\ a = (False)\<^sub>e"
  by (expr_simp)

lemma liberate_disj [simp]: "(P \<or> Q)\<^sub>e \\ a = (P \\ a \<or> Q \\ a)\<^sub>e"
  by (expr_auto)

end


section \<open>Miscellaneous facts\<close>

text \<open>This theory proves various facts that are not directly related to this developments
but do not occur in the imported theories.\<close>

theory Misc
  imports
    Complex_Bounded_Operators.Cblinfun_Code
    "HOL-Library.Z2"
    Jordan_Normal_Form.Matrix
begin

\<comment> \<open>Remove notation that collides with the notation we use\<close>
no_notation Order.top ("\<top>\<index>")
no_notation m_inv ("inv\<index> _" [81] 80)
unbundle no_vec_syntax
unbundle no_inner_syntax

\<comment> \<open>Import notation from Bounded Operator and Jordan Normal Form libraries\<close>
unbundle cblinfun_notation
unbundle jnf_notation

abbreviation "butterket i j \<equiv> butterfly (ket i) (ket j)"
abbreviation "selfbutterket i \<equiv> butterfly (ket i) (ket i)"

text \<open>The following declares the ML antiquotation \<^verbatim>\<open>fact\<close>. In ML code,
  \<^verbatim>\<open>@{fact f}\<close> for a theorem/fact name f is replaced by an ML string
  containing a printable(!) representation of fact. (I.e.,
  if you print that string using writeln, the user can ctrl-click on it.)

  This is useful when constructing diagnostic messages in ML code, e.g.,
  \<^verbatim>\<open>"Use the theorem " ^ @{fact thmname} ^ "here."\<close>\<close>

setup \<open>ML_Antiquotation.inline_embedded \<^binding>\<open>fact\<close>
((Args.context -- Scan.lift Args.name_position) >> (fn (ctxt,namepos) => let
  val facts = Proof_Context.facts_of ctxt
  val fullname = Facts.check (Context.Proof ctxt) facts namepos
  val (markup, shortname) = Proof_Context.markup_extern_fact ctxt fullname
  val string = Markup.markups markup shortname
  in ML_Syntax.print_string string end
))
\<close>

instantiation bit :: enum begin
definition "enum_bit = [0::bit,1]"
definition "enum_all_bit P \<longleftrightarrow> P (0::bit) \<and> P 1"
definition "enum_ex_bit P \<longleftrightarrow> P (0::bit) \<or> P 1"
instance
  apply intro_classes
     apply (auto simp: enum_bit_def enum_all_bit_def enum_ex_bit_def)
   apply (metis bit_not_one_iff)
  by (metis bit_not_zero_iff)
end

lemma card_bit[simp]: "CARD(bit) = 2"
  using card_2_iff' by force

instantiation bit :: card_UNIV begin
definition "finite_UNIV = Phantom(bit) True"
definition "card_UNIV = Phantom(bit) 2"
instance
  apply intro_classes
  by (simp_all add: finite_UNIV_bit_def card_UNIV_bit_def)
end

lemma mat_of_rows_list_carrier[simp]:
  "mat_of_rows_list n vs \<in> carrier_mat (length vs) n"
  "dim_row (mat_of_rows_list n vs) = length vs"
  "dim_col (mat_of_rows_list n vs) = n"
  unfolding mat_of_rows_list_def by auto

lemma apply_id_cblinfun[simp]: \<open>(*\<^sub>V) id_cblinfun = id\<close>
  by auto

text \<open>Overriding \\<^theory>\<open>Complex_Bounded_Operators.Complex_Bounded_Linear_Function\<close>.\<^term>\<open>sandwich\<close>.
      The latter is the same function but defined as a \<^typ>\<open>(_,_) cblinfun\<close> which is less convenient for us.\<close>
definition sandwich where \<open>sandwich a b = a o\<^sub>C\<^sub>L b o\<^sub>C\<^sub>L a*\<close>

lemma clinear_sandwich[simp]: \<open>clinear (sandwich a)\<close>
  apply (rule clinearI)
   apply (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right sandwich_def)
  by (simp add: sandwich_def)

lemma sandwich_id[simp]: \<open>sandwich id_cblinfun = id\<close>
  by (auto simp: sandwich_def)

lemma mat_of_cblinfun_sandwich:
  fixes a :: "(_::onb_enum, _::onb_enum) cblinfun"
  shows \<open>mat_of_cblinfun (sandwich a b) = (let a' = mat_of_cblinfun a in a' * mat_of_cblinfun b * mat_adjoint a')\<close>
  by (simp add: mat_of_cblinfun_compose sandwich_def Let_def mat_of_cblinfun_adj)

lemma prod_cases3' [cases type]:
  obtains (fields) a b c where "y = ((a, b), c)"
  by (cases y, case_tac a) blast

lemma lift_cblinfun_comp:
  assumes \<open>a o\<^sub>C\<^sub>L b = c\<close>
  shows \<open>a o\<^sub>C\<^sub>L b = c\<close>
    and \<open>a o\<^sub>C\<^sub>L (b o\<^sub>C\<^sub>L d) = c o\<^sub>C\<^sub>L d\<close>
    and \<open>a *\<^sub>S (b *\<^sub>S S) = c *\<^sub>S S\<close>
    and \<open>a *\<^sub>V (b *\<^sub>V x) = c *\<^sub>V x\<close>
     apply (fact assms)
    apply (simp add: assms cblinfun_assoc_left(1))
  using assms cblinfun_assoc_left(2) apply force
  using assms by force

text \<open>We define the following abbreviations:
\<^item> \<open>mutually f (x\<^sub>1,x\<^sub>2,\<dots>,x\<^sub>n)\<close> expands to the conjuction of all \<^term>\<open>f x\<^sub>i x\<^sub>j\<close> with \<^term>\<open>i\<noteq>j\<close>.
\<^item> \<open>each f (x\<^sub>1,x\<^sub>2,\<dots>,x\<^sub>n)\<close> expands to the conjuction of all \<^term>\<open>f x\<^sub>i\<close>.\<close>

syntax "_mutually" :: "'a \<Rightarrow> args \<Rightarrow> 'b" ("mutually _ '(_')")
syntax "_mutually2" :: "'a \<Rightarrow> 'b \<Rightarrow> args \<Rightarrow> args \<Rightarrow> 'c"

translations "mutually f (x)" => "CONST True"
translations "mutually f (_args x y)" => "f x y \<and> f y x"
translations "mutually f (_args x (_args x' xs))" => "_mutually2 f x (_args x' xs) (_args x' xs)"
translations "_mutually2 f x y zs" => "f x y \<and> f y x \<and> _mutually f zs"
translations "_mutually2 f x (_args y ys) zs" => "f x y \<and> f y x \<and> _mutually2 f x ys zs"

syntax "_each" :: "'a \<Rightarrow> args \<Rightarrow> 'b" ("each _ '(_')")
translations "each f (x)" => "f x"
translations "_each f (_args x xs)" => "f x \<and> _each f xs"

lemma enum_inj:
  assumes "i < CARD('a)" and "j < CARD('a)"
  shows "(Enum.enum ! i :: 'a::enum) = Enum.enum ! j \<longleftrightarrow> i = j"
  using inj_on_nth[OF enum_distinct, where I=\<open>{..<CARD('a)}\<close>]
  using assms by (auto dest: inj_onD simp flip: card_UNIV_length_enum)

lemma invI:
  assumes \<open>inj f\<close>
  assumes \<open>x = f y\<close>
  shows \<open>inv f x = y\<close>
  by (simp add: assms(1) assms(2))

instantiation prod :: (default,default) default begin
definition \<open>default_prod = (default, default)\<close>
instance..
end

instance bit :: default..

lemma surj_from_comp:
  assumes \<open>surj (g o f)\<close>
  assumes \<open>inj g\<close>
  shows \<open>surj f\<close>
  by (metis assms(1) assms(2) f_inv_into_f fun.set_map inj_image_mem_iff iso_tuple_UNIV_I surj_iff_all)

lemma double_exists: \<open>(\<exists>x y. Q x y) \<longleftrightarrow> (\<exists>z. Q (fst z) (snd z))\<close>
  by simp

end


(*<*)
theory simp imports Main begin
(*>*)

subsection\<open>Simplification Rules\<close>

text\<open>\index{simplification rules}
To facilitate simplification,
the attribute \<open>[simp]\<close>\index{*simp (attribute)}
declares theorems to be simplification rules, which the simplifier
will use automatically.  In addition, \isacommand{datatype} and
\isacommand{primrec} declarations (and a few others)
implicitly declare some simplification rules.
Explicit definitions are \emph{not} declared as
simplification rules automatically!

Nearly any theorem can become a simplification
rule. The simplifier will try to transform it into an equation.
For example, the theorem
\<^prop>\<open>~P\<close> is turned into \<^prop>\<open>P = False\<close>. The details
are explained in \S\ref{sec:SimpHow}.

The simplification attribute of theorems can be turned on and off:%
\index{*simp del (attribute)}
\begin{quote}
\isacommand{declare} \textit{theorem-name}\<open>[simp]\<close>\\
\isacommand{declare} \textit{theorem-name}\<open>[simp del]\<close>
\end{quote}
Only equations that really simplify, like \isa{rev\
{\isacharparenleft}rev\ xs{\isacharparenright}\ {\isacharequal}\ xs} and
\isa{xs\ {\isacharat}\ {\isacharbrackleft}{\isacharbrackright}\
{\isacharequal}\ xs}, should be declared as default simplification rules.
More specific ones should only be used selectively and should
not be made default.  Distributivity laws, for example, alter
the structure of terms and can produce an exponential blow-up instead of
simplification.  A default simplification rule may
need to be disabled in certain proofs.  Frequent changes in the simplification
status of a theorem may indicate an unwise use of defaults.
\begin{warn}
  Simplification can run forever, for example if both $f(x) = g(x)$ and
  $g(x) = f(x)$ are simplification rules. It is the user's responsibility not
  to include simplification rules that can lead to nontermination, either on
  their own or in combination with other simplification rules.
\end{warn}
\begin{warn}
  It is inadvisable to toggle the simplification attribute of a
  theorem from a parent theory $A$ in a child theory $B$ for good.
  The reason is that if some theory $C$ is based both on $B$ and (via a
  different path) on $A$, it is not defined what the simplification attribute
  of that theorem will be in $C$: it could be either.
\end{warn}
\<close>

subsection\<open>The {\tt\slshape simp}  Method\<close>

text\<open>\index{*simp (method)|bold}
The general format of the simplification method is
\begin{quote}
\<open>simp\<close> \textit{list of modifiers}
\end{quote}
where the list of \emph{modifiers} fine tunes the behaviour and may
be empty. Specific modifiers are discussed below.  Most if not all of the
proofs seen so far could have been performed
with \<open>simp\<close> instead of \isa{auto}, except that \<open>simp\<close> attacks
only the first subgoal and may thus need to be repeated --- use
\methdx{simp_all} to simplify all subgoals.
If nothing changes, \<open>simp\<close> fails.
\<close>

subsection\<open>Adding and Deleting Simplification Rules\<close>

text\<open>
\index{simplification rules!adding and deleting}%
If a certain theorem is merely needed in a few proofs by simplification,
we do not need to make it a global simplification rule. Instead we can modify
the set of simplification rules used in a simplification step by adding rules
to it and/or deleting rules from it. The two modifiers for this are
\begin{quote}
\<open>add:\<close> \textit{list of theorem names}\index{*add (modifier)}\\
\<open>del:\<close> \textit{list of theorem names}\index{*del (modifier)}
\end{quote}
Or you can use a specific list of theorems and omit all others:
\begin{quote}
\<open>only:\<close> \textit{list of theorem names}\index{*only (modifier)}
\end{quote}
In this example, we invoke the simplifier, adding two distributive
laws:
\begin{quote}
\isacommand{apply}\<open>(simp add: mod_mult_distrib add_mult_distrib)\<close>
\end{quote}
\<close>

subsection\<open>Assumptions\<close>

text\<open>\index{simplification!with/of assumptions}
By default, assumptions are part of the simplification process: they are used
as simplification rules and are simplified themselves. For example:
\<close>

lemma "\<lbrakk> xs @ zs = ys @ xs; [] @ xs = [] @ [] \<rbrakk> \<Longrightarrow> ys = zs"
apply simp
done

text\<open>\noindent
The second assumption simplifies to \<^term>\<open>xs = []\<close>, which in turn
simplifies the first assumption to \<^term>\<open>zs = ys\<close>, thus reducing the
conclusion to \<^term>\<open>ys = ys\<close> and hence to \<^term>\<open>True\<close>.

In some cases, using the assumptions can lead to nontermination:
\<close>

lemma "\<forall>x. f x = g (f (g x)) \<Longrightarrow> f [] = f [] @ []"

txt\<open>\noindent
An unmodified application of \<open>simp\<close> loops.  The culprit is the
simplification rule \<^term>\<open>f x = g (f (g x))\<close>, which is extracted from
the assumption.  (Isabelle notices certain simple forms of
nontermination but not this one.)  The problem can be circumvented by
telling the simplifier to ignore the assumptions:
\<close>

apply(simp (no_asm))
done

text\<open>\noindent
Three modifiers influence the treatment of assumptions:
\begin{description}
\item[\<open>(no_asm)\<close>]\index{*no_asm (modifier)}
 means that assumptions are completely ignored.
\item[\<open>(no_asm_simp)\<close>]\index{*no_asm_simp (modifier)}
 means that the assumptions are not simplified but
  are used in the simplification of the conclusion.
\item[\<open>(no_asm_use)\<close>]\index{*no_asm_use (modifier)}
 means that the assumptions are simplified but are not
  used in the simplification of each other or the conclusion.
\end{description}
Only one of the modifiers is allowed, and it must precede all
other modifiers.
%\begin{warn}
%Assumptions are simplified in a left-to-right fashion. If an
%assumption can help in simplifying one to the left of it, this may get
%overlooked. In such cases you have to rotate the assumptions explicitly:
%\isacommand{apply}@ {text"("}\methdx{rotate_tac}~$n$@ {text")"}
%causes a cyclic shift by $n$ positions from right to left, if $n$ is
%positive, and from left to right, if $n$ is negative.
%Beware that such rotations make proofs quite brittle.
%\end{warn}
\<close>

subsection\<open>Rewriting with Definitions\<close>

text\<open>\label{sec:Simp-with-Defs}\index{simplification!with definitions}
Constant definitions (\S\ref{sec:ConstDefinitions}) can be used as
simplification rules, but by default they are not: the simplifier does not
expand them automatically.  Definitions are intended for introducing abstract
concepts and not merely as abbreviations.  Of course, we need to expand
the definition initially, but once we have proved enough abstract properties
of the new constant, we can forget its original definition.  This style makes
proofs more robust: if the definition has to be changed,
only the proofs of the abstract properties will be affected.

For example, given\<close>

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"xor A B \<equiv> (A \<and> \<not>B) \<or> (\<not>A \<and> B)"

text\<open>\noindent
we may want to prove
\<close>

lemma "xor A (\<not>A)"

txt\<open>\noindent
Typically, we begin by unfolding some definitions:
\indexbold{definitions!unfolding}
\<close>

apply(simp only: xor_def)

txt\<open>\noindent
In this particular case, the resulting goal
@{subgoals[display,indent=0]}
can be proved by simplification. Thus we could have proved the lemma outright by
\<close>(*<*)oops lemma "xor A (\<not>A)"(*>*)
apply(simp add: xor_def)
(*<*)done(*>*)
text\<open>\noindent
Of course we can also unfold definitions in the middle of a proof.

\begin{warn}
  If you have defined $f\,x\,y~\isasymequiv~t$ then you can only unfold
  occurrences of $f$ with at least two arguments. This may be helpful for unfolding
  $f$ selectively, but it may also get in the way. Defining
  $f$~\isasymequiv~\isasymlambda$x\,y.\;t$ allows to unfold all occurrences of $f$.
\end{warn}

There is also the special method \isa{unfold}\index{*unfold (method)|bold}
which merely unfolds
one or several definitions, as in \isacommand{apply}\isa{(unfold xor_def)}.
This is can be useful in situations where \isa{simp} does too much.
Warning: \isa{unfold} acts on all subgoals!
\<close>

subsection\<open>Simplifying {\tt\slshape let}-Expressions\<close>

text\<open>\index{simplification!of \isa{let}-expressions}\index{*let expressions}%
Proving a goal containing \isa{let}-expressions almost invariably requires the
\<open>let\<close>-con\-structs to be expanded at some point. Since
\<open>let\<close>\ldots\isa{=}\ldots\<open>in\<close>{\ldots} is just syntactic sugar for
the predefined constant \<^term>\<open>Let\<close>, expanding \<open>let\<close>-constructs
means rewriting with \tdx{Let_def}:\<close>

lemma "(let xs = [] in xs@ys@xs) = ys"
apply(simp add: Let_def)
done

text\<open>
If, in a particular context, there is no danger of a combinatorial explosion
of nested \<open>let\<close>s, you could even simplify with @{thm[source]Let_def} by
default:
\<close>
declare Let_def [simp]

subsection\<open>Conditional Simplification Rules\<close>

text\<open>
\index{conditional simplification rules}%
So far all examples of rewrite rules were equations. The simplifier also
accepts \emph{conditional} equations, for example
\<close>

lemma hd_Cons_tl[simp]: "xs \<noteq> []  \<Longrightarrow>  hd xs # tl xs = xs"
apply(case_tac xs, simp, simp)
done

text\<open>\noindent
Note the use of ``\ttindexboldpos{,}{$Isar}'' to string together a
sequence of methods. Assuming that the simplification rule
\<^term>\<open>(rev xs = []) = (xs = [])\<close>
is present as well,
the lemma below is proved by plain simplification:
\<close>

lemma "xs \<noteq> [] \<Longrightarrow> hd(rev xs) # tl(rev xs) = rev xs"
(*<*)
by(simp)
(*>*)
text\<open>\noindent
The conditional equation @{thm[source]hd_Cons_tl} above
can simplify \<^term>\<open>hd(rev xs) # tl(rev xs)\<close> to \<^term>\<open>rev xs\<close>
because the corresponding precondition \<^term>\<open>rev xs ~= []\<close>
simplifies to \<^term>\<open>xs ~= []\<close>, which is exactly the local
assumption of the subgoal.
\<close>

subsection\<open>Automatic Case Splits\<close>

text\<open>\label{sec:AutoCaseSplits}\indexbold{case splits}%
Goals containing \<open>if\<close>-expressions\index{*if expressions!splitting of}
are usually proved by case
distinction on the boolean condition.  Here is an example:
\<close>

lemma "\<forall>xs. if xs = [] then rev xs = [] else rev xs \<noteq> []"

txt\<open>\noindent
The goal can be split by a special method, \methdx{split}:
\<close>

apply(split if_split)

txt\<open>\noindent
@{subgoals[display,indent=0]}
where \tdx{if_split} is a theorem that expresses splitting of
\<open>if\<close>s. Because
splitting the \<open>if\<close>s is usually the right proof strategy, the
simplifier does it automatically.  Try \isacommand{apply}\<open>(simp)\<close>
on the initial goal above.

This splitting idea generalizes from \<open>if\<close> to \sdx{case}.
Let us simplify a case analysis over lists:\index{*list.split (theorem)}
\<close>(*<*)by simp(*>*)
lemma "(case xs of [] \<Rightarrow> zs | y#ys \<Rightarrow> y#(ys@zs)) = xs@zs"
apply(split list.split)

txt\<open>
@{subgoals[display,indent=0]}
The simplifier does not split
\<open>case\<close>-expressions, as it does \<open>if\<close>-expressions,
because with recursive datatypes it could lead to nontermination.
Instead, the simplifier has a modifier
\<open>split\<close>\index{*split (modifier)}
for adding splitting rules explicitly.  The
lemma above can be proved in one step by
\<close>
(*<*)oops
lemma "(case xs of [] \<Rightarrow> zs | y#ys \<Rightarrow> y#(ys@zs)) = xs@zs"
(*>*)
apply(simp split: list.split)
(*<*)done(*>*)
text\<open>\noindent
whereas \isacommand{apply}\<open>(simp)\<close> alone will not succeed.

Every datatype $t$ comes with a theorem
$t$\<open>.split\<close> which can be declared to be a \bfindex{split rule} either
locally as above, or by giving it the \attrdx{split} attribute globally:
\<close>

declare list.split [split]

text\<open>\noindent
The \<open>split\<close> attribute can be removed with the \<open>del\<close> modifier,
either locally
\<close>
(*<*)
lemma "dummy=dummy"
(*>*)
apply(simp split del: if_split)
(*<*)
oops
(*>*)
text\<open>\noindent
or globally:
\<close>
declare list.split [split del]

text\<open>
Polished proofs typically perform splitting within \<open>simp\<close> rather than
invoking the \<open>split\<close> method.  However, if a goal contains
several \<open>if\<close> and \<open>case\<close> expressions,
the \<open>split\<close> method can be
helpful in selectively exploring the effects of splitting.

The split rules shown above are intended to affect only the subgoal's
conclusion.  If you want to split an \<open>if\<close> or \<open>case\<close>-expression
in the assumptions, you have to apply \tdx{if_split_asm} or
$t$\<open>.split_asm\<close>:\<close>

lemma "if xs = [] then ys \<noteq> [] else ys = [] \<Longrightarrow> xs @ ys \<noteq> []"
apply(split if_split_asm)

txt\<open>\noindent
Unlike splitting the conclusion, this step creates two
separate subgoals, which here can be solved by \<open>simp_all\<close>:
@{subgoals[display,indent=0]}
If you need to split both in the assumptions and the conclusion,
use $t$\<open>.splits\<close> which subsumes $t$\<open>.split\<close> and
$t$\<open>.split_asm\<close>. Analogously, there is @{thm[source]if_splits}.

\begin{warn}
  The simplifier merely simplifies the condition of an
  \isa{if}\index{*if expressions!simplification of} but not the
  \isa{then} or \isa{else} parts. The latter are simplified only after the
  condition reduces to \isa{True} or \isa{False}, or after splitting. The
  same is true for \sdx{case}-expressions: only the selector is
  simplified at first, until either the expression reduces to one of the
  cases or it is split.
\end{warn}
\<close>
(*<*)
by(simp_all)
(*>*)

subsection\<open>Tracing\<close>
text\<open>\indexbold{tracing the simplifier}
Using the simplifier effectively may take a bit of experimentation.  Set the
Proof General flag \pgmenu{Isabelle} $>$ \pgmenu{Settings} $>$ \pgmenu{Trace Simplifier} to get a better idea of what is going on:
\<close>

lemma "rev [a] = []"
apply(simp)
(*<*)oops(*>*)

text\<open>\noindent
produces the following trace in Proof General's \pgmenu{Trace} buffer:

\begin{ttbox}\makeatother
[1]Applying instance of rewrite rule "List.rev.simps_2":
rev (?x1 # ?xs1) \(\equiv\) rev ?xs1 @ [?x1]

[1]Rewriting:
rev [a] \(\equiv\) rev [] @ [a]

[1]Applying instance of rewrite rule "List.rev.simps_1":
rev [] \(\equiv\) []

[1]Rewriting:
rev [] \(\equiv\) []

[1]Applying instance of rewrite rule "List.append.append_Nil":
[] @ ?y \(\equiv\) ?y

[1]Rewriting:
[] @ [a] \(\equiv\) [a]

[1]Applying instance of rewrite rule
?x2 # ?t1 = ?t1 \(\equiv\) False

[1]Rewriting:
[a] = [] \(\equiv\) False
\end{ttbox}
The trace lists each rule being applied, both in its general form and
the instance being used. The \texttt{[}$i$\texttt{]} in front (where
above $i$ is always \texttt{1}) indicates that we are inside the $i$th
invocation of the simplifier. Each attempt to apply a
conditional rule shows the rule followed by the trace of the
(recursive!) simplification of the conditions, the latter prefixed by
\texttt{[}$i+1$\texttt{]} instead of \texttt{[}$i$\texttt{]}.
Another source of recursive invocations of the simplifier are
proofs of arithmetic formulae. By default, recursive invocations are not shown,
you must increase the trace depth via \pgmenu{Isabelle} $>$ \pgmenu{Settings} $>$ \pgmenu{Trace Simplifier Depth}.

Many other hints about the simplifier's actions may appear.

In more complicated cases, the trace can be very lengthy.  Thus it is
advisable to reset the \pgmenu{Trace Simplifier} flag after having
obtained the desired trace.
Since this is easily forgotten (and may have the unpleasant effect of
swamping the interface with trace information), here is how you can switch
the trace on locally in a proof:\<close>

(*<*)lemma "x=x"
(*>*)
using [[simp_trace=true]]
apply simp
(*<*)oops(*>*)

text\<open>\noindent
Within the current proof, all simplifications in subsequent proof steps
will be traced, but the text reminds you to remove the \isa{using} clause
after it has done its job.\<close>

subsection\<open>Finding Theorems\label{sec:find}\<close>

text\<open>\indexbold{finding theorems}\indexbold{searching theorems}
Isabelle's large database of proved theorems
offers a powerful search engine. Its chief limitation is
its restriction to the theories currently loaded.

\begin{pgnote}
The search engine is started by clicking on Proof General's \pgmenu{Find} icon.
You specify your search textually in the input buffer at the bottom
of the window.
\end{pgnote}

The simplest form of search finds theorems containing specified
patterns.  A pattern can be any term (even
a single identifier).  It may contain ``\texttt{\_}'', a wildcard standing
for any term. Here are some
examples:
\begin{ttbox}
length
"_ # _ = _ # _"
"_ + _"
"_ * (_ - (_::nat))"
\end{ttbox}
Specifying types, as shown in the last example,
constrains searches involving overloaded operators.

\begin{warn}
Always use ``\texttt{\_}'' rather than variable names: searching for
\texttt{"x + y"} will usually not find any matching theorems
because they would need to contain \texttt{x} and~\texttt{y} literally.
When searching for infix operators, do not just type in the symbol,
such as~\texttt{+}, but a proper term such as \texttt{"_ + _"}.
This remark applies to more complicated syntaxes, too.
\end{warn}

If you are looking for rewrite rules (possibly conditional) that could
simplify some term, prefix the pattern with \texttt{simp:}.
\begin{ttbox}
simp: "_ * (_ + _)"
\end{ttbox}
This finds \emph{all} equations---not just those with a \isa{simp} attribute---whose conclusion has the form
@{text[display]"_ * (_ + _) = \<dots>"}
It only finds equations that can simplify the given pattern
at the root, not somewhere inside: for example, equations of the form
\<open>_ + _ = \<dots>\<close> do not match.

You may also search for theorems by name---you merely
need to specify a substring. For example, you could search for all
commutativity theorems like this:
\begin{ttbox}
name: comm
\end{ttbox}
This retrieves all theorems whose name contains \texttt{comm}.

Search criteria can also be negated by prefixing them with ``\texttt{-}''.
For example,
\begin{ttbox}
-name: List
\end{ttbox}
finds theorems whose name does not contain \texttt{List}. You can use this
to exclude particular theories from the search: the long name of
a theorem contains the name of the theory it comes from.

Finallly, different search criteria can be combined arbitrarily.
The effect is conjuctive: Find returns the theorems that satisfy all of
the criteria. For example,
\begin{ttbox}
"_ + _"  -"_ - _"  -simp: "_ * (_ + _)"  name: assoc
\end{ttbox}
looks for theorems containing plus but not minus, and which do not simplify
\mbox{\<open>_ * (_ + _)\<close>} at the root, and whose name contains \texttt{assoc}.

Further search criteria are explained in \S\ref{sec:find2}.

\begin{pgnote}
Proof General keeps a history of all your search expressions.
If you click on \pgmenu{Find}, you can use the arrow keys to scroll
through previous searches and just modify them. This saves you having
to type in lengthy expressions again and again.
\end{pgnote}
\<close>
(*<*)
end
(*>*)