(*

 Licensed under the Apache License, Version 2.0 (the "License");
 you may not use this file except in compliance with the License.
 You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

 Unless required by applicable law or agreed to in writing, software
 distributed under the License is distributed on an "AS IS" BASIS,
 WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 See the License for the specific language governing permissions and
 limitations under the License.

 *)

theory BitVector_Rewriting
  imports artifact_rewriting.Take_Bits_Rewriting artifact_manual_execution.BitVectors
begin

subsection \<open>Logical Operators\<close>

lemma bv_to_bool_bool_to_bv:
  shows "bv_to_bool (bool_to_bv b) = b"
  by (cases b,auto simp add: bv_to_bool_def)

lemma snd_bool_to_bv:
  shows "snd (bool_to_bv b) = 1"
  by (cases b,auto)

lemma bv_to_bool_True:
  shows "bv_to_bool (1, 1) = True"
  by (auto simp add: bv_to_bool_def)

lemma bv_to_bool_True_Suc0:
  shows "bv_to_bool (1, Suc 0) = True"
  by (auto simp add: bv_to_bool_def)

lemma bv_to_bool_False:
  shows "bv_to_bool (0, 1) = False"
  by (auto simp add: bv_to_bool_def)

lemma bv_to_bool_False_Suc0:
  shows "bv_to_bool (0, Suc 0) = False"
  by (auto simp add: bv_to_bool_def)

lemma bool_to_bv_eq:
  shows "bool_to_bv b = (x, Suc 0) \<longleftrightarrow> (x \<in> {0,1} \<and> ((x = 1) \<longleftrightarrow> b))"
  by (cases b,auto)

lemma bv_NOT_bool_to_bv:
  shows "bv_NOT (bool_to_bv b) = bool_to_bv (\<not>b)"
  by (cases b, auto simp add: max_word_def)

subsection \<open>Concatenation and slicing\<close>

lemmas bv_slice_simps[simp] =
  bv_slice.simps[of "numeral h" "numeral l" "numeral w" "numeral s"]
  bv_slice.simps[of "numeral h" "numeral l" "numeral w" 0]
  bv_slice.simps[of "numeral h" "numeral l" "numeral w" 1]
  bv_slice.simps[of "numeral h" "numeral l" 0            "numeral s"]
  bv_slice.simps[of "numeral h" "numeral l" 0            0]
  bv_slice.simps[of "numeral h" "numeral l" 0            1]
  bv_slice.simps[of "numeral h" "numeral l" 1            "numeral s"]
  bv_slice.simps[of "numeral h" "numeral l" 1            0]
  bv_slice.simps[of "numeral h" "numeral l" 1            1]
  bv_slice.simps[of "numeral h" 0            "numeral w" "numeral s"]
  bv_slice.simps[of "numeral h" 0            "numeral w" 0]
  bv_slice.simps[of "numeral h" 0            "numeral w" 1]
  bv_slice.simps[of "numeral h" 0            0            "numeral s"]
  bv_slice.simps[of "numeral h" 0            0            0]
  bv_slice.simps[of "numeral h" 0            0            1]
  bv_slice.simps[of "numeral h" 0            1            "numeral s"]
  bv_slice.simps[of "numeral h" 0            1            0]
  bv_slice.simps[of "numeral h" 0            1            1]
  bv_slice.simps[of "numeral h" 1            "numeral w" "numeral s"]
  bv_slice.simps[of "numeral h" 1            "numeral w" 0]
  bv_slice.simps[of "numeral h" 1            "numeral w" 1]
  bv_slice.simps[of "numeral h" 1            0            "numeral s"]
  bv_slice.simps[of "numeral h" 1            0            0]
  bv_slice.simps[of "numeral h" 1            0            1]
  bv_slice.simps[of "numeral h" 1            1            "numeral s"]
  bv_slice.simps[of "numeral h" 1            1            0]
  bv_slice.simps[of "numeral h" 1            1            1]
  bv_slice.simps[of 0           "numeral l" "numeral w" "numeral s"]
  bv_slice.simps[of 0           "numeral l" "numeral w" 0]
  bv_slice.simps[of 0           "numeral l" "numeral w" 1]
  bv_slice.simps[of 0           "numeral l" 0            "numeral s"]
  bv_slice.simps[of 0           "numeral l" 0            0]
  bv_slice.simps[of 0           "numeral l" 0            1]
  bv_slice.simps[of 0           "numeral l" 1            "numeral s"]
  bv_slice.simps[of 0           "numeral l" 1            0]
  bv_slice.simps[of 0           "numeral l" 1            1]
  bv_slice.simps[of 0           0            "numeral w" "numeral s"]
  bv_slice.simps[of 0           0            "numeral w" 0]
  bv_slice.simps[of 0           0            "numeral w" 1]
  bv_slice.simps[of 0           0            0            "numeral s"]
  bv_slice.simps[of 0           0            0            0]
  bv_slice.simps[of 0           0            0            1]
  bv_slice.simps[of 0           0            1            "numeral s"]
  bv_slice.simps[of 0           0            1            0]
  bv_slice.simps[of 0           0            1            1]
  bv_slice.simps[of 0           1            "numeral w" "numeral s"]
  bv_slice.simps[of 0           1            "numeral w" 0]
  bv_slice.simps[of 0           1            "numeral w" 1]
  bv_slice.simps[of 0           1            0            "numeral s"]
  bv_slice.simps[of 0           1            0            0]
  bv_slice.simps[of 0           1            0            1]
  bv_slice.simps[of 0           1            1            "numeral s"]
  bv_slice.simps[of 0           1            1            0]
  bv_slice.simps[of 0           1            1            1]
  bv_slice.simps[of 1           "numeral l" "numeral w" "numeral s"]
  bv_slice.simps[of 1           "numeral l" "numeral w" 0]
  bv_slice.simps[of 1           "numeral l" "numeral w" 1]
  bv_slice.simps[of 1           "numeral l" 0            "numeral s"]
  bv_slice.simps[of 1           "numeral l" 0            0]
  bv_slice.simps[of 1           "numeral l" 0            1]
  bv_slice.simps[of 1           "numeral l" 1            "numeral s"]
  bv_slice.simps[of 1           "numeral l" 1            0]
  bv_slice.simps[of 1           "numeral l" 1            1]
  bv_slice.simps[of 1           0            "numeral w" "numeral s"]
  bv_slice.simps[of 1           0            "numeral w" 0]
  bv_slice.simps[of 1           0            "numeral w" 1]
  bv_slice.simps[of 1           0            0            "numeral s"]
  bv_slice.simps[of 1           0            0            0]
  bv_slice.simps[of 1           0            0            1]
  bv_slice.simps[of 1           0            1            "numeral s"]
  bv_slice.simps[of 1           0            1            0]
  bv_slice.simps[of 1           0            1            1]
  bv_slice.simps[of 1           1            "numeral w" "numeral s"]
  bv_slice.simps[of 1           1            "numeral w" 0]
  bv_slice.simps[of 1           1            "numeral w" 1]
  bv_slice.simps[of 1           1            0            "numeral s"]
  bv_slice.simps[of 1           1            0            0]
  bv_slice.simps[of 1           1            0            1]
  bv_slice.simps[of 1           1            1            "numeral s"]
  bv_slice.simps[of 1           1            1            0]
  bv_slice.simps[of 1           1            1            1]
  for h l w s

lemmas bv_cat_simps[simp] =
  bv_cat.simps[of "numeral w0" "numeral s0" "numeral w1" "numeral s1"]
  bv_cat.simps[of "numeral w0" "numeral s0" "numeral w1" 0]
  bv_cat.simps[of "numeral w0" "numeral s0" "numeral w1" 1]
  bv_cat.simps[of "numeral w0" "numeral s0" 0            "numeral s1"]
  bv_cat.simps[of "numeral w0" "numeral s0" 0            0]
  bv_cat.simps[of "numeral w0" "numeral s0" 0            1]
  bv_cat.simps[of "numeral w0" "numeral s0" 1            "numeral s1"]
  bv_cat.simps[of "numeral w0" "numeral s0" 1            0]
  bv_cat.simps[of "numeral w0" "numeral s0" 1            1]
  bv_cat.simps[of "numeral w0" 0            "numeral w1" "numeral s1"]
  bv_cat.simps[of "numeral w0" 0            "numeral w1" 0]
  bv_cat.simps[of "numeral w0" 0            "numeral w1" 1]
  bv_cat.simps[of "numeral w0" 0            0            "numeral s1"]
  bv_cat.simps[of "numeral w0" 0            0            0]
  bv_cat.simps[of "numeral w0" 0            0            1]
  bv_cat.simps[of "numeral w0" 0            1            "numeral s1"]
  bv_cat.simps[of "numeral w0" 0            1            0]
  bv_cat.simps[of "numeral w0" 0            1            1]
  bv_cat.simps[of "numeral w0" 1            "numeral w1" "numeral s1"]
  bv_cat.simps[of "numeral w0" 1            "numeral w1" 0]
  bv_cat.simps[of "numeral w0" 1            "numeral w1" 1]
  bv_cat.simps[of "numeral w0" 1            0            "numeral s1"]
  bv_cat.simps[of "numeral w0" 1            0            0]
  bv_cat.simps[of "numeral w0" 1            0            1]
  bv_cat.simps[of "numeral w0" 1            1            "numeral s1"]
  bv_cat.simps[of "numeral w0" 1            1            0]
  bv_cat.simps[of "numeral w0" 1            1            1]
  bv_cat.simps[of 0           "numeral s0" "numeral w1" "numeral s1"]
  bv_cat.simps[of 0           "numeral s0" "numeral w1" 0]
  bv_cat.simps[of 0           "numeral s0" "numeral w1" 1]
  bv_cat.simps[of 0           "numeral s0" 0            "numeral s1"]
  bv_cat.simps[of 0           "numeral s0" 0            0]
  bv_cat.simps[of 0           "numeral s0" 0            1]
  bv_cat.simps[of 0           "numeral s0" 1            "numeral s1"]
  bv_cat.simps[of 0           "numeral s0" 1            0]
  bv_cat.simps[of 0           "numeral s0" 1            1]
  bv_cat.simps[of 0           0            "numeral w1" "numeral s1"]
  bv_cat.simps[of 0           0            "numeral w1" 0]
  bv_cat.simps[of 0           0            "numeral w1" 1]
  bv_cat.simps[of 0           0            0            "numeral s1"]
  bv_cat.simps[of 0           0            0            0]
  bv_cat.simps[of 0           0            0            1]
  bv_cat.simps[of 0           0            1            "numeral s1"]
  bv_cat.simps[of 0           0            1            0]
  bv_cat.simps[of 0           0            1            1]
  bv_cat.simps[of 0           1            "numeral w1" "numeral s1"]
  bv_cat.simps[of 0           1            "numeral w1" 0]
  bv_cat.simps[of 0           1            "numeral w1" 1]
  bv_cat.simps[of 0           1            0            "numeral s1"]
  bv_cat.simps[of 0           1            0            0]
  bv_cat.simps[of 0           1            0            1]
  bv_cat.simps[of 0           1            1            "numeral s1"]
  bv_cat.simps[of 0           1            1            0]
  bv_cat.simps[of 0           1            1            1]
  bv_cat.simps[of 1           "numeral s0" "numeral w1" "numeral s1"]
  bv_cat.simps[of 1           "numeral s0" "numeral w1" 0]
  bv_cat.simps[of 1           "numeral s0" "numeral w1" 1]
  bv_cat.simps[of 1           "numeral s0" 0            "numeral s1"]
  bv_cat.simps[of 1           "numeral s0" 0            0]
  bv_cat.simps[of 1           "numeral s0" 0            1]
  bv_cat.simps[of 1           "numeral s0" 1            "numeral s1"]
  bv_cat.simps[of 1           "numeral s0" 1            0]
  bv_cat.simps[of 1           "numeral s0" 1            1]
  bv_cat.simps[of 1           0            "numeral w1" "numeral s1"]
  bv_cat.simps[of 1           0            "numeral w1" 0]
  bv_cat.simps[of 1           0            "numeral w1" 1]
  bv_cat.simps[of 1           0            0            "numeral s1"]
  bv_cat.simps[of 1           0            0            0]
  bv_cat.simps[of 1           0            0            1]
  bv_cat.simps[of 1           0            1            "numeral s1"]
  bv_cat.simps[of 1           0            1            0]
  bv_cat.simps[of 1           0            1            1]
  bv_cat.simps[of 1           1            "numeral w1" "numeral s1"]
  bv_cat.simps[of 1           1            "numeral w1" 0]
  bv_cat.simps[of 1           1            "numeral w1" 1]
  bv_cat.simps[of 1           1            0            "numeral s1"]
  bv_cat.simps[of 1           1            0            0]
  bv_cat.simps[of 1           1            0            1]
  bv_cat.simps[of 1           1            1            "numeral s1"]
  bv_cat.simps[of 1           1            1            0]
  bv_cat.simps[of 1           1            1            1]
  for w0 s0 w1 s1

lemma size_bv_cat:
  shows "snd (bv_cat a b) = snd a + snd b"
  by (cases a,cases b,auto simp add: bv_cat.simps)

lemma size_bv_slice:
  shows "snd (bv_slice h l a) = h + 1 - l"
  by (cases a,auto simp add: bv_slice.simps)

lemma bv_cat_prepend_0:
  fixes a :: "'a::len word"
  assumes "s < LENGTH('a)"
  shows "bv_cat (0, s') (a,s) = (if s = 0 then 0 else \<langle>s-1,0\<rangle>a,s + s')"
proof(cases "s = 0")
  case True
  thus ?thesis
    by (auto simp add: bv_cat.simps)
next
  case False
  {
    fix b :: "'a::len word"
    assume b: "b=0"
    {
      fix n::nat
      assume n: "n < LENGTH('a)"
      {
        fix x h l :: nat
        {
          fix m :: nat
          assume m: "m < LENGTH('a)"
          hence "\<not> b !! (LENGTH('a) - 1 - m)"
            using b
            by auto
          hence "\<not> to_bl b ! m"
            using m
            by (auto simp add: unfold_test_bit split: if_split_asm)
        }
        hence "\<not>((\<langle>h,l\<rangle>b)::'a::len word) !! x"
          apply (cases "x < LENGTH('a)";cases "h < LENGTH('a)")
          apply (auto simp add: test_bit_of_take_bits)[1]
          using b apply simp
          by (auto simp add: take_bits_def test_bit_bl word_size rev_nth word_rep_drop min_def nth_append)
      }
      note 1 = this
      have "(fst (bv_cat (b, s') (a,s))) !! n= ((\<langle>s-1,0\<rangle>a):: 'a::len word)!!n"
        using assms n 1 False
        apply (auto split: if_split_asm simp add: test_bit_of_take_bits bv_cat.simps word_ao_nth nth_shiftl)
        using b nth_0 by blast
    }
    hence "(fst (bv_cat (b, s') (a,s))) = ((\<langle>s-1,0\<rangle>a):: 'a::len word)"
      and "(snd (bv_cat (b, s') (a,s))) = (s+s')"
      apply (intro word_eqI)
      by (auto simp add: word_size bv_cat.simps)+
  }
  thus ?thesis
    using False
    apply auto
    by (metis prod.exhaust_sel)
qed

lemma test_bit_of_bv_cat:
  fixes a b :: "'a ::len0 word \<times> nat"
  assumes "snd a \<le> LENGTH('a)"
      and "snd b \<le> LENGTH('a)"
      and "i < LENGTH('a)"
    shows "fst (bv_cat a b) !! i = (if i \<ge> snd b then (fst a) !! (i - snd b) else (fst b) !! i)"
  using assms
  by (cases a, cases b,auto simp add: bv_cat.simps test_bit_of_take_bits word_ao_nth nth_shiftl word_size split: if_split_asm)

lemma test_bit_of_bv_slice:
  assumes "h < \<M>"
  shows "fst (bv_slice h l a) !! n = (if n < Suc h - l then fst a!!(l+n) else False)"
  using assms
  apply (cases a, cases "n < \<M>",auto simp add: bv_slice.simps test_bit_of_take_bits)
  by (simp add: word_size test_bit_bin')

lemma bv_slice_bv_cat:
assumes "h < \<M>"
    and "snd a \<le> \<M>"
    and "snd b \<le> \<M>"
  shows "bv_slice h l (bv_cat a b) =
        (if h \<ge> snd b then
          (if l \<ge> snd b then
            bv_slice (h - snd b) (l - snd b) a
           else
            bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b))
        else
          (if l \<ge> snd b then
               (0,0)
           else
              bv_slice h l b))"
proof(cases "h \<ge> snd b")
  case True
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = fst (bv_slice (h - snd b) (l - snd b) a) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps test_bit_of_bv_slice nth_ucast test_bit_of_bv_cat split: if_split_asm)
    }
    hence "fst (bv_slice h l (bv_cat a b)) = fst (bv_slice (h - snd b) (l - snd b) a)"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = snd (bv_slice (h - snd b) (l - snd b) a)"
      using True h
      by (cases a, cases b,auto simp add: size_bv_slice)
    ultimately
    show ?thesis
      using True h
      apply (auto)
      by (metis prod.exhaust_sel)
  next
    case False
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = fst (bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b)) !! i"
        using h False assms
        apply (auto simp add: bv_cat.simps nth_ucast test_bit_of_bv_slice test_bit_of_bv_cat word_ao_nth nth_shiftl size_bv_slice split: if_split_asm)
        by (simp add: Groups.add_ac(2))+
    }
    hence "fst (bv_slice h l (bv_cat a b)) = fst (bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b))"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = snd (bv_cat (bv_slice (h - snd b) 0 a) (bv_slice (snd b - 1) l b))"
      using False h
      by (cases a, cases b,auto simp add: size_bv_slice size_bv_cat)
    ultimately
    show ?thesis
      using False h
      apply (auto)
      by (metis prod.exhaust_sel)
  qed
next
  case False
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = (0::longword) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_bv_slice test_bit_of_bv_cat split: if_split_asm)
    }
    hence "fst (bv_slice h l (bv_cat a b)) = 0"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = 0"
      using True h
      by (cases a, cases b,auto simp add: size_bv_slice size_bv_cat)
    ultimately
    show ?thesis
      using True h
      apply (auto)
      by (metis prod.exhaust_sel)
  next
    case False
    {
      fix i :: nat
      assume "i < \<M>"
      hence "fst (bv_slice h l (bv_cat a b)) !! i = fst (bv_slice h l b) !! i"
        using h False assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_bv_slice test_bit_of_bv_cat split: if_split_asm)
    }
    hence "fst (bv_slice h l (bv_cat a b)) = fst (bv_slice h l b)"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    moreover
    have "snd (bv_slice h l (bv_cat a b)) = snd (bv_slice h l b)"
      using False h
      by (cases a, cases b,auto simp add: size_bv_slice size_bv_cat)
    ultimately
    show ?thesis
      using False h
      apply (auto)
      by (metis prod.exhaust_sel)
  qed
qed

lemma take_bits_bv_cat:
  fixes a b :: "'b ::len0 word \<times> nat"
  assumes "h < LENGTH('b)"
      and "h - l < LENGTH('a)"
      and "snd b \<le> LENGTH('b)"
    shows "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) =
        (if h \<ge> snd b then
          (if l \<ge> snd b then
            \<langle>h - snd b,l - snd b\<rangle>fst a
           else
            fst (bv_cat (\<langle>h- snd b,0\<rangle> fst a, h + 1 - snd b) (\<langle>snd b-1,l\<rangle> fst b, snd b - l))
          )
        else
          (if l \<ge> snd b then
               0
           else
              \<langle>h,l\<rangle> (fst b)))"
proof(cases "h \<ge> snd b")
  case True
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < LENGTH('a)"
      hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i = ((\<langle>h - snd b,l - snd b\<rangle>fst a)::'a::len0 word) !! i"
        using h True assms
        apply (cases "snd a \<le> LENGTH('b)",auto simp add: bv_cat.simps test_bit_of_take_bits nth_ucast test_bit_of_bv_cat split: if_split_asm)
        apply (cases a,cases b,auto simp add: word_ao_nth nth_shiftl bv_cat.simps test_bit_of_take_bits nth_ucast split: if_split_asm)
        apply (cases a,cases b,auto simp add: word_ao_nth nth_shiftl bv_cat.simps test_bit_of_take_bits nth_ucast split: if_split_asm)
        done
    }
    hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) = ((\<langle>h - snd b,l - snd b\<rangle>fst a)::'a::len0 word)"
      apply (intro word_eqI)
      by (auto simp add: word_size)
    thus ?thesis
      using True h
      by auto
  next
    case False
    {
      fix i
      assume "i < LENGTH('a)"
      hence "(fst (bv_cat (\<langle>h- snd b,0\<rangle> fst a, h + 1 - snd b) (\<langle>snd b-1,l\<rangle> fst b, snd b - l)) ::'a::len0 word) !! i = ((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i"
        using h False True assms
        apply (cases a;cases b;auto simp add: word_ao_nth nth_shiftl bv_cat.simps test_bit_of_take_bits nth_ucast split: if_split_asm)
        by (auto simp add: Groups.add_ac(2) bv_cat.simps test_bit_of_take_bits nth_ucast test_bit_of_bv_cat word_ao_nth nth_shiftl split: if_split_asm)

      }
    thus ?thesis
      using False True
      apply (auto simp add: )
      apply (intro word_eqI)
      by (auto simp add: word_size)
  qed
next
  case False
  note h = this
  show ?thesis
  proof(cases "l \<ge> snd b")
    case True
    {
      fix i :: nat
      assume "i < LENGTH('a)"
      hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i = (0::'a::len0 word) !! i"
        using h True assms
        by (auto simp add: bv_cat.simps nth_ucast test_bit_of_take_bits test_bit_of_bv_cat split: if_split_asm)
    }
    thus ?thesis
      using True h
      apply (auto)
      apply (intro word_eqI)
      by (auto simp add: word_size)
  next
    case False
    {
      fix i :: nat
      assume "i < LENGTH('a)"
      hence "((\<langle>h,l\<rangle> (fst (bv_cat a b)))::'a::len0 word) !! i = (\<langle>h,l\<rangle> (fst b)::'a::len0 word) !! i"
        using h False assms
        by (cases a,cases b,auto simp add: word_ao_nth nth_shiftl bv_cat.simps test_bit_of_take_bits nth_ucast split: if_split_asm)
    }
    thus ?thesis
      using False h
      apply (auto)
      apply (intro word_eqI)
      by (auto simp add: word_size)
  qed
qed

lemma bv_cat_rassoc:
  fixes a b c :: "'a::len word \<times> nat"
  assumes "s = snd a + snd b"
      and "s0 = snd b + snd c"
      and "s0 < LENGTH('a)"
    shows "fst (bv_cat (fst (bv_cat a b), s) c) = fst (bv_cat a (fst (bv_cat b c), s0))"
  apply (rule word_eqI)
  using assms
  by (cases a;cases b;cases c;auto simp add: Groups.add_ac(2) bv_cat.simps word_ao_nth word_size nth_shiftl test_bit_of_take_bits)

lemma take_bits_bv_slice:
  assumes "h < \<M>"
      and "h' < \<M>"
  shows "\<langle>h,l\<rangle>fst (bv_slice h' l' a) =  \<langle>(if Suc h - l < Suc h' - (l + l') then h + l' else h'),l + l'\<rangle>fst a"
  using assms
  by (cases a,auto simp add: bv_slice.simps)

lemma bv_slice_take_bits:
  assumes "h < \<M>"
      and "h' < LENGTH('a)"
  fixes a ::"'a::len0 word"
  shows "bv_slice h l (\<langle>h',l'\<rangle>a, s) = (\<langle>(if Suc h - l < Suc h' - (l + l') then h + l' else h'),l + l'\<rangle>a, h + 1 - l)"
  using assms
  by (auto simp add: bv_slice.simps)

lemma bv_slice_bit32:
  fixes a :: longword
  assumes "s \<ge> 32"
  shows "bv_slice 31 0 (a,s) = (ucast (\<langle>31,0\<rangle>a::32 word), 32)"
  using assms
  by (auto simp add: bv_slice.simps)

(* TO BE MERGED *)
lemma bv_slice_bit64:
  fixes a :: longword
  assumes "s \<ge> 64"
  shows "bv_slice 63 0 (a, s) = (ucast (\<langle>63,0\<rangle>a::64 word), 64)"
  using assms
  by (auto simp add: bv_slice.simps)
(* END TO BE MERGED *)

lemma bv_slice_nth_bit:
  assumes "h < \<M>"
  shows "bv_slice h h a = bool_to_bv (fst a !! h)"
proof-
  {
    fix i :: nat
    assume "i < \<M>"
    hence "((\<langle>h,h\<rangle>(fst a))::longword) !! i = (if fst a !! h then 1::longword else 0) !! i"
      using assms
      by (auto simp add: test_bit_of_take_bits)
  }
  hence "((\<langle>h,h\<rangle>(fst a))::longword) = (if fst a !! h then 1::longword else 0)"
    apply (intro word_eqI)
    by (auto simp add: word_size)
  thus ?thesis
    by (cases a;auto simp add: bv_slice.simps)
qed

subsection \<open>Arithmetic\<close>

lemma BV_Add_bit64:
  fixes a b :: longword
    shows "(a,64) +\<^sup>b\<^sup>v (b,64) = (ucast (((\<langle>63,0\<rangle>a)::64 word) + \<langle>63,0\<rangle>b), 64)"
proof-
  have "(a,64) +\<^sup>b\<^sup>v (b,64) = (\<langle>63,0\<rangle>(a + b), 64)"
    by (cases a;cases b;auto simp add: exec_BV_Plus_def case_prod_unfold)
  also have "... = (ucast ((\<langle>63,0\<rangle>(a + b))::64 word), 64)"
    by (subst ucast_take_bits,simp,simp,simp)
  also have "... = (ucast (((\<langle>63,0\<rangle>a)::64 word) + \<langle>63,0\<rangle>b), 64)"
    by (subst take_bits_plus,simp,simp,simp)
  finally
  show ?thesis
    by auto
qed

lemma BV_Add_bit33:
  fixes a b :: longword
    shows "(a,33) +\<^sup>b\<^sup>v (b,33) = (ucast (((\<langle>32,0\<rangle>a)::33 word) + \<langle>32,0\<rangle>b), 33)"
proof-
  have "(a,33) +\<^sup>b\<^sup>v (b,33) = (\<langle>32,0\<rangle>(a + b), 33)"
    by (cases a;cases b;auto simp add: exec_BV_Plus_def case_prod_unfold)
  also have "... = (ucast ((\<langle>32,0\<rangle>(a + b))::33 word), 33)"
    by (subst ucast_take_bits,simp,simp,simp)
  also have "... = (ucast (((\<langle>32,0\<rangle>a)::33 word) + \<langle>32,0\<rangle>b), 33)"
    by (subst take_bits_plus,simp,simp,simp)
  finally
  show ?thesis
    by auto
qed

lemma BV_Add_bit65:
  fixes a b :: longword
    shows "(a,65) +\<^sup>b\<^sup>v (b,65) = (ucast (((\<langle>64,0\<rangle>a)::65 word) + \<langle>64,0\<rangle>b), 65)"
proof-
  have "(a,65) +\<^sup>b\<^sup>v (b,65) = (\<langle>64,0\<rangle>(a + b), 65)"
    by (cases a;cases b;auto simp add: exec_BV_Plus_def case_prod_unfold)
  also have "... = (ucast ((\<langle>64,0\<rangle>(a + b))::65 word), 65)"
    by (subst ucast_take_bits,simp,simp,simp)
  also have "... = (ucast (((\<langle>64,0\<rangle>a)::65 word) + \<langle>64,0\<rangle>b), 65)"
    by (subst take_bits_plus,simp,simp,simp)
  finally
  show ?thesis
    by auto
qed

subsection \<open>Floating Point operations\<close>

context abstract_float
begin

lemma BV_Plus_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fplus\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a +\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Plus_Double_def ucast_id)

lemma BV_Plus_bit64_numeral:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fplus\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a +\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Plus_Double_def ucast_id)

lemma BV_Sub_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fsub\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a -\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Sub_Double_def ucast_id)

lemma BV_Sub_bit64_numeral:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fsub\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a -\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Sub_Double_def ucast_id)

lemma BV_Mult_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fmult\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a *\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Mul_Double_def ucast_id)

lemma BV_Mult_bit64_numeral_r:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fmult\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a *\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Mul_Double_def ucast_id)
lemma BV_Mult_bit64_numeral_l:
  fixes a :: "64 word"
  shows "(numeral n, 64) fmult\<^sup>b\<^sup>v (\<langle>63,0\<rangle>a, 64) = (\<langle>63,0\<rangle>(\<langle>63,0\<rangle>((numeral n)::longword) *\<^sup>f a), 64)"
  by (auto simp add: exec_BV_Mul_Double_def ucast_id)
lemma BV_Mult_bit64_0_l:
  fixes a :: "64 word"
  shows "(0, 64) fmult\<^sup>b\<^sup>v (\<langle>63,0\<rangle>a, 64) = (\<langle>63,0\<rangle>(0\<^sup>+ *\<^sup>f a), 64)"
  by (auto simp add: exec_BV_Mul_Double_def plus_zero_def ucast_id)
lemma BV_Mult_bit64_0_r:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fmult\<^sup>b\<^sup>v (0, 64) = (\<langle>63,0\<rangle>(a *\<^sup>f 0\<^sup>+), 64)"
  by (auto simp add: exec_BV_Mul_Double_def plus_zero_def ucast_id)

lemma BV_Div_bit64:
  fixes a b :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fdiv\<^sup>b\<^sup>v (\<langle>63,0\<rangle>b, 64) = (\<langle>63,0\<rangle>(a div\<^sup>f b), 64)"
  by (auto simp add: exec_BV_Div_Double_def ucast_id)

lemma BV_Div_bit64_numeral:
  fixes a :: "64 word"
  shows "(\<langle>63,0\<rangle>a, 64) fdiv\<^sup>b\<^sup>v (numeral n, 64) = (\<langle>63,0\<rangle>(a div\<^sup>f \<langle>63,0\<rangle>((numeral n)::longword)), 64)"
  by (auto simp add: exec_BV_Div_Double_def ucast_id)

end

subsection \<open>Simplification rules\<close>

lemmas (in abstract_float) bit_vector_simps =
    bv_slice_bv_cat take_bits_bv_slice bv_slice_take_bits take_bits_bv_cat bv_slice_bit32
    bv_cat_prepend_0 size_bv_cat size_bv_slice
    bv_to_bool_bool_to_bv snd_bool_to_bv
    bv_to_bool_True bv_to_bool_True_Suc0
    bv_to_bool_False bv_to_bool_False_Suc0
    BV_Add_bit65 BV_Add_bit64 BV_Add_bit33
    BV_Plus_bit64 BV_Plus_bit64_numeral
    BV_Sub_bit64 BV_Sub_bit64_numeral
    BV_Mult_bit64 BV_Mult_bit64_numeral_r BV_Mult_bit64_numeral_l BV_Mult_bit64_0_l BV_Mult_bit64_0_r
    BV_Div_bit64 BV_Div_bit64_numeral
    bv_slice_bit32
    bv_slice_bit64 (* TO BE MERGED *)
    bv_NOT.simps
    bv_NOT_bool_to_bv bool_to_bv_eq bv_slice_nth_bit bv_cat_rassoc
end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Discrete category\<close>
theory CZH_ECAT_Discrete
  imports
    CZH_ECAT_Simple
    CZH_ECAT_Small_Functor
begin

subsection\<open>Abstract discrete category\<close>

named_theorems cat_discrete_cs_simps
named_theorems cat_discrete_cs_intros

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale cat_discrete = category \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_discrete_Arr: "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr> \<Longrightarrow> f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>)"

text\<open>Rules.\<close>

lemma (in cat_discrete)
  assumes "\<alpha>' = \<alpha>" "\<CC>' = \<CC>"
  shows "cat_discrete \<alpha>' \<CC>'"
  unfolding assms by (rule cat_discrete_axioms)

mk_ide rf cat_discrete_def[unfolded cat_discrete_axioms_def]
  |intro cat_discreteI|
  |dest cat_discreteD[dest]|
  |elim cat_discreteE[elim]|

lemmas [cat_discrete_cs_intros] = cat_discreteD(1)

text\<open>Elementary properties.\<close>

lemma (in cat_discrete) cat_discrete_is_arrD[dest]:
  assumes "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  shows "b = a" and "f = \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr>"
proof-
  from assms cat_discrete_Arr have "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>)"
    by (auto simp: cat_cs_simps)
  with cat_CId_vdomain obtain a' where f_def: "f = \<CC>\<lparr>CId\<rparr>\<lparr>a'\<rparr>" and "a' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    by (blast dest: CId.vrange_atD)
  then have "f : a' \<mapsto>\<^bsub>\<CC>\<^esub> a'" by (auto intro: cat_CId_is_arr')
  with assms have "a = a'" and "b = a'" by blast+
  with f_def show "b = a" and "f = \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr>" by auto
qed

lemma (in cat_discrete) cat_discrete_is_arrE[elim]:
  assumes "f : b \<mapsto>\<^bsub>\<CC>\<^esub> c"
  obtains a where "f : a \<mapsto>\<^bsub>\<CC>\<^esub> a" and "f = \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr>"
  using assms by auto

subsection\<open>The discrete category\<close>

text\<open>
As explained in Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>, every discrete
category is identified with its set of objects.
In this work, it is assumed that the set of objects and the set of arrows
in the canonical discrete category coincide; the domain and the codomain
functions are identities.
\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition the_cat_discrete :: "V \<Rightarrow> V" (\<open>:\<^sub>C\<close>)
  where ":\<^sub>C I = [I, I, vid_on I, vid_on I, (\<lambda>fg\<in>\<^sub>\<circ>fid_on I. fg\<lparr>0\<rparr>), vid_on I]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma the_cat_discrete_components:
  shows ":\<^sub>C I\<lparr>Obj\<rparr> = I"
    and ":\<^sub>C I\<lparr>Arr\<rparr> = I"
    and ":\<^sub>C I\<lparr>Dom\<rparr> = vid_on I"
    and ":\<^sub>C I\<lparr>Cod\<rparr> = vid_on I"
    and ":\<^sub>C I\<lparr>Comp\<rparr> = (\<lambda>fg\<in>\<^sub>\<circ>fid_on I. fg\<lparr>0\<rparr>)"
    and ":\<^sub>C I\<lparr>CId\<rparr> = vid_on I"
  unfolding the_cat_discrete_def dg_field_simps
  by (simp_all add: nat_omega_simps)

subsubsection\<open>Domain\<close>

mk_VLambda the_cat_discrete_components(3)[folded VLambda_vid_on]
  |vsv the_cat_discrete_Dom_vsv[cat_discrete_cs_intros]|
  |vdomain the_cat_discrete_Dom_vdomain[cat_discrete_cs_simps]|
  |app the_cat_discrete_Dom_app[cat_discrete_cs_simps]|

subsubsection\<open>Codomain\<close>

mk_VLambda the_cat_discrete_components(4)[folded VLambda_vid_on]
  |vsv the_cat_discrete_Cod_vsv[cat_discrete_cs_intros]|
  |vdomain the_cat_discrete_Cod_vdomain[cat_discrete_cs_simps]|
  |app the_cat_discrete_Cod_app[cat_discrete_cs_simps]|

subsubsection\<open>Composition\<close>

lemma the_cat_discrete_Comp_vsv[cat_discrete_cs_intros]: "vsv (:\<^sub>C I\<lparr>Comp\<rparr>)"
  unfolding the_cat_discrete_components by simp

lemma the_cat_discrete_Comp_vdomain: "\<D>\<^sub>\<circ> (:\<^sub>C I\<lparr>Comp\<rparr>) = fid_on I"
  unfolding the_cat_discrete_components by simp

lemma the_cat_discrete_Comp_vrange:
  "\<R>\<^sub>\<circ> (:\<^sub>C I\<lparr>Comp\<rparr>) = I"
proof(intro vsubset_antisym vsubsetI)
  fix f assume "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (:\<^sub>C I\<lparr>Comp\<rparr>)"
  then obtain gg where f_def: "f = :\<^sub>C I\<lparr>Comp\<rparr>\<lparr>gg\<rparr>" and gg: "gg \<in>\<^sub>\<circ> fid_on I"
    unfolding the_cat_discrete_components by auto
  from gg show "f \<in>\<^sub>\<circ> I"
    unfolding f_def the_cat_discrete_components by clarsimp
next
  fix f assume "f \<in>\<^sub>\<circ> I"
  then have "[f, f]\<^sub>\<circ> \<in>\<^sub>\<circ> fid_on I" by clarsimp
  moreover then have "f = :\<^sub>C I\<lparr>Comp\<rparr>\<lparr>f, f\<rparr>\<^sub>\<bullet>"
    unfolding the_cat_discrete_components by simp
  ultimately show "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (:\<^sub>C I\<lparr>Comp\<rparr>)"
    unfolding the_cat_discrete_components
    by (metis rel_VLambda.vsv_vimageI2 vdomain_VLambda)
qed

lemma the_cat_discrete_Comp_app[cat_discrete_cs_simps]:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "i \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> i = i"
proof-
  from assms have "[i, i]\<^sub>\<circ> \<in>\<^sub>\<circ> fid_on I" by clarsimp
  then show ?thesis unfolding the_cat_discrete_components by simp
qed

subsubsection\<open>Identity\<close>

mk_VLambda the_cat_discrete_components(6)[folded VLambda_vid_on]
  |vsv the_cat_discrete_CId_vsv[cat_discrete_cs_intros]|
  |vdomain the_cat_discrete_CId_vdomain[cat_discrete_cs_simps]|
  |app the_cat_discrete_CId_app[cat_discrete_cs_simps]|

subsubsection\<open>Arrow with a domain and a codomain\<close>

lemma the_cat_discrete_is_arrI:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "i : i \<mapsto>\<^bsub>:\<^sub>C I\<^esub> i"
  using assms unfolding is_arr_def the_cat_discrete_components by simp

lemma the_cat_discrete_is_arrI'[cat_discrete_cs_intros]:
  assumes "i \<in>\<^sub>\<circ> I"
    and "a = i"
    and "b = i"
  shows "i : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
  using assms(1) unfolding assms(2,3) by (rule the_cat_discrete_is_arrI)

lemma the_cat_discrete_is_arrD:
  assumes "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
  shows "f : f \<mapsto>\<^bsub>:\<^sub>C I\<^esub> f"
    and "a : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> a"
    and "b : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
    and "f \<in>\<^sub>\<circ> I"
    and "a \<in>\<^sub>\<circ> I"
    and "b \<in>\<^sub>\<circ> I"
    and "f = a"
    and "f = b"
    and "b = a"
  using assms unfolding is_arr_def the_cat_discrete_components by force+

subsubsection\<open>The discrete category is a discrete category\<close>

lemma (in \<Z>) cat_discrete_the_cat_discrete:
  assumes "I \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  shows "cat_discrete \<alpha> (:\<^sub>C I)"
proof(intro cat_discreteI categoryI')
  show "vfsequence (:\<^sub>C I)" unfolding the_cat_discrete_def by simp
  show "vcard (:\<^sub>C I) = 6\<^sub>\<nat>"
    unfolding the_cat_discrete_def by (simp add: nat_omega_simps)
  show "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (:\<^sub>C I\<lparr>Comp\<rparr>) \<longleftrightarrow>
    (\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c \<and> f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b)"
    for gf
    unfolding the_cat_discrete_Comp_vdomain
  proof
    assume "gf \<in>\<^sub>\<circ> fid_on I"
    then obtain a where "gf = [a, a]\<^sub>\<circ>" and "a \<in>\<^sub>\<circ> I" by clarsimp
    moreover then have "a : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> a"
      by (auto intro: the_cat_discrete_is_arrI)
    ultimately show
      "\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c \<and> f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
      by auto
  next
    assume "\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c \<and> f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
    then obtain g f b c a where gf_def: "gf = [g, f]\<^sub>\<circ>"
      and g: "g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c"
      and f: "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
      by clarsimp
    then have "g = f" by (metis is_arrE the_cat_discrete_is_arrD(1))
    with the_cat_discrete_is_arrD(4)[OF f] show "gf \<in>\<^sub>\<circ> fid_on I"
      unfolding gf_def by clarsimp
  qed
  show "g \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c" if "g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c" and "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
    for g b c f a
  proof-
    from that have fba: "f = a" "b = a" and a: "a \<in>\<^sub>\<circ> I"
      unfolding the_cat_discrete_is_arrD[OF that(2)] by (simp_all add: \<open>a \<in>\<^sub>\<circ> I\<close>)
    from that have gcb: "g = b" "c = b"
      unfolding the_cat_discrete_is_arrD[OF that(1)] by simp_all
    from a show ?thesis
      unfolding fba gcb
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_discrete_cs_simps cs_intro: cat_discrete_cs_intros
        )
  qed
  show "h \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> g \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> f = h \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> (g \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> f)"
    if "h : c \<mapsto>\<^bsub>:\<^sub>C I\<^esub> d" and "g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c" and "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b"
    for h c d g b f a
  proof-
    from that have fba: "f = a" "b = a" and a: "a \<in>\<^sub>\<circ> I"
      unfolding the_cat_discrete_is_arrD[OF that(3)] by (simp_all add: \<open>a \<in>\<^sub>\<circ> I\<close>)
    from that have gcb: "g = b" "c = b"
      unfolding the_cat_discrete_is_arrD[OF that(2)] by simp_all
    from that have hcd: "h = c" "d = c"
      unfolding the_cat_discrete_is_arrD[OF that(1)] by simp_all
    from a show ?thesis
      unfolding fba gcb hcd
      by (cs_concl cs_shallow cs_simp: cat_discrete_cs_simps)
  qed
  show ":\<^sub>C I\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> f = f" if "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b" for f a b
  proof-
    from that have fba: "f = a" "b = a" and a: "a \<in>\<^sub>\<circ> I"
      unfolding the_cat_discrete_is_arrD[OF that] by (simp_all add: \<open>a \<in>\<^sub>\<circ> I\<close>)
    from a show ?thesis
      by (cs_concl cs_shallow cs_simp: cat_discrete_cs_simps fba)
  qed
  show "f \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> :\<^sub>C I\<lparr>CId\<rparr>\<lparr>b\<rparr> = f" if "f : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c" for f b c
  proof-
    from that have fba: "f = b" "c = b" and b: "b \<in>\<^sub>\<circ> I"
      unfolding the_cat_discrete_is_arrD[OF that] by (simp_all add: \<open>b \<in>\<^sub>\<circ> I\<close>)
    from b show ?thesis
      by (cs_concl cs_shallow cs_simp: cat_discrete_cs_simps fba)
  qed
  show ":\<^sub>C I\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> a"
    if "a \<in>\<^sub>\<circ> :\<^sub>C I\<lparr>Obj\<rparr>" for a
    using that
    by (auto simp: the_cat_discrete_components intro: cat_discrete_cs_intros)
  show "\<Union>\<^sub>\<circ>((\<lambda>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>(VLambda B (Hom (:\<^sub>C I) a) `\<^sub>\<circ> B)) `\<^sub>\<circ> A) \<in>\<^sub>\<circ> Vset \<alpha>"
    if "A \<subseteq>\<^sub>\<circ> :\<^sub>C I\<lparr>Obj\<rparr>"
      and "B \<subseteq>\<^sub>\<circ> :\<^sub>C I\<lparr>Obj\<rparr>"
      and "A \<in>\<^sub>\<circ> Vset \<alpha>"
      and "B \<in>\<^sub>\<circ> Vset \<alpha>"
    for A B
  proof-
    have "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom (:\<^sub>C I) a b) \<subseteq>\<^sub>\<circ> A \<union>\<^sub>\<circ> B"
    proof(intro vsubsetI, elim vifunionE, unfold in_Hom_iff)
      fix i j f assume prems: "i \<in>\<^sub>\<circ> A" "j \<in>\<^sub>\<circ> B" "f : i \<mapsto>\<^bsub>:\<^sub>C I\<^esub> j"
      then show "f \<in>\<^sub>\<circ> A \<union>\<^sub>\<circ> B"
        unfolding the_cat_discrete_is_arrD[OF prems(3)] by simp
    qed
    moreover have "A \<union>\<^sub>\<circ> B \<in>\<^sub>\<circ> Vset \<alpha>" by (simp add: that(3,4) vunion_in_VsetI)
    ultimately show "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom (:\<^sub>C I) a b) \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto simp: vsubset_in_VsetI)
  qed
qed (auto simp: assms the_cat_discrete_components intro: cat_cs_intros)

lemmas [cat_discrete_cs_intros] = \<Z>.cat_discrete_the_cat_discrete

subsubsection\<open>Opposite discrete category\<close>

lemma (in \<Z>) the_cat_discrete_op[cat_op_simps]:
  assumes "I \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  shows "op_cat (:\<^sub>C I) = :\<^sub>C I"
proof(rule cat_eqI[of \<alpha>])
  from assms show dI: "category \<alpha> (:\<^sub>C I)"
    by (cs_concl cs_intro: cat_discrete_the_cat_discrete cat_discrete_cs_intros)
  then show op_dI: "category \<alpha> (op_cat (:\<^sub>C I))"
    by (cs_concl cs_shallow cs_intro: cat_op_intros)
  interpret category \<alpha> \<open>op_cat (:\<^sub>C I)\<close> by (rule op_dI)
  show "op_cat (:\<^sub>C I)\<lparr>Comp\<rparr> = :\<^sub>C I\<lparr>Comp\<rparr>"
  proof(rule vsv_eqI)
    show "\<D>\<^sub>\<circ> (op_cat (:\<^sub>C I)\<lparr>Comp\<rparr>) = \<D>\<^sub>\<circ> (:\<^sub>C I\<lparr>Comp\<rparr>)"
      by (simp add: the_cat_discrete_components op_cat_components)
    fix gf assume "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (op_cat (:\<^sub>C I)\<lparr>Comp\<rparr>)"
    then have "gf \<in>\<^sub>\<circ> fid_on I"
      by (simp add: the_cat_discrete_components op_cat_components)
    then obtain h where gf_def: "gf = [h, h]\<^sub>\<circ>" and h: "h \<in>\<^sub>\<circ> I" by clarsimp
    from dI h show "op_cat (:\<^sub>C I)\<lparr>Comp\<rparr>\<lparr>gf\<rparr> = :\<^sub>C I\<lparr>Comp\<rparr>\<lparr>gf\<rparr>"
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_op_simps gf_def cs_intro: cat_discrete_cs_intros
        )
  qed (auto intro: cat_discrete_cs_intros)
qed (unfold the_cat_discrete_components op_cat_components, simp_all)

subsection\<open>Discrete functor\<close>

subsubsection\<open>Local assumptions for the discrete functor\<close>

text\<open>See Chapter III in \<^cite>\<open>"mac_lane_categories_2010"\<close>).\<close>

locale cf_discrete = category \<alpha> \<CC> for \<alpha> I F \<CC> +
  assumes cf_discrete_selector_vrange[cat_discrete_cs_intros]:
    "i \<in>\<^sub>\<circ> I \<Longrightarrow> F i \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and cf_discrete_vdomain_vsubset_Vset: "I \<subseteq>\<^sub>\<circ> Vset \<alpha>"

lemmas (in cf_discrete) cf_discrete_category = category_axioms

lemmas [cat_discrete_cs_intros] = cf_discrete.cf_discrete_category

text\<open>Rules.\<close>

lemma (in cf_discrete) cf_discrete_axioms'[cat_discrete_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "I' = I" and "F' = F"
  shows "cf_discrete \<alpha>' I' F' \<CC>"
  unfolding assms by (rule cf_discrete_axioms)

mk_ide rf cf_discrete_def[unfolded cf_discrete_axioms_def]
  |intro cf_discreteI|
  |dest cf_discreteD[dest]|
  |elim cf_discreteE[elim]|

text\<open>Elementary properties.\<close>

lemma (in cf_discrete) cf_discrete_is_functor_cf_CId_selector_is_arr:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "\<CC>\<lparr>CId\<rparr>\<lparr>F i\<rparr> : F i \<mapsto>\<^bsub>\<CC>\<^esub> F i"
  using assms by (meson cat_CId_is_arr' cf_discreteD(2) cf_discrete_axioms)

lemma (in cf_discrete)
  cf_discrete_is_functor_cf_CId_selector_is_arr'[cat_discrete_cs_intros]:
  assumes "i \<in>\<^sub>\<circ> I" and "a = F i" and "b = F i"
  shows "\<CC>\<lparr>CId\<rparr>\<lparr>F i\<rparr> : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  using assms(1)
  unfolding assms(2,3)
  by (rule cf_discrete_is_functor_cf_CId_selector_is_arr)

subsubsection\<open>Definition and elementary properties\<close>

definition the_cf_discrete :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> V" (\<open>:\<rightarrow>:\<close>)
  where ":\<rightarrow>: I F \<CC> = [VLambda I F, (\<lambda>i\<in>\<^sub>\<circ>I. \<CC>\<lparr>CId\<rparr>\<lparr>F i\<rparr>), :\<^sub>C I, \<CC>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma the_cf_discrete_components:
  shows ":\<rightarrow>: I F \<CC>\<lparr>ObjMap\<rparr> = (\<lambda>i\<in>\<^sub>\<circ>I. F i)"
    and ":\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr> = (\<lambda>i\<in>\<^sub>\<circ>I. \<CC>\<lparr>CId\<rparr>\<lparr>F i\<rparr>)"
    and [cat_discrete_cs_simps]: ":\<rightarrow>: I F \<CC>\<lparr>HomDom\<rparr> = :\<^sub>C I"
    and [cat_discrete_cs_simps]: ":\<rightarrow>: I F \<CC>\<lparr>HomCod\<rparr> = \<CC>"
  unfolding the_cf_discrete_def dghm_field_simps
  by (simp_all add: nat_omega_simps)

subsubsection\<open>Object map\<close>

mk_VLambda the_cf_discrete_components(1)
  |vsv the_cf_discrete_ObjMap_vsv[cat_discrete_cs_intros]|
  |vdomain the_cf_discrete_ObjMap_vdomain[cat_discrete_cs_simps]|
  |app the_cf_discrete_ObjMap_app[cat_discrete_cs_simps]|

lemma (in cf_discrete) cf_discrete_the_cf_discrete_ObjMap_vrange:
  "\<R>\<^sub>\<circ> (:\<rightarrow>: I F \<CC>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using cf_discrete_is_functor_cf_CId_selector_is_arr
  unfolding the_cf_discrete_components
  by (intro vrange_VLambda_vsubset) auto

subsubsection\<open>Arrow map\<close>

mk_VLambda the_cf_discrete_components(2)
  |vsv the_cf_discrete_ArrMap_vsv[cat_discrete_cs_intros]|
  |vdomain the_cf_discrete_ArrMap_vdomain[cat_discrete_cs_simps]|
  |app the_cf_discrete_ArrMap_app[cat_discrete_cs_simps]|

lemma (in cf_discrete) cf_discrete_the_cf_discrete_ArrMap_vrange:
  "\<R>\<^sub>\<circ> (:\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
  using cf_discrete_is_functor_cf_CId_selector_is_arr
  unfolding the_cf_discrete_components
  by (intro vrange_VLambda_vsubset) (auto simp: cf_discrete_selector_vrange)

subsubsection\<open>Discrete functor is a functor\<close>

lemma (in cf_discrete) cf_discrete_the_cf_discrete_is_functor:
  ":\<rightarrow>: I F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof(intro is_functorI')
  show "vfsequence (:\<rightarrow>: I F \<CC>)" unfolding the_cf_discrete_def by simp
  show "category \<alpha> (:\<^sub>C I)"
    by
      (
        simp add:
          cat_discrete_the_cat_discrete
          cf_discrete_vdomain_vsubset_Vset
          cat_discrete.axioms(1)
      )
  show "vcard (:\<rightarrow>: I F \<CC>) = 4\<^sub>\<nat>"
    unfolding the_cf_discrete_def by (simp add: nat_omega_simps)
  show
    ":\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> : :\<rightarrow>: I F \<CC>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> :\<rightarrow>: I F \<CC>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
    if "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b" for f a b
  proof-
    from that have fba: "f = a" "b = a" and a: "a \<in>\<^sub>\<circ> I"
      unfolding the_cat_discrete_is_arrD[OF that] by (simp_all add: \<open>a \<in>\<^sub>\<circ> I\<close>)
    from that \<open>a \<in>\<^sub>\<circ> I\<close> show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_discrete_cs_simps fba cs_intro: cat_discrete_cs_intros
        )
  qed
  show ":\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>\<lparr>g \<circ>\<^sub>A\<^bsub>:\<^sub>C I\<^esub> f\<rparr> =
    :\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> :\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
    if "g : b \<mapsto>\<^bsub>:\<^sub>C I\<^esub> c" and "f : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b" for g b c f a
  proof-
    from that have gfacb: "f = a" "a = b" "g = b" "c = b" and b: "b \<in>\<^sub>\<circ> I"
      by
        (
          simp_all add:
            the_cat_discrete_is_arrD(8-9)[OF that(1)]
            the_cat_discrete_is_arrD(5-9)[OF that(2)]
        )
    have "F b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by (simp add: b cf_discrete_selector_vrange)
    from b category_axioms this show ?thesis
      using that
      unfolding gfacb
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_discrete_cs_simps cs_intro: cat_cs_intros
        )
  qed
  show ":\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>\<lparr>:\<^sub>C I\<lparr>CId\<rparr>\<lparr>c\<rparr>\<rparr> = \<CC>\<lparr>CId\<rparr>\<lparr>:\<rightarrow>: I F \<CC>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>\<rparr>"
    if "c \<in>\<^sub>\<circ> :\<^sub>C I\<lparr>Obj\<rparr>" for c
    using that
    unfolding the_cat_discrete_components(1)
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_discrete_cs_simps cs_intro: cat_cs_intros
      )
qed
  (
    auto simp:
      the_cf_discrete_components
      the_cat_discrete_components
      cat_cs_intros
      cat_discrete_cs_intros
  )

lemma (in cf_discrete) cf_discrete_the_cf_discrete_is_functor':
  assumes "\<AA>' = :\<^sub>C I" and "\<CC>' = \<CC>"
  shows ":\<rightarrow>: I F \<CC> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule cf_discrete_the_cf_discrete_is_functor)

lemmas [cat_discrete_cs_intros] =
  cf_discrete.cf_discrete_the_cf_discrete_is_functor'

subsubsection\<open>Uniqueness of the discrete category\<close>

lemma (in cat_discrete) cat_discrete_iso_the_cat_discrete:
  assumes "I \<subseteq>\<^sub>\<circ> Vset \<alpha>" and "I \<approx>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  obtains F where ":\<rightarrow>: I F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<CC>"
proof-

  from assms obtain F where v11_f: "v11 F"
    and dr[simp]: "\<D>\<^sub>\<circ> F = I" "\<R>\<^sub>\<circ> F = \<CC>\<lparr>Obj\<rparr>"
    by auto
  let ?F = "\<lambda>i. F\<lparr>i\<rparr>"
  interpret F: v11 F by (rule v11_f)
  from assms(1) interpret \<CC>: cf_discrete \<alpha> I ?F \<CC>
    apply(intro cf_discreteI)
    unfolding dr[symmetric]
    by (cs_concl cs_shallow cs_intro: V_cs_intros cat_cs_intros)+
  have ":\<rightarrow>: I ?F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> \<CC>"
  proof(intro is_iso_functorI')
    from \<CC>.cf_discrete_selector_vrange show
      ":\<rightarrow>: I ?F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
      by (intro cf_discrete.cf_discrete_the_cf_discrete_is_functor cf_discreteI)
        (auto simp: category_axioms assms(1))
    show "v11 (:\<rightarrow>: I ?F \<CC>\<lparr>ArrMap\<rparr>)"
    proof(rule vsv.vsv_valeq_v11I, unfold the_cf_discrete_ArrMap_vdomain)
      fix i j assume prems:
        "i \<in>\<^sub>\<circ> I" "j \<in>\<^sub>\<circ> I" ":\<rightarrow>: I ?F \<CC>\<lparr>ArrMap\<rparr>\<lparr>i\<rparr> = :\<rightarrow>: I ?F \<CC>\<lparr>ArrMap\<rparr>\<lparr>j\<rparr>"
      from prems(3) have "\<CC>\<lparr>CId\<rparr>\<lparr>?F i\<rparr> = \<CC>\<lparr>CId\<rparr>\<lparr>?F j\<rparr>"
        unfolding
          the_cf_discrete_ArrMap_app[OF prems(1)]
          the_cf_discrete_ArrMap_app[OF prems(2)].
      then have "?F i = ?F j"
        by
          (
            metis
              \<CC>.cf_discrete_is_functor_cf_CId_selector_is_arr
              prems(1,2)
              cat_is_arrD(4)
          )
      with F.v11_eq_iff prems show "i = j" by simp
    qed (simp add: the_cf_discrete_components)
    show "\<R>\<^sub>\<circ> (:\<rightarrow>: I ?F \<CC>\<lparr>ArrMap\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    proof(intro vsubset_antisym vsubsetI)
      fix f assume "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (:\<rightarrow>: I ?F \<CC>\<lparr>ArrMap\<rparr>)"
      with \<CC>.cf_discrete_the_cf_discrete_ArrMap_vrange show "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
        by auto
    next
      fix f assume "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
      then obtain a b where "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" by auto
      then obtain a where f_def: "f = \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr>" and a: "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto
      from a F.vrange_atD dr obtain i where a_def: "a = ?F i" and i: "i \<in>\<^sub>\<circ> I"
        by blast
      from a i show "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (:\<rightarrow>: I ?F \<CC>\<lparr>ArrMap\<rparr>)"
        unfolding a_def f_def the_cf_discrete_components by auto
    qed
  qed (auto simp: v11_f the_cf_discrete_components)
  with that show ?thesis by simp

qed

subsubsection\<open>Opposite discrete functor\<close>

lemma (in cf_discrete) cf_discrete_the_cf_discrete_op[cat_op_simps]:
  "op_cf (:\<rightarrow>: I F \<CC>) = :\<rightarrow>: I F (op_cat \<CC>)"
proof(rule cf_eqI)
  from cf_discrete_vdomain_vsubset_Vset show
    "op_cf (:\<rightarrow>: I F \<CC>) : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_op_simps cs_intro: cat_op_intros cat_discrete_cs_intros
      )
  show ":\<rightarrow>: I F (op_cat \<CC>) : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  proof(intro cf_discrete.cf_discrete_the_cf_discrete_is_functor cf_discreteI)
    fix i assume "i \<in>\<^sub>\<circ> I"
    then show "F i \<in>\<^sub>\<circ> op_cat \<CC>\<lparr>Obj\<rparr>"
      by (simp add: cat_op_simps cf_discrete_selector_vrange)
  qed (intro cf_discrete_vdomain_vsubset_Vset cat_cs_intros)+
qed (unfold cat_op_simps the_cf_discrete_components, simp_all)

lemmas [cat_op_simps] = cf_discrete.cf_discrete_the_cf_discrete_op

lemma (in cf_discrete) cf_discrete_op[cat_op_intros]:
  "cf_discrete \<alpha> I F (op_cat \<CC>)"
proof(intro cf_discreteI)
  show "category \<alpha> (op_cat \<CC>)"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  fix i assume "i \<in>\<^sub>\<circ> I"
  then show "F i \<in>\<^sub>\<circ> op_cat \<CC>\<lparr>Obj\<rparr>"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_op_simps cs_intro: cat_discrete_cs_intros
      )
qed (intro cf_discrete_vdomain_vsubset_Vset)

lemmas [cat_op_intros] = cf_discrete.cf_discrete_op

subsection\<open>Tiny discrete category\<close>

subsubsection\<open>Background\<close>

named_theorems cat_small_discrete_cs_simps
named_theorems cat_small_discrete_cs_intros

lemmas [cat_small_discrete_cs_simps] = cat_discrete_cs_simps
lemmas [cat_small_discrete_cs_intros] = cat_discrete_cs_intros

subsubsection\<open>Definition and elementary properties\<close>

locale tiny_cat_discrete = cat_discrete \<alpha> \<CC> + tiny_category \<alpha> \<CC> for \<alpha> \<CC>

text\<open>Rules.\<close>

lemma (in tiny_cat_discrete) tiny_cat_discrete_axioms'[cat_discrete_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "tiny_cat_discrete \<alpha>' \<CC>'"
  unfolding assms by (rule tiny_cat_discrete_axioms)

mk_ide rf tiny_cat_discrete_def
  |intro tiny_cat_discreteI|
  |dest tiny_cat_discreteD[dest]|
  |elim tiny_cat_discreteE[elim]|

lemmas [cat_small_discrete_cs_intros] = tiny_cat_discreteD

lemma tiny_cat_discreteI':
  assumes "tiny_category \<alpha> \<CC>" and "\<And>f. f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr> \<Longrightarrow> f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>)"
  shows "tiny_cat_discrete \<alpha> \<CC>"
proof(intro tiny_cat_discreteI cat_discreteI)
  interpret tiny_category \<alpha> \<CC> by (rule assms(1))
  show "category \<alpha> \<CC>" by (auto intro: tiny_cat_category)
  show "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>)" if "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>" for f using that by (rule assms(2))
qed (auto intro: assms(1))

subsubsection\<open>The discrete category is a tiny category\<close>

lemma (in \<Z>) tiny_cat_discrete_the_cat_discrete[cat_small_discrete_cs_intros]:
  assumes "I \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "tiny_cat_discrete \<alpha> (:\<^sub>C I)"
proof(intro tiny_cat_discreteI cat_discrete_the_cat_discrete)
  from assms show "I \<subseteq>\<^sub>\<circ> Vset \<alpha>" by auto
  then interpret cat_discrete \<alpha> \<open>:\<^sub>C I\<close> by (intro cat_discrete_the_cat_discrete)
  show "tiny_category \<alpha> (:\<^sub>C I)"
    by (intro tiny_categoryI', unfold the_cat_discrete_components)
      (auto intro: cat_cs_intros assms)
qed

lemmas [cat_small_discrete_cs_intros] = \<Z>.cat_discrete_the_cat_discrete

subsection\<open>Discrete functor with tiny maps\<close>

subsubsection\<open>Definition and elementary properties\<close>

locale tm_cf_discrete = category \<alpha> \<CC> for \<alpha> I F \<CC> +
  assumes tm_cf_discrete_selector_vrange[cat_small_discrete_cs_intros]:
    "i \<in>\<^sub>\<circ> I \<Longrightarrow> F i \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and tm_cf_discrete_ObjMap_in_Vset: "VLambda I F \<in>\<^sub>\<circ> Vset \<alpha>"
    and tm_cf_discrete_ArrMap_in_Vset: "(\<lambda>i\<in>\<^sub>\<circ>I. \<CC>\<lparr>CId\<rparr>\<lparr>F i\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"

text\<open>Rules.\<close>

lemma (in tm_cf_discrete) tm_cf_discrete_axioms'[cat_small_discrete_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "I' = I" and "F' = F"
  shows "tm_cf_discrete \<alpha>' I' F' \<CC>"
  unfolding assms by (rule tm_cf_discrete_axioms)

mk_ide rf tm_cf_discrete_def[unfolded tm_cf_discrete_axioms_def]
  |intro tm_cf_discreteI|
  |dest tm_cf_discreteD[dest]|
  |elim tm_cf_discreteE[elim]|

lemma tm_cf_discreteI':
  assumes "cf_discrete \<alpha> I F \<CC>"
    and "(\<lambda>i\<in>\<^sub>\<circ>I. F i) \<in>\<^sub>\<circ> Vset \<alpha>"
    and "(\<lambda>i\<in>\<^sub>\<circ>I. \<CC>\<lparr>CId\<rparr>\<lparr>F i\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "tm_cf_discrete \<alpha> I F \<CC>"
proof-
  interpret cf_discrete \<alpha> I F \<CC> by (rule assms(1))
  show ?thesis
    by (intro tm_cf_discreteI)
      (auto intro: assms cf_discrete_selector_vrange cat_cs_intros)
qed

text\<open>Elementary properties.\<close>

sublocale tm_cf_discrete \<subseteq> cf_discrete
proof(intro cf_discreteI)
  from tm_cf_discrete_ObjMap_in_Vset have "\<D>\<^sub>\<circ> (\<lambda>i\<in>\<^sub>\<circ>I. F i) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (cs_concl cs_shallow cs_intro: vdomain_in_VsetI)
  then show "I \<subseteq>\<^sub>\<circ> Vset \<alpha>" by auto
qed (auto intro: cat_cs_intros tm_cf_discrete_selector_vrange)

lemmas (in tm_cf_discrete) tm_cf_discrete_is_cf_discrete_axioms =
  cf_discrete_axioms

lemmas [cat_small_discrete_cs_intros] =
  tm_cf_discrete.tm_cf_discrete_is_cf_discrete_axioms

lemma (in tm_cf_discrete)
  tm_cf_discrete_index_in_Vset[cat_small_discrete_cs_intros]:
  "I \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  from tm_cf_discrete_ObjMap_in_Vset have "\<D>\<^sub>\<circ> (\<lambda>i\<in>\<^sub>\<circ>I. F i) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (cs_concl cs_shallow cs_intro: vdomain_in_VsetI)
  then show ?thesis by simp
qed

subsubsection\<open>Opposite discrete functor with tiny maps\<close>

lemma (in tm_cf_discrete) tm_cf_discrete_op[cat_op_intros]:
  "tm_cf_discrete \<alpha> I F (op_cat \<CC>)"
  using tm_cf_discrete_ObjMap_in_Vset tm_cf_discrete_ArrMap_in_Vset
  by (intro tm_cf_discreteI' cf_discrete_op) (auto simp: cat_op_simps)

lemmas [cat_op_intros] = tm_cf_discrete.tm_cf_discrete_op

subsubsection\<open>Discrete functor with tiny maps is a functor with tiny maps\<close>

lemma (in tm_cf_discrete) tm_cf_discrete_the_cf_discrete_is_tm_functor:
  ":\<rightarrow>: I F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
  by (intro is_tm_functorI' cf_discrete_the_cf_discrete_is_functor)
    (
      auto simp:
        the_cf_discrete_components
        tm_cf_discrete_ObjMap_in_Vset
        tm_cf_discrete_ArrMap_in_Vset
    )

lemma (in tm_cf_discrete) tm_cf_discrete_the_cf_discrete_is_tm_functor':
  assumes "\<AA>' = :\<^sub>C I" and "\<CC>' = \<CC>"
  shows ":\<rightarrow>: I F \<CC> : \<AA>' \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule tm_cf_discrete_the_cf_discrete_is_tm_functor)

lemmas [cat_discrete_cs_intros] =
  tm_cf_discrete.tm_cf_discrete_the_cf_discrete_is_tm_functor'

text\<open>\newpage\<close>

end


theory Scratch
  imports AssumeGuarantee
begin

datatype n = None

definition X :: char where "X = CHR ''x''"

definition P1 :: "n proc" where
"P1 = Rep (Interrupt (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_ . 1)))) (\<lambda>_ . True) [(''ch1''[!](\<lambda> (a,s). s X) ,Cm (''ch2''[?]X))])"

definition P2 :: "n proc" where
"P2 = Rep (Wait (\<lambda> s. 1);Cm (''ch1''[?]X);Cm (''ch2''[!](\<lambda> (a,s). s X - 1)))"

inductive p1_assn :: "state \<Rightarrow> (real \<times> real) list \<Rightarrow> n tassn" where
  "p1_assn s [] []"
| "(d = 1 \<and> x = s X) \<longrightarrow> p1_assn (s(X := x)) rest tr3 \<Longrightarrow>
   (WaitOut\<^sub>t d None (\<lambda> t. s(X := s X + t)) (''ch1'') (\<lambda> (a,s). s X) ({''ch1''},{}) tr1 \<and>
   In\<^sub>t (EState (None,s(X := s X + d))) (''ch2'') x tr2) \<Longrightarrow>
   p1_assn s ((d,x)#rest) (tr1@tr2@tr3)"

lemma p1_0:
"p1_assn s [] = emp\<^sub>t"
   using p1_assn.cases
   apply(auto simp add: emp_assn_def)
   using p1_assn.intros(1) by blast

lemma p1_1:
  assumes "d = 1 \<and> x = s X"
  shows "p1_assn s ((d,x)#rest) =
    WaitOut\<^sub>t d None (\<lambda> t. s(X := s X + t)) (''ch1'') (\<lambda> (a,s). s X) ({''ch1''},{}) @\<^sub>t
    In\<^sub>t (EState (None,s(X := s X + d))) (''ch2'') x @\<^sub>t
    p1_assn (s(X := x)) rest"
  apply (rule ext)
  subgoal for tr
  proof-
    have 1:"p1_assn s ((d, x) # rest) tr \<Longrightarrow>
    (WaitOut\<^sub>t d n.None (\<lambda>t. s(X := s X + t)) ''ch1'' (\<lambda>(a, s). s X) ({''ch1''}, {}) @\<^sub>t
     In\<^sub>t (EState (n.None, s(X := s X + d))) ''ch2'' x @\<^sub>t p1_assn (s(X := x)) rest) tr "
      apply(rule p1_assn.cases[of s "((d, x) # rest)" tr])
      by (auto simp add: assms join_assn_def)
    have 2:"(WaitOut\<^sub>t d n.None (\<lambda>t. s(X := s X + t)) ''ch1'' (\<lambda>(a, s). s X) ({''ch1''}, {}) @\<^sub>t
     In\<^sub>t (EState (n.None, s(X := s X + d))) ''ch2'' x @\<^sub>t p1_assn (s(X := x)) rest) tr
            \<Longrightarrow> p1_assn s ((d, x) # rest) tr"
      apply (auto simp add: join_assn_def)
      subgoal for tr1 tr2 tr3
        using p1_assn.intros(2)[of d x s rest tr3 tr1 tr2]
        using assms by auto
      done
    show ?thesis
      using 1 2 by auto
  qed
  done

lemma p1_3:
  "p1_assn s ((d,x)#rest) =
   WaitOut\<^sub>t d None (\<lambda> t. s(X := s X + t)) (''ch1'') (\<lambda> (a,s). s X) ({''ch1''},{}) @\<^sub>t
   In\<^sub>t (EState (None,s(X := s X + d))) (''ch2'') x @\<^sub>t
   (\<up>(d = 1 \<and> x = s X) \<longrightarrow>\<^sub>t p1_assn (s(X := x)) rest)"
  apply(rule ext)
  subgoal for tr
  proof-
    have 1:"p1_assn s ((d, x) # rest) tr \<Longrightarrow>
    (WaitOut\<^sub>t d n.None (\<lambda>t. s(X := s X + t)) ''ch1'' (\<lambda>(a, s). s X) ({''ch1''}, {}) @\<^sub>t
     In\<^sub>t (EState (n.None, s(X := s X + d))) ''ch2'' x @\<^sub>t
     (\<up> (d = 1 \<and> x = s X) \<longrightarrow>\<^sub>t p1_assn (s(X := x)) rest)) tr "
      apply(rule p1_assn.cases[of s "(d, x) # rest" tr])
        apply simp
      subgoal by auto
      by (auto simp add: pure_assn_def imp_assn_def join_assn_def)
    have 2:"(WaitOut\<^sub>t d n.None (\<lambda>t. s(X := s X + t)) ''ch1'' (\<lambda>(a, s). s X) ({''ch1''}, {}) @\<^sub>t
     In\<^sub>t (EState (n.None, s(X := s X + d))) ''ch2'' x @\<^sub>t
     (\<up> (d = 1 \<and> x = s X) \<longrightarrow>\<^sub>t p1_assn (s(X := x)) rest)) tr
          \<Longrightarrow> p1_assn s ((d, x) # rest) tr "
      apply(auto simp add:join_assn_def)
      subgoal for tr1 tr2 tr3
        using p1_assn.intros(2)[of d x s rest tr3 tr1 tr2]
        by(auto simp add: pure_assn_def imp_assn_def)
      done
    show ?thesis
      using 1 2 by auto
  qed
  done

lemma P1_rep:
"\<Turnstile> {\<lambda> s tr. s = (None,ss) \<and> emp\<^sub>t tr}
    P1
    {\<lambda> s tr. \<exists> l. s = (None,ss(X := snd(last ((0,ss X)#l)))) \<and> p1_assn ss l tr}"
  unfolding P1_def
  apply(rule Valid_weaken_pre)
  prefer 2
   apply(rule Valid_rep)
  subgoal
    apply(rule Valid_ex_pre)
    subgoal for l
      sorry
    done
  sorry

inductive p2_assn :: "state \<Rightarrow> real list \<Rightarrow> n tassn" where
  "p2_assn s [] []"
| "p2_assn (s(X:=x)) rest tr4 \<Longrightarrow>
   Wait\<^sub>t 1 (\<lambda> _ . EState (None,s)) ({},{}) tr1 \<and>
   In\<^sub>t (EState (None,s)) (''ch1'') x tr2 \<and>
   Out\<^sub>t (EState (None,s(X:=x))) (''ch2'') (x-1) tr3 \<Longrightarrow>
   p2_assn s (x#rest)(tr1@tr2@tr3@tr4)"

lemma p2_0:
"p2_assn s [] = emp\<^sub>t"
   using p2_assn.cases
   apply(auto simp add: emp_assn_def)
   using p2_assn.intros(1) by blast

lemma p2_1:
"p2_assn s (x#l2) = Wait\<^sub>t 1 (\<lambda> _ . EState (None,s)) ({},{}) @\<^sub>t
   In\<^sub>t (EState (None,s)) (''ch1'') x @\<^sub>t
   Out\<^sub>t (EState (None,s(X:=x))) (''ch2'') (x-1) @\<^sub>t
   p2_assn (s(X:=x)) l2"
  apply(rule ext)
  subgoal for tr
  proof-
    have 1:"p2_assn s (x # l2) tr \<Longrightarrow>
    (Wait\<^sub>t 1 (\<lambda>_. EState (n.None, s)) ({}, {}) @\<^sub>t
     In\<^sub>t (EState (n.None, s)) ''ch1'' x @\<^sub>t
     Out\<^sub>t (EState (n.None, s(X := x))) ''ch2'' (x - 1) @\<^sub>t p2_assn (s(X := x)) l2) tr"
      apply(rule p2_assn.cases[of s "(x # l2)" tr])
        apply auto
      apply(auto simp add:join_assn_def) by blast
    have 2:"(Wait\<^sub>t 1 (\<lambda>_. EState (n.None, s)) ({}, {}) @\<^sub>t
     In\<^sub>t (EState (n.None, s)) ''ch1'' x @\<^sub>t
     Out\<^sub>t (EState (n.None, s(X := x))) ''ch2'' (x - 1) @\<^sub>t p2_assn (s(X := x)) l2) tr
            \<Longrightarrow> p2_assn s (x # l2) tr"
      apply (auto simp add: join_assn_def)
      subgoal for tr1 tr2 tr3 tr4
        using p2_assn.intros(2)[of s x l2 tr4 tr1 tr2 tr3] by auto
      done
    show ?thesis using 1 2 by auto
  qed
  done

inductive t_assn :: "state \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> n tassn" where
  "t_assn s s' 0 []"
| "t_assn s (s'(X := s X + 1)) m tr4 \<Longrightarrow>
   Wait\<^sub>t 1 (\<lambda> t . ParState (EState (None,s(X:= s X + t))) (EState (None,s'))) ({''ch1''},{}) tr1 \<and>
   IO\<^sub>t (''ch1'') (s X + 1) tr2 \<and>
   IO\<^sub>t (''ch2'') (s X) tr3 \<Longrightarrow>
   t_assn s s' (m+1) (tr1@tr2@tr3@tr4)"

lemma t_0:
"t_assn s s' 0 = emp\<^sub>t"
   using t_assn.cases
   apply(auto simp add: emp_assn_def)
   using t_assn.intros(1) by blast

lemma t_1:
"t_assn s s' (Suc n) =
   Wait\<^sub>t 1 (\<lambda> t . ParState (EState (None,s(X:= s X + t))) (EState (None,s'))) ({''ch1''},{}) @\<^sub>t
   IO\<^sub>t (''ch1'') (s X + 1) @\<^sub>t
   IO\<^sub>t (''ch2'') (s X) @\<^sub>t
   t_assn s (s'(X := s X + 1)) n"
  apply(rule ext)
  subgoal for tr
  proof-
    have 1:"t_assn s s' (Suc n) tr \<Longrightarrow>
    (Wait\<^sub>t 1 (\<lambda>t. ParState (EState (n.None, s(X := s X + t))) (EState (n.None, s')))
      ({''ch1''}, {}) @\<^sub>t
     IO\<^sub>t ''ch1'' (s X + 1) @\<^sub>t IO\<^sub>t ''ch2'' (s X) @\<^sub>t t_assn s (s'(X := s X + 1)) n)tr "
      apply(rule t_assn.cases[of s s'"Suc n" tr])
        apply(auto simp add:join_assn_def) by blast
    have 2:"(Wait\<^sub>t 1 (\<lambda>t. ParState (EState (n.None, s(X := s X + t))) (EState (n.None, s')))
      ({''ch1''}, {}) @\<^sub>t
     IO\<^sub>t ''ch1'' (s X + 1) @\<^sub>t IO\<^sub>t ''ch2'' (s X) @\<^sub>t t_assn s (s'(X := s X + 1)) n) tr
            \<Longrightarrow> t_assn s s' (Suc n) tr"
      apply(auto simp add: join_assn_def)
      subgoal for tr1 tr2 tr3 tr4
        using t_assn.intros(2)[of s s' n tr4 tr1 tr2 tr3]
        by auto
      done
    show ?thesis
      using 1 2 by auto
  qed
  done

lemma combine:
"combine_assn {''ch1'',''ch2''} (p1_assn s l1) (p2_assn s' l2) \<Longrightarrow>\<^sub>t t_assn s s' (length l1)"
proof(induction l1 arbitrary: s s' l2)
  case Nil
  then show ?case
  proof(cases l2)
    case Nil
    then show ?thesis
      apply (auto simp add:entails_tassn_def)
      subgoal for tr
        using p1_0 p2_0 t_0  by simp
      done
  next
    case (Cons a list)
    then show ?thesis
      apply (auto simp add:p1_0 p2_1)
      apply (subst combine_assn_emp_wait)
      apply simp
      by (rule false_assn_entails)
  qed
next
  case (Cons a l1')
  note Cons1 = Cons
  then show ?case
  proof (cases l2)
    case Nil
    then show ?thesis
      apply(cases a)
      apply(auto simp add:p1_3 p2_0)
      apply(rule entails_tassn_trans)
       apply(rule combine_assn_waitout_emp)
      by auto
  next
    case (Cons b l2')
    then show ?thesis
      apply auto
      apply(cases a)
      subgoal for d x
        apply (auto simp add:p1_3 p2_1 t_1)
        apply(rule entails_tassn_trans)
         apply(rule combine_assn_waitout_wait)
           apply auto
        apply(rule entails_tassn_cancel_left)
        apply(rule entails_tassn_trans)
         apply(rule combine_assn_waitout_in)
          apply auto
        apply(rule entails_tassn_cancel_left)
        apply(rule entails_tassn_trans)
         apply(rule combine_assn_in_out)
         apply auto
        apply(rule entails_tassn_cancel_left)
        using Cons1[of s "(s'(X := s X + 1))" l2']
        apply (auto simp add: pure_assn_def imp_assn_def)
        using \<open>combine_assn {''ch1'', ''ch2''} (p1_assn s l1') (p2_assn (s'(X := s X + 1)) l2') \<Longrightarrow>\<^sub>t t_assn s (s'(X := s X + 1)) (length l1')\<close> by force
      done
  qed
qed

fun p1_assn' :: "nat \<Rightarrow> state \<Rightarrow> n tassn" where
  "p1_assn' 0 s tr \<longleftrightarrow> (emp\<^sub>t tr)"
| "p1_assn' (Suc k) s tr \<longleftrightarrow>
   waitout_assm_assn {1} (\<lambda>t. EState(None, s(X := s X + t))) ({''ch1''},{}) ''ch1'' (\<lambda>_ .1)
   (in_orig_assn ''ch2'' 0 (EState(None,s(X := s X + 1))) (p1_assn' k (s(X:=0)))) tr"

fun p2_assn' :: "nat \<Rightarrow> state \<Rightarrow> n tassn" where
  "p2_assn' 0 s tr \<longleftrightarrow> (emp\<^sub>t tr)"
| "p2_assn' (Suc k) s tr \<longleftrightarrow>
   wait_orig_assn 1 (\<lambda> _ . EState (None,s)) ({},{})
   (in_orig_assn ''ch1'' 1 (EState (None,s)) (out_orig_assn ''ch2'' 0 (EState (None,s(X:=1))) (p2_assn' k (s(X:=1))))) tr
   "

fun t_assn' :: "nat \<Rightarrow> state \<Rightarrow> state \<Rightarrow> n tassn" where
  "t_assn' 0 s s' tr \<longleftrightarrow> (emp\<^sub>t tr)"
| "t_assn' (Suc k) s s' tr \<longleftrightarrow>
   wait_orig_assn 1 (\<lambda> t . ParState (EState(None, s(X := s X + t))) (EState (None,s'))) ({''ch1''},{})
   (io_orig_assn ''ch1'' 1
   (io_orig_assn ''ch2'' 0 (t_assn' k (s(X:=0)) (s'(X:=1))))) tr
   "

lemma combine':
"combine_assn {''ch1'',''ch2''} (p1_assn' m1 s1) (p2_assn' m2 s2) \<Longrightarrow>\<^sub>t t_assn' m1 s1 s2"
proof(induction m1 arbitrary: s1 s2 m2)
  case 0
  then show ?case
  proof(cases m2)
    case 0
    then show ?thesis
      by auto
  next
    case (Suc nat)
    then show ?thesis
      apply auto
      apply(rule combine_emp_wait_orig1)
      by auto
  qed
next
  case (Suc m1)
  note suc = Suc
  then show ?case
  proof(cases m2)
    case 0
    then show ?thesis
      apply auto
      apply(rule combine_waitout_assm_emp1)
      by auto
  next
    case (Suc nat)
    then show ?thesis
      apply auto
      apply(subst wait_orig_to_guard)
      apply(rule entails_tassn_trans)
       apply(rule combine_waitout_assm_wait_guar1)
        apply auto
      apply(subst wait_orig_to_guard')
      apply(rule wait_guar'_assn_tran)
      apply auto
      apply(rule entails_tassn_trans)
       apply(rule combine_waitout_assm_in_orig1)
      apply(auto simp add:wait_set_minus_def)
      apply(rule io_orig_assn_tran)
      apply(rule entails_tassn_trans)
       apply(rule combine_in_orig_out_orig1)
      apply auto
      apply(rule io_orig_assn_tran)
      using suc by auto
  qed
qed

end