(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Code Equations for Determinants\<close>

text \<open>We compute determinants on arbitrary rings by applying elementary row-operations
  to bring a matrix on upper-triangular form. Then the determinant can be determined
  by multiplying all entries on the diagonal. Moreover the final result has to be divided
  by a factor which is determined by the row-operations that we performed. To this end,
  we require a division operation on the element type.

  The algorithm is parametric in a selection function for the pivot-element, e.g., for
  matrices over polynomials it turned out that selecting a polynomial of minimal degree
  is beneficial.\<close>

theory Determinant_Impl
imports
  Polynomial_Interpolation.Missing_Polynomial
  "HOL-Computational_Algebra.Polynomial_Factorial"
  Determinant
begin

type_synonym 'a det_selection_fun = "(nat \<times> 'a)list \<Rightarrow> nat"

definition det_selection_fun :: "'a det_selection_fun \<Rightarrow> bool" where
  "det_selection_fun f = (\<forall> xs. xs \<noteq> [] \<longrightarrow> f xs \<in> fst ` set xs)"

lemma det_selection_funD: "det_selection_fun f \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> f xs \<in> fst ` set xs"
  unfolding det_selection_fun_def by auto

definition mute_fun :: "('a :: comm_ring_1 \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a) \<Rightarrow> bool" where
  "mute_fun f = (\<forall> x y x' y' g. f x y = (x',y',g) \<longrightarrow> y \<noteq> 0
   \<longrightarrow> x = x' * g \<and> y * x' = x * y')"

context
  fixes sel_fun :: "'a ::idom_divide det_selection_fun"
begin

subsection \<open>Properties of triangular matrices\<close>

text \<open>
  Each column of a triangular matrix should satisfy the following property.
\<close>

definition triangular_column::"nat \<Rightarrow> 'a mat \<Rightarrow> bool"
  where "triangular_column j A \<equiv> \<forall>i. j < i \<longrightarrow> i < dim_row A \<longrightarrow> A $$ (i,j) = 0"

lemma triangular_columnD [dest]:
  "triangular_column j A \<Longrightarrow> j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0"
  unfolding triangular_column_def by auto

lemma triangular_columnI [intro]:
  "(\<And>i. j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0) \<Longrightarrow> triangular_column j A"
  unfolding triangular_column_def by auto

text \<open>
  The following predicate states that the first $k$ columns satisfy
  triangularity.
\<close>

definition triangular_to:: "nat \<Rightarrow> 'a mat \<Rightarrow> bool"
  where "triangular_to k A == \<forall>j. j<k \<longrightarrow> triangular_column j A"

lemma triangular_to_triangular: "upper_triangular A = triangular_to (dim_row A) A"
  unfolding triangular_to_def triangular_column_def upper_triangular_def
  by auto

lemma triangular_toD [dest]:
  "triangular_to k A \<Longrightarrow> j < k \<Longrightarrow> j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0"
  unfolding triangular_to_def triangular_column_def by auto

lemma triangular_toI [intro]:
  "(\<And>i j. j < k \<Longrightarrow> j < i \<Longrightarrow> i < dim_row A \<Longrightarrow> A $$ (i,j) = 0) \<Longrightarrow> triangular_to k A"
  unfolding triangular_to_def triangular_column_def by auto

lemma triangle_growth:
  assumes tri:"triangular_to k A"
  and col:"triangular_column k A"
  shows "triangular_to (Suc k) A"
  unfolding triangular_to_def
proof (intro allI impI)
  fix i assume iSk:"i < Suc k"
  show "triangular_column i A"
  proof (cases "i = k")
    case True
      then show ?thesis using col by auto next
    case False
      then have "i < k" using iSk by auto
      thus ?thesis using tri unfolding triangular_to_def by auto
  qed
qed

lemma triangle_trans: "triangular_to k A \<Longrightarrow> k > k' \<Longrightarrow> triangular_to k' A"
  by (intro triangular_toI, elim triangular_toD, auto)

subsection \<open>Algorithms for Triangulization\<close>

context
  fixes mf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a"
begin

private fun mute :: "'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<times> 'a mat \<Rightarrow> 'a \<times> 'a mat" where
  "mute A_ll k l (r,A) = (let p = A $$ (k,l) in if p = 0 then (r,A) else
    case mf A_ll p of (q',p',g) \<Rightarrow>
      (r * q', addrow (-p') k l (multrow k q' A)))"

lemma mute_preserves_dimensions:
  assumes "mute q k l (r,A) = (r',A')"
  shows [simp]: "dim_row A' = dim_row A" and [simp]: "dim_col A' = dim_col A"
using assms by (auto simp: Let_def split: if_splits prod.splits)

text \<open>
  Algorithm @{term "mute k l"} makes $k$-th row $l$-th column element to 0.
\<close>

lemma mute_makes_0 :
 assumes mute_fun: "mute_fun mf"
 assumes "mute (A $$ (l,l)) k l (r,A) = (r',A')"
 "l < dim_row A"
 "l < dim_col A"
 "k < dim_row A"
 "k \<noteq> l"
 shows "A' $$ (k,l) = 0"
proof -
  define a where "a = A $$ (l, l)"
  define b where "b = A $$ (k, l)"
  let ?mf = "mf (A $$ (l, l)) (A $$ (k, l))"
  obtain q' p' g where id: "?mf = (q',p',g)" by (cases ?mf, auto)
  note mf = mute_fun[unfolded mute_fun_def, rule_format, OF id]
  from assms show ?thesis
  unfolding mat_addrow_def using mf id by (auto simp: ac_simps Let_def split: if_splits)
qed

text \<open>It will not touch unexpected rows.\<close>
lemma mute_preserves:
  "mute q k l (r,A) = (r',A') \<Longrightarrow>
   i < dim_row A \<Longrightarrow>
   j < dim_col A \<Longrightarrow>
   l < dim_row A \<Longrightarrow>
   k < dim_row A \<Longrightarrow>
   i \<noteq> k \<Longrightarrow>
   A' $$ (i,j) = A $$ (i,j)"
   by (auto simp: Let_def split: if_splits prod.splits)

text \<open>It preserves $0$s in the touched row.\<close>
lemma mute_preserves_0:
  "mute q k l (r,A) = (r',A') \<Longrightarrow>
   i < dim_row A \<Longrightarrow>
   j < dim_col A \<Longrightarrow>
   l < dim_row A \<Longrightarrow>
   k < dim_row A \<Longrightarrow>
   A $$ (i,j) = 0 \<Longrightarrow>
   A $$ (l,j) = 0 \<Longrightarrow>
   A' $$ (i,j) = 0"
   by (auto simp: Let_def split: if_splits prod.splits)

text \<open>Hence, it will respect partially triangular matrix.\<close>
lemma mute_preserves_triangle:
 assumes rA' : "mute q k l (r,A) = (r',A')"
 and triA: "triangular_to l A"
 and lk: "l < k"
 and kr: "k < dim_row A"
 and lr: "l < dim_row A"
 and lc: "l < dim_col A"
 shows "triangular_to l A'"
proof (rule triangular_toI)
  fix i j
  assume jl: "j < l" and ji: "j < i" and ir': "i < dim_row A'"
  then have A0: "A $$ (i,j) = 0" using triA rA' by auto
  moreover have "A $$ (l,j) = 0" using triA jl jl lr by auto
  moreover have jc:"j < dim_col A" using jl lc by auto
  moreover have ir: "i < dim_row A" using ir' rA' by auto
  ultimately show "A' $$ (i,j) = 0"
    using mute_preserves_0[OF rA'] lr kr by auto
qed

text \<open>Recursive application of @{const mute}\<close>

private fun sub1 :: "'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<times> 'a mat \<Rightarrow> 'a \<times> 'a mat"
where "sub1 q 0 l rA = rA"
  | "sub1 q (Suc k) l rA = mute q (l + Suc k) l (sub1 q k l rA)"

lemma sub1_preserves_dimensions[simp]:
  "sub1 q k l (r,A) = (r',A') \<Longrightarrow> dim_row A' = dim_row A"
  "sub1 q k l (r,A) = (r',A') \<Longrightarrow> dim_col A' = dim_col A"
proof (induction k arbitrary: r' A')
  case (Suc k)
    moreover obtain r' A' where rA': "sub1 q k l (r, A) = (r', A')" by force
    moreover fix r'' A'' assume "sub1 q (Suc k) l (r, A) = (r'', A'')"
    ultimately show "dim_row A'' = dim_row A" "dim_col A'' = dim_col A" by auto
qed auto

lemma sub1_closed [simp]:
  "sub1 q k l (r,A) = (r',A') \<Longrightarrow> A \<in> carrier_mat m n \<Longrightarrow> A' \<in> carrier_mat m n"
  unfolding carrier_mat_def by auto

lemma sub1_preserves_diagnal:
  assumes "sub1 q k l (r,A) = (r',A')"
  and "l < dim_col A"
  and "k + l < dim_row A"
  shows "A' $$ (l,l) = A $$ (l,l)"
using assms
proof -
  show "k + l < dim_row A \<Longrightarrow> sub1 q k l (r,A) = (r',A') \<Longrightarrow>
    A' $$ (l,l) = A $$ (l,l)"
  proof (induction k arbitrary: r' A')
    case (Suc k)
      obtain r'' A'' where rA''[simp]: "sub1 q k l (r,A) = (r'',A'')" by force
      have [simp]:"dim_row A'' = dim_row A" and [simp]:"dim_col A'' = dim_col A"
        using snd_conv sub1_preserves_dimensions[OF rA''] by auto
      have "A'' $$ (l,l) = A $$ (l,l)" using assms Suc by auto
      have rA': "mute q (l + Suc k) l (r'', A'') = (r',A')"
        using Suc by auto
      show ?case using subst mute_preserves[OF rA'] Suc assms by auto
  qed auto
qed

text \<open>Triangularity is respected by @{const sub1}.\<close>
lemma sub1_preserves_triangle:
  assumes "sub1 q k l (r,A) = (r',A')"
  and tri: "triangular_to l A"
  and lr: "l < dim_row A"
  and lc: "l < dim_col A"
  and lkr: "l + k < dim_row A"
  shows "triangular_to l A'"
using assms
proof -
  show "sub1 q k l (r,A) = (r',A') \<Longrightarrow> l + k < dim_row A \<Longrightarrow>
    triangular_to l A'"
  proof (induction k arbitrary: r' A')
  case (Suc k)
    then have "sub1 q (Suc k) l (r,A) = (r',A')" by auto
    moreover obtain r'' A''
      where rA'': "sub1 q k l (r, A) = (r'',A'')" by force
    ultimately
      have rA': "mute q (Suc (l + k)) l (r'',A'') = (r',A')" by auto
    have "triangular_to l A''" using rA'' Suc by auto
    thus ?case
      using Suc assms mute_preserves_triangle[OF rA'] rA'' by auto
  qed (insert assms,auto)
qed

context
  assumes mf: "mute_fun mf"
begin
lemma sub1_makes_0s:
  assumes "sub1 (A $$ (l,l)) k l (r,A) = (r',A')"
  and lr: "l < dim_row A"
  and lc: "l < dim_col A"
  and li: "l < i"
  and "i \<le> k + l"
  and "k + l < dim_row A"
  shows "A' $$ (i,l) = 0"
using assms
proof -
  show "sub1 (A $$ (l,l)) k l (r,A) = (r',A') \<Longrightarrow> i \<le> k + l \<Longrightarrow> k + l < dim_row A \<Longrightarrow>
    A' $$ (i,l) = 0"
  using lr lc li
  proof (induction k arbitrary: r' A')
  case (Suc k)
    obtain r' A' where rA': "sub1 (A $$ (l,l)) k l (r, A) = (r',A')" by force
    fix r'' A''
    from sub1_preserves_diagnal[OF rA'] have AA': "A $$ (l, l) = A' $$ (l, l)" using Suc(2-) by auto
    assume "sub1 (A $$ (l,l)) (Suc k) l (r, A) = (r'',A'')"
    then have rA'': "mute (A $$ (l,l)) (Suc (l + k)) l (r', A') = (r'', A'')"
      using rA' by simp
    have ir: "i < dim_row A" using Suc by auto
    have il: "i \<noteq> l" using li by auto
    have lr': "l < dim_row A'" using lr rA' by auto
    have lc': "l < dim_col A'" using lc rA' by auto
    have Slkr': "Suc (l+k) < dim_row A'" using Suc rA' by auto
    show "A'' $$ (i,l) = 0"
    proof (cases "Suc(l + k) = i")
      case True {
        have l: "Suc (l + k) \<noteq> l" by auto
        show ?thesis
          using mute_makes_0[OF mf rA''[unfolded AA'] lr' lc' Slkr' l] ir il rA'
          by (simp add:True)
      } next
      case False {
        then have ikl: "i \<le> k+l" using Suc by auto
        have ir': "i < dim_row A'" using ir rA' by auto
        have lc': "l < dim_col A'" using lc rA' by auto
        have IH: "A' $$ (i,l) = 0" using rA' Suc False by auto
        thus ?thesis using mute_preserves[OF rA'' ir' lc'] rA' False Suc
          by simp
      }
    qed
  qed auto
qed

lemma sub1_triangulizes_column:
  assumes rA': "sub1 (A $$ (l,l)) (dim_row A - Suc l) l (r,A) = (r',A')"
  and tri:"triangular_to l A"
  and r: "dim_row A > 0"
  and lr: "l < dim_row A"
  and lc: "l < dim_col A"
  shows "triangular_column l A'"
proof (intro triangular_columnI)
  fix i
  assume li: "l < i"
  assume ir: "i < dim_row A'"
    also have "... = dim_row A" using sub1_preserves_dimensions[OF rA'] by auto
    also have "... = dim_row A - l + l" using lr li by auto
    finally have ir2: "i \<le> dim_row A - l + l" by auto
  show "A' $$ (i,l) = 0"
    apply (subst sub1_makes_0s[OF rA' lr lc])
    using li ir assms
    by auto
qed

text \<open>
  The algorithm @{const sub1} increases the number of columns that form triangle.
\<close>
lemma sub1_grows_triangle:
  assumes rA': "sub1 (A $$ (l,l)) (dim_row A - Suc l) l (r,A) = (r',A')"
  and r: "dim_row A > 0"
  and tri:"triangular_to l A"
  and lr: "l < dim_row A"
  and lc: "l < dim_col A"
  shows "triangular_to (Suc l) A'"
proof -
  have "triangular_to l A'"
    using sub1_preserves_triangle[OF rA'] assms by auto
  moreover have "triangular_column l A'"
    using sub1_triangulizes_column[OF rA'] assms by auto
  ultimately show ?thesis by (rule triangle_growth)
qed
end

subsection \<open>Finding Non-Zero Elements\<close>

private definition find_non0 :: "nat \<Rightarrow> 'a mat \<Rightarrow> nat option" where
  "find_non0 l A = (let is = [Suc l ..< dim_row A];
    Ais = filter (\<lambda> (i,Ail). Ail \<noteq> 0) (map (\<lambda> i. (i, A $$ (i,l))) is)
    in case Ais of [] \<Rightarrow> None | _ \<Rightarrow> Some (sel_fun Ais))"

lemma find_non0: assumes sel_fun: "det_selection_fun sel_fun"
  and res: "find_non0 l A = Some m"
  shows "A $$ (m,l) \<noteq> 0" "l < m" "m < dim_row A"
proof -
  let ?xs = "filter (\<lambda> (i,Ail). Ail \<noteq> 0) (map (\<lambda> i. (i, A $$ (i,l))) [Suc l..<dim_row A])"
  from res[unfolded find_non0_def Let_def]
  have xs: "?xs \<noteq> []" and m: "m = sel_fun ?xs"
    by (cases ?xs, auto)+
  from det_selection_funD[OF sel_fun xs, folded m] show "A $$ (m, l) \<noteq> 0" "l < m" "m < dim_row A" by auto
qed

text \<open>
  If @{term "find_non0 l A"} fails,
  then $A$ is already triangular to $l$-th column.
\<close>

lemma find_non0_all0:
  "find_non0 l A = None \<Longrightarrow> triangular_column l A"
proof (intro triangular_columnI)
  fix i
  let ?xs = "filter (\<lambda> (i,Ail). Ail \<noteq> 0) (map (\<lambda> i. (i, A $$ (i,l))) [Suc l..<dim_row A])"
  assume none: "find_non0 l A = None" and li: "l < i" "i < dim_row A"
  from none have xs: "?xs = []"
    unfolding find_non0_def Let_def by (cases ?xs, auto)
  from li have "(i, A $$ (i,l)) \<in> set (map (\<lambda> i. (i, A $$ (i,l))) [Suc l..<dim_row A])" by auto
  with xs show "A $$ (i,l) = 0"
    by (metis (mono_tags) xs case_prodI filter_empty_conv)
qed

subsection \<open>Determinant Preserving Growth of Triangle\<close>

text \<open>
  The algorithm @{const sub1} does not preserve determinants when it hits
  a $0$-valued diagonal element. To avoid this case, we introduce the following
  operation:
\<close>

private fun sub2 :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<times> 'a mat \<Rightarrow> 'a \<times> 'a mat"
  where "sub2 d l (r,A) = (
    case find_non0 l A of None \<Rightarrow> (r,A)
    | Some m \<Rightarrow> let A' = swaprows m l A in sub1 (A' $$ (l,l)) (d - Suc l) l (-r, A'))"

lemma sub2_preserves_dimensions[simp]:
  assumes rA': "sub2 d l (r,A) = (r',A')"
  shows "dim_row A' = dim_row A \<and> dim_col A' = dim_col A"
proof (cases "find_non0 l A")
  case None then show ?thesis using rA' by auto next
  case (Some m) then show ?thesis using rA' by (cases "m = l", auto simp: Let_def)
qed

lemma sub2_closed [simp]:
  "sub2 d l (r,A) = (r',A') \<Longrightarrow> A \<in> carrier_mat m n \<Longrightarrow> A' \<in> carrier_mat m n"
  unfolding carrier_mat_def by auto

context
  assumes sel_fun: "det_selection_fun sel_fun"
begin

lemma sub2_preserves_triangle:
  assumes rA': "sub2 d l (r,A) = (r',A')"
  and tri: "triangular_to l A"
  and lc: "l < dim_col A"
  and ld: "l < d"
  and dr: "d \<le> dim_row A"
  shows "triangular_to l A'"
proof -
  have lr: "l < dim_row A" using ld dr by auto
  show ?thesis
  proof (cases "find_non0 l A")
    case None then show ?thesis using rA' tri by simp next
    case (Some m) {
      have lm : "l < m" and mr : "m < dim_row A"
        using find_non0[OF sel_fun Some] by auto
      let ?A1 = "swaprows m l A"

      have tri'': "triangular_to l ?A1"
      proof (intro triangular_toI)
        fix i j
        assume jl:"j < l" and ji:"j < i" and ir1: "i < dim_row ?A1"
        have jm: "j < m" using jl lm by auto
        have ir: "i < dim_row A" using ir1 by auto
        have jc: "j < dim_col A" using jl lc by auto
        show "?A1 $$ (i, j) = 0"
        proof (cases "m=i")
          case True {
            then have li: "l \<noteq> i" using lm by auto
            hence "?A1 $$ (i,j) = A $$ (l,j)" using ir jc \<open>m=i\<close> by auto
            also have "... = 0" using tri jl lr by auto
            finally show ?thesis.
           }  next
          case False show ?thesis
            proof (cases "l=i")
              case True {
                then have "?A1 $$ (i,j) = A $$ (m,j)"
                  using ir jc \<open>m\<noteq>i\<close> by auto
                thus "?A1 $$ (i,j) = 0" using tri jl jm mr by auto
              } next
              case False {
                then have "?A1 $$ (i,j) = A $$ (i,j)"
                  using ir jc \<open>m\<noteq>i\<close> by auto
                thus "?A1 $$ (i,j) = 0" using tri jl ji ir by auto
              }
           qed
        qed
      qed

      let ?rA3 = "sub1 (?A1 $$ (l,l)) (d - Suc l) l (-r,?A1)"
      have [simp]: "dim_row ?A1 = dim_row A \<and> dim_col ?A1 = dim_col A" by auto
      have rA'2: "?rA3 = (r',A')" using rA' Some by (simp add: Let_def)
      have "l + (d - Suc l) < dim_row A" using ld dr by auto
      thus ?thesis
        using sub1_preserves_triangle[OF rA'2 tri''] lr lc rA' by auto
    }
  qed
qed

lemma sub2_grows_triangle:
  assumes mf: "mute_fun mf"
  and rA': "sub2 (dim_row A) l (r,A) = (r',A')"
  and tri: "triangular_to l A"
  and lc: "l < dim_col A"
  and lr: "l < dim_row A"
  shows "triangular_to (Suc l) A'"
proof (rule triangle_growth)
  show "triangular_to l A'"
    using sub2_preserves_triangle[OF rA' tri lc lr] by auto
    next
  have r0: "0 < dim_row A" using lr by auto
  show "triangular_column l A'"
    proof (cases "find_non0 l A")
      case None {
        then have "A' = A" using rA' by simp
        moreover have "triangular_column l A"  using find_non0_all0[OF None].
        ultimately show ?thesis by auto
      } next
      case (Some m) {
        have lm: "l < m" and mr: "m < dim_row A"
          using find_non0[OF sel_fun Some] by auto
        let ?A = "swaprows m l A"
        have tri2: "triangular_to l ?A"
          proof
            fix i j assume jl: "j < l" and ji:"j < i" and ir: "i < dim_row ?A"
            show "?A $$ (i,j) = 0"
            proof (cases "i = m")
              case True {
                then have "?A $$ (i,j) = A $$ (l,j)"
                  using jl lc ir by simp
                also have "... = 0"
                  using triangular_toD[OF tri jl jl] lr by auto
                finally show ?thesis by auto
              } next
              case False show ?thesis
                proof (cases "i = l")
                  case True {
                    then have "?A $$ (i,j) = A $$ (m,j)"
                      using jl lc ir by auto
                    also have "... = 0"
                      using triangular_toD[OF tri jl] jl lm mr by auto
                    finally show ?thesis by auto
                  } next
                  case False {
                    then have "?A $$ (i,j) = A $$ (i,j)"
                      using \<open>i \<noteq> m\<close> jl lc ir by auto
                    thus ?thesis using tri jl ji ir by auto
                  }
                qed
            qed
          qed
        have rA'2: "sub1 (?A $$ (l,l)) (dim_row ?A - Suc l) l (-r, ?A) = (r',A')"
          using lm Some rA' by (simp add: Let_def)
        show ?thesis
          using sub1_triangulizes_column[OF mf rA'2 tri2] r0 lr lc by auto
      }
    qed
qed
end

subsection \<open>Recursive Triangulization of Columns\<close>

text \<open>
  Now we recursively apply @{const sub2} to make the entire matrix to be triangular.
\<close>

private fun sub3 :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<times> 'a mat \<Rightarrow> 'a \<times> 'a mat"
  where "sub3 d 0 rA = rA"
  | "sub3 d (Suc l) rA = sub2 d l (sub3 d l rA)"

lemma sub3_preserves_dimensions[simp]:
  "sub3 d l (r,A) = (r',A') \<Longrightarrow> dim_row A' = dim_row A"
  "sub3 d l (r,A) = (r',A') \<Longrightarrow> dim_col A' = dim_col A"
proof (induction l arbitrary: r' A')
  case (Suc l)
    obtain r' A' where rA': "sub3 d l (r, A) = (r', A')" by force
    fix r'' A'' assume rA'': "sub3 d (Suc l) (r, A) = (r'', A'')"
    then show "dim_row A'' = dim_row A" "dim_col A'' = dim_col A"
    using Suc rA' by auto
qed auto

lemma sub3_closed[simp]:
  "sub3 k l (r,A) = (r',A') \<Longrightarrow> A \<in> carrier_mat m n \<Longrightarrow> A' \<in> carrier_mat m n"
  unfolding carrier_mat_def by auto

lemma sub3_makes_triangle:
  assumes mf: "mute_fun mf"
  and sel_fun: "det_selection_fun sel_fun"
  and "sub3 (dim_row A) l (r,A) = (r',A')"
  and "l \<le> dim_row A"
  and "l \<le> dim_col A"
  shows "triangular_to l A'"
  using assms
proof -
  show "sub3 (dim_row A) l (r,A) = (r',A') \<Longrightarrow> l \<le> dim_row A \<Longrightarrow> l \<le> dim_col A \<Longrightarrow>
    triangular_to l A'"
  proof (induction l arbitrary:r' A')
    case (Suc l)
      then have Slr: "Suc l \<le> dim_row A" and Slc: "Suc l \<le> dim_col A" by auto
      hence lr: "l < dim_row A" and lc: "l < dim_col A" by auto
      moreover obtain r'' A''
        where rA'': "sub3 (dim_row A) l (r,A) = (r'',A'')" by force
      ultimately have IH: "triangular_to l A''" using Suc by auto
      have [simp]:"dim_row A'' = dim_row A" and [simp]:"dim_col A'' = dim_col A"
        using Slr Slc rA'' by auto
      fix r' A'
      assume "sub3 (dim_row A) (Suc l) (r, A) = (r', A')"
      then have rA': "sub2 (dim_row A'') l (r'',A'') = (r',A')"
        using rA'' by auto
      show "triangular_to (Suc l) A'"
        using sub2_grows_triangle[OF sel_fun mf rA'] lr lc rA'' IH by auto
  qed auto
qed

subsection \<open>Triangulization\<close>

definition triangulize :: "'a mat \<Rightarrow> 'a \<times> 'a mat"
where "triangulize A = sub3 (dim_row A) (dim_row A) (1,A)"

lemma triangulize_preserves_dimensions[simp]:
  "triangulize A = (r',A') \<Longrightarrow> dim_row A' = dim_row A"
  "triangulize A = (r',A') \<Longrightarrow> dim_col A' = dim_col A"
  unfolding triangulize_def by auto

lemma triangulize_closed[simp]:
  "triangulize A = (r',A') \<Longrightarrow> A \<in> carrier_mat m n \<Longrightarrow> A' \<in> carrier_mat m n"
  unfolding carrier_mat_def by auto

context
  assumes mf: "mute_fun mf"
  and sel_fun: "det_selection_fun sel_fun"
begin

theorem triangulized:
  assumes "A \<in> carrier_mat n n"
  and "triangulize A = (r',A')"
  shows "upper_triangular A'"
proof (cases "0<n")
  case True
    have rA': "sub3 (dim_row A) (dim_row A) (1,A) = (r',A')"
      using assms unfolding triangulize_def by auto
    have nr:"n = dim_row A" and nc:"n = dim_col A" and nr':"n = dim_row A'"
    using assms by auto
    thus ?thesis
      unfolding triangular_to_triangular
      using sub3_makes_triangle[OF mf sel_fun rA'] True by auto
    next
  case False
    then have nr':"dim_row A' = 0" using assms by auto
    thus ?thesis unfolding upper_triangular_def by auto
qed

subsection\<open>Divisor will not be 0\<close>

text \<open>
  Here we show that each sub-algorithm will not make $r$
  of the input/output pair $(r,A)$ to 0.
  The algorithm @{term "sub1 A_ll k l (r,A)"} requires $A_{l,l} \neq 0$.
\<close>

lemma sub1_divisor [simp]:
  assumes rA': "sub1 q k l (r, A) = (r',A')"
  and r0: "r \<noteq> 0"
  and All: "q \<noteq> 0"
  and "k + l < dim_row A "
  and lc: "l < dim_col A"
  shows "r' \<noteq> 0"
using assms
proof -
  show "sub1 q k l (r,A) = (r',A') \<Longrightarrow> k + l < dim_row A \<Longrightarrow> r' \<noteq> 0"
  proof (induction k arbitrary: r' A')
    case (Suc k)
      obtain r'' A'' where rA'': "sub1 q k l (r, A) = (r'', A'')" by force
      then have IH: "r'' \<noteq> 0" using Suc by auto
      obtain q' l' g where mf_id: "mf q (A'' $$ (Suc (l + k), l)) = (q',l',g)" by (rule prod_cases3)
      define fact where "fact = (if A'' $$ (Suc (l+k),l) = 0 then 1 else q')"
      note mf = mf[unfolded mute_fun_def, rule_format, OF mf_id]
      have All: "q \<noteq> 0"
        using sub1_preserves_diagnal[OF rA'' lc] All Suc by auto
      moreover have "fact \<noteq> 0" unfolding fact_def using All mf by auto
      moreover assume "sub1 q (Suc k) l (r,A) = (r',A')"
        then have "mute q (Suc (l + k)) l (r'',A'') = (r',A')"
          using rA'' by auto
        hence "r'' * fact = r'"
          unfolding mute.simps fact_def Let_def mf_id using IH by (auto split: if_splits)
      ultimately show "r' \<noteq> 0" using IH by auto
  qed (insert r0, simp)
qed

text \<open>The algorithm @{term "sub2"} will not require such a condition.\<close>
lemma sub2_divisor [simp]:
  assumes rA': "sub2 k l (r, A) = (r',A')"
  and lk: "l < k"
  and kr: "k \<le> dim_row A"
  and lc: "l < dim_col A"
  and r0: "r \<noteq> 0"
  shows "r' \<noteq> 0"
using assms
proof (cases "find_non0 l A") {
  case (Some m)
    then have Aml0: "A $$ (m,l) \<noteq> 0" using find_non0[OF sel_fun] by auto
    have md: "m < dim_row A" using find_non0[OF sel_fun Some] lk kr by auto
    let ?A'' = "swaprows m l A"
    have rA'2: "sub1 (?A'' $$ (l,l)) (k - Suc l) l (-r, ?A'') = (r',A')"
      using rA' Some by (simp add: Let_def)
    have All0: "?A'' $$ (l,l) \<noteq> 0" using Aml0 md lk kr lc by auto
    show ?thesis using sub1_divisor[OF rA'2 _ All0] r0 lk kr lc by simp
} qed auto

lemma sub3_divisor [simp]:
  assumes "sub3 d l (r,A) = (r'',A'')"
  and "l \<le> d"
  and "d \<le> dim_row A"
  and "l \<le> dim_col A"
  and r0: "r \<noteq> 0"
  shows "r'' \<noteq> 0"
  using assms
proof -
  show
    "sub3 d l (r,A) = (r'',A'') \<Longrightarrow>
     l \<le> d \<Longrightarrow> d \<le> dim_row A \<Longrightarrow> l \<le> dim_col A \<Longrightarrow> ?thesis"
  proof (induction l arbitrary: r'' A'')
    case 0
      then show ?case using r0 by simp
      next
    case (Suc l)
      obtain r' A' where rA': "sub3 d l (r,A) = (r',A')" by force
      then have [simp]:"dim_row A' = dim_row A" and [simp]:"dim_col A' = dim_col A"
        by auto
      from rA' have "r' \<noteq> 0" using Suc r0 by auto
      moreover have "sub2 d l (r',A') = (r'',A'')"
        using rA' Suc by simp
      ultimately show ?case using sub2_divisor using Suc by simp
  qed
qed

theorem triangulize_divisor:
  assumes A: "A \<in> carrier_mat d d"
  shows "triangulize A = (r',A') \<Longrightarrow> r' \<noteq> 0"
unfolding triangulize_def
proof -
  assume rA': "sub3 (dim_row A) (dim_row A) (1, A) = (r', A')"
  show ?thesis using sub3_divisor[OF rA'] A by auto
qed

subsection \<open>Determinant Preservation Results\<close>

text \<open>
  For each sub-algorithm $f$,
  we show $f(r,A) = (r',A')$ implies @{term "r * det A' = r' * det A"}.
\<close>

lemma mute_det:
  assumes "A \<in> carrier_mat n n"
  and rA': "mute q k l (r,A) = (r',A')"
  and "k < n"
  and "l < n"
  and "k \<noteq> l"
  shows "r * det A' = r' * det A"
proof (cases "A $$ (k,l) = 0")
  case True
  thus ?thesis using assms by auto
next
  case False
  obtain p' q' g where mf_id: "mf q (A $$ (k,l)) = (q',p',g)" by (rule prod_cases3)
  let ?All = "q'"
  let ?Akl = "- p'"
  let ?B = "multrow k ?All A"
  let ?C = "addrow ?Akl k l ?B"
  have "r * det A' = r * det ?C"  using assms by (simp add: Let_def mf_id False)
  also have "det ?C = det ?B" using assms by (auto simp: det_addrow)
  also have "\<dots> = ?All * det A" using assms det_multrow by auto
  also have "r * \<dots> = (r * ?All) * det A" by simp
  also have r: "r * ?All = r'" using assms by (simp add: Let_def mf_id False)
  finally show ?thesis.
qed

lemma sub1_det:
  assumes A: "A \<in> carrier_mat n n"
  and sub1: "sub1 q k l (r,A) = (r'',A'')"
  and r0: "r \<noteq> 0"
  and All0: "q \<noteq> 0"
  and l: "l + k < n"
  shows "r * det A'' = r'' * det A"
  using sub1 l
proof (induction k arbitrary: A'' r'')
  case 0
  then show ?case by auto
next
  case (Suc k)
  let ?rA' = "sub1 q k l (r,A)"
  obtain r' A' where rA':"?rA' = (r',A')" by force
  have A':"A' \<in> carrier_mat n n" using sub1_closed[OF rA'] A by auto
  have IH: "r * det A' = r' * det A" using Suc assms rA' by auto
  assume "sub1 q (Suc k) l (r,A) = (r'',A'')"
  then have rA'':"mute q (Suc (l+k)) l (r',A') = (r'',A'')" using rA' by auto
  hence lem: "r' * det A'' = r'' * det A'"
    using assms Suc A' mute_det[OF A' rA''] by auto
  hence "r * r' * det A'' = r * r'' * det A'" by auto
  also from IH have "... = r'' * r' * det A" by auto
  finally have *: "r * r' * det A'' = r'' * r' * det A" .
  then have "r * r' * det A'' div r' = r'' * r' * det A div r'" by presburger
  moreover have "r' \<noteq> 0"
    using r0 sub1_divisor[OF rA'] All0 Suc A by auto
  ultimately show ?case using * by auto
qed

lemma sub2_det:
  assumes A: "A \<in> carrier_mat d d"
  and rA': "sub2 d l (r,A) = (r',A')"
  and r0: "r \<noteq> 0"
  and ld: "l < d"
  shows "r * det A' = r' * det A"
proof (cases "find_non0 l A")
  case None then show ?thesis using assms by auto next
  case (Some m) {
    then have lm: "l < m" and md: "m < d"
      using A find_non0[OF sel_fun Some] ld by auto
    hence "m \<noteq> l" by auto
    let ?A'' = "swaprows m l A"
    have rA'2: "sub1 (?A'' $$ (l,l)) (d - Suc l) l (-r, ?A'') = (r',A')"
      using rA' Some by (simp add: Let_def)
    have A'': "?A'' \<in> carrier_mat d d" using A by auto
    hence A''ll0: "?A'' $$ (l,l) \<noteq> 0"
      using find_non0[OF sel_fun Some] ld by auto
    hence "-r * det A' = r' * det ?A''"
      using sub1_det[OF A'' rA'2] ld A r0 by auto
    also have "r * ... = -r * r' * det A"
      using det_swaprows[OF md ld \<open>m\<noteq>l\<close> A] by auto
    finally have "r * -r * det A' = -r * r' * det A" by auto
    thus ?thesis using r0 by auto
  }
qed

lemma sub3_det:
  assumes A:"A \<in> carrier_mat d d"
  and "sub3 d l (r,A) = (r'',A'')"
  and r0: "r \<noteq> 0"
  and "l \<le> d"
  shows "r * det A'' = r'' * det A"
  using assms
proof -
  have d: "d = dim_row A" using A by auto
  show "sub3 d l (r,A) = (r'',A'') \<Longrightarrow> l \<le> d \<Longrightarrow> r * det A'' = r'' * det A"
  proof (induction l arbitrary: r'' A'')
    case (Suc l)
      let ?rA' = "sub3 d l (r,A)"
      obtain r' A' where rA':"?rA' = (r',A')" by force
      then have rA'': "sub2 d l (r',A') = (r'',A'')"
        using Suc by auto
      have A': "A' \<in> carrier_mat d d" using A rA' rA'' by auto
      have r'0: "r' \<noteq> 0" using r0 sub3_divisor[OF rA'] A Suc by auto
      have "r' * det A'' = r'' * det A'"
        using Suc r'0 A by(subst sub2_det[OF A' rA''],auto)
      also have "r * ... = r'' * (r * det A')" by auto
      also have "r * det A' = r' * det A" using Suc rA' by auto
      also have "r'' * ... div r' = r'' * r' * det A div r'" by (simp add: ac_simps)
      finally show "r * det A'' = r'' * det A" using r'0
        by (metis \<open>r * det A' = r' * det A\<close> \<open>r' * det A'' = r'' * det A'\<close>
          mult.left_commute mult_cancel_left)
  qed simp
qed

theorem triangulize_det:
  assumes A: "A \<in> carrier_mat d d"
  and rA': "triangulize A = (r',A')"
  shows "det A * r' = det A'"
proof -
  have rA'2: "sub3 d d (1,A) = (r',A')"
    using A rA' unfolding triangulize_def by auto
  show ?thesis
  proof (cases "d = 0")
    case True
      then have A': "A' \<in> carrier_mat 0 0" using A rA'2 by auto
      have rA'3: "(r',A') = (1,A)" using True rA'2 by simp
      thus ?thesis by auto
      next
    case False
      then show ?thesis using sub3_det[OF A rA'2] assms by auto
  qed
qed
end

subsection \<open>Determinant Computation\<close>

definition det_code :: "'a mat \<Rightarrow> 'a" where
  "det_code A = (if dim_row A = dim_col A then
     case triangulize A of (m,A') \<Rightarrow>
       prod_list (diag_mat A') div m
   else 0)"

lemma det_code[simp]: assumes sel_fun: "det_selection_fun sel_fun"
  and mf: "mute_fun mf"
  shows "det_code A = det A"
  using det_code_def[simp]
proof (cases "dim_row A = dim_col A")
  case True
  then have A: "A \<in> carrier_mat (dim_row A) (dim_row A)" unfolding carrier_mat_def by auto
  obtain r' A' where rA': "triangulize A = (r',A')" by force
  from triangulize_divisor[OF mf sel_fun A] rA' have r'0: "r' \<noteq> 0" by auto
  from triangulize_det[OF mf sel_fun A rA'] have det': "det A * r' = det A'" by auto
  from triangulized[OF mf sel_fun A, unfolded rA'] have tri': "upper_triangular A'" by simp
  have A': "A' \<in> carrier_mat (dim_row A') (dim_row A')"
    using triangulize_closed[OF rA' A] by auto
  from tri' have tr: "triangular_to (dim_row A') A'" by auto
  have "det_code A = prod_list (diag_mat A') div r'" using rA' True by simp
  also have "prod_list (diag_mat A') = det A'"
    unfolding det_upper_triangular[OF tri' A'] ..
  also have "\<dots> = det A * r'" by (simp add: det')
  also have "\<dots> div r' = det A" using r'0 by auto
  finally show ?thesis .
qed (simp add: det_def)

end
end

text \<open>Now we can select an arbitrary selection and mute function. This will be important for computing
  resultants over polynomials, where usually a polynomial with small degree is preferable.

  The default however is to use the first element.\<close>

definition trivial_mute_fun :: "'a :: comm_ring_1 \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a" where
  "trivial_mute_fun x y = (x,y,1)"

lemma trivial_mute_fun[simp,intro]: "mute_fun trivial_mute_fun"
  unfolding mute_fun_def trivial_mute_fun_def by auto

definition fst_sel_fun :: "'a det_selection_fun" where
  "fst_sel_fun x = fst (hd x)"

lemma fst_sel_fun[simp]: "det_selection_fun fst_sel_fun"
  unfolding det_selection_fun_def fst_sel_fun_def by auto

context
  fixes measure :: "'a \<Rightarrow> nat"
begin
private fun select_min_main where
  "select_min_main m i ((j,p) # xs) = (let n = measure p in if n < m then select_min_main n j xs
    else select_min_main m i xs)"
| "select_min_main m i [] = i"

definition select_min :: "(nat \<times> 'a) list \<Rightarrow> nat" where
  "select_min xs = (case xs of ((i,p) # ys) \<Rightarrow> (select_min_main (measure p) i ys))"

lemma select_min[simp]: "det_selection_fun select_min"
  unfolding det_selection_fun_def
proof (intro allI impI)
  fix xs :: "(nat \<times> 'a)list"
  assume "xs \<noteq> []"
  then obtain i p ys where xs: "xs = ((i,p) # ys)" by (cases xs, auto)
  then obtain m where id: "select_min xs = select_min_main m i ys" unfolding select_min_def by auto
  have "i \<in> fst ` set xs" "set ys \<subseteq> set xs" unfolding xs by auto
  thus "select_min xs \<in> fst ` set xs" unfolding id
  proof (induct ys arbitrary: m i )
    case (Cons jp ys m i)
    obtain j p where jp: "jp = (j,p)" by force
    obtain k n where res: "select_min_main m i (jp # ys) = select_min_main n k ys"
      and k: "k \<in> fst ` set xs"
      using Cons(2-) unfolding jp by (cases "measure p < m"; force simp: Let_def)
    from Cons(1)[OF k, of n] Cons(3)
    show ?case unfolding res by auto
  qed simp
qed
end

text \<open>For the code equation we use the trivial mute and selection function as this does
  not impose any further class restrictions.\<close>

lemma det_code_fst_sel_fun[code]: "det A = det_code fst_sel_fun trivial_mute_fun A" by simp

text \<open>But we also provide specialiced functions for more specific carriers.\<close>

definition field_mute_fun :: "'a :: field \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a" where
  "field_mute_fun x y = (x/y,1,y)"

lemma field_mute_fun[simp,intro]: "mute_fun field_mute_fun"
  unfolding mute_fun_def field_mute_fun_def by auto

definition det_field :: "'a :: field mat \<Rightarrow> 'a" where
  "det_field A = det_code fst_sel_fun field_mute_fun A"

lemma det_field[simp]: "det_field = det"
  by (intro ext, auto simp: det_field_def)

definition gcd_mute_fun :: "'a :: ring_gcd \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a" where
  "gcd_mute_fun x y = (let g = gcd x y in (x div g, y div g,g))"

lemma gcd_mute_fun[simp,intro]: "mute_fun gcd_mute_fun"
  unfolding mute_fun_def gcd_mute_fun_def by (auto simp: Let_def div_mult_swap mult.commute)

definition det_int :: "int mat \<Rightarrow> int" where
  "det_int A = det_code (select_min (\<lambda> x. nat (abs x))) gcd_mute_fun A"

lemma det_int[simp]: "det_int = det"
  by (intro ext, auto simp: det_int_def)

definition det_field_poly :: "'a :: {field,field_gcd} poly mat \<Rightarrow> 'a poly" where
  "det_field_poly A = det_code (select_min degree) gcd_mute_fun A"

lemma det_field_poly[simp]: "det_field_poly = det"
  by (intro ext, auto simp: det_field_poly_def)

end


theory Cbrt23_Irrational
  imports Complex_Main

begin

lemma cuberoot_irrational:
  defines "x \<equiv> root 3 2 + root 3 3"
  shows "x \<notin> \<rat>"
proof
  assume "x \<in> \<rat>"
  moreover
  have "root 3 8 = 2" "root 3 27 = 3"
    by auto
  then have xcubed: "x^3 = 5 + 3 * x * root 3 6"
    by (simp add: x_def algebra_simps eval_nat_numeral flip: real_root_mult)
  ultimately have Q: "5 + 3 * x * root 3 6 \<in> \<rat>"
    by (metis Rats_power \<open>x \<in> \<rat>\<close>)
  have "root 3 6 \<notin> \<rat>"
  proof
    assume "root 3 6 \<in> \<rat>"
    then obtain a b where "a / b = root 3 6" and cop: "coprime a b" "b\<noteq>0"
      by (smt (verit, best) Rats_cases')
    then have "(a/b)^3 = 6"
      by auto
    then have eq: "a^3 = 2*3 * b^3"
      using of_int_eq_iff by (fastforce simp: divide_simps \<open>b\<noteq>0\<close>)
    then have p: "2 dvd a"
      by (metis coprime_left_2_iff_odd coprime_power_right_iff dvd_triv_left mult.assoc)
    then obtain c where "a = 2*c"
      by blast
    with eq have "2 dvd b"
      by (simp add: eval_nat_numeral) (metis even_mult_iff even_numeral odd_numeral)
    with p and cop show False
      by fastforce
  qed
  moreover have "3*x \<in> \<rat> - {0}"
    using xcubed  by (force simp: \<open>x \<in> \<rat>\<close>)
  ultimately have "3 * x * root 3 6 \<notin> \<rat>"
    using Rats_divide by force
  with Q show False
    by (metis Rats_diff Rats_number_of add.commute add_uminus_conv_diff diff_add_cancel)
qed

end


theory T51
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory BasicSecurityPredicates
imports Views "../Basics/Projection"
begin

(*Auxiliary predicate capturing that a a set of traces consists
only of traces of a given set of events *)
definition areTracesOver :: "('e list) set \<Rightarrow> 'e set \<Rightarrow> bool "
where
"areTracesOver Tr E \<equiv>
  \<forall> \<tau> \<in> Tr. (set \<tau>) \<subseteq> E"

(* Basic Security Predicates are properties of sets of traces
 that are parameterized with a view *)
type_synonym 'e BSP = "'e V_rec \<Rightarrow> (('e list) set) \<Rightarrow> bool"

(* Basic Security Predicates are valid if and only if they are closure property of sets of traces
for arbitrary views and sets of traces *)
definition BSP_valid :: "'e BSP \<Rightarrow> bool"
where
"BSP_valid bsp \<equiv>
  \<forall>\<V> Tr E. ( isViewOn \<V> E \<and> areTracesOver Tr E )
              \<longrightarrow> (\<exists> Tr'. Tr' \<supseteq> Tr  \<and> bsp \<V> Tr')"

(* Removal of Confidential Events (R) *)
definition R :: "'e BSP"
where
"R \<V> Tr \<equiv>
  \<forall>\<tau>\<in>Tr. \<exists>\<tau>'\<in>Tr. \<tau>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [] \<and> \<tau>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<tau> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"

lemma BSP_valid_R: "BSP_valid R"
proof -
  {
    fix \<V>::"('e V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "R \<V> ?Tr'"
      proof -
        {
          fix \<tau>
          assume "\<tau> \<in> {t. (set t) \<subseteq> E}"
          let ?\<tau>'="\<tau>\<upharpoonleft>(V\<^bsub>\<V>\<^esub>)"
          have "?\<tau>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []  \<and> ?\<tau>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<tau> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
            using \<open>isViewOn \<V> E\<close>  disjoint_projection projection_idempotent
            unfolding isViewOn_def V_valid_def VC_disjoint_def  by metis
          moreover
          from \<open>\<tau> \<in> {t. (set t) \<subseteq> E}\<close> have "?\<tau>' \<in> ?Tr'" using \<open>isViewOn \<V> E\<close>
            unfolding isViewOn_def
            by (simp add: list_subset_iff_projection_neutral projection_commute)
          ultimately
          have " \<exists>\<tau>'\<in>{t. set t \<subseteq> E}. \<tau>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [] \<and> \<tau>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<tau> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
            by auto
        }
        thus ?thesis unfolding R_def
          by auto
      qed
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> R \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Deletion of Confidential Events (D) *)
definition D :: "'e BSP"
where
"D \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ [c] @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [])
    \<longrightarrow> (\<exists>\<alpha>' \<beta>'. ((\<beta>' @ \<alpha>') \<in> Tr \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []
                  \<and> \<beta>'\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> C\<^bsub>\<V>\<^esub>) = \<beta>\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> C\<^bsub>\<V>\<^esub>)))"

lemma BSP_valid_D: "BSP_valid D"
proof -
  {
    fix \<V>::"('e V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "D \<V> ?Tr'"
      unfolding D_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> D \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Insertion of Confidential Events (I) *)
definition I :: "'e BSP"
where
"I \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [])
    \<longrightarrow> (\<exists>\<alpha>' \<beta>'. ((\<beta>' @ [c] @ \<alpha>') \<in> Tr \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []
                     \<and> \<beta>'\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> C\<^bsub>\<V>\<^esub>) = \<beta>\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> C\<^bsub>\<V>\<^esub>)))"

lemma BSP_valid_I: "BSP_valid I"
proof -
  {
    fix \<V>::"('e V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "I \<V> ?Tr'" using \<open>isViewOn \<V> E\<close>
      unfolding isViewOn_def I_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> I \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* \<rho>-Admissibility *)
type_synonym 'e Rho = "'e V_rec \<Rightarrow> 'e set"

definition
Adm :: "'e V_rec \<Rightarrow> 'e Rho \<Rightarrow> ('e list) set \<Rightarrow> 'e list \<Rightarrow> 'e \<Rightarrow> bool"
where
"Adm \<V> \<rho> Tr \<beta> e \<equiv>
   \<exists>\<gamma>. ((\<gamma> @ [e]) \<in> Tr \<and> \<gamma>\<upharpoonleft>(\<rho> \<V>) = \<beta>\<upharpoonleft>(\<rho> \<V>))"

(* Insertion of Admissible Confidential Events (IA) *)
definition IA :: "'e Rho \<Rightarrow> 'e BSP"
where
"IA \<rho> \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [] \<and> (Adm \<V> \<rho> Tr \<beta> c))
    \<longrightarrow> (\<exists> \<alpha>' \<beta>'. ((\<beta>' @ [c] @ \<alpha>') \<in> Tr) \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub>
                    \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [] \<and> \<beta>'\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> C\<^bsub>\<V>\<^esub>) = \<beta>\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> C\<^bsub>\<V>\<^esub>))"

lemma BSP_valid_IA: "BSP_valid (IA \<rho>) "
proof -
  {
    fix \<V> :: "('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "IA \<rho> \<V> ?Tr'" using \<open>isViewOn \<V> E\<close>
      unfolding isViewOn_def IA_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> IA \<rho> \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Backwards Strict Deletion of Confidential Events (BSD) *)
definition BSD :: "'e BSP"
where
"BSD \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ [c] @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [])
    \<longrightarrow> (\<exists>\<alpha>'. ((\<beta> @ \<alpha>') \<in> Tr \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []))"

(* Backwards Strict Insertion of Confidential Events (BSI) *)
definition BSI :: "'e BSP"
where
"BSI \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [])
    \<longrightarrow> (\<exists>\<alpha>'. ((\<beta> @ [c] @ \<alpha>') \<in> Tr \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []))"

lemma BSP_valid_BSI: "BSP_valid BSI"
proof -
  {
    fix \<V>::"('e V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "BSI \<V> ?Tr'" using \<open>isViewOn \<V> E\<close>
      unfolding isViewOn_def BSI_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> BSI \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Backwards Strict Insertion of Admissible Confidential Events (BSIA) *)
definition BSIA :: "'e Rho \<Rightarrow> 'e BSP"
where
"BSIA \<rho> \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [] \<and> (Adm \<V> \<rho> Tr \<beta> c))
    \<longrightarrow> (\<exists>\<alpha>'. ((\<beta> @ [c] @ \<alpha>') \<in> Tr \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []))"

lemma BSP_valid_BSIA: "BSP_valid (BSIA \<rho>) "
proof -
  {
    fix \<V> :: "('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "BSIA \<rho> \<V> ?Tr'" using \<open>isViewOn \<V> E\<close>
      unfolding isViewOn_def BSIA_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> BSIA \<rho> \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Forward Correctable BSPs *)
record 'e Gamma =
  Nabla :: "'e set"
  Delta :: "'e set"
  Upsilon :: "'e set"

(* syntax abbreviations for Gamma *)
abbreviation GammaNabla :: "'e Gamma \<Rightarrow> 'e set"
("\<nabla>\<^bsub>_\<^esub>" [100] 1000)
where
"\<nabla>\<^bsub>\<Gamma>\<^esub> \<equiv> (Nabla \<Gamma>)"

abbreviation GammaDelta :: "'e Gamma \<Rightarrow> 'e set"
("\<Delta>\<^bsub>_\<^esub>" [100] 1000)
where
"\<Delta>\<^bsub>\<Gamma>\<^esub> \<equiv> (Delta \<Gamma>)"

abbreviation GammaUpsilon :: "'e Gamma \<Rightarrow> 'e set"
("\<Upsilon>\<^bsub>_\<^esub>" [100] 1000)
where
"\<Upsilon>\<^bsub>\<Gamma>\<^esub> \<equiv> (Upsilon \<Gamma>)"

(* Forward Correctable Deletion of Confidential Events (FCD) *)
definition FCD :: "'e Gamma \<Rightarrow> 'e BSP"
where
"FCD \<Gamma> \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>(C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>). \<forall>v\<in>(V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>).
    ((\<beta> @ [c,v] @ \<alpha>) \<in> Tr \<and> \<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])
      \<longrightarrow> (\<exists>\<alpha>'. \<exists>\<delta>'. (set \<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>)
                      \<and> ((\<beta> @ \<delta>' @ [v] @ \<alpha>') \<in> Tr
                      \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []))"

lemma BSP_valid_FCD: "BSP_valid (FCD \<Gamma>)"
proof -
  {
    fix \<V>::"('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "FCD \<Gamma> \<V> ?Tr'"
      proof -
        {
          fix \<alpha> \<beta> c v
          assume  "c \<in> C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>"
             and  "v \<in>V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>"
             and  "\<beta> @ [c ,v] @ \<alpha> \<in> ?Tr'"
             and  "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
          let ?\<alpha>'="\<alpha>" and ?\<delta>'="[]"
          from \<open>\<beta> @ [c ,v] @ \<alpha> \<in> ?Tr'\<close> have "\<beta> @ ?\<delta>' @ [v] @ ?\<alpha>' \<in> ?Tr'"
            by auto
          hence  "(set ?\<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> ((\<beta> @ ?\<delta>' @ [v] @ ?\<alpha>') \<in> ?Tr'
                      \<and> ?\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> ?\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
            using \<open>isViewOn \<V> E\<close> \<open>\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []\<close>
            unfolding isViewOn_def \<open>\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []\<close> by auto
          hence "\<exists>\<alpha>'. \<exists>\<delta>'. (set \<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> ((\<beta> @ \<delta>' @ [v] @ \<alpha>') \<in> ?Tr'
            \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
            by blast
        }
        thus ?thesis
          unfolding FCD_def by auto
      qed
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> FCD \<Gamma> \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Forward Correctable Insertion of Confidential Events (FCI) *)
definition FCI :: "'e Gamma \<Rightarrow> 'e BSP"
where
"FCI \<Gamma> \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>(C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>). \<forall>v\<in>(V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>).
    ((\<beta> @ [v] @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [])
      \<longrightarrow> (\<exists>\<alpha>'. \<exists>\<delta>'. (set \<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>)
                      \<and> ((\<beta> @ [c] @ \<delta>' @ [v] @ \<alpha>') \<in> Tr
                      \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []))"

lemma BSP_valid_FCI: "BSP_valid (FCI \<Gamma>)"
proof -
  {
    fix \<V>::"('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "FCI \<Gamma> \<V> ?Tr'"
      proof -
        {
          fix \<alpha> \<beta> c v
          assume  "c \<in> C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>"
             and  "v \<in>V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>"
             and  "\<beta> @ [v] @ \<alpha> \<in> ?Tr'"
             and  "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
          let ?\<alpha>'="\<alpha>" and ?\<delta>'="[]"
          from \<open>c \<in> C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>\<close> have" c \<in> E"
            using \<open>isViewOn \<V> E\<close>
            unfolding isViewOn_def by auto
          with  \<open>\<beta> @ [v] @ \<alpha> \<in> ?Tr'\<close> have "\<beta> @ [c] @ ?\<delta>' @ [v] @ ?\<alpha>' \<in> ?Tr'"
            by auto
          hence  "(set ?\<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> ((\<beta> @ [c] @ ?\<delta>' @ [v] @ ?\<alpha>') \<in> ?Tr'
                      \<and> ?\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> ?\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
           using \<open>isViewOn \<V> E\<close> \<open>\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []\<close>  unfolding isViewOn_def \<open>\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []\<close> by auto
         hence
           "\<exists>\<alpha>'. \<exists>\<delta>'. (set \<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> ((\<beta> @ [c] @ \<delta>' @ [v] @ \<alpha>') \<in> ?Tr'
            \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
            by blast
        }
        thus ?thesis
          unfolding FCI_def by auto
      qed
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> FCI \<Gamma> \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Forward correctable Insertion of Admissible Confidential Events (FCIA) *)
definition FCIA :: "'e Rho \<Rightarrow> 'e Gamma \<Rightarrow> 'e BSP"
where
"FCIA \<rho> \<Gamma> \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>(C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>). \<forall>v\<in>(V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>).
    ((\<beta> @ [v] @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = [] \<and> (Adm \<V> \<rho> Tr \<beta> c))
      \<longrightarrow> (\<exists>\<alpha>'. \<exists>\<delta>'. (set \<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>)
                      \<and> ((\<beta> @ [c] @ \<delta>' @ [v] @ \<alpha>') \<in> Tr
                      \<and> \<alpha>'\<upharpoonleft>V\<^bsub>\<V>\<^esub> = \<alpha>\<upharpoonleft>V\<^bsub>\<V>\<^esub> \<and> \<alpha>'\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []))"

lemma BSP_valid_FCIA: "BSP_valid (FCIA \<rho> \<Gamma>) "
proof -
  {
    fix \<V> :: "('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "FCIA \<rho> \<Gamma> \<V> ?Tr'"
    proof -
        {
          fix \<alpha> \<beta> c v
          assume  "c \<in> C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>"
             and  "v \<in>V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>"
             and  "\<beta> @ [v] @ \<alpha> \<in> ?Tr'"
             and  "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
          let ?\<alpha>'="\<alpha>" and ?\<delta>'="[]"
          from \<open>c \<in> C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>\<close> have" c \<in> E"
            using \<open>isViewOn \<V> E\<close> unfolding isViewOn_def by auto
          with  \<open>\<beta> @ [v] @ \<alpha> \<in> ?Tr'\<close> have "\<beta> @ [c] @ ?\<delta>' @ [v] @ ?\<alpha>' \<in> ?Tr'"
            by auto
          hence  "(set ?\<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> ((\<beta> @ [c] @ ?\<delta>' @ [v] @ ?\<alpha>') \<in> ?Tr'
                      \<and> ?\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> ?\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
            using \<open>isViewOn \<V> E\<close> \<open>\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []\<close>
            unfolding isViewOn_def \<open>\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []\<close> by auto
          hence
            "\<exists>\<alpha>'. \<exists>\<delta>'. (set \<delta>') \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> ((\<beta> @ [c] @ \<delta>' @ [v] @ \<alpha>') \<in> ?Tr'
            \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
            by blast
        }
        thus ?thesis
          unfolding FCIA_def by auto
      qed
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> FCIA \<rho> \<Gamma> \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Strict Removal of Confidential Events (SR) *)
definition SR :: "'e BSP"
where
"SR \<V> Tr \<equiv> \<forall>\<tau>\<in>Tr. \<tau> \<upharpoonleft> (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>) \<in> Tr"

lemma "BSP_valid SR"
proof -
  {
    fix \<V>::"('e V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. \<exists>\<tau> \<in> Tr. t=\<tau>\<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>)} \<union> Tr"
    have "?Tr'\<supseteq> Tr"
      by blast
    moreover
    have "SR \<V> ?Tr'" unfolding SR_def
      proof
        fix \<tau>
        assume "\<tau> \<in> ?Tr'"
        {
          from \<open>\<tau> \<in> ?Tr'\<close> have "(\<exists>t\<in>Tr. \<tau> = t \<upharpoonleft> (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>)) \<or> \<tau> \<in> Tr"
            by auto
          hence "\<tau> \<upharpoonleft> (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>) \<in> ?Tr'"
            proof
              assume "\<exists>t\<in>Tr. \<tau> = t \<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>)"
              hence "\<exists>t\<in>Tr. \<tau> \<upharpoonleft> (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>)= t \<upharpoonleft>(V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>)"
                using projection_idempotent by metis
              thus ?thesis
                by auto
            next
              assume "\<tau> \<in> Tr"
              thus ?thesis
                by auto
            qed
        }
        thus "\<tau> \<upharpoonleft> (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>) \<in> ?Tr'"
          by auto
      qed
    ultimately
    have "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> SR \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Strict Deletion of Confidential Events (SD) *)
definition SD :: "'e BSP"
where
"SD \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ [c] @ \<alpha>) \<in> Tr \<and> \<alpha>\<upharpoonleft>C\<^bsub>\<V>\<^esub> = []) \<longrightarrow> \<beta> @ \<alpha> \<in> Tr"

lemma "BSP_valid SD"
proof -
  {
    fix \<V>::"('e V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr" by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "SD \<V> ?Tr'" unfolding SD_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> SD \<V> Tr'" by auto
  }
  thus ?thesis unfolding BSP_valid_def by auto
qed

(* Strict Insertion of Confidential Events (SI) *)
definition SI :: "'e BSP"
where
"SI \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ \<alpha>) \<in> Tr \<and> \<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []) \<longrightarrow> \<beta> @ [c] @ \<alpha> \<in> Tr"

lemma "BSP_valid SI"
proof -
  {
    fix \<V>::"('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "SI \<V> ?Tr'"
      using \<open>isViewOn \<V> E\<close>
      unfolding isViewOn_def SI_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> SI \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

(* Strict Insertion of Admissible Confidential Events (SIA) *)
definition SIA :: "'e Rho \<Rightarrow> 'e BSP"
where
"SIA \<rho> \<V> Tr \<equiv>
  \<forall>\<alpha> \<beta>. \<forall>c\<in>C\<^bsub>\<V>\<^esub>. ((\<beta> @ \<alpha>) \<in> Tr \<and> \<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [] \<and> (Adm \<V> \<rho> Tr \<beta> c))
    \<longrightarrow> (\<beta> @ [c] @ \<alpha>) \<in> Tr"

lemma "BSP_valid (SIA \<rho>) "
proof -
  {
    fix \<V> :: "('a V_rec)"
    fix Tr E
    assume "isViewOn \<V> E"
    and "areTracesOver Tr E"
    let ?Tr'="{t. (set t) \<subseteq> E}"
    have "?Tr'\<supseteq> Tr"
      by (meson Ball_Collect \<open>areTracesOver Tr E\<close> areTracesOver_def)
    moreover
    have "SIA \<rho> \<V> ?Tr'"
      using \<open>isViewOn \<V> E\<close>
      unfolding isViewOn_def SIA_def by auto
    ultimately
    have  "\<exists> Tr'. Tr' \<supseteq> Tr  \<and> SIA \<rho> \<V> Tr'"
      by auto
  }
  thus ?thesis
    unfolding BSP_valid_def by auto
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_nat_plus_assoc
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

theorem property0 :
  "((plus x (plus y z)) = (plus (plus x y) z))"
  oops

end


(*  Title:      HOL/Proofs/Lambda/Commutation.thy
    Author:     Tobias Nipkow
    Copyright   1995  TU Muenchen
*)

section \<open>Abstract commutation and confluence notions\<close>

theory Commutation
imports Main
begin

declare [[syntax_ambiguity_warning = false]]

subsection \<open>Basic definitions\<close>

definition
  square :: "['a => 'a => bool, 'a => 'a => bool, 'a => 'a => bool, 'a => 'a => bool] => bool" where
  "square R S T U =
    (\<forall>x y. R x y --> (\<forall>z. S x z --> (\<exists>u. T y u \<and> U z u)))"

definition
  commute :: "['a => 'a => bool, 'a => 'a => bool] => bool" where
  "commute R S = square R S S R"

definition
  diamond :: "('a => 'a => bool) => bool" where
  "diamond R = commute R R"

definition
  Church_Rosser :: "('a => 'a => bool) => bool" where
  "Church_Rosser R =
    (\<forall>x y. (sup R (R\<inverse>\<inverse>))\<^sup>*\<^sup>* x y \<longrightarrow> (\<exists>z. R\<^sup>*\<^sup>* x z \<and> R\<^sup>*\<^sup>* y z))"

abbreviation
  confluent :: "('a => 'a => bool) => bool" where
  "confluent R == diamond (R\<^sup>*\<^sup>*)"

subsection \<open>Basic lemmas\<close>

subsubsection \<open>\<open>square\<close>\<close>

lemma square_sym: "square R S T U ==> square S R U T"
  apply (unfold square_def)
  apply blast
  done

lemma square_subset:
    "[| square R S T U; T \<le> T' |] ==> square R S T' U"
  apply (unfold square_def)
  apply (blast dest: predicate2D)
  done

lemma square_reflcl:
    "[| square R S T (R\<^sup>=\<^sup>=); S \<le> T |] ==> square (R\<^sup>=\<^sup>=) S T (R\<^sup>=\<^sup>=)"
  apply (unfold square_def)
  apply (blast dest: predicate2D)
  done

lemma square_rtrancl:
    "square R S S T ==> square (R\<^sup>*\<^sup>*) S S (T\<^sup>*\<^sup>*)"
  apply (unfold square_def)
  apply (intro strip)
  apply (erule rtranclp_induct)
   apply blast
  apply (blast intro: rtranclp.rtrancl_into_rtrancl)
  done

lemma square_rtrancl_reflcl_commute:
    "square R S (S\<^sup>*\<^sup>*) (R\<^sup>=\<^sup>=) ==> commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  apply (unfold commute_def)
  apply (fastforce dest: square_reflcl square_sym [THEN square_rtrancl])
  done

subsubsection \<open>\<open>commute\<close>\<close>

lemma commute_sym: "commute R S ==> commute S R"
  apply (unfold commute_def)
  apply (blast intro: square_sym)
  done

lemma commute_rtrancl: "commute R S ==> commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  apply (unfold commute_def)
  apply (blast intro: square_rtrancl square_sym)
  done

lemma commute_Un:
    "[| commute R T; commute S T |] ==> commute (sup R S) T"
  apply (unfold commute_def square_def)
  apply blast
  done

subsubsection \<open>\<open>diamond\<close>, \<open>confluence\<close>, and \<open>union\<close>\<close>

lemma diamond_Un:
    "[| diamond R; diamond S; commute R S |] ==> diamond (sup R S)"
  apply (unfold diamond_def)
  apply (blast intro: commute_Un commute_sym)
  done

lemma diamond_confluent: "diamond R ==> confluent R"
  apply (unfold diamond_def)
  apply (erule commute_rtrancl)
  done

lemma square_reflcl_confluent:
    "square R R (R\<^sup>=\<^sup>=) (R\<^sup>=\<^sup>=) ==> confluent R"
  apply (unfold diamond_def)
  apply (fast intro: square_rtrancl_reflcl_commute elim: square_subset)
  done

lemma confluent_Un:
    "[| confluent R; confluent S; commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*) |] ==> confluent (sup R S)"
  apply (rule rtranclp_sup_rtranclp [THEN subst])
  apply (blast dest: diamond_Un intro: diamond_confluent)
  done

lemma diamond_to_confluence:
    "[| diamond R; T \<le> R; R \<le> T\<^sup>*\<^sup>* |] ==> confluent T"
  apply (force intro: diamond_confluent
    dest: rtranclp_subset [symmetric])
  done

subsection \<open>Church-Rosser\<close>

lemma Church_Rosser_confluent: "Church_Rosser R = confluent R"
  apply (unfold square_def commute_def diamond_def Church_Rosser_def)
  apply (tactic \<open>safe_tac (put_claset HOL_cs \<^context>)\<close>)
   apply (tactic \<open>
     blast_tac (put_claset HOL_cs \<^context> addIs
       [@{thm sup_ge2} RS @{thm rtranclp_mono} RS @{thm predicate2D} RS @{thm rtranclp_trans},
        @{thm rtranclp_converseI}, @{thm conversepI},
        @{thm sup_ge1} RS @{thm rtranclp_mono} RS @{thm predicate2D}]) 1\<close>)
  apply (erule rtranclp_induct)
   apply blast
  apply (blast del: rtranclp.rtrancl_refl intro: rtranclp_trans)
  done

subsection \<open>Newman's lemma\<close>

text \<open>Proof by Stefan Berghofer\<close>

theorem newman:
  assumes wf: "wfP (R\<inverse>\<inverse>)"
  and lc: "\<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  shows "\<And>b c. R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  using wf
proof induct
  case (less x b c)
  have xc: "R\<^sup>*\<^sup>* x c" by fact
  have xb: "R\<^sup>*\<^sup>* x b" by fact thus ?case
  proof (rule converse_rtranclpE)
    assume "x = b"
    with xc have "R\<^sup>*\<^sup>* b c" by simp
    thus ?thesis by iprover
  next
    fix y
    assume xy: "R x y"
    assume yb: "R\<^sup>*\<^sup>* y b"
    from xc show ?thesis
    proof (rule converse_rtranclpE)
      assume "x = c"
      with xb have "R\<^sup>*\<^sup>* c b" by simp
      thus ?thesis by iprover
    next
      fix y'
      assume y'c: "R\<^sup>*\<^sup>* y' c"
      assume xy': "R x y'"
      with xy have "\<exists>u. R\<^sup>*\<^sup>* y u \<and> R\<^sup>*\<^sup>* y' u" by (rule lc)
      then obtain u where yu: "R\<^sup>*\<^sup>* y u" and y'u: "R\<^sup>*\<^sup>* y' u" by iprover
      from xy have "R\<inverse>\<inverse> y x" ..
      from this and yb yu have "\<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* u d" by (rule less)
      then obtain v where bv: "R\<^sup>*\<^sup>* b v" and uv: "R\<^sup>*\<^sup>* u v" by iprover
      from xy' have "R\<inverse>\<inverse> y' x" ..
      moreover from y'u and uv have "R\<^sup>*\<^sup>* y' v" by (rule rtranclp_trans)
      moreover note y'c
      ultimately have "\<exists>d. R\<^sup>*\<^sup>* v d \<and> R\<^sup>*\<^sup>* c d" by (rule less)
      then obtain w where vw: "R\<^sup>*\<^sup>* v w" and cw: "R\<^sup>*\<^sup>* c w" by iprover
      from bv vw have "R\<^sup>*\<^sup>* b w" by (rule rtranclp_trans)
      with cw show ?thesis by iprover
    qed
  qed
qed

text \<open>
  Alternative version.  Partly automated by Tobias
  Nipkow. Takes 2 minutes (2002).

  This is the maximal amount of automation possible using \<open>blast\<close>.
\<close>

theorem newman':
  assumes wf: "wfP (R\<inverse>\<inverse>)"
  and lc: "\<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  shows "\<And>b c. R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  using wf
proof induct
  case (less x b c)
  note IH = \<open>\<And>y b c. \<lbrakk>R\<inverse>\<inverse> y x; R\<^sup>*\<^sup>* y b; R\<^sup>*\<^sup>* y c\<rbrakk>
                     \<Longrightarrow> \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d\<close>
  have xc: "R\<^sup>*\<^sup>* x c" by fact
  have xb: "R\<^sup>*\<^sup>* x b" by fact
  thus ?case
  proof (rule converse_rtranclpE)
    assume "x = b"
    with xc have "R\<^sup>*\<^sup>* b c" by simp
    thus ?thesis by iprover
  next
    fix y
    assume xy: "R x y"
    assume yb: "R\<^sup>*\<^sup>* y b"
    from xc show ?thesis
    proof (rule converse_rtranclpE)
      assume "x = c"
      with xb have "R\<^sup>*\<^sup>* c b" by simp
      thus ?thesis by iprover
    next
      fix y'
      assume y'c: "R\<^sup>*\<^sup>* y' c"
      assume xy': "R x y'"
      with xy obtain u where u: "R\<^sup>*\<^sup>* y u" "R\<^sup>*\<^sup>* y' u"
        by (blast dest: lc)
      from yb u y'c show ?thesis
        by (blast del: rtranclp.rtrancl_refl
            intro: rtranclp_trans
            dest: IH [OF conversepI, OF xy] IH [OF conversepI, OF xy'])
    qed
  qed
qed

text \<open>
  Using the coherent logic prover, the proof of the induction step
  is completely automatic.
\<close>

lemma eq_imp_rtranclp: "x = y \<Longrightarrow> r\<^sup>*\<^sup>* x y"
  by simp

theorem newman'':
  assumes wf: "wfP (R\<inverse>\<inverse>)"
  and lc: "\<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  shows "\<And>b c. R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  using wf
proof induct
  case (less x b c)
  note IH = \<open>\<And>y b c. \<lbrakk>R\<inverse>\<inverse> y x; R\<^sup>*\<^sup>* y b; R\<^sup>*\<^sup>* y c\<rbrakk>
                     \<Longrightarrow> \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d\<close>
  show ?case
    by (coherent
      \<open>R\<^sup>*\<^sup>* x c\<close> \<open>R\<^sup>*\<^sup>* x b\<close>
      refl [where 'a='a] sym
      eq_imp_rtranclp
      r_into_rtranclp [of R]
      rtranclp_trans
      lc IH [OF conversepI]
      converse_rtranclpE)
qed

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section "From regular expressions directly to nondeterministic automata"

theory RegExp2NA
imports "Regular-Sets.Regular_Exp" NA
begin

type_synonym 'a bitsNA = "('a,bool list)na"

definition
"atom"  :: "'a \<Rightarrow> 'a bitsNA" where
"atom a = ([True],
            \<lambda>b s. if s=[True] \<and> b=a then {[False]} else {},
            \<lambda>s. s=[False])"

definition
 or :: "'a bitsNA \<Rightarrow> 'a bitsNA \<Rightarrow> 'a bitsNA" where
"or = (\<lambda>(ql,dl,fl)(qr,dr,fr).
   ([],
    \<lambda>a s. case s of
            [] \<Rightarrow> (True ## dl a ql) \<union> (False ## dr a qr)
          | left#s \<Rightarrow> if left then True ## dl a s
                              else False ## dr a s,
    \<lambda>s. case s of [] \<Rightarrow> (fl ql | fr qr)
                | left#s \<Rightarrow> if left then fl s else fr s))"

definition
 conc :: "'a bitsNA \<Rightarrow> 'a bitsNA \<Rightarrow> 'a bitsNA" where
"conc = (\<lambda>(ql,dl,fl)(qr,dr,fr).
   (True#ql,
    \<lambda>a s. case s of
            [] \<Rightarrow> {}
          | left#s \<Rightarrow> if left then (True ## dl a s) \<union>
                                   (if fl s then False ## dr a qr else {})
                              else False ## dr a s,
    \<lambda>s. case s of [] \<Rightarrow> False | left#s \<Rightarrow> left \<and> fl s \<and> fr qr | \<not>left \<and> fr s))"

definition
 epsilon :: "'a bitsNA" where
"epsilon = ([],\<lambda>a s. {}, \<lambda>s. s=[])"

definition
 plus :: "'a bitsNA \<Rightarrow> 'a bitsNA" where
"plus = (\<lambda>(q,d,f). (q, \<lambda>a s. d a s \<union> (if f s then d a q else {}), f))"

definition
 star :: "'a bitsNA \<Rightarrow> 'a bitsNA" where
"star A = or epsilon (plus A)"

primrec rexp2na :: "'a rexp \<Rightarrow> 'a bitsNA" where
"rexp2na Zero       = ([], \<lambda>a s. {}, \<lambda>s. False)" |
"rexp2na One        = epsilon" |
"rexp2na(Atom a)    = atom a" |
"rexp2na(Plus r s)  = or (rexp2na r) (rexp2na s)" |
"rexp2na(Times r s) = conc (rexp2na r) (rexp2na s)" |
"rexp2na(Star r)    = star (rexp2na r)"

declare split_paired_all[simp]

(******************************************************)
(*                       atom                         *)
(******************************************************)

lemma fin_atom: "(fin (atom a) q) = (q = [False])"
by(simp add:atom_def)

lemma start_atom: "start (atom a) = [True]"
by(simp add:atom_def)

lemma in_step_atom_Some[simp]:
 "(p,q) : step (atom a) b = (p=[True] \<and> q=[False] \<and> b=a)"
by (simp add: atom_def step_def)

lemma False_False_in_steps_atom:
 "([False],[False]) : steps (atom a) w = (w = [])"
apply (induct "w")
 apply simp
apply (simp add: relcomp_unfold)
done

lemma start_fin_in_steps_atom:
 "(start (atom a), [False]) : steps (atom a) w = (w = [a])"
apply (induct "w")
 apply (simp add: start_atom)
apply (simp add: False_False_in_steps_atom relcomp_unfold start_atom)
done

lemma accepts_atom:
 "accepts (atom a) w = (w = [a])"
by (simp add: accepts_conv_steps start_fin_in_steps_atom fin_atom)

(******************************************************)
(*                      or                            *)
(******************************************************)

(***** lift True/False over fin *****)

lemma fin_or_True[iff]:
 "\<And>L R. fin (or L R) (True#p) = fin L p"
by(simp add:or_def)

lemma fin_or_False[iff]:
 "\<And>L R. fin (or L R) (False#p) = fin R p"
by(simp add:or_def)

(***** lift True/False over step *****)

(***** lift True/False over steps *****)

lemma lift_True_over_steps_or[iff]:
 "\<And>p. (True#p,q)\<in>steps (or L R) w = (\<exists>r. q = True # r \<and> (p,r) \<in> steps L w)"
apply (induct "w")
 apply force
apply force
done

lemma lift_False_over_steps_or[iff]:
 "\<And>p. (False#p,q)\<in>steps (or L R) w = (\<exists>r. q = False#r \<and> (p,r)\<in>steps R w)"
apply (induct "w")
 apply force
apply force
done

(** From the start  **)

lemma start_step_or[iff]:
 "\<And>L R. (start(or L R),q) : step(or L R) a =
         (\<exists>p. (q = True#p \<and> (start L,p) : step L a) |
               (q = False#p \<and> (start R,p) : step R a))"
apply (simp add:or_def step_def)
apply blast
done

lemma steps_or:
 "(start(or L R), q) : steps (or L R) w =
  ( (w = [] \<and> q = start(or L R)) |
    (w \<noteq> [] \<and> (\<exists>p.  q = True  # p \<and> (start L,p) : steps L w |
                      q = False # p \<and> (start R,p) : steps R w)))"
apply (case_tac "w")
 apply (simp)
 apply blast
apply (simp)
apply blast
done

lemma fin_start_or[iff]:
 "\<And>L R. fin (or L R) (start(or L R)) = (fin L (start L) | fin R (start R))"
by (simp add:or_def)

lemma accepts_or[iff]:
 "accepts (or L R) w = (accepts L w | accepts R w)"
apply (simp add: accepts_conv_steps steps_or)
(* get rid of case_tac: *)
apply (case_tac "w = []")
 apply auto
done

(******************************************************)
(*                      conc                        *)
(******************************************************)

(** True/False in fin **)

lemma fin_conc_True[iff]:
 "\<And>L R. fin (conc L R) (True#p) = (fin L p \<and> fin R (start R))"
by(simp add:conc_def)

lemma fin_conc_False[iff]:
 "\<And>L R. fin (conc L R) (False#p) = fin R p"
by(simp add:conc_def)

(** True/False in step **)

lemma True_step_conc[iff]:
 "\<And>L R. (True#p,q) : step (conc L R) a =
        ((\<exists>r. q=True#r \<and> (p,r): step L a) |
         (fin L p \<and> (\<exists>r. q=False#r \<and> (start R,r) : step R a)))"
apply (simp add:conc_def step_def)
apply blast
done

lemma False_step_conc[iff]:
 "\<And>L R. (False#p,q) : step (conc L R) a =
       (\<exists>r. q = False#r \<and> (p,r) : step R a)"
apply (simp add:conc_def step_def)
apply blast
done

(** False in steps **)

lemma False_steps_conc[iff]:
 "\<And>p. (False#p,q): steps (conc L R) w = (\<exists>r. q=False#r \<and> (p,r): steps R w)"
apply (induct "w")
 apply fastforce
apply force
done

(** True in steps **)

lemma True_True_steps_concI:
 "\<And>L R p. (p,q) : steps L w \<Longrightarrow> (True#p,True#q) : steps (conc L R) w"
apply (induct "w")
 apply simp
apply simp
apply fast
done

lemma True_False_step_conc[iff]:
 "\<And>L R. (True#p,False#q) : step (conc L R) a =
         (fin L p \<and> (start R,q) : step R a)"
by simp

lemma True_steps_concD[rule_format]:
 "\<forall>p. (True#p,q) : steps (conc L R) w \<longrightarrow>
     ((\<exists>r. (p,r) : steps L w \<and> q = True#r)  \<or>
  (\<exists>u a v. w = u@a#v \<and>
            (\<exists>r. (p,r) : steps L u \<and> fin L r \<and>
            (\<exists>s. (start R,s) : step R a \<and>
            (\<exists>t. (s,t) : steps R v \<and> q = False#t)))))"
apply (induct "w")
 apply simp
apply simp
apply (clarify del:disjCI)
apply (erule disjE)
 apply (clarify del:disjCI)
 apply (erule allE, erule impE, assumption)
 apply (erule disjE)
  apply blast
 apply (rule disjI2)
 apply (clarify)
 apply simp
 apply (rule_tac x = "a#u" in exI)
 apply simp
 apply blast
apply (rule disjI2)
apply (clarify)
apply simp
apply (rule_tac x = "[]" in exI)
apply simp
apply blast
done

lemma True_steps_conc:
 "(True#p,q) : steps (conc L R) w =
 ((\<exists>r. (p,r) : steps L w \<and> q = True#r)  \<or>
  (\<exists>u a v. w = u@a#v \<and>
            (\<exists>r. (p,r) : steps L u \<and> fin L r \<and>
            (\<exists>s. (start R,s) : step R a \<and>
            (\<exists>t. (s,t) : steps R v \<and> q = False#t)))))"
by(force dest!: True_steps_concD intro!: True_True_steps_concI)

(** starting from the start **)

lemma start_conc:
  "\<And>L R. start(conc L R) = True#start L"
by (simp add:conc_def)

lemma final_conc:
 "\<And>L R. fin(conc L R) p = ((fin R (start R) \<and> (\<exists>s. p = True#s \<and> fin L s)) \<or>
                           (\<exists>s. p = False#s \<and> fin R s))"
apply (simp add:conc_def split: list.split)
apply blast
done

lemma accepts_conc:
 "accepts (conc L R) w = (\<exists>u v. w = u@v \<and> accepts L u \<and> accepts R v)"
apply (simp add: accepts_conv_steps True_steps_conc final_conc start_conc)
apply (rule iffI)
 apply (clarify)
 apply (erule disjE)
  apply (clarify)
  apply (erule disjE)
   apply (rule_tac x = "w" in exI)
   apply simp
   apply blast
  apply blast
 apply (erule disjE)
  apply blast
 apply (clarify)
 apply (rule_tac x = "u" in exI)
 apply simp
 apply blast
apply (clarify)
apply (case_tac "v")
 apply simp
 apply blast
apply simp
apply blast
done

(******************************************************)
(*                     epsilon                        *)
(******************************************************)

lemma step_epsilon[simp]: "step epsilon a = {}"
by(simp add:epsilon_def step_def)

lemma steps_epsilon: "((p,q) : steps epsilon w) = (w=[] \<and> p=q)"
by (induct "w") auto

lemma accepts_epsilon[iff]: "accepts epsilon w = (w = [])"
apply (simp add: steps_epsilon accepts_conv_steps)
apply (simp add: epsilon_def)
done

(******************************************************)
(*                       plus                         *)
(******************************************************)

lemma start_plus[simp]: "\<And>A. start (plus A) = start A"
by(simp add:plus_def)

lemma fin_plus[iff]: "\<And>A. fin (plus A) = fin A"
by(simp add:plus_def)

lemma step_plusI:
  "\<And>A. (p,q) : step A a \<Longrightarrow> (p,q) : step (plus A) a"
by(simp add:plus_def step_def)

lemma steps_plusI: "\<And>p. (p,q) : steps A w \<Longrightarrow> (p,q) \<in> steps (plus A) w"
apply (induct "w")
 apply simp
apply simp
apply (blast intro: step_plusI)
done

lemma step_plus_conv[iff]:
 "\<And>A. (p,r): step (plus A) a =
       ( (p,r): step A a | fin A p \<and> (start A,r) : step A a )"
by(simp add:plus_def step_def)

lemma fin_steps_plusI:
 "[| (start A,q) : steps A u; u \<noteq> []; fin A p |]
 ==> (p,q) : steps (plus A) u"
apply (case_tac "u")
 apply blast
apply simp
apply (blast intro: steps_plusI)
done

(* reverse list induction! Complicates matters for conc? *)
lemma start_steps_plusD[rule_format]:
 "\<forall>r. (start A,r) \<in> steps (plus A) w \<longrightarrow>
     (\<exists>us v. w = concat us @ v \<and>
              (\<forall>u\<in>set us. accepts A u) \<and>
              (start A,r) \<in> steps A v)"
apply (induct w rule: rev_induct)
 apply simp
 apply (rule_tac x = "[]" in exI)
 apply simp
apply simp
apply (clarify)
apply (erule allE, erule impE, assumption)
apply (clarify)
apply (erule disjE)
 apply (rule_tac x = "us" in exI)
 apply (simp)
 apply blast
apply (rule_tac x = "us@[v]" in exI)
apply (simp add: accepts_conv_steps)
apply blast
done

lemma steps_star_cycle[rule_format]:
 "us \<noteq> [] \<longrightarrow> (\<forall>u \<in> set us. accepts A u) \<longrightarrow> accepts (plus A) (concat us)"
apply (simp add: accepts_conv_steps)
apply (induct us rule: rev_induct)
 apply simp
apply (rename_tac u us)
apply simp
apply (clarify)
apply (case_tac "us = []")
 apply (simp)
 apply (blast intro: steps_plusI fin_steps_plusI)
apply (clarify)
apply (case_tac "u = []")
 apply (simp)
 apply (blast intro: steps_plusI fin_steps_plusI)
apply (blast intro: steps_plusI fin_steps_plusI)
done

lemma accepts_plus[iff]:
 "accepts (plus A) w =
 (\<exists>us. us \<noteq> [] \<and> w = concat us \<and> (\<forall>u \<in> set us. accepts A u))"
apply (rule iffI)
 apply (simp add: accepts_conv_steps)
 apply (clarify)
 apply (drule start_steps_plusD)
 apply (clarify)
 apply (rule_tac x = "us@[v]" in exI)
 apply (simp add: accepts_conv_steps)
 apply blast
apply (blast intro: steps_star_cycle)
done

(******************************************************)
(*                       star                         *)
(******************************************************)

lemma accepts_star:
 "accepts (star A) w = (\<exists>us. (\<forall>u \<in> set us. accepts A u) \<and> w = concat us)"
apply(unfold star_def)
apply (rule iffI)
 apply (clarify)
 apply (erule disjE)
  apply (rule_tac x = "[]" in exI)
  apply simp
 apply blast
apply force
done

(***** Correctness of r2n *****)

lemma accepts_rexp2na:
 "\<And>w. accepts (rexp2na r) w = (w : lang r)"
apply (induct "r")
     apply (simp add: accepts_conv_steps)
    apply simp
   apply (simp add: accepts_atom)
  apply (simp)
 apply (simp add: accepts_conc Regular_Set.conc_def)
apply (simp add: accepts_star in_star_iff_concat subset_iff Ball_def)
done

end