section\<open>Tangle\_Algebra: Tensor product of tangles and its properties\<close>
theory Tangle_Algebra
imports Tangles
begin

section\<open>Definition of tensor product of walls\<close>

text\<open>the following definition is used to construct a block of n vert strands\<close>
primrec make_vert_block:: "nat \<Rightarrow> block"
where
"make_vert_block 0 = []"
|"make_vert_block (Suc n) = vert#(make_vert_block n)"

lemma domain_make_vert:"domain_block (make_vert_block n) = int n"
 by (induction n) (auto)

lemma codomain_make_vert:"codomain_block (make_vert_block n) = int n"
  by (induction n) (auto)

(*we defined the tensor of wall as described in the standard tangle algebra*)
fun tensor::"wall => wall => wall" (infixr "\<otimes>" 65)
where
1:"tensor (basic x) (basic y) = (basic (x \<otimes> y))"
|2:"tensor (x*xs) (basic y) = (
                  if (codomain_block y = 0)
                  then (x \<otimes> y)*xs
                   else
                    (x \<otimes> y)
                     *(xs\<otimes>(basic (make_vert_block (nat (codomain_block y))))))"
|3:"tensor (basic x) (y*ys) = (
                  if (codomain_block x = 0)
                   then (x \<otimes> y)*ys
                   else
                    (x \<otimes> y)
                    *((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys))"
|4:"tensor (x*xs) (y*ys) = (x \<otimes> y)* (xs \<otimes> ys)"

section\<open>Properties of tensor product of tangles\<close>

lemma Nil_right_tensor:"(basic ([])) \<otimes> xs = xs"
 by (cases xs) (auto)

text\<open>The definition of tensors is extended to diagrams by using the
following function\<close>
definition tensor_Tangle ::"Tangle_Diagram \<Rightarrow> Tangle_Diagram \<Rightarrow> Tangle_Diagram" (infixl "\<otimes>" 65)
where
"tensor_Tangle x y = Abs_Tangle_Diagram ((Rep_Tangle_Diagram x) \<otimes> (Rep_Tangle_Diagram y))"

(*some lemmas*)
lemma "tensor (basic [vert]) (basic ([vert])) = (basic (([vert]) \<otimes> ([vert])))"
 by simp

text\<open>domain\_wall of a tensor product of two walls is the sum of
the domain\_wall of each of the tensor
 products\<close>

lemma tensor_domain_wall_additivity:
 "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
proof(cases xs)
 fix x
 assume A:"xs = basic x"
 then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
  proof(cases ys)
   fix y
   assume B:"ys = basic y"
   have "domain_block (x \<otimes> y) = domain_block x + domain_block y"
       using domain_additive by auto
   then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
       using tensor.simps(1) A B by auto
   thus ?thesis by auto
 next
  fix z zs
  assume C:"ys = (z*zs)"
  have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
   proof(cases "(codomain_block x) = 0")
     assume "codomain_block x = 0"
     then have "(xs \<otimes> ys) = (x \<otimes> z)*zs"
          using A C tensor.simps(4) by auto
     then have "domain_wall (xs \<otimes> ys) = domain_block (x \<otimes> z)"
          by auto
     moreover have "domain_wall ys = domain_block z"
          unfolding domain_wall_def C by auto
     moreover have "domain_wall xs = domain_block x"
          unfolding domain_wall_def A by auto
     moreover have "domain_block (x \<otimes> z) = domain_block x + domain_block z"
          using domain_additive by auto
     ultimately show ?thesis by auto
    next
     assume "codomain_block x \<noteq> 0"
     have "(xs \<otimes> ys)
                 = (x \<otimes> z)
                    *((basic (make_vert_block (nat (codomain_block x))))\<otimes> zs)"
          using tensor.simps(3) A C \<open>codomain_block x \<noteq> 0\<close>  by auto
     then have "domain_wall (xs \<otimes> ys) = domain_block (x \<otimes> z)"
          by auto
     moreover have "domain_wall ys = domain_block z"
          unfolding domain_wall_def C by auto
     moreover have "domain_wall xs = domain_block x"
          unfolding domain_wall_def A by auto
     moreover have "domain_block (x \<otimes> z) = domain_block x + domain_block z"
          using domain_additive by auto
     ultimately show ?thesis by auto
   qed
   then show ?thesis by auto
 qed
 then show ?thesis by auto
 next
  fix z zs
  assume D:"xs = z * zs"
  then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
   proof(cases ys)
    fix y
    assume E:"ys = basic y"
    then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
    proof(cases "codomain_block y = 0")
      assume "codomain_block y = 0"
      have "(xs \<otimes> ys) = (z \<otimes> y)*zs"
          using tensor.simps(2)  D E \<open>codomain_block y = 0\<close> by auto
      then have "domain_wall (xs \<otimes> ys) = domain_block (z \<otimes> y)"
          by auto
      moreover have "domain_wall xs = domain_block z"
          unfolding domain_wall_def D by auto
      moreover have "domain_wall ys = domain_block y"
          unfolding domain_wall_def E by auto
      moreover have "domain_block (z \<otimes> y) = domain_block z + domain_block y"
          using domain_additive by auto
      ultimately show ?thesis by auto
    next
     assume "codomain_block y \<noteq> 0"
     have "(xs \<otimes> ys)
               =
                (z \<otimes> y)
                  *(zs\<otimes>(basic (make_vert_block (nat (codomain_block y)))))"
          using tensor.simps(3) D E \<open>codomain_block y \<noteq> 0\<close>  by auto
     then have "domain_wall (xs \<otimes> ys) = domain_block (z \<otimes> y)"
          by auto
     moreover have "domain_wall ys = domain_block y"
          unfolding domain_wall_def E by auto
     moreover have "domain_wall xs = domain_block z"
          unfolding domain_wall_def D by auto
     moreover have "domain_block (z \<otimes> y) = domain_block z + domain_block y"
          using domain_additive by auto
     ultimately show ?thesis by auto
   qed
   then show ?thesis by auto
  next
   fix w ws
   assume F:"ys = w*ws"
   have "(xs \<otimes> ys) = (z \<otimes> w) * (zs \<otimes> ws)"
          using D F by auto
   then have "domain_wall (xs \<otimes> ys) = domain_block (z \<otimes> w)"
          by auto
   moreover have "domain_wall ys = domain_block w"
          unfolding domain_wall_def F by auto
   moreover have "domain_wall xs = domain_block z"
          unfolding domain_wall_def D by auto
   moreover have "domain_block (z \<otimes> w) = domain_block z + domain_block w"
          using domain_additive by auto
   ultimately show ?thesis by auto
  qed
  then show ?thesis by auto
qed

text\<open>codomain of tensor of two walls is the sum of the respective
codomain's is shown by the following theorem\<close>

lemma tensor_codomain_wall_additivity:
 "codomain_wall (xs \<otimes> ys) = codomain_wall xs + codomain_wall ys"
proof(induction xs ys  rule:tensor.induct)
 fix xs ys
 let ?case = "(codomain_wall ((basic xs) \<otimes> (basic ys))
                       = (codomain_wall (basic (xs)))
                              + (codomain_wall (basic ys)))"
 show ?case using codomain_wall.simps codomain_block.simps tensor.simps
                     by (metis codomain_additive)
next
 fix x xs y
 assume case_2:
         "codomain_block y \<noteq> 0
           \<Longrightarrow> codomain_wall
                (xs \<otimes> basic (make_vert_block (nat (codomain_block y))))
                  = codomain_wall xs
                     + codomain_wall
                          (basic (make_vert_block (nat (codomain_block y))))"

 let ?case = "codomain_wall ((x*xs)\<otimes> (basic y))
                  = (codomain_wall (x*xs)) + (codomain_wall (basic y))"
 show ?case
 proof(cases "(codomain_block y = 0)")
  case True
   have "((x*xs)\<otimes> (basic y)) =  (x \<otimes> y)*xs "
                using "Tangle_Algebra.2" True by auto
   then have "codomain_wall ((x*xs)\<otimes> (basic y))
                                = codomain_wall ((x \<otimes> y)*xs)"
                by auto
   then have "... = codomain_wall xs"
                using codomain_wall.simps by auto
   then have "... = codomain_wall xs + codomain_wall (basic y)"
                using True codomain_wall.simps(1) by auto
   then show ?thesis by auto
  next
  case False
   have "(x*xs) \<otimes> (basic y)
                 = (x \<otimes> y)
                     *(xs\<otimes>(basic (make_vert_block (nat (codomain_block y)))))"
                using False by (metis "Tangle_Algebra.2")
   moreover then have "codomain_wall ((x*xs) \<otimes> (basic y))
                      = codomain_wall(...)"
                 by auto
   moreover have "...
                  = codomain_wall
                      (xs\<otimes>(basic (make_vert_block (nat (codomain_block y)))))"
                 using domain_wall.simps by auto
   moreover have "...
                  = codomain_wall xs
                     + codomain_wall
                          (basic (make_vert_block (nat (codomain_block y))))"
                 using case_2 False by auto
   moreover have "... = codomain_wall (x*xs)
                       + codomain_block y"
                 using codomain_wall.simps
                 by (metis codomain_block_nonnegative   codomain_make_vert int_nat_eq)
   moreover have "... = codomain_wall (x*xs) + codomain_wall (basic y)"
                  using codomain_wall.simps(1) by auto
   ultimately show ?thesis by auto
 qed
 next
  fix x y ys
  assume case_3:"(codomain_block x \<noteq> 0 \<Longrightarrow>
        codomain_wall
             (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)
            = codomain_wall
               (basic (make_vert_block (nat (codomain_block x))))
                  + codomain_wall ys)"
  let ?case = "codomain_wall ((basic x) \<otimes> (y*ys))
                  = codomain_wall (basic x) + codomain_wall (y*ys)"
  show ?case
   proof(cases "codomain_block x = 0")
    case True
     have "(basic x)\<otimes>(y*ys) = (x \<otimes> y)*ys"
                using True 3 by auto
     then have "codomain_wall (...) = codomain_wall (...)"
                by auto
     then have "... = codomain_wall ys"
                by auto
     then have "... = codomain_wall ys + codomain_wall (basic x)"
                using codomain_wall.simps(1) True by auto
     then show ?thesis by auto
    next
    case False
     have "(basic x) \<otimes> (y*ys)
                 = (x \<otimes> y)
                    *((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys)"
                using False 3 by auto
     then have "codomain_wall (...) = codomain_wall (...)"
                by auto
     then have "...
                 = codomain_wall
                     ((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys)"
                using codomain_wall.simps(2) by auto
     then have "... = codomain_block x + codomain_wall ys"
                using codomain_wall.simps case_3 False
                      codomain_block_nonnegative codomain_make_vert int_nat_eq
                by auto
     then have "... = codomain_wall (basic x) + codomain_wall (y*ys)"
                using codomain_wall.simps by auto
        then show ?thesis by (metis \<open>basic x \<otimes> y * ys = (x \<otimes> y) * (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)\<close> \<open>codomain_wall ((x \<otimes> y) * (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)) = codomain_wall (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)\<close> \<open>codomain_wall (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys) = codomain_block x + codomain_wall ys\<close>)
   qed
   next
    fix x xs y ys
    assume case_4:"codomain_wall (xs \<otimes> ys) = codomain_wall xs + codomain_wall ys "
    let ?case = "codomain_wall ((x*xs) \<otimes> (y*ys))
                      = codomain_wall (x*xs) + codomain_wall (y*ys)"
    have " ((x*xs) \<otimes> (y*ys)) = (x \<otimes> y)*(xs \<otimes> ys)"
                using 4 by auto
    then have "codomain_wall (...) = codomain_wall (...)"
                by auto
    then have "... = codomain_wall (xs \<otimes> ys)"
                using codomain_wall.simps(2) by auto
    then have "... = codomain_wall xs + codomain_wall ys"
                using case_4 by auto
    then have "... = codomain_wall (x*xs) + (codomain_wall (y*ys))"
         using codomain_wall.simps(2) by auto
    then show ?case by (metis \<open>codomain_wall ((x \<otimes> y) * (xs \<otimes> ys)) = codomain_wall (xs \<otimes> ys)\<close> \<open>x * xs \<otimes> y * ys = (x \<otimes> y) * (xs \<otimes> ys)\<close> case_4)
qed

(*the following theorem tells us that
given a tensor product of a tangle diagram with a block consisting of
only vertical strands, it gives a tangle diagram*)

theorem is_tangle_make_vert_right:
 "(is_tangle_diagram xs)
          \<Longrightarrow> is_tangle_diagram (xs \<otimes> (basic (make_vert_block n)))"
proof(induct xs)
 case (basic xs)
  show ?case by auto
 next
 case (prod x xs)
  have ?case
   proof(cases n)
    case 0
     have
        "codomain_block (x \<otimes> (make_vert_block 0))
               = (codomain_block x) + codomain_block(make_vert_block 0)"
            using  codomain_additive by auto
     moreover have "codomain_block (make_vert_block 0) = 0"
            by auto
     ultimately have "codomain_block (x \<otimes> (make_vert_block 0)) = codomain_block (x)"
            by auto
     moreover have "is_tangle_diagram xs"
          using prod.prems by (metis is_tangle_diagram.simps(2))
     then have "is_tangle_diagram ((x \<otimes> (make_vert_block 0))*xs)"
          using is_tangle_diagram.simps(2) by (metis calculation prod.prems)
     then  have "is_tangle_diagram ((x*xs) \<otimes> (basic (make_vert_block 0)))"
          by auto
     then show ?thesis using  "0" by (metis)
    next
    case (Suc k)
     have "codomain_block (make_vert_block (k+1)) = int (k+1)"
         using codomain_make_vert  by auto
     then have "(nat (codomain_block (make_vert_block (k+1)))) = k+1"
         by auto
     then have "make_vert_block (nat (codomain_block (make_vert_block (k+1))))
                             = make_vert_block (k+1)"
          by auto
     moreover have "codomain_wall (basic (make_vert_block (k+1)))>0"
       using make_vert_block.simps codomain_wall.simps  Suc_eq_plus1
       codomain_make_vert of_nat_0_less_iff zero_less_Suc
       by metis
     ultimately have 1: "(x*xs) \<otimes> (basic (make_vert_block (k+1)))
             =  (x\<otimes>(make_vert_block (k+1)))*(xs\<otimes>(basic (make_vert_block (k+1))))"
        using tensor.simps(2) by simp
     have "domain_wall (xs\<otimes>(basic (make_vert_block (k+1))))
                 = domain_wall xs + domain_wall (basic (make_vert_block (k+1)))"
            using tensor_domain_wall_additivity by auto
     then have 2:
          "domain_wall (xs\<otimes>(basic (make_vert_block (k+1))))
                  = (domain_wall xs) + int (k+1)"
             using domain_make_vert domain_wall.simps(1) by auto
     moreover have 3: "codomain_block (x \<otimes> (make_vert_block (k+1)))
                 = codomain_block x + int (k+1)"
             using  codomain_additive codomain_make_vert by (metis)
     have "is_tangle_diagram (x*xs)"
            using prod.prems by auto
     then have 4:"codomain_block x = domain_wall xs"
            using is_tangle_diagram.simps(2) by metis
     from 2 3 4 have
       "domain_wall (xs\<otimes>(basic (make_vert_block (k+1))))
               = codomain_block (x \<otimes> (make_vert_block (k+1))) "
            by auto
     moreover have "is_tangle_diagram (xs\<otimes>(basic (make_vert_block (k+1))))"
            using prod.hyps prod.prems by (metis Suc Suc_eq_plus1 is_tangle_diagram.simps(2))
     ultimately have "is_tangle_diagram ((x*xs) \<otimes> (basic (make_vert_block (k+1))))"
                using 1 by auto
     then show ?thesis using  Suc Suc_eq_plus1 by metis
   qed
   then show ?case by auto
 qed

(*the following theorem tells us that given a tensor product of a vertical strand block with a
tangle diagram, it gives a tangle diagram. If the above result can be treated as right product,
this can be treated as the left product*)

theorem is_tangle_make_vert_left:
 "(is_tangle_diagram xs) \<Longrightarrow> is_tangle_diagram ((basic (make_vert_block n)) \<otimes> xs)"
proof(induct xs)
 case (basic xs)
  show ?case by auto
 next
 case (prod x xs)
  have ?case
  proof(cases n)
   case 0
    have
        "codomain_block ( (make_vert_block 0) \<otimes> x)
               = (codomain_block x) + codomain_block(make_vert_block 0)"
            using  codomain_additive by auto
    moreover have "codomain_block (make_vert_block 0) = 0"
            by auto
    ultimately have "codomain_block ( (make_vert_block 0) \<otimes> x) = codomain_block (x)"
            by auto
    moreover have "is_tangle_diagram xs"
          using prod.prems by (metis is_tangle_diagram.simps(2))
    then have "is_tangle_diagram (( (make_vert_block 0) \<otimes> x)*xs)"
          using is_tangle_diagram.simps(2) by (metis calculation prod.prems)
    then  have "is_tangle_diagram ((basic (make_vert_block 0)) \<otimes> (x*xs) )"
          by auto
    then show ?thesis using  "0" by (metis)
   next
   case (Suc k)
    have "codomain_block (make_vert_block (k+1)) = int (k+1)"
         using codomain_make_vert  by auto
    then have "(nat (codomain_block (make_vert_block (k+1)))) = k+1"
         by auto
    then have "make_vert_block (nat (codomain_block (make_vert_block (k+1))))
                             = make_vert_block (k+1)"
         by auto
    moreover have "codomain_wall (basic (make_vert_block (k+1)))>0"
        using make_vert_block.simps codomain_wall.simps  Suc_eq_plus1
              codomain_make_vert of_nat_0_less_iff zero_less_Suc
        by metis
    ultimately have 1: "  (basic (make_vert_block (k+1))) \<otimes> (x*xs)
             =  ((make_vert_block (k+1)) \<otimes> x)*((basic (make_vert_block (k+1))) \<otimes> xs)"
        using tensor.simps(3) by simp
    have "domain_wall ((basic (make_vert_block (k+1))) \<otimes> xs)
                 = domain_wall xs + domain_wall (basic (make_vert_block (k+1)))"
        using tensor_domain_wall_additivity by auto
    then have 2:
          "domain_wall ((basic (make_vert_block (k+1))) \<otimes> xs)
                  = (domain_wall xs) + int (k+1)"
        using domain_make_vert domain_wall.simps(1) by auto
    moreover have 3: "codomain_block ( (make_vert_block (k+1)) \<otimes> x)
                 = codomain_block x + int (k+1)"
         using  codomain_additive codomain_make_vert
         by (simp add: codomain_additive)
    have "is_tangle_diagram (x*xs)"
         using prod.prems by auto
    then have 4:"codomain_block x = domain_wall xs"
            using is_tangle_diagram.simps(2) by metis
    from 2 3 4 have
       "domain_wall ((basic (make_vert_block (k+1))) \<otimes> xs)
               = codomain_block ((make_vert_block (k+1)) \<otimes> x)"
            by auto
    moreover have "is_tangle_diagram ((basic (make_vert_block (k+1))) \<otimes> xs)"
            using prod.hyps prod.prems by (metis Suc Suc_eq_plus1 is_tangle_diagram.simps(2))
    ultimately have "is_tangle_diagram ((basic (make_vert_block (k+1))) \<otimes> (x*xs))"
                using 1 by auto
    then show ?thesis using  Suc Suc_eq_plus1 by metis
  qed
  then show ?case by auto
qed

(*We prove that tensor product of two tangle diagrams is a tangle diagram .
The following lemmas are used in the process of proving each of the
inductive cases*)
lemma simp1: "(codomain_block y) \<noteq> 0 \<Longrightarrow>
       is_tangle_diagram (xs)
\<and> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block y))))) \<longrightarrow>
               is_tangle_diagram (xs \<otimes>  ((basic (make_vert_block (nat (codomain_block y)))))) \<Longrightarrow>
(is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow> is_tangle_diagram (x * xs \<otimes> basic y))
"
proof-
 assume A: "(codomain_block y) \<noteq> 0"
 assume B:
     " is_tangle_diagram (xs)
     \<and> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block y)))))
      \<longrightarrow>
       is_tangle_diagram (xs \<otimes>  ((basic (make_vert_block (nat (codomain_block y))))))"
 have " is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow> is_tangle_diagram xs"
        by (metis is_tangle_diagram.simps(2))
 moreover have "(is_tangle_diagram (basic (make_vert_block (nat (codomain_block y))))) "
        using is_tangle_diagram.simps(1) by auto
 ultimately have
   " ((is_tangle_diagram xs)
   \<and>(is_tangle_diagram (basic (make_vert_block (nat (codomain_block y)))))
    \<longrightarrow> is_tangle_diagram (xs \<otimes> basic (make_vert_block (nat (codomain_block y)))))
      \<Longrightarrow>
       is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
       is_tangle_diagram (xs \<otimes> basic (make_vert_block (nat (codomain_block y))))"
        by metis
  moreover have 1:"codomain_block y = domain_wall (basic (make_vert_block (nat (codomain_block y))))"
        using codomain_block_nonnegative domain_make_vert domain_wall.simps(1) int_nat_eq by auto
  moreover have 2:"is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
                 codomain_block x = domain_wall xs"
        using is_tangle_diagram.simps(2) by metis
 moreover have "codomain_block (x \<otimes> y) = codomain_block x +codomain_block y"
        using codomain_additive by auto
 moreover have "domain_wall (xs \<otimes> (basic (make_vert_block (nat (codomain_block y)))))
                 = domain_wall xs + domain_wall (basic (make_vert_block (nat (codomain_block y))))"
        using tensor_domain_wall_additivity by auto
 moreover then have " is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
          domain_wall (xs \<otimes> (basic (make_vert_block (nat (codomain_block y)))))
                   = codomain_block (x \<otimes> y)"
        by (metis "1" "2" calculation(4))
 ultimately have
      "(is_tangle_diagram xs)
      \<and> (is_tangle_diagram (basic (make_vert_block (nat (codomain_block y)))))
       \<longrightarrow> is_tangle_diagram (xs \<otimes> basic (make_vert_block (nat (codomain_block y))))
       \<Longrightarrow>
         is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
         is_tangle_diagram ((x \<otimes> y)* (xs \<otimes> (basic (make_vert_block (nat (codomain_block y))))))"
        using is_tangle_diagram.simps(2)  by auto
 then have "
       is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
               is_tangle_diagram ((x*xs) \<otimes> (basic y))"
        by (metis "Tangle_Algebra.2" \<open>
        codomain_block y \<noteq> 0\<close> is_tangle_make_vert_right)
 then show ?thesis by auto
qed

lemma simp2:
 "(codomain_block x) \<noteq> 0
 \<Longrightarrow>
   is_tangle_diagram  (basic (make_vert_block (nat (codomain_block x))))
 \<and> is_tangle_diagram (ys)
    \<longrightarrow>
      is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)
     \<Longrightarrow>
    (is_tangle_diagram (basic x)
   \<and> is_tangle_diagram (y*ys)
         \<longrightarrow> is_tangle_diagram ((basic x) \<otimes> (y*ys)))"
proof-
 assume A: "(codomain_block x) \<noteq> 0"
 assume B: "is_tangle_diagram  (basic (make_vert_block (nat (codomain_block x))))
            \<and> is_tangle_diagram (ys) \<longrightarrow>
              is_tangle_diagram
                            ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)"
 have " is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys)
                                               \<longrightarrow> is_tangle_diagram ys"
        by (metis is_tangle_diagram.simps(2))
 moreover have "(is_tangle_diagram
                          (basic (make_vert_block (nat (codomain_block x))))) "
        using is_tangle_diagram.simps(1) by auto
 ultimately have
      " ((is_tangle_diagram ys)
               \<and>(is_tangle_diagram (basic (make_vert_block (nat (codomain_block x)))))
    \<longrightarrow> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys))
    \<Longrightarrow>
     is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
                is_tangle_diagram
                        (( basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)"
        by metis
 moreover have 1:"codomain_block x
                         = domain_wall (basic (make_vert_block (nat (codomain_block x))))"
        using codomain_block_nonnegative domain_make_vert domain_wall.simps(1)
              int_nat_eq by auto
 moreover have 2:"is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
                 codomain_block y = domain_wall ys"
        using is_tangle_diagram.simps(2) by metis
 moreover have "codomain_block (x \<otimes> y) = codomain_block x +codomain_block y"
        using codomain_additive by auto
 moreover have "domain_wall ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)
                 = domain_wall (basic (make_vert_block (nat (codomain_block x))))
                   + domain_wall ys"
        using tensor_domain_wall_additivity by auto
 moreover then have " is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
          domain_wall ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)
                   = codomain_block (x \<otimes> y)"
        by (metis "1" "2" calculation(4))
 ultimately have
      "(is_tangle_diagram ys)
      \<and> (is_tangle_diagram (basic (make_vert_block (nat (codomain_block x)))))
        \<longrightarrow> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys)
         \<Longrightarrow>
          is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys)
          \<longrightarrow>
          is_tangle_diagram ((x \<otimes> y)*((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys))"
        using is_tangle_diagram.simps(2)  by auto
 then have "
       is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
               is_tangle_diagram ((basic x) \<otimes> (y*ys))"
        by (metis "Tangle_Algebra.3" A B)
 then show ?thesis by auto
qed

lemma simp3:
 "is_tangle_diagram xs \<and> is_tangle_diagram ys \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)
 \<Longrightarrow>
     is_tangle_diagram (x * xs) \<and> is_tangle_diagram (y * ys)
     \<longrightarrow> is_tangle_diagram (x * xs \<otimes> y * ys)"
proof-
 assume A: "is_tangle_diagram xs \<and> is_tangle_diagram ys \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)"
 have "is_tangle_diagram (x*xs) \<longrightarrow> (codomain_block x = domain_wall xs)"
       using is_tangle_diagram.simps(2) by auto
 moreover have "is_tangle_diagram (y*ys) \<longrightarrow> (codomain_block y = domain_wall ys)"
       using is_tangle_diagram.simps(2) by auto
 ultimately have "is_tangle_diagram (x*xs)\<and> is_tangle_diagram (y*ys)
              \<longrightarrow> codomain_block (x \<otimes> y) = domain_wall (xs \<otimes> ys)"
       using codomain_additive tensor_domain_wall_additivity by auto
 moreover have "is_tangle_diagram (x*xs)\<and> is_tangle_diagram (y*ys)
              \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)"
       using A is_tangle_diagram.simps(2) by auto
 moreover  have "(x*xs) \<otimes> (y*ys) = (x \<otimes> y)*(xs \<otimes> ys)"
      using tensor.simps(4) by auto
 ultimately have "is_tangle_diagram (x*xs)\<and> is_tangle_diagram (y*ys)
              \<longrightarrow> is_tangle_diagram ((x*xs) \<otimes> (y*ys))"
      by auto
 then show ?thesis by simp
qed

(*tensor product of two tangle diagrams is a tangle diagram*)

theorem is_tangle_diagramness:
 shows"(is_tangle_diagram x)\<and>(is_tangle_diagram y) \<longrightarrow>is_tangle_diagram (tensor x y)"
proof(induction x y  rule:tensor.induct)
 fix z w
 let ?case = "(is_tangle_diagram (basic z))\<and>(is_tangle_diagram (basic w))
                  \<longrightarrow>is_tangle_diagram ((basic z) \<otimes> (basic w))"
  show ?case by auto
 next
 fix x xs y
 let ?case = "(is_tangle_diagram (x*xs))\<and>(is_tangle_diagram (basic y))
                  \<longrightarrow>is_tangle_diagram ((x*xs) \<otimes> (basic y))"
  from simp1 show ?case
      by (metis "Tangle_Algebra.2" add.commute codomain_additive comm_monoid_add_class.add_0
                is_tangle_diagram.simps(2) is_tangle_make_vert_right)
 next
 fix x y ys
 let ?case = "(is_tangle_diagram (basic x))\<and>(is_tangle_diagram (y*ys))
                  \<longrightarrow>is_tangle_diagram ((basic x) \<otimes> (y*ys))"
  from simp2 show ?case
        by (metis "Tangle_Algebra.3" codomain_additive comm_monoid_add_class.add_0
                   is_tangle_diagram.simps(2) is_tangle_make_vert_left)
 next
 fix x y xs ys
 assume A:"  is_tangle_diagram xs \<and> is_tangle_diagram ys \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)"
 let ?case =
    "is_tangle_diagram (x * xs) \<and> is_tangle_diagram (y * ys) \<longrightarrow> is_tangle_diagram (x * xs \<otimes> y * ys)"
  from simp3 show ?case using A by auto
qed

theorem tensor_preserves_is_tangle:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
 shows "is_tangle_diagram (x \<otimes> y)"
  using assms  is_tangle_diagramness by auto

definition Tensor_Tangle::"Tangle_Diagram \<Rightarrow> Tangle_Diagram \<Rightarrow> Tangle_Diagram"
          (infixl "\<circ>" 65)
 where
"Tensor_Tangle x y =
     Abs_Tangle_Diagram ((Rep_Tangle_Diagram x) \<otimes> (Rep_Tangle_Diagram y))"

theorem well_defined_compose:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
 shows "(Abs_Tangle_Diagram x) \<otimes> (Abs_Tangle_Diagram y) = (Abs_Tangle_Diagram (x \<otimes> y))"
     using  Abs_Tangle_Diagram_inverse assms(1) assms(2)
      mem_Collect_eq tensor_preserves_is_tangle
     tensor_Tangle_def
     by auto

end


theory TickTock_SeqComp
  imports TickTock_Core TickTock_Basic_Ops
begin

subsection {* Sequential Composition *}

text_raw \<open>\DefineSnippet{SeqCompTT}{\<close>
definition SeqCompTT :: "'e ttprocess \<Rightarrow> 'e ttprocess \<Rightarrow> 'e ttprocess" (infixl ";\<^sub>C" 60) where
  "P ;\<^sub>C Q = {\<rho>\<in>P. \<nexists> s. \<rho> = s @ [[Tick]\<^sub>E]}
            \<union> {\<rho>. \<exists> s t. s @ [[Tick]\<^sub>E] \<in> P \<and> t \<in> Q \<and> \<rho> = s @ t}"
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{SeqComp_wf}{\<close>
lemma SeqComp_wf:
  assumes "\<forall>t\<in>P. ttWF t" "\<forall>t\<in>Q. ttWF t"
  shows "\<forall> t \<in> P ;\<^sub>C Q. ttWF t"
  unfolding SeqCompTT_def
proof auto
  fix t
  assume "t \<in> P" "\<forall>s. t \<noteq> s @ [[Tick]\<^sub>E]"
  then show "ttWF t"
    using assms(1) by auto
next
  fix s ta
  assume "s @ [[Tick]\<^sub>E] \<in> P"
  then have 1: "ttWF (s @ [[Tick]\<^sub>E])"
    using assms(1) by auto
  assume "ta \<in> Q"
  then have 2: "ttWF ta"
    using assms(2) by auto
  from 1 2 show "ttWF (s @ ta)"
    by (induct s rule:ttWF.induct, auto)
qed
text_raw \<open>}%EndSnippet\<close>

lemma TT0_SeqComp: "TT0 P \<Longrightarrow> TT0 Q \<Longrightarrow> TT0 (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT0_def by blast

lemma TT1_SeqComp:
  assumes "\<forall>t\<in>P. ttWF t" "TT1 P" "TT1 Q"
  shows "TT1 (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT1_def
proof (auto)
  fix \<rho> \<sigma> :: "'a ttobs list"
  show "\<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> \<sigma> \<in> P \<Longrightarrow> \<rho> \<in> P"
    using TT1_def assms(2) by blast
next
  fix \<sigma> s :: "'a ttobs list"
  assume case_assms: "s @ [[Tick]\<^sub>E] \<lesssim>\<^sub>C \<sigma>" "\<sigma> \<in> P"
  then obtain s' t where \<sigma>_assms: "\<sigma> = s' @ t \<and> s @ [[Tick]\<^sub>E] \<subseteq>\<^sub>C s'"
    by (meson tt_prefix_split tt_prefix_subset_imp_tt_subset_tt_prefix)
  then have "\<exists> s'' x. s' = s'' @ x \<and> [[Tick]\<^sub>E] \<subseteq>\<^sub>C x"
    using tt_subset_split2 by blast
  then obtain s'' where "\<sigma> = s'' @ [[Tick]\<^sub>E] @ t"
    by (auto, case_tac x rule:ttWF.cases, auto simp add: \<sigma>_assms)
  then have "ttWF \<sigma> \<Longrightarrow> \<sigma> = s'' @ [[Tick]\<^sub>E]"
  proof auto
    show "ttWF (s'' @ [Tick]\<^sub>E # t) \<Longrightarrow> t = []"
      by (induct s'' rule:ttWF.induct, auto, cases t, auto)
  qed
  then have "\<sigma> = s'' @ [[Tick]\<^sub>E]"
    using assms(1) case_assms(2) by blast
  then show "\<forall>s. \<sigma> \<noteq> s @ [[Tick]\<^sub>E] \<Longrightarrow> False"
    by auto
next
  fix \<rho> \<sigma> s t :: "'a ttobs list"
  have assm1: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P \<longrightarrow> \<rho> \<in> P"
    using TT1_def assms(2) by blast
  have assm2: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> Q \<longrightarrow> \<rho> \<in> Q"
    using TT1_def assms(3) by blast
  assume assm3: "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> \<rho> \<noteq> s @ t)"
  assume assm4: "\<rho> \<lesssim>\<^sub>C s @ t"
  assume assm5: "s @ [[Tick]\<^sub>E] \<in> P"
  assume assm6: "t \<in> Q"
  obtain r where 1: "\<rho> \<subseteq>\<^sub>C r \<and> r \<le>\<^sub>C s @ t"
    using assm4 tt_prefix_subset_imp_tt_subset_tt_prefix by blast
  then obtain t' where 2: "(r = s @ t' \<and> t' \<le>\<^sub>C t) \<or> r \<le>\<^sub>C s"
    using tt_prefix_append_split by blast
  then show "\<rho> \<in> P"
  proof auto
    assume case_assms: "r = s @ t'" "t' \<le>\<^sub>C t"
    obtain s' t'' where \<rho>_assms: "\<rho> = s' @ t'' \<and> s' \<subseteq>\<^sub>C s \<and> t'' \<subseteq>\<^sub>C t'"
      using "1" case_assms(1) tt_subset_split by blast
    have "s' @ [[Tick]\<^sub>E] \<in> P"
      using \<rho>_assms assm1 assm5 tt_subset_end_event tt_subset_imp_prefix_subset by blast
    also have "t'' \<in> Q"
      using \<rho>_assms assm2 assm6 case_assms(2) tt_prefix_imp_prefix_subset tt_subset_imp_prefix_subset by blast
    then show "\<rho> \<in> P"
      using \<rho>_assms assm3 calculation by blast
  next
    show "r \<le>\<^sub>C s \<Longrightarrow> \<rho> \<in> P"
      by (meson "1" assm1 assm5 tt_prefix_concat tt_prefix_imp_prefix_subset tt_subset_imp_prefix_subset)
  qed
next
  fix s t sa :: "'a ttobs list"
  have assm1: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P \<longrightarrow> \<rho> \<in> P"
    using TT1_def assms(2) by blast
  have assm2: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> Q \<longrightarrow> \<rho> \<in> Q"
    using TT1_def assms(3) by blast
  assume case_assms: "sa @ [[Tick]\<^sub>E] \<lesssim>\<^sub>C s @ t" "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q"
  obtain r where 1: "sa @ [[Tick]\<^sub>E] \<subseteq>\<^sub>C r \<and> r \<le>\<^sub>C s @ t"
    using case_assms(1) tt_prefix_subset_imp_tt_subset_tt_prefix by blast
  then obtain t' where 2: "(r = s @ t' \<and> t' \<le>\<^sub>C t) \<or> r \<le>\<^sub>C s"
    using tt_prefix_append_split by blast
  then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
  proof auto
    assume case_assms2: "r = s @ t'" "t' \<le>\<^sub>C t"
    obtain s' t'' where \<rho>_assms: "sa @ [[Tick]\<^sub>E] = s' @ t'' \<and> s' \<subseteq>\<^sub>C s \<and> t'' \<subseteq>\<^sub>C t'"
      using "1" case_assms2(1) tt_subset_split by blast
    have "s' @ [[Tick]\<^sub>E] \<in> P"
      using \<rho>_assms assm1 case_assms(2) tt_subset_end_event tt_subset_imp_prefix_subset by blast
    also have "t'' \<in> Q"
      using \<rho>_assms assm2 case_assms(3) case_assms2(2) tt_prefix_imp_prefix_subset tt_subset_imp_prefix_subset by blast
    then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
      using \<rho>_assms case_assms calculation by blast
  next
    have "\<exists> r1 r2. r = r1 @ r2 \<and> sa \<subseteq>\<^sub>C r1 \<and> [[Tick]\<^sub>E] \<subseteq>\<^sub>C r2"
      by (simp add: "1" tt_subset_split2)
    then obtain r' where "r = r' @ [[Tick]\<^sub>E]"
      by (auto, case_tac r2 rule:ttWF.cases, auto)
    also assume "r \<le>\<^sub>C s"
    then obtain s' where "r' @ [[Tick]\<^sub>E] @ s' @ [[Tick]\<^sub>E] \<in> P"
      using calculation case_assms(2) tt_prefix_split by fastforce
    then have "ttWF (r' @ [[Tick]\<^sub>E] @ s' @ [[Tick]\<^sub>E])"
      using assms(1) by blast
    then show "False"
      by (induct r' rule:ttWF.induct, auto, induct s' rule:ttWF.induct, auto)
  qed
qed

lemma TT2w_SeqComp: "TT3ww P \<Longrightarrow> TT P \<Longrightarrow> TT Q \<Longrightarrow> TT2w (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT2w_def
proof auto
  fix \<rho> X Y
  assume assm1: "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
           e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))} = {}"
  assume assm2: "TT P"
  assume assm3: "\<rho> @ [[X]\<^sub>R] \<in> P"
  assume assm4: "TT3ww P"
  have "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
      e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))}
    = Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick}
      \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
        e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))})"
    by auto
  then have "Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick}
      \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
        e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
    using assm1 by auto
  then have 1: "(Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick})
      \<union> (Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
        e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
    by (simp add: Int_Un_distrib)
  have TT2w_P: "TT2w P"
    using assm2 TT_TT2w by auto
  have "{e\<in>Y. e \<noteq> Tick} \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using 1 by blast
  then have 2: "\<rho> @ [[X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R] \<in> P"
    using TT2w_P assm3 unfolding TT2w_def by auto
  show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
  proof (cases "Tick \<in> Y")
    assume case_assm: "Tick \<in> Y"
    have "\<rho> @ [[X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R] \<in> P"
      using 2 assm4 unfolding TT3ww_def by auto
    also have "X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
      using case_assm by blast
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      using calculation by auto
  next
    assume "Tick \<notin> Y"
    then have "X \<union> {e\<in>Y. e \<noteq> Tick} = X \<union> Y"
      by blast
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      using 2 by auto
  qed
next
  fix \<rho> X Y s t
  assume assm1: "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
    e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))} = {}"
  assume assm2: "TT P"
  assume assm3: "TT Q"
  assume assm4: "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> \<rho> @ [[X \<union> Y]\<^sub>R] \<noteq> s @ t)"
  assume assm5: "s @ [[Tick]\<^sub>E] \<in> P"
  assume assm6: "t \<in> Q"
  assume assm7: "\<rho> @ [[X]\<^sub>R] = s @ t"
  have "t = [] \<or> (\<exists> t'. t = t' @ [[X]\<^sub>R])"
    by (metis append_butlast_last_id assm7 last_appendR last_snoc)
  then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
  proof auto
    assume case_assm: "t = []"
    then have "s = \<rho> @ [[X]\<^sub>R]"
      by (simp add: assm7)
    then have "\<rho> @ [[X]\<^sub>R, [Tick]\<^sub>E] \<in> P"
      using assm5 by auto
    then have "ttWF (\<rho> @ [[X]\<^sub>R, [Tick]\<^sub>E])"
      using TT_wf assm2 by blast
    then have "False"
      by (induct \<rho> rule:ttWF.induct, auto)
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      by auto
  next
    fix t'
    assume case_assm: "t = t' @ [[X]\<^sub>R]"
    then have 1: "{e. e \<noteq> Tock \<and> t' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> t' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q}
      \<subseteq> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}"
      using assm5 assm7 by auto
    have "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
        e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))}
      = Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P}
        \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))})"
      by auto
    then have "Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P}
        \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
      using assm1 by auto
    then have "(Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P})
        \<union> (Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
      by (simp add: Int_Un_distrib)
    then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}
      \<and> Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))} = {}"
      by auto
    then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}
        \<and> Y \<inter> {e. e \<noteq> Tock \<and> t' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> t' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
      by (metis (no_types, lifting) 1 Int_left_commute inf.orderE inf_bot_right)
    then have "t' @ [[X \<union> Y]\<^sub>R] \<in> Q"
      using TT2w_def TT_def assm3 assm6 case_assm by auto
    then have "\<rho> @ [[X \<union> Y]\<^sub>R] \<noteq> s @ t' @ [[X \<union> Y]\<^sub>R]"
      using assm4 assm5 by auto
    then have "False"
      using case_assm assm7 by auto
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      by auto
  qed
qed

lemma TT2_SeqComp:
  assumes TT1_P: "TT1 P" and TT3w_P: "TT3w P"
  assumes TT2_P: "TT2 P" and TT2_Q: "TT2 Q"
  shows "TT2 (P ;\<^sub>C Q)"
  unfolding TT2_def
proof auto
  fix \<rho> \<sigma> X Y
  assume assm1: "\<rho> @ [X]\<^sub>R # \<sigma> \<in> P ;\<^sub>C Q"
  assume assm2: "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q} = {}"
  have "{e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} \<subseteq>
      {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q}"
    unfolding SeqCompTT_def by auto
  then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using assm2 subset_iff by auto
  then have P_assm2: "{e\<in>Y. e \<noteq> Tick} \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using assm2 subset_iff by auto
  show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P ;\<^sub>C Q"
    using assm1 unfolding SeqCompTT_def
  proof auto
    assume case_assm: "\<rho> @ [X]\<^sub>R # \<sigma> \<in> P"
    then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P"
      using TT2_P P_assm2 unfolding TT2_def by auto
    then show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
    proof (cases "Tick \<in> Y")
      have "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P \<Longrightarrow> \<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R # \<sigma> \<in> P"
        using TT1_P TT3w_TT1_add_Tick TT3w_P by blast
      also have "Tick \<in> Y \<Longrightarrow> X \<union> {e \<in> Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
        by blast
      then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P \<Longrightarrow> Tick \<in> Y \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
        using calculation by auto
    next
      assume "Tick \<notin> Y"
      then have "X \<union> {e \<in> Y. e \<noteq> Tick} = X \<union> Y"
        by auto
      then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
        by auto
    qed
  next
    fix s t
    assume case_assms: "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "\<rho> @ [X]\<^sub>R # \<sigma> = s @ t"
    have "(\<exists> \<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t) \<or> (\<exists> \<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<and> \<rho> = s @ \<rho>')"
      using case_assms(3)
    proof auto
      have "\<And> s t. \<rho> @ [X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> \<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> \<rho> \<noteq> s @ \<rho>' \<Longrightarrow> \<exists>\<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
      proof (induct \<rho>, auto)
        fix s t
        show "[X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> s \<noteq> [] \<Longrightarrow> \<exists>\<sigma>'. s = [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
          by (metis Cons_eq_append_conv)
      next
        fix a \<rho> s t
        assume ind_hyp: "\<And>s t. \<rho> @ [X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> \<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> \<rho> \<noteq> s @ \<rho>' \<Longrightarrow> \<exists>\<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
        assume case_assms2: "a # \<rho> @ [X]\<^sub>R # \<sigma> = s @ t" "\<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> a # \<rho> \<noteq> s @ \<rho>'"
        have "s = [] \<or> (\<exists> s'. s = a # s')"
          by (metis Cons_eq_append_conv case_assms2(1))
        then show "\<exists>\<sigma>'. s = a # \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
        proof auto
          fix t'
          assume case_assm3: "s = []"
          then have "t = a # \<rho> @ [X]\<^sub>R # \<sigma>"
            by (simp add: case_assms2(1))
          then obtain t' where "t = a # t' \<and> t' = \<rho> @ [X]\<^sub>R # \<sigma>"
            by blast
          then have "\<exists>\<sigma>'. [] = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ \<rho> @ [X]\<^sub>R # \<sigma>"
            using case_assm3 case_assms2(2) by auto
          then show False
            by blast
        next
          fix s'
          assume case_assm3: "s = a # s'"
          then have "\<rho> @ [X]\<^sub>R # \<sigma> = s' @ t"
            using case_assms2(1) by auto
          then have "\<exists>\<sigma>'. s' = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
            using case_assm3 case_assms2(2) ind_hyp by auto
          then show "\<exists>\<sigma>'. s' = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
            by blast
        qed
      qed
      then show "\<rho> @ [X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> \<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> \<rho> \<noteq> s @ \<rho>' \<Longrightarrow> \<exists>\<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
        by auto
    qed
    then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<noteq> s @ t) \<Longrightarrow>
      \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
    proof auto
      fix \<sigma>'
      assume case_assms2: "s = \<rho> @ [X]\<^sub>R # \<sigma>'" "\<sigma> = \<sigma>' @ t"
      then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
        using TT2_P P_assm2 case_assms case_assms2 unfolding TT2_def by auto
      then have "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
      proof (cases "Tick \<in> Y")
        assume case_assms3: "Tick \<in> Y" "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
        then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
          using TT1_P TT3w_TT1_add_Tick TT3w_P by blast
        also have "X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
          using case_assms3(1) by auto
        then show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
          using calculation by auto
      next
        assume "Tick \<notin> Y"
        then have "X \<union> {e\<in>Y. e \<noteq> Tick} = X \<union> Y"
          by auto
        then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
          by auto
      qed
      then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>ta. ta \<in> Q \<longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ t \<noteq> s @ ta) \<Longrightarrow>
          \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ t \<in> P"
        using case_assms by (erule_tac x="\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>'" in allE, auto)
    next
      fix \<rho>'
      assume case_assms2: "t = \<rho>' @ [X]\<^sub>R # \<sigma>" "\<rho> = s @ \<rho>'"

      have "{e. e \<noteq> Tock \<and> \<rho>' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} \<subseteq>
      {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q}"
        unfolding SeqCompTT_def using case_assms case_assms2 by auto
      then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho>' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
        using assm2 subsetCE by auto
      then have "\<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> Q"
        using TT2_Q P_assm2 case_assms case_assms2 unfolding TT2_def by auto
      then show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> s @ \<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<noteq> sa @ t) \<Longrightarrow>
          s @ \<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
        using case_assms case_assms2 by auto
    qed
  next
    fix s :: "'a ttobs list"
    assume "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> = s @ [[Tick]\<^sub>E]"
    then obtain \<sigma>' where "\<sigma> = \<sigma>' @ [[Tick]\<^sub>E]"
      by (induct \<rho> s rule:tt_subset.induct, auto)
    then show "\<forall>s. \<rho> @ [X]\<^sub>R # \<sigma> \<noteq> s @ [[Tick]\<^sub>E] \<Longrightarrow> False"
      by simp
  next
    fix s t sa :: "'a ttobs list"
    assume case_assms: "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> = sa @ [[Tick]\<^sub>E]" "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "\<rho> @ [X]\<^sub>R # \<sigma> = s @ t"
    obtain \<sigma>' where "\<sigma> = \<sigma>' @ [[Tick]\<^sub>E]"
      using case_assms(1) by (induct \<rho> sa rule:tt_subset.induct, auto)
    have "(\<exists> \<rho>2. \<rho> = s @ \<rho>2 \<and> t = \<rho>2 @ [X]\<^sub>R # \<sigma>) \<or> (\<exists> \<sigma>1. s = \<rho> @ [X]\<^sub>R # \<sigma>1 \<and> \<sigma> = \<sigma>1 @ t)"
      using case_assms(4) by (induct s \<rho> rule:tt_subset.induct, auto)
    then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
    proof auto
      fix \<rho>2 :: "'a ttobs list"
      assume case_assms2: "\<rho> = s @ \<rho>2" "t = \<rho>2 @ [X]\<^sub>R # \<sigma>"
      have "{e. e \<noteq> Tock \<and> \<rho>2 @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>2 @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} \<subseteq>
      {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q}"
        unfolding SeqCompTT_def using case_assms case_assms2 by auto
      then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho>2 @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>2 @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
        using assm2 subsetCE by auto
      then have "\<rho>2 @ [X \<union> Y]\<^sub>R # \<sigma> \<in> Q"
        using TT2_Q case_assms(3) case_assms2(2) unfolding TT2_def by auto
      then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
        using case_assms by (erule_tac x="s" in allE, auto, erule_tac x="\<rho>2 @ [X \<union> Y]\<^sub>R # \<sigma>" in allE, auto simp add: case_assms2)
    next
      fix \<sigma>1 :: "'a ttobs list"
      assume case_assms2: "s = \<rho> @ [X]\<^sub>R # \<sigma>1" "\<sigma> = \<sigma>1 @ t"
      then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
        using TT2_P P_assm2 case_assms case_assms2 unfolding TT2_def by auto
      then have "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
      proof (cases "Tick \<in> Y")
        assume case_assms3: "Tick \<in> Y" "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
        then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
          using TT1_P TT3w_TT1_add_Tick TT3w_P by blast
        also have "X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
          using case_assms3(1) by auto
        then show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
          using calculation by auto
      next
        assume "Tick \<notin> Y"
        then have "X \<union> {e\<in>Y. e \<noteq> Tick} = X \<union> Y"
          by auto
        then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
          by auto
      qed
      then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
        using case_assms by (erule_tac x="\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1" in allE, auto, erule_tac x="t" in allE, auto simp add: case_assms2)
    qed
  qed
qed

text_raw \<open>\DefineSnippet{ttWFx_SeqComp}{\<close>
lemma ttWFx_SeqComp:
  assumes "TT P" "TT Q"
  shows "ttWFx (P ;\<^sub>C Q)"
  unfolding ttWFx_def SeqCompTT_def
proof auto
  fix x
  show "x \<in> P \<Longrightarrow> ttWFx_trace x"
    using ttWFx_def TT_ttWFx assms(1) by blast
next
  fix s t
  assume "s @ [[Tick]\<^sub>E] \<in> P"
  then have 1: "ttWFx_trace s"
    by (meson TT1_def ttWFx_def TT_TT1 TT_ttWFx assms(1)
              tt_prefix_concat tt_prefix_imp_prefix_subset)
  assume "t \<in> Q"
  then have 2: "ttWFx_trace t \<and> ttWF t"
    using ttWFx_def TT_ttWFx TT_wf assms(2) by blast
  show "ttWFx_trace (s @ t)"
    using 1 2 ttWFx_append by auto
qed
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{TT3w_SeqComp}{\<close>
lemma TT3w_SeqComp:
  assumes "TT3w P" "TT3w Q"
  shows "TT3w (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT3w_def
proof auto
  fix \<rho>
  show "\<rho> \<in> P \<Longrightarrow> add_Tick_refusal_trace \<rho> \<in> P"
    using TT3w_def assms(1) by blast
next
  fix s t
  assume "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q"
  then have "add_Tick_refusal_trace s @ [[Tick]\<^sub>E] \<in> P \<and> add_Tick_refusal_trace t \<in> Q"
    by (metis TT3w_def add_Tick_refusal_trace_end_event assms(1) assms(2))
  then show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>ta. ta \<in> Q \<longrightarrow> add_Tick_refusal_trace (s @ t) \<noteq> sa @ ta) \<Longrightarrow>
    add_Tick_refusal_trace (s @ t) \<in> P"
    using add_Tick_refusal_trace_concat by blast
next
  fix \<rho> s
  assume case_assms: "\<rho> \<in> P" "\<forall>s. \<rho> \<noteq> s @ [[Tick]\<^sub>E]" "add_Tick_refusal_trace \<rho> = s @ [[Tick]\<^sub>E]"
  have "\<exists> s'. s = add_Tick_refusal_trace s' \<and> \<rho> = s' @ [[Tick]\<^sub>E]"
    using case_assms(3) apply (induct \<rho> s rule:tt_subset.induct, auto)
    using add_Tick_refusal_trace.elims apply (rule_tac x="[]" in exI, auto)
    by (rule_tac x="[]" in exI, auto, metis list.discI list.sel(3))
  then show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> s @ [[Tick]\<^sub>E] \<noteq> sa @ t) \<Longrightarrow> False"
    using case_assms(2) by blast
next
  fix s t sa
  assume case_assms: "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "add_Tick_refusal_trace (s @ t) = sa @ [[Tick]\<^sub>E]"
  have 1: "add_Tick_refusal_trace s @ [[Tick]\<^sub>E] \<in> P"
    by (metis TT3w_def add_Tick_refusal_trace_end_event assms(1) case_assms(1))
  have 2: "add_Tick_refusal_trace t \<in> Q"
    using TT3w_def assms(2) case_assms(2) by blast
  show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
    using 1 2 case_assms apply (erule_tac x="add_Tick_refusal_trace s" in allE, auto)
    by (erule_tac x="add_Tick_refusal_trace t" in allE, auto simp add: add_Tick_refusal_trace_concat)
qed
text_raw \<open>}%EndSnippet\<close>

lemma TT3_SeqComp:
  assumes "\<forall>t\<in>P. ttWF t" "TT1 P" "TT1 Q" "TT3 P" "TT3 Q"
  shows "TT3 (P ;\<^sub>C Q)"
  by (meson TT1_SeqComp TT1_TT3w_equiv_TT3 TT3w_SeqComp assms)

lemma TT_SeqComp:
  assumes "TT P" "TT Q" "TT3ww P"
  shows "TT (P ;\<^sub>C Q)"
  unfolding TT_def apply auto
  apply (metis TT_def SeqComp_wf assms(1) assms(2))
  apply (simp add: TT0_SeqComp TT_TT0 assms(1) assms(2))
  using TT1_SeqComp TT_def assms(1) assms(2) apply blast
  apply (simp add: TT2w_SeqComp assms(1) assms(2) assms(3))
  apply (simp add: ttWFx_SeqComp assms(1) assms(2))
  done

lemma SeqComp_right_unit:
  assumes "TT1 P"
  shows "P ;\<^sub>C SKIP\<^sub>C = P"
  unfolding SkipTT_def SeqCompTT_def
proof auto
  fix s
  show "s @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow> s \<in> P"
    using TT1_def assms tt_prefix_concat tt_prefix_imp_prefix_subset by blast
qed

lemma SeqComp_left_unit:
  assumes "TT0 P" "TT1 P"
  shows "SKIP\<^sub>C ;\<^sub>C P = P"
  unfolding SkipTT_def SeqCompTT_def
proof (safe, simp_all)
  show "[] \<in> P"
    by (simp add: TT0_TT1_empty assms(1) assms(2))
qed

lemma SeqComp_Union_dist1:
  "S \<noteq> {} \<Longrightarrow> P ;\<^sub>C (\<Union>S) = \<Union>{R. \<exists>Q. Q \<in> S \<and> R = P ;\<^sub>C Q}"
  unfolding SeqCompTT_def by auto

lemma SeqComp_Union_dist2:
  "S \<noteq> {} \<Longrightarrow> (\<Union>S) ;\<^sub>C Q = \<Union>{R. \<exists>P. P \<in> S \<and> R = P ;\<^sub>C Q}"
  unfolding SeqCompTT_def by auto

lemma SeqComp_mono1:
  "P \<sqsubseteq>\<^sub>C Q \<Longrightarrow> P ;\<^sub>C R \<sqsubseteq>\<^sub>C Q ;\<^sub>C R"
  unfolding RefinesTT_def SeqCompTT_def by auto

lemma SeqComp_mono2:
  "P \<sqsubseteq>\<^sub>C Q \<Longrightarrow> R ;\<^sub>C P \<sqsubseteq>\<^sub>C R ;\<^sub>C Q"
  unfolding RefinesTT_def SeqCompTT_def by auto

end


(*  Title:      HOL/UNITY/UNITY.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

The basic UNITY theory (revised version, based upon the "co"
operator).

From Misra, "A Logic for Concurrent Programming", 1994.
*)

section {*The Basic UNITY Theory*}

theory UNITY imports Main begin

definition
  "Program =
    {(init:: 'a set, acts :: ('a * 'a)set set,
      allowed :: ('a * 'a)set set). Id \<in> acts & Id: allowed}"

typedef 'a program = "Program :: ('a set * ('a * 'a) set set * ('a * 'a) set set) set"
  morphisms Rep_Program Abs_Program
  unfolding Program_def by blast

definition Acts :: "'a program => ('a * 'a)set set" where
    "Acts F == (%(init, acts, allowed). acts) (Rep_Program F)"

definition "constrains" :: "['a set, 'a set] => 'a program set"  (infixl "co"     60) where
    "A co B == {F. \<forall>act \<in> Acts F. act``A \<subseteq> B}"

definition unless  :: "['a set, 'a set] => 'a program set"  (infixl "unless" 60)  where
    "A unless B == (A-B) co (A \<union> B)"

definition mk_program :: "('a set * ('a * 'a)set set * ('a * 'a)set set)
                   => 'a program" where
    "mk_program == %(init, acts, allowed).
                      Abs_Program (init, insert Id acts, insert Id allowed)"

definition Init :: "'a program => 'a set" where
    "Init F == (%(init, acts, allowed). init) (Rep_Program F)"

definition AllowedActs :: "'a program => ('a * 'a)set set" where
    "AllowedActs F == (%(init, acts, allowed). allowed) (Rep_Program F)"

definition Allowed :: "'a program => 'a program set" where
    "Allowed F == {G. Acts G \<subseteq> AllowedActs F}"

definition stable     :: "'a set => 'a program set" where
    "stable A == A co A"

definition strongest_rhs :: "['a program, 'a set] => 'a set" where
    "strongest_rhs F A == Inter {B. F \<in> A co B}"

definition invariant :: "'a set => 'a program set" where
    "invariant A == {F. Init F \<subseteq> A} \<inter> stable A"

definition increasing :: "['a => 'b::{order}] => 'a program set" where
    --{*Polymorphic in both states and the meaning of @{text "\<le>"}*}
    "increasing f == \<Inter>z. stable {s. z \<le> f s}"

subsubsection{*The abstract type of programs*}

lemmas program_typedef =
     Rep_Program Rep_Program_inverse Abs_Program_inverse
     Program_def Init_def Acts_def AllowedActs_def mk_program_def

lemma Id_in_Acts [iff]: "Id \<in> Acts F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
done

lemma insert_Id_Acts [iff]: "insert Id (Acts F) = Acts F"
by (simp add: insert_absorb)

lemma Acts_nonempty [simp]: "Acts F \<noteq> {}"
by auto

lemma Id_in_AllowedActs [iff]: "Id \<in> AllowedActs F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
done

lemma insert_Id_AllowedActs [iff]: "insert Id (AllowedActs F) = AllowedActs F"
by (simp add: insert_absorb)

subsubsection{*Inspectors for type "program"*}

lemma Init_eq [simp]: "Init (mk_program (init,acts,allowed)) = init"
by (simp add: program_typedef)

lemma Acts_eq [simp]: "Acts (mk_program (init,acts,allowed)) = insert Id acts"
by (simp add: program_typedef)

lemma AllowedActs_eq [simp]:
     "AllowedActs (mk_program (init,acts,allowed)) = insert Id allowed"
by (simp add: program_typedef)

subsubsection{*Equality for UNITY programs*}

lemma surjective_mk_program [simp]:
     "mk_program (Init F, Acts F, AllowedActs F) = F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
apply (drule_tac f = Abs_Program in arg_cong)+
apply (simp add: program_typedef insert_absorb)
done

lemma program_equalityI:
     "[| Init F = Init G; Acts F = Acts G; AllowedActs F = AllowedActs G |]
      ==> F = G"
apply (rule_tac t = F in surjective_mk_program [THEN subst])
apply (rule_tac t = G in surjective_mk_program [THEN subst], simp)
done

lemma program_equalityE:
     "[| F = G;
         [| Init F = Init G; Acts F = Acts G; AllowedActs F = AllowedActs G |]
         ==> P |] ==> P"
by simp

lemma program_equality_iff:
     "(F=G) =
      (Init F = Init G & Acts F = Acts G &AllowedActs F = AllowedActs G)"
by (blast intro: program_equalityI program_equalityE)

subsubsection{*co*}

lemma constrainsI:
    "(!!act s s'. [| act: Acts F;  (s,s') \<in> act;  s \<in> A |] ==> s': A')
     ==> F \<in> A co A'"
by (simp add: constrains_def, blast)

lemma constrainsD:
    "[| F \<in> A co A'; act: Acts F;  (s,s'): act;  s \<in> A |] ==> s': A'"
by (unfold constrains_def, blast)

lemma constrains_empty [iff]: "F \<in> {} co B"
by (unfold constrains_def, blast)

lemma constrains_empty2 [iff]: "(F \<in> A co {}) = (A={})"
by (unfold constrains_def, blast)

lemma constrains_UNIV [iff]: "(F \<in> UNIV co B) = (B = UNIV)"
by (unfold constrains_def, blast)

lemma constrains_UNIV2 [iff]: "F \<in> A co UNIV"
by (unfold constrains_def, blast)

text{*monotonic in 2nd argument*}
lemma constrains_weaken_R:
    "[| F \<in> A co A'; A'<=B' |] ==> F \<in> A co B'"
by (unfold constrains_def, blast)

text{*anti-monotonic in 1st argument*}
lemma constrains_weaken_L:
    "[| F \<in> A co A'; B \<subseteq> A |] ==> F \<in> B co A'"
by (unfold constrains_def, blast)

lemma constrains_weaken:
   "[| F \<in> A co A'; B \<subseteq> A; A'<=B' |] ==> F \<in> B co B'"
by (unfold constrains_def, blast)

subsubsection{*Union*}

lemma constrains_Un:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<union> B) co (A' \<union> B')"
by (unfold constrains_def, blast)

lemma constrains_UN:
    "(!!i. i \<in> I ==> F \<in> (A i) co (A' i))
     ==> F \<in> (\<Union>i \<in> I. A i) co (\<Union>i \<in> I. A' i)"
by (unfold constrains_def, blast)

lemma constrains_Un_distrib: "(A \<union> B) co C = (A co C) \<inter> (B co C)"
by (unfold constrains_def, blast)

lemma constrains_UN_distrib: "(\<Union>i \<in> I. A i) co B = (\<Inter>i \<in> I. A i co B)"
by (unfold constrains_def, blast)

lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
by (unfold constrains_def, blast)

lemma constrains_INT_distrib: "A co (\<Inter>i \<in> I. B i) = (\<Inter>i \<in> I. A co B i)"
by (unfold constrains_def, blast)

subsubsection{*Intersection*}

lemma constrains_Int:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<inter> B) co (A' \<inter> B')"
by (unfold constrains_def, blast)

lemma constrains_INT:
    "(!!i. i \<in> I ==> F \<in> (A i) co (A' i))
     ==> F \<in> (\<Inter>i \<in> I. A i) co (\<Inter>i \<in> I. A' i)"
by (unfold constrains_def, blast)

lemma constrains_imp_subset: "F \<in> A co A' ==> A \<subseteq> A'"
by (unfold constrains_def, auto)

text{*The reasoning is by subsets since "co" refers to single actions
  only.  So this rule isn't that useful.*}
lemma constrains_trans:
    "[| F \<in> A co B; F \<in> B co C |] ==> F \<in> A co C"
by (unfold constrains_def, blast)

lemma constrains_cancel:
   "[| F \<in> A co (A' \<union> B); F \<in> B co B' |] ==> F \<in> A co (A' \<union> B')"
by (unfold constrains_def, clarify, blast)

subsubsection{*unless*}

lemma unlessI: "F \<in> (A-B) co (A \<union> B) ==> F \<in> A unless B"
by (unfold unless_def, assumption)

lemma unlessD: "F \<in> A unless B ==> F \<in> (A-B) co (A \<union> B)"
by (unfold unless_def, assumption)

subsubsection{*stable*}

lemma stableI: "F \<in> A co A ==> F \<in> stable A"
by (unfold stable_def, assumption)

lemma stableD: "F \<in> stable A ==> F \<in> A co A"
by (unfold stable_def, assumption)

lemma stable_UNIV [simp]: "stable UNIV = UNIV"
by (unfold stable_def constrains_def, auto)

subsubsection{*Union*}

lemma stable_Un:
    "[| F \<in> stable A; F \<in> stable A' |] ==> F \<in> stable (A \<union> A')"

apply (unfold stable_def)
apply (blast intro: constrains_Un)
done

lemma stable_UN:
    "(!!i. i \<in> I ==> F \<in> stable (A i)) ==> F \<in> stable (\<Union>i \<in> I. A i)"
apply (unfold stable_def)
apply (blast intro: constrains_UN)
done

lemma stable_Union:
    "(!!A. A \<in> X ==> F \<in> stable A) ==> F \<in> stable (\<Union>X)"
by (unfold stable_def constrains_def, blast)

subsubsection{*Intersection*}

lemma stable_Int:
    "[| F \<in> stable A;  F \<in> stable A' |] ==> F \<in> stable (A \<inter> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Int)
done

lemma stable_INT:
    "(!!i. i \<in> I ==> F \<in> stable (A i)) ==> F \<in> stable (\<Inter>i \<in> I. A i)"
apply (unfold stable_def)
apply (blast intro: constrains_INT)
done

lemma stable_Inter:
    "(!!A. A \<in> X ==> F \<in> stable A) ==> F \<in> stable (\<Inter>X)"
by (unfold stable_def constrains_def, blast)

lemma stable_constrains_Un:
    "[| F \<in> stable C; F \<in> A co (C \<union> A') |] ==> F \<in> (C \<union> A) co (C \<union> A')"
by (unfold stable_def constrains_def, blast)

lemma stable_constrains_Int:
  "[| F \<in> stable C; F \<in>  (C \<inter> A) co A' |] ==> F \<in> (C \<inter> A) co (C \<inter> A')"
by (unfold stable_def constrains_def, blast)

(*[| F \<in> stable C; F \<in>  (C \<inter> A) co A |] ==> F \<in> stable (C \<inter> A) *)
lemmas stable_constrains_stable = stable_constrains_Int[THEN stableI]

subsubsection{*invariant*}

lemma invariantI: "[| Init F \<subseteq> A;  F \<in> stable A |] ==> F \<in> invariant A"
by (simp add: invariant_def)

text{*Could also say @{term "invariant A \<inter> invariant B \<subseteq> invariant(A \<inter> B)"}*}
lemma invariant_Int:
     "[| F \<in> invariant A;  F \<in> invariant B |] ==> F \<in> invariant (A \<inter> B)"
by (auto simp add: invariant_def stable_Int)

subsubsection{*increasing*}

lemma increasingD:
     "F \<in> increasing f ==> F \<in> stable {s. z \<subseteq> f s}"
by (unfold increasing_def, blast)

lemma increasing_constant [iff]: "F \<in> increasing (%s. c)"
by (unfold increasing_def stable_def, auto)

lemma mono_increasing_o:
     "mono g ==> increasing f \<subseteq> increasing (g o f)"
apply (unfold increasing_def stable_def constrains_def, auto)
apply (blast intro: monoD order_trans)
done

(*Holds by the theorem (Suc m \<subseteq> n) = (m < n) *)
lemma strict_increasingD:
     "!!z::nat. F \<in> increasing f ==> F \<in> stable {s. z < f s}"
by (simp add: increasing_def Suc_le_eq [symmetric])

(** The Elimination Theorem.  The "free" m has become universally quantified!
    Should the premise be !!m instead of \<forall>m ?  Would make it harder to use
    in forward proof. **)

lemma elimination:
    "[| \<forall>m \<in> M. F \<in> {s. s x = m} co (B m) |]
     ==> F \<in> {s. s x \<in> M} co (\<Union>m \<in> M. B m)"
by (unfold constrains_def, blast)

text{*As above, but for the trivial case of a one-variable state, in which the
  state is identified with its one variable.*}
lemma elimination_sing:
    "(\<forall>m \<in> M. F \<in> {m} co (B m)) ==> F \<in> M co (\<Union>m \<in> M. B m)"
by (unfold constrains_def, blast)

subsubsection{*Theoretical Results from Section 6*}

lemma constrains_strongest_rhs:
    "F \<in> A co (strongest_rhs F A )"
by (unfold constrains_def strongest_rhs_def, blast)

lemma strongest_rhs_is_strongest:
    "F \<in> A co B ==> strongest_rhs F A \<subseteq> B"
by (unfold constrains_def strongest_rhs_def, blast)

subsubsection{*Ad-hoc set-theory rules*}

lemma Un_Diff_Diff [simp]: "A \<union> B - (A - B) = B"
by blast

lemma Int_Union_Union: "Union(B) \<inter> A = Union((%C. C \<inter> A)`B)"
by blast

text{*Needed for WF reasoning in WFair.thy*}

lemma Image_less_than [simp]: "less_than `` {k} = greaterThan k"
by blast

lemma Image_inverse_less_than [simp]: "less_than^-1 `` {k} = lessThan k"
by blast

subsection{*Partial versus Total Transitions*}

definition totalize_act :: "('a * 'a)set => ('a * 'a)set" where
    "totalize_act act == act \<union> Id_on (-(Domain act))"

definition totalize :: "'a program => 'a program" where
    "totalize F == mk_program (Init F,
                               totalize_act ` Acts F,
                               AllowedActs F)"

definition mk_total_program :: "('a set * ('a * 'a)set set * ('a * 'a)set set)
                   => 'a program" where
    "mk_total_program args == totalize (mk_program args)"

definition all_total :: "'a program => bool" where
    "all_total F == \<forall>act \<in> Acts F. Domain act = UNIV"

lemma insert_Id_image_Acts: "f Id = Id ==> insert Id (f`Acts F) = f ` Acts F"
by (blast intro: sym [THEN image_eqI])

subsubsection{*Basic properties*}

lemma totalize_act_Id [simp]: "totalize_act Id = Id"
by (simp add: totalize_act_def)

lemma Domain_totalize_act [simp]: "Domain (totalize_act act) = UNIV"
by (auto simp add: totalize_act_def)

lemma Init_totalize [simp]: "Init (totalize F) = Init F"
by (unfold totalize_def, auto)

lemma Acts_totalize [simp]: "Acts (totalize F) = (totalize_act ` Acts F)"
by (simp add: totalize_def insert_Id_image_Acts)

lemma AllowedActs_totalize [simp]: "AllowedActs (totalize F) = AllowedActs F"
by (simp add: totalize_def)

lemma totalize_constrains_iff [simp]: "(totalize F \<in> A co B) = (F \<in> A co B)"
by (simp add: totalize_def totalize_act_def constrains_def, blast)

lemma totalize_stable_iff [simp]: "(totalize F \<in> stable A) = (F \<in> stable A)"
by (simp add: stable_def)

lemma totalize_invariant_iff [simp]:
     "(totalize F \<in> invariant A) = (F \<in> invariant A)"
by (simp add: invariant_def)

lemma all_total_totalize: "all_total (totalize F)"
by (simp add: totalize_def all_total_def)

lemma Domain_iff_totalize_act: "(Domain act = UNIV) = (totalize_act act = act)"
by (force simp add: totalize_act_def)

lemma all_total_imp_totalize: "all_total F ==> (totalize F = F)"
apply (simp add: all_total_def totalize_def)
apply (rule program_equalityI)
  apply (simp_all add: Domain_iff_totalize_act image_def)
done

lemma all_total_iff_totalize: "all_total F = (totalize F = F)"
apply (rule iffI)
 apply (erule all_total_imp_totalize)
apply (erule subst)
apply (rule all_total_totalize)
done

lemma mk_total_program_constrains_iff [simp]:
     "(mk_total_program args \<in> A co B) = (mk_program args \<in> A co B)"
by (simp add: mk_total_program_def)

subsection{*Rules for Lazy Definition Expansion*}

text{*They avoid expanding the full program, which is a large expression*}

lemma def_prg_Init:
     "F = mk_total_program (init,acts,allowed) ==> Init F = init"
by (simp add: mk_total_program_def)

lemma def_prg_Acts:
     "F = mk_total_program (init,acts,allowed)
      ==> Acts F = insert Id (totalize_act ` acts)"
by (simp add: mk_total_program_def)

lemma def_prg_AllowedActs:
     "F = mk_total_program (init,acts,allowed)
      ==> AllowedActs F = insert Id allowed"
by (simp add: mk_total_program_def)

text{*An action is expanded if a pair of states is being tested against it*}
lemma def_act_simp:
     "act = {(s,s'). P s s'} ==> ((s,s') \<in> act) = P s s'"
by (simp add: mk_total_program_def)

text{*A set is expanded only if an element is being tested against it*}
lemma def_set_simp: "A = B ==> (x \<in> A) = (x \<in> B)"
by (simp add: mk_total_program_def)

subsubsection{*Inspectors for type "program"*}

lemma Init_total_eq [simp]:
     "Init (mk_total_program (init,acts,allowed)) = init"
by (simp add: mk_total_program_def)

lemma Acts_total_eq [simp]:
    "Acts(mk_total_program(init,acts,allowed)) = insert Id (totalize_act`acts)"
by (simp add: mk_total_program_def)

lemma AllowedActs_total_eq [simp]:
     "AllowedActs (mk_total_program (init,acts,allowed)) = insert Id allowed"
by (auto simp add: mk_total_program_def)

end


theory GDPR_DDL           (*GDPR CTD Example. C. Benzmüller & Xavier Parent, 2019*)
imports DDL
begin
(*Unimportant.*) sledgehammer_params [max_facts=20,timeout=20]
(*Unimportant.*) nitpick_params [user_axioms,expect=genuine,show_all,dont_box]

datatype data = d1 | d2  (*We introduce concrete data objects d1 and d2.*)
datatype indiv = Mary | Peter  (*We introduce individuals Mary and Peter.*)
consts process_lawfully::"data\<Rightarrow>\<sigma>" erase::"data\<Rightarrow>\<sigma>" is_protected_by_GDPR::"data\<Rightarrow>\<sigma>"
       belongs_to::"data\<Rightarrow>indiv\<Rightarrow>\<sigma>" is_european::"indiv=>\<sigma> " kill::"indiv\<Rightarrow>\<sigma>"

axiomatization where
(*Data belonging to Europeans is protected by the GDPR.*)
 A0: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>d. (is_european x \<^bold>\<and> belongs_to d x) \<^bold>\<rightarrow> is_protected_by_GDPR d\<rfloor>" and
(*Data d1 is belonging to the European Peter.*)
 F1: "\<lfloor>belongs_to d1 Peter \<^bold>\<and> is_european Peter\<rfloor>" and

(*It is an obligation to process data lawfully.*)
 A1: "\<lfloor>\<^bold>\<forall>d. is_protected_by_GDPR d \<^bold>\<rightarrow> \<^bold>\<circle><process_lawfully d>\<rfloor>"  and
(*If data was not processed lawfully, then it is an obligation to erase the data.*)
 A2: "\<lfloor>\<^bold>\<forall>d.  (is_protected_by_GDPR d  \<^bold>\<and> \<^bold>\<not>process_lawfully d) \<^bold>\<rightarrow> \<^bold>\<circle><erase d>\<rfloor>" and
(*Implicit: It is an obligation to keep the data if it was processed lawfully.*)
 Implicit: "\<lfloor>\<^bold>\<forall>d. \<^bold>\<circle><(is_protected_by_GDPR d \<^bold>\<and> process_lawfully d) \<^bold>\<rightarrow> \<^bold>\<not>erase d>\<rfloor>" and
(*Given a situation where data is processed unlawfully.*)
 Situation: "\<lfloor>\<^bold>\<not>process_lawfully d1\<rfloor>\<^sub>l"

(***Some Experiments***)
 lemma True nitpick [satisfy] oops (*Consistency-check: Nitpick finds a model.*)
 lemma False sledgehammer nitpick oops (*Nitpick presents countermodel; provers timeout.*)

(*Should the data be erased? — Yes, proof found by ATPs*)
 lemma "\<lfloor>\<^bold>\<circle><erase d1>\<rfloor>\<^sub>l" using A0 F1 A1 A2 Implicit Situation unfolding DDLdefs sledgehammer by blast
(*Should the data be kept? — Yes, proof found by ATPs*)
 lemma "\<lfloor>\<^bold>\<circle><\<^bold>\<not>erase d1>\<rfloor>\<^sub>l" sledgehammer nitpick oops
(*Should Mary be killed? — Yes, proof found by ATPs*)
 lemma "\<lfloor>\<^bold>\<circle><kill Mary>\<rfloor>\<^sub>l" sledgehammer nitpick oops
end


theory Scratch
  imports Main Observation
begin

text \<open>So, you can't have a typeclass return a type parameter. Let's see if we can define a type with
no properties, then later, assert some properties *of* that type and use them in a proof. So... some
`foo` exists. We don't know what it is.\<close>

typedecl foo

text \<open>We can make a container for foo\<close>

datatype box = Box "foo"

text \<open>We can use foo for equality...\<close>

lemma "(x :: foo) \<noteq> (y :: foo) \<longrightarrow> (Box x) \<noteq> (Box y)"
  apply auto
  done

lemma "(x :: foo) = (y :: foo) \<longrightarrow> (Box x) = (Box y)"
  apply auto
  done

text \<open>We can define a typeclass which returns foos...\<close>

class openable =
  fixes open1 :: "'a \<Rightarrow> foo"

instantiation box :: openable
begin
primrec open1 :: "box \<Rightarrow> foo" where
"open1 (Box f) = f"
instance ..
end

text \<open>Now it'd be nice if we could show something trivial, like... if foo is, say, a nat, then open1
returns a nat. If we were using type parameters, I'd make a "box nat", but since we're NOT using
type parameters... I want to write, like, (foo = nat) \<Rightarrow> is_nat (openable x)" but I have no idea how\<close>

text \<open>I think what I want here is maybe... a locale? Let's try that...\<close>

locale partial_order =
  fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes refl [intro, simp]: "le x x"
    and anti_sym [intro]: "\<lbrakk>le x y; le y x\<rbrakk> \<Longrightarrow> x = y"
    and trans [trans]: "\<lbrakk>le x y; le y z\<rbrakk> \<Longrightarrow> le x z"

text \<open>So... what we've done here is assert a le function exists, and it obeys these laws, but we
haven't actually said what le is. le could operate over cats or cargo ships. It could be < or >. Can
I define a locale that returns a type parameter?\<close>

locale openable2 =
  fixes open2 :: "'a \<Rightarrow> 'b"

text \<open>Huh. So... all I've said here is that a binary function exists. What about... making a box for
a type parameter? That's something we can't do with typeclasses...\<close>

datatype 'a abstract_box = AbstractBox "'a"
locale boxable =
  fixes box :: "'a \<Rightarrow> ('b abstract_box)"

text \<open>Okay, so I can define a boxable function which returns something with type parameters. Note
that our box is over a different type, so we could, I dunno, take strings and constantly return
AbstractBox 2 or something.\<close>