           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               February 2005               |
            |                   June 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_ufp
imports CSP_F_continuous CSP_F_contraction CSP_F_mono
        CSP_F_law_decompo CSP_T.CSP_T_law_ufp
begin

(*****************************************************************

         1. cms fixed point theory in CSP-Prover
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*=======================================================*
 |                                                       |
 |                        CMS                            |
 |                                                       |
 *=======================================================*)

(*-------------*
 |  existency  |
 *-------------*)

lemma semF_hasUFP_cms:
 "[| Pf = PNfun ; guardedfun (Pf) |]
  ==> [[Pf]]Ffun hasUFP"
apply (rule Banach_thm_EX)
apply (rule contraction_semFfun)
apply (simp)
done

lemma semF_UFP_cms:
  "[| Pf = PNfun ;
      guardedfun (Pf) ;
      FPmode = CMSmode |]
  ==> [[$p]]F = UFP ([[Pf]]Ffun) p"
apply (simp add: semF_def)
apply (simp add: semFf_Proc_name)
apply (simp add: MF_def)
apply (simp add: semFfix_def)
done

lemma semF_UFP_fun_cms:
  "[| Pf = PNfun ;
      guardedfun (Pf) ;
      FPmode = CMSmode |]
  ==> (%p. [[$p]]F) = UFP ([[Pf]]Ffun)"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semF_UFP_cms)
done

(*---------*
 |    MF   |
 *---------*)

lemma MF_fixed_point_cms:
      "[| (Pf::'p=>('p,'a) proc) = PNfun; guardedfun Pf ; FPmode = CMSmode|]
        ==> [[Pf]]Ffun (MF::'p => 'a domF) = (MF::'p => 'a domF)"
apply (simp add: MF_def)
apply (simp add: semFfix_def)
apply (rule UFP_fp)
apply (simp add: semF_hasUFP_cms)
done

(*---------*
 |  unique |
 *---------*)

lemma ALL_cspF_unique_cms:
  "[| Pf = PNfun ; guardedfun Pf ;
       FPmode = CMSmode ;
       ALL p. (Pf p) << f =F f p |] ==> ALL p. f p =F $p"
apply (simp add: eqF_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (rule hasUFP_unique_solution[of "[[PNfun]]Ffun"])
apply (simp add: semF_hasUFP_cms)
apply (fold semF_def)

apply (simp add: semF_subst)
apply (simp add: semFfun_def)

apply (simp add: semF_UFP_fun_cms)
apply (simp add: UFP_fp semF_hasUFP_cms)
done

lemma cspF_unique_cms:
  "[| Pf = PNfun ; guardedfun Pf ;
       FPmode = CMSmode ;
       ALL p. (Pf p) << f =F f p |] ==> f p =F $p"
by (simp add: ALL_cspF_unique_cms)

(*-------------------------------------------------------*
 |                                                       |
 |           Fixpoint unwind (CSP-Prover rule)           |
 |                                                       |
 *-------------------------------------------------------*)

lemma ALL_cspF_unwind_cms:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode |]
     ==> ALL p. ($p =F Pf p)"
apply (simp add: eqF_def)
apply (simp add: semFf_Proc_name)
apply (simp add: MF_def)
apply (simp add: semFfix_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semFf_semFfun)
apply (simp add: UFP_fp semF_hasUFP_cms)
done

(*  csp law  *)

lemma cspF_unwind_cms:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode |]
     ==> $p =F Pf p"
by (simp add: ALL_cspF_unwind_cms)

(*-------------------------------------------------------*
 |                                                       |
 |    fixed point inducntion (CSP-Prover intro rule)     |
 |                                                       |
 *-------------------------------------------------------*)

(*----------- refinement -----------*)

(*** left ***)

lemma cspF_fp_induct_cms_ref_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p <=F Q ;
       ALL p. (Pf p)<<f <=F f p |]
    ==> $p <=F Q"
apply (simp add: refF_semF)
apply (insert cms_fixpoint_induction_ref
       [of "[[Pf]]Ffun" "(%p. [[f p]]F)" "UFP ([[Pf]]Ffun)"])
apply (simp add: UFP_fp semF_hasUFP_cms)
apply (simp add: fold_order_prod_def)
apply (simp add: semF_subst_semFfun)
apply (simp add: mono_semFfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semFfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+

apply (simp add: semF_UFP_cms)
done

(*  csp law  *)

lemma cspF_fp_induct_cms_ref_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p <=F Q ;
       !! p. (Pf p)<<f <=F f p |]
    ==> $p <=F Q"
by (simp add: cspF_fp_induct_cms_ref_left_ALL)

(*** right ***)

lemma cspF_fp_induct_cms_ref_right_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q <=F f p;
       ALL p. f p <=F (Pf p)<<f |]
    ==> Q <=F $p"
apply (simp add: refF_semF)
apply (insert cms_fixpoint_induction_rev
       [of "[[Pf]]Ffun" "(%p. [[f p]]F)" "UFP ([[Pf]]Ffun)"])
apply (simp add: UFP_fp semF_hasUFP_cms)
apply (simp add: fold_order_prod_def)
apply (simp add: semF_subst_semFfun)
apply (simp add: mono_semFfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semFfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+

apply (simp add: semF_UFP_cms)
done

(*  csp law  *)

lemma cspF_fp_induct_cms_ref_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q <=F f p;
       !! p. f p <=F (Pf p)<<f |]
    ==> Q <=F $p"
by (simp add: cspF_fp_induct_cms_ref_right_ALL)

(*----------- equality -----------*)

(*** left ***)

lemma cspF_fp_induct_cms_eq_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p =F Q ;
       ALL p. (Pf p)<<f =F f p |]
    ==> $p =F Q"
apply (simp add: eqF_semF)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semF_subst_semFfun)
apply (insert semF_UFP_fun_cms[of Pf])
apply (simp)
apply (subgoal_tac "(%p. [[$p]]F) = (%p. [[f p]]F)")
apply (simp add: fun_eq_iff)

apply (rule hasUFP_unique_solution[of "[[Pf]]Ffun"])
apply (simp_all add: semF_hasUFP_cms)
apply (simp add: UFP_fp semF_hasUFP_cms)
done

(*  csp law  *)

lemma cspF_fp_induct_cms_eq_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p =F Q;
       !! p. (Pf p)<<f =F f p |]
    ==> $p =F Q"
by (simp add: cspF_fp_induct_cms_eq_left_ALL)

lemma cspF_fp_induct_cms_eq_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q =F f p;
       !! p. f p =F (Pf p)<<f |]
    ==> Q =F $p"
apply (rule cspF_sym)
apply (rule cspF_fp_induct_cms_eq_left[of Pf f p Q])
apply (simp_all)
apply (rule cspF_sym)
apply (simp)
apply (rule cspF_sym)
apply (simp)
done

lemmas cspF_fp_induct_cms_left
     = cspF_fp_induct_cms_ref_left cspF_fp_induct_cms_eq_left

lemmas cspF_fp_induct_cms_right
     = cspF_fp_induct_cms_ref_right cspF_fp_induct_cms_eq_right

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


           (*-------------------------------------------*
            |                N Buffers                  |
            |                                           |
            |                June 2009                  |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory NBuff
imports CSP_F
begin

(*=============================================================*
 |                                                             |
 |                           Process                           |
 |                                                             |
 *=============================================================*)

(*********************************************************
               process names and events
 *********************************************************)

datatype Event = inC | outC | midC
datatype PN = Buff1 | Buff1' | Buff "nat" "nat"

(*********************************************************
                  Recursivey Process
 *********************************************************)

primrec
  PNdef :: "PN => (PN, Event) proc"
where
 "PNdef  (Buff1) = inC -> $Buff1'"
|"PNdef (Buff1') = outC -> $Buff1"

|"PNdef  (Buff N k) =
    (IF (0 < N & k <= N)
     THEN ((IF (k < N)
            THEN (inC -> $Buff N (Suc k)) ELSE STOP) [+]
           (IF (0 < k)
            THEN (outC -> $Buff N (k - 1)) ELSE STOP))
     ELSE STOP)"

(*
defs (overloaded) Set_PNfun_def [simp]: "PNfun == PNdef"
*)

overloading Set_PNdef ==
  "PNfun :: (PN, Event) pnfun"
begin
  definition "PNfun == PNdef"
end
declare Set_PNdef_def [simp]

(* ------------------ *
      guardedness
 * ------------------ *)

lemma guardedfun_PN[simp]:
      "guardedfun PNdef"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)

(*
defs FPmode_def [simp]: "FPmode == CMSmode"
*)

overloading FPmode ==
  "FPmode :: fpmode"
begin
  definition "FPmode == CMSmode"
end

declare FPmode_def [simp]

(*********************************************************
                     Composition
 *********************************************************)

abbreviation
 Link :: "(PN, Event) proc => (PN, Event) proc => (PN, Event) proc"
        ("(1_ /<---> _)" [76,77] 76)
where "P <---> Q == (P[[outC<-->midC]] |[{midC}]|
                     Q[[inC<-->midC]]) -- {midC}"

primrec
 LinkBuff :: "nat => nat => (PN, Event) proc"
where
 "LinkBuff      0  = (%k. STOP)"
|"LinkBuff (Suc n) = (%k.
    IF (n=0)
    THEN IF (0 < k)
         THEN $Buff1'
         ELSE $Buff1
    ELSE IF (n < k)
         THEN ($Buff1' <---> LinkBuff n (k - 1))
         ELSE ($Buff1 <---> LinkBuff n k))"

(*********************************************************
                  for automatising
 *********************************************************)

declare simp_event_set [simp]

lemma Link_cong: "Q =F R ==> P <---> Q =F P <---> R"
by (simp)

(*********************************************************
                  data tranfer
 *********************************************************)

lemma internal_data_transfer[rule_format]:
      "k < N -->
       ($Buff1' <---> $Buff N k) =F
       ($Buff1 <---> $Buff N (Suc k))"
apply (induct_tac k)

(* base case k=0 *)
apply (intro impI)
apply (cspF_unwind_left)
apply (cspF_hsf_left)+

(* induction case *)
apply (intro impI)

apply (cspF_auto)+
apply (rule cspF_Int_choice_eq_left)
apply (simp_all)
apply (subgoal_tac
  "(? b:{midC} -> $Buff1 [[outC<-->midC]] |[{midC}]| $Buff N n [[inC<-->midC]]) -- {midC} =F
   $Buff1' <---> $Buff N n")

defer

 apply (erule cspF_symE)
 apply (cspF_unwind_right)+
 apply (cspF_ren_deep_right)+
 apply (rule cspF_decompo)
 apply (simp_all)
 apply (rule cspF_decompo)
 apply (simp_all)
 apply (cspF_unwind_left)+
 apply (cspF_ren_deep)+

 apply (case_tac "(Suc (Suc n)) < N")
 apply (cspF_hsf)+
 apply (auto)
 apply (cspF_simp)+
 apply (rule cspF_Int_choice_eq_left)
 apply (cspF_unwind)
 apply (cspF_ren)
 apply (cspF_simp_deep)+

 apply (cspF_auto)+
 apply (auto)
 apply (cspF_simp)+
 apply (rule cspF_Int_choice_eq_left)
 apply (simp_all)
 apply (rule cspF_decompo)
 apply (simp_all)
 apply (rule cspF_decompo)
 apply (simp_all)
 apply (cspF_unwind_left)+
 apply (cspF_ren_deep)+
done

(*********************************************************
                 one step concurrency
 *********************************************************)

primrec
  Buff_to_Link_Buff :: "PN => (PN, Event) proc"
where
  "Buff_to_Link_Buff (Buff1)   = $Buff1"
 |"Buff_to_Link_Buff (Buff1')  = $Buff1'"
 |"Buff_to_Link_Buff (Buff N k) =
     (IF (0 < N & k <= N)
      THEN IF (N=Suc 0)
           THEN IF (k<N) THEN $Buff1
                         ELSE $Buff1'
           ELSE IF (k<N) THEN ($Buff1 <---> $Buff (N - 1) k)
                         ELSE ($Buff1' <---> $Buff (N - 1) (k - 1))
      ELSE STOP)"

theorem LinkBuff_eq_Buff_step_k:
   "[| 0 < N ; k <= (Suc N) |] ==>
       $Buff N k =F Buff_to_Link_Buff (Buff N k)"
apply (rule cspF_fp_induct_left[of _ "Buff_to_Link_Buff"])
apply (simp)+
apply (induct_tac p)
apply (auto)
apply (cspF_unwind)+

apply (case_tac "~(0 < x1 & x2 <= x1)")
apply (auto)
apply (cspF_simp)+

apply (subgoal_tac "(x2 - Suc 0 < x1)")
apply (cspF_simp_deep)+

apply (erule rem_asmE)
apply (erule rem_asmE)
apply (rename_tac N k)

(* N=0 *)
apply (case_tac "N=0")
apply (simp)

(* N=Suc 0 *)
apply (case_tac "N= Suc 0")
 apply (cspF_simp)
 apply (case_tac "k=0")
  apply (cspF_simp_deep)+
  apply (cspF_hsf)+

(* N=Suc (Suc 0) *)
apply (case_tac "N = Suc (Suc 0)")
 apply (cspF_simp)
 apply (case_tac "k=0")
  apply (cspF_simp_deep)+
  apply (cspF_unwind | cspF_hsf)+

(* k < N *)
apply (case_tac "k < N")
 apply (cspF_simp)
 apply (case_tac "k=0")
  apply (cspF_simp_deep)+
  apply (cspF_unwind | cspF_hsf)+
  apply (auto)
  apply (cspF_simp_deep)+
  apply (cspF_unwind | cspF_hsf)+

 (* k < N - Suc 0 *)
  apply (case_tac "k < N - Suc 0")
  apply (cspF_simp_deep)+
  apply (cspF_hsf)+
  apply (auto)
  apply (cspF_simp_deep)+
 (* ok *)
  defer

  apply (cspF_simp_deep)+
  apply (case_tac "Suc k < N")
   apply (cspF_simp_deep)+
   (* by transfer *)
   defer

 (* ~ (k < N - Suc 0) *)
 (* i.e. k = N - Suc 0 *)
apply (subgoal_tac "k = N - Suc 0")
 apply (simp)
 apply (cspF_simp_deep)+
  apply (cspF_hsf)+
  apply (auto)
   apply (cspF_simp_deep)+
  (* ok *)
  defer

   apply (cspF_simp_deep)+
  (* ok *)
  defer

apply (cspF_simp_deep)+
apply (cspF_unwind | cspF_hsf)+
 apply (auto)
 apply (cspF_simp_deep)+
   (* by transfer *)
   defer

(* by decompo *)
  apply (rule cspF_decompo, auto)+
  defer

(* by transfer lemma *)
apply (rule cspF_rw_left)
apply (rule internal_data_transfer[THEN cspF_symE])
apply (subgoal_tac "k < (N - Suc 0)")
apply (rotate_tac -1)
apply (assumption)
apply (simp)
apply (assumption)
  apply (rule cspF_decompo, auto)+
  defer

(* by decompo *)
  apply (rule cspF_decompo, auto)+
  defer

(* by decompo *)
  apply (rule cspF_decompo, auto)+
  defer

(* by transfer lemma *)
apply (rule cspF_rw_left)
apply (rule internal_data_transfer[THEN cspF_symE])
apply (subgoal_tac "(N - (Suc (Suc 0))) < N - (Suc 0)")
apply (rotate_tac -1)
apply (assumption)
apply (simp)
apply (subgoal_tac "Suc (N - Suc (Suc 0)) = N - Suc 0")
apply (simp)
apply (simp)
  apply (rule cspF_decompo, auto)+
  defer

(* easy *)

  apply (cspF_auto)+
done

(* --------------------- *
 |        one step       |
 * --------------------- *)

theorem LinkBuff_eq_Buff_step:
   "$Buff (Suc N) 0 =F
     IF (N=0) THEN ($Buff1)
     ELSE ($Buff1 <---> $Buff N 0)"
apply (cspF_simp LinkBuff_eq_Buff_step_k)+
done

(* --------------------- *
 |          main         |
 * --------------------- *)

theorem LinkBuff_eq_Buff:
   "ALL N. $Buff N 0 =F LinkBuff N 0"
apply (rule allI)
(* by induction on N *)
apply (induct_tac N)
(* N=0 *)
apply (cspF_unwind)
(* N+1 *)
apply (case_tac "n=0")
apply (cspF_simp LinkBuff_eq_Buff_step)+
done

end


theory Word_More
imports Main
  "~~/src/HOL/Word/Word"
  "../Word_Lib/Word_Lemmas"
begin

section\<open>Helper Lemmas about Machine Words\<close>

  (*usually: x,y = (len_of TYPE ('a)) i.e. 32 for ipv4addr*)
  lemma bitmagic_zeroLast_leq_or1Last:
    "(a::('a::len) word) AND (mask len << x - len) \<le> a OR mask (y - len)"
    by (meson le_word_or2 order_trans word_and_le2)

  lemma zero_base_lsb_imp_set_eq_as_bit_operation:
    fixes base ::"'a::len word"
    assumes valid_prefix: "mask (len_of TYPE('a) - len) AND base = 0"
    shows "(base = NOT mask (len_of TYPE('a) - len) AND a) \<longleftrightarrow>
           (a \<in> {base .. base OR mask (len_of TYPE('a) - len)})"
  proof
    have helper3: "x OR y = x OR y AND NOT x" for x y ::"'a::len word" by (simp add: word_oa_dist2)
    from assms show "base = NOT mask (len_of TYPE('a) - len) AND a \<Longrightarrow>
                      a \<in> {base..base OR mask (len_of TYPE('a) - len)}"
      apply(simp add: word_and_le1)
      apply(metis helper3 le_word_or2 word_bw_comms(1) word_bw_comms(2))
    done
  next
    assume "a \<in> {base..base OR mask (len_of TYPE('a) - len)}"
    hence a: "base \<le> a \<and> a \<le> base OR mask (len_of TYPE('a) - len)" by simp
    show "base = NOT mask (len_of TYPE('a) - len) AND a"
    proof -
      have f2: "\<forall>x\<^sub>0. base AND NOT mask x\<^sub>0 \<le> a AND NOT mask x\<^sub>0"
        using a neg_mask_mono_le by blast
      have f3: "\<forall>x\<^sub>0. a AND NOT mask x\<^sub>0 \<le> (base OR mask (len_of TYPE('a) - len)) AND NOT mask x\<^sub>0"
        using a neg_mask_mono_le by blast
      have f4: "base = base AND NOT mask (len_of TYPE('a) - len)"
        using valid_prefix by (metis mask_eq_0_eq_x word_bw_comms(1))
      hence f5: "\<forall>x\<^sub>6. (base OR x\<^sub>6) AND NOT mask (len_of TYPE('a) - len) =
                        base OR x\<^sub>6 AND NOT mask (len_of TYPE('a) - len)"
        using word_ao_dist by (metis)
      have f6: "\<forall>x\<^sub>2 x\<^sub>3. a AND NOT mask x\<^sub>2 \<le> x\<^sub>3 \<or>
                        \<not> (base OR mask (len_of TYPE('a) - len)) AND NOT mask x\<^sub>2 \<le> x\<^sub>3"
        using f3 dual_order.trans by auto
      have "base = (base OR mask (len_of TYPE('a) - len)) AND NOT mask (len_of TYPE('a) - len)"
        using f5 by auto
      hence "base = a AND NOT mask (len_of TYPE('a) - len)"
        using f2 f4 f6 by (metis eq_iff)
      thus "base = NOT mask (len_of TYPE('a) - len) AND a"
        by (metis word_bw_comms(1))
    qed
  qed
end


theory Retime
imports RubyEquality
begin

definition retime :: "[i,i,i] \<Rightarrow> o" where
  "retime(A,B,R) == (R = (D(A) ;; R ;; D(B)~))"

theorem D_invD_lemma: "t:int \<Longrightarrow> a`t = (lam x:int. a`(x $- $#1)) ` (t $+ $#1)"
apply(simp)
done

theorem invD_D_lemma: "t:int \<Longrightarrow> (lam x:int. a`(x $+ $#1))`t = a`(t $+ $#1)"
apply(simp)
done

theorem delay_Id_1: "\<lbrakk> <x,y>:Id(A) \<rbrakk> \<Longrightarrow> <x,y>: D(A);;D(A)~"
apply(insert Id_type[of A], simp, drule subsetD, simp)
apply(elim RubyE, simp)
apply(intro RubyI)
apply(rule)
apply(rule D_invD_lemma, simp+)
done

theorem delay_Id: "D(A) ;; D(A)~ = Id(A)"
apply(rule, auto)
apply(subgoal_tac "D(A) ;; D(A)~ : A<~>A", typecheck, simp)
apply(drule subsetD, simp, safe)
apply(elim RubyE, typecheck)
apply(subgoal_tac "xa = y", simp)
apply(rule IdI, simp)
apply(rule fun_extension, simp_all)
apply((drule bspec, simp)+, simp)
apply(insert Id_type[of A], simp, drule subsetD, simp, safe)
apply(erule delay_Id_1)
done

theorem delay_Id_inv1: "\<lbrakk> <x,y>:Id(A) \<rbrakk> \<Longrightarrow> <x,y>:D(A)~ ;; D(A)"
apply(insert Id_type[of A], simp, drule subsetD, simp)
apply(elim RubyE, simp)
apply(intro RubyI, rule)
apply(rule invD_D_lemma, simp+)
done

lemma ball_int_minus1: "\<forall>t\<in>int. ya ` t = y ` (t $+ $# 1) \<Longrightarrow> \<forall>t\<in>int. ya ` (t $- $#1) = y ` t"
apply(auto)
done

lemma sig_fun_extension_lemma:
  "\<lbrakk> \<forall>t\<in>int. ya ` t = y ` (t $+ $# 1);
    \<forall>t\<in>int. ya ` t = xa ` (t $+ $# 1); xa:sig(A); y:sig(A) \<rbrakk> \<Longrightarrow>
    xa = y"
apply(drule ball_int_minus1, drule ball_int_minus1)
apply(rule fun_extension, simp, simp)
apply(drule bspec, simp, drule bspec, simp, simp)
done

theorem delay_Id_inv: "D(A)~ ;; D(A) = Id(A)"
apply(rule, auto)
apply(subgoal_tac "D(A)~ ;; D(A) : A<~>A", typecheck, simp)
apply(drule subsetD, simp, safe)
apply(elim RubyE, typecheck)
apply(subgoal_tac "xa = y", simp)
apply(rule IdI, simp)
apply(rule sig_fun_extension_lemma, blast+)
apply(insert Id_type[of A], simp, drule subsetD, simp)
apply(safe, erule delay_Id_inv1)
done

theorem retime_delay: "retime(A,A,D(A))"
apply(unfold retime_def)
apply(subst comp_assoc, typecheck)
apply(subst delay_Id)
apply(insert delay_type[of A], simp)
done

lemma R_to_type: "R:A<R>B \<Longrightarrow> R:A<~>B"
apply(insert ruby_sub_sig[of A B], blast)
done

theorem retime_comp:
  "\<lbrakk> R:A<R>B; S:B<R>C ; retime(A,B,R); retime(B,C,S) \<rbrakk> \<Longrightarrow> retime(A,C,R;;S)"
apply(unfold retime_def)
apply(subgoal_tac "(D(A) ;; R ;; D(B)~) ;; (D(B) ;; S ;; D(C)~) = D(A) ;; (R ;; S) ;; D(C)~")
apply(simp)
apply(subst comp_assoc[of "D(A) ;; R" A B "D(B)~" B "D(B) ;; S ;; D(C)~" C])
apply(typecheck, (erule R_to_type)+)
apply(subst comp_assoc[of "D(B)~" B B "D(B) ;; S" C "D(C)~" C, THEN sym])
apply(typecheck, (erule R_to_type)+)
apply(subst comp_assoc[of "D(B)~" B B "D(B)" B "S" C, THEN sym])
apply(typecheck, (erule R_to_type)+)
apply(subst delay_Id_inv)
apply(insert Id_left[of S B C, OF R_to_type], simp)
apply(subst comp_assoc[of "D(A) ;; R" A B "S" C "D(C)~" C, THEN sym])
apply(typecheck, (erule R_to_type)+)
apply(subst comp_assoc[of "D(A)" A A "R" B "S" C, THEN sym])
apply(typecheck, (erule R_to_type)+, simp)
done

theorem retime_spread: "f:A~B \<Longrightarrow> retime(A,B,spread(f))"
apply(unfold retime_def)
apply(rule, auto)
apply(insert spread_type[of f A B], simp, drule subsetD, simp)
apply(safe, erule spreadE)
apply(rule compI)
apply(subgoal_tac "\<langle>xa, (lam t:int. y`(t $- $#1))\<rangle> \<in> D(A) ;; spread(f)", simp)
apply(intro RubyI)
apply(rule, rule D_invD_lemma, simp+)
apply(intro RubyI)
apply(rule, simp+)
apply(thin_tac "spread(f) \<subseteq> (sig(A)) \<times> (sig(B))")
apply(subgoal_tac " D(A) ;; spread(f) ;; D(B)~ : A<~>B", typecheck, simp_all)
apply(drule subsetD, simp, safe)
apply(elim RubyE, typecheck, simp_all)
apply(intro RubyI, typecheck, simp_all)
done

theorem D_eq_parD: "[[D(A), D(B)]] = D(A*B)"
apply(rule, auto)
apply(subgoal_tac "[[D(A), D(B)]]:A*B<~>A*B", typecheck)
apply(simp, drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim RubyE, simp_all)
apply(intro RubyI, simp_all)
apply(rule, (subst spair_apply_time, simp)+, simp)
apply(insert delay_type[of "A*B"], simp, drule subsetD, simp)
apply(safe, elim sig_pairE, simp)
apply(elim RubyE)
apply(intro RubyI)
apply(rule, drule bspec, simp)
apply((subst (asm) spair_apply_time, simp)+, simp_all)
apply(rule, drule bspec, simp)
apply((subst (asm) spair_apply_time, simp)+, simp_all)
done

theorem retime_par:
  "\<lbrakk> R:A<R>B; S:C<R>E; retime(A,B,R); retime(C,E,S) \<rbrakk>
    \<Longrightarrow> retime(A*C, B*E, [[R,S]])"
apply(unfold retime_def)
apply((subst D_eq_parD[THEN sym])+)
apply(subst par_inv_distrib, typecheck)
apply(subst par_comb, typecheck, (erule R_to_type)+)
apply(subst par_comb, typecheck, (erule R_to_type)+)
apply(simp)
done

theorem retime: "R:A<R>B \<Longrightarrow> retime(A,B,R)"
apply(erule ruby_induct)
apply(rule retime_spread, simp_all)
apply(rule retime_delay)
apply(rule retime_comp, simp_all)
apply(rule retime_par, simp_all)
done

theorem retime_eq: "R:A<R>B \<Longrightarrow> D(A) ;; R ;; D(B)~ = R"
apply(drule retime)
apply(unfold retime_def, simp)
done

theorem retime_D_comm: "R:A<R>B \<Longrightarrow> D(A) ;; R = R ;; D(B)"
apply(frule retime)
apply(unfold retime_def)
apply(subgoal_tac "R ;; D(B) = D(A) ;; R ;; D(B)~ ;; D(B)")
apply(thin_tac "R = D(A) ;; R ;; D(B)~")
apply(subst (asm) comp_assoc[of "D(A);;R" A B "D(B)~" B "D(B)" B])
apply(typecheck, (erule R_to_type)+)
apply(subst (asm) delay_Id_inv)
apply(subst (asm) Id_right, typecheck, (erule R_to_type)+)
apply(simp+)
done

end


text_raw \<open>\subsection[Isomorphically Unique Particulars]{Isomorphically Unique Particulars\isalabel{subsec:isomorphical-uniqueness}}\<close>

theory IsomorphicalUniqueness
  imports ParticularStructureMorphisms
begin

context ufo_particular_theory_sig
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  We can study a particular's formal properties in a particular structure through the various possible mappings it may have through morphisms that initiate or target
  that particular structure. One of these properties if that of being isomorphically
  unique, defined by considering the bijective morphisms from the particular structure.

  The existence of a bijective morphism between particular structures \<open>\<Gamma>\<^sub>1\<close> and
  \<open>\<Gamma>\<^sub>2\<close> implies that both structures express the same configuration,
  differing, if they do, only in representation of particulars.

  We say that a particular \<open>x\<close> is isomorphically unique in a particular structure
  \<open>\<Gamma>\<close> if and only if, for every bijective morphism \<open>\<phi>\<close> from \<open>\<Gamma>\<close> to some
  particular structure \<open>\<Gamma>'\<close>, and for every morphism \<open>\<sigma>\<close> from \<open>\<Gamma>\<close> to \<open>\<Gamma>'\<close>,
  \<open>\<phi>\<close> and \<open>\<sigma>\<close> agree with respect to \<open>x\<close>.

  Since particular structures are polymorphic on the type of particulars
  and Isabelle/HOL does not allow quantification over types, we need to
  define the notion of an isomorphically unique particular using some
  fixed choice of representation for the target particular structures.
  We chose here to use the \<open>ZF\<close> Isabelle/HOL type of ZF sets as the
  target representation, assuming that any domain of particulars is
  representable using ZF sets.

  Thus, the formal definition of isomorphically unique particulars is:
\<close>

definition isomorphically_unique_particulars (\<open>\<P>\<^sub>\<simeq>\<^sub>!\<close>)
  where \<open>\<P>\<^sub>\<simeq>\<^sub>! \<equiv> { x . x \<in> \<P> \<and> (
          \<forall>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>. \<forall>\<sigma> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>.
          \<forall>y \<in> \<P>.
          \<sigma> y = \<phi> x \<longleftrightarrow> y = x)}\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> isomorphically_unique_particulars_I[intro!]:
  assumes \<open>x \<in> \<P>\<close>
    \<open>\<And>\<phi> \<sigma> y. \<lbrakk> \<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ; \<sigma> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>
            ; y \<in> \<P> \<rbrakk>
      \<Longrightarrow> \<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close>
  shows \<open>x \<in> \<P>\<^sub>\<simeq>\<^sub>!\<close>
  using assms by (auto simp: isomorphically_unique_particulars_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> isomorphically_unique_particulars_E[elim!]:
  assumes \<open>x \<in> \<P>\<^sub>\<simeq>\<^sub>!\<close>
  obtains \<open>x \<in> \<P>\<close>
    \<open>\<And>\<phi> \<sigma> y. \<lbrakk> \<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub> ; \<sigma> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub> ; y \<in> \<P> \<rbrakk>
      \<Longrightarrow> \<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close>
  using assms by (auto simp: isomorphically_unique_particulars_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> isomorphically_unique_particulars_are_particulars: \<open>\<P>\<^sub>\<simeq>\<^sub>! \<subseteq> \<P>\<close>
  by auto

end

end


theory SimpComb
imports Wiring
begin

definition inv' :: "[i, i, i] \<Rightarrow> i" where
  "inv'(A,B,R) == lwir(B,A) ;; [[Id(B), [[R,Id(A)]]]] ;; rwir(B,A)"

definition "inv" :: "i \<Rightarrow> i" ("(_~)" [70] 70) where
  "R~ == inv'(dtyp(R), rtyp(R), R)"

definition Conj :: "[i, i] \<Rightarrow> i" where
  "Conj(R,S) == S ;; R ;; (S~)"

definition Fst :: "[i, i] \<Rightarrow> i" where
  "Fst(A,R) == [[R, Id(A)]]"

definition Snd :: "[i, i] \<Rightarrow> i" where
  "Snd(A,R) == [[Id(A), R]]"

definition below' :: "[i, i, i, i, i, i, i, i, i] \<Rightarrow> i" where
  "below'(A,B,C,De, E, F, G, R, S) ==
    reorg(A,E,F) ;; Snd(A,S) ;; (reorg(A,B,G)~) ;;
    Fst(G,R) ;; reorg(C, De, G)"

definition below :: "[i, i] \<Rightarrow> i" ("(_ ||/ _)" [67, 66] 66) where
  "R || S == below'(ddtyp(R), rdtyp(R), drtyp(R), rrtyp(R),
                    ddtyp(S), rdtyp(S), rrtyp(S), R, S)"

definition beside :: "[i, i] \<Rightarrow> i" ("(_ <~~>/ _)" [67, 66] 66) where
  "(R <~~> S) == ((R)~ || (S)~)~"

definition loop2' :: "[i, i, i, i] \<Rightarrow> i" where
  "loop2'(A,B,C,R) ==
    lwir(A,B) ;; (reorg(A,B,B)~) ;; Fst(B,R) ;; reorg(C,B,B) ;; (lwir(C,B)~)"

definition loop2 :: "i \<Rightarrow> i" where
  "loop2(R) == loop2'(ddtyp(R), rdtyp(R), drtyp(R), R)"

definition loop4' :: "[i, i, i, i, i, i] \<Rightarrow> i" where
  "loop4'(A,B,C,De, E, R) ==
    cross(A,C) ;; loop2(reorg(C,A,B) ;; cross(C,A*B) ;; R ;; (reorg(De, E, B)~))"

definition loop4 :: "i \<Rightarrow> i" where
  "loop4(R) == loop4'(domain(ddtyp(R)), range(ddtyp(R)),
                      rdtyp(R), drtyp(R), domain(rrtyp(R)), R)"

lemma inv_inv'_iff_typ_rel: "\<lbrakk>R:A<~>B; x:R~; R~ :rtyp(R)<~>dtyp(R)\<rbrakk> \<Longrightarrow> x \<in> inv'(A, B, R)"
apply(auto, drule subsetD, simp, safe)
apply(unfold inv_def inv'_def)
apply(erule compE, typecheck, rule sub_dtyp_rtyp, simp)
apply(elim sig_pairE, simp)
apply(erule rwirE, simp)
apply(erule compE, typecheck, rule sub_dtyp_rtyp, simp)
apply(elim sig_pairE, simp)
apply(elim parE IdE lwirE, simp_all)
apply(intro RubyI)
apply(subgoal_tac "<aa, <aa#<y#y>>>:lwir(B,A)", simp)
apply(intro RubyI, simp_all, blast, blast)
apply(subgoal_tac "<<aa#<y#y>>, <aa#<aa#y>>>:[[Id(B), [[R, Id(A)]]]]", simp)
apply(intro RubyI, simp_all, blast, blast)
apply(intro RubyI, blast, blast)
done

lemma inv_inv'_iff_typ_sig: "\<lbrakk>R:A<~>B; x:inv'(A, B, R); inv'(A, B, R):B<~>A\<rbrakk> \<Longrightarrow> x \<in> R~"
apply(auto, drule subsetD, simp, safe)
apply(unfold inv_def inv'_def)
apply(erule compE, typecheck, simp)
apply(elim sig_pairE, simp)
apply(erule rwirE, simp)
apply(erule compE, typecheck, simp)
apply(elim sig_pairE, simp)
apply(elim parE IdE lwirE, simp_all)
apply(intro RubyI)
apply(subgoal_tac "<aa, <aa#<y#y>>>:lwir(rtyp(R), dtyp(R))", simp)
apply(intro RubyI, simp_all add: rtyp_sig dtyp_sig)
apply(subgoal_tac "<<aa#<y#y>>, <aa#<aa#y>>>:[[Id(rtyp(R)),[[R,Id(dtyp(R))]]]]", simp)
apply(intro RubyI, simp_all add: rtyp_sig dtyp_sig)
apply(intro RubyI, simp_all add: rtyp_sig dtyp_sig)
done

theorem inv_inv'_iff: "R:A<~>B \<Longrightarrow> R~ = inv'(A,B,R)"
apply(rule, auto)
apply(subgoal_tac "R~ : rtyp(R)<~>dtyp(R)")
apply(rule inv_inv'_iff_typ_rel, blast+)
defer
apply(subgoal_tac "inv'(A,B,R) : B<~>A")
apply(rule inv_inv'_iff_typ_sig, blast+)
apply(unfold inv_def inv'_def)
apply(typecheck, simp_all)
done

theorem inv_type: "R:A<~>B \<Longrightarrow> R~ : B<~>A"
apply(subst inv_inv'_iff, simp)
apply(unfold inv'_def, typecheck)
done

theorem invR: "\<lbrakk> R:A<R>B \<rbrakk> \<Longrightarrow> R~ : B<R>A"
apply(subst inv_inv'_iff)
apply(insert ruby_sub_sig[of A B], blast)
apply(drule subsetD, simp)
apply(unfold inv'_def)
apply(intro RubyR)
apply(subgoal_tac "lwir(B, A) \<in> B<R>B*A*A", simp)
prefer 2
apply(subgoal_tac "[[Id(B),[[R,Id(A)]]]] \<in> B \<times> A \<times> A<R> B*B*A", simp)
apply((intro RubyR, simp_all add: Ruby_ch)+)
done

lemma dtyp_sig_rev: "\<lbrakk>x:sig(A); \<langle>x, y\<rangle> \<in> R\<rbrakk> \<Longrightarrow> x \<in> sig(dtyp(R))"
apply(rule dtyp_sig, simp_all)
done

lemma rtyp_sig_rev: "\<lbrakk>y:sig(B); \<langle>x, y\<rangle> \<in> R\<rbrakk> \<Longrightarrow> y \<in> sig(rtyp(R))"
apply(rule rtyp_sig, simp_all)
done

theorem invI: "\<lbrakk> <b,a>:R; a:sig(A); b:sig(B) \<rbrakk> \<Longrightarrow> <a,b>:R~"
apply(drule rtyp_sig_rev, simp, drule dtyp_sig_rev, simp)
apply(unfold inv_def inv'_def)
apply(intro RubyI)
apply(subgoal_tac "<a, <a#<b#b>>>:lwir(rtyp(R), dtyp(R))", simp)
apply(intro RubyI, simp_all)
apply(subgoal_tac "\<langle><a#<b#b>>, <a#<a#b>>\<rangle>:[[Id(rtyp(R)),[[R,Id(dtyp(R))]]]]", simp)
apply((intro RubyI, simp_all)+)
done

theorem invE: "\<lbrakk> <a,b>:R~; R:A<~>B; \<lbrakk> <b,a>:R \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(frule inv_type)
apply(frule mem_rel_dtype, simp)
apply(frule mem_rel_rtype, simp)
apply(subgoal_tac "<b,a>:R", simp)
apply(subst (asm) inv_inv'_iff, simp, unfold inv'_def)
apply(erule compE, typecheck)
apply(elim sig_pairE, simp)
apply(erule rwirE, simp_all)
apply(erule compE, typecheck, simp)
apply(elim sig_pairE, simp)
apply(elim parE, simp_all)
apply(elim IdE lwirE, simp_all)
done

theorem inv_iff: "R:A<~>B \<Longrightarrow> <a,b>:R~ \<longleftrightarrow> <b,a>:R"
apply(rule)
apply(erule invE, simp, simp)
apply(frule mem_rel_dtype, simp)
apply(frule mem_rel_rtype, simp)
apply(rule invI, simp_all)
done

theorem Conj_type: "\<lbrakk> R:A<~>A; S:B<~>A \<rbrakk> \<Longrightarrow> Conj(R,S):B<~>B"
apply(unfold Conj_def)
apply(typecheck add: inv_type)
done

theorem ConjR: "\<lbrakk> R:A<R>A; S:B<R>A \<rbrakk> \<Longrightarrow> Conj(R,S):B<R>B"
apply(unfold Conj_def)
apply(intro RubyR invR, simp_all)
done

theorem ConjI: "\<lbrakk> x:(S ;; R ;; (S~)) \<rbrakk> \<Longrightarrow> x:Conj(R,S)"
apply(unfold Conj_def, simp)
done

theorem ConjE: "\<lbrakk> x:Conj(R,S); x:(S;;R;;(S~)) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold Conj_def, simp)
done

theorem Fst_type: "\<lbrakk> R:A<~>B \<rbrakk> \<Longrightarrow> Fst(C,R):A*C<~>B*C"
apply(unfold Fst_def, typecheck)
done

theorem FstR: "\<lbrakk> R:A<R>B; C:ChTy \<rbrakk> \<Longrightarrow> Fst(C,R):A*C<R>B*C"
apply(unfold Fst_def)
apply(intro RubyR, simp_all)
done

theorem FstI: "\<lbrakk> x:[[R, Id(A)]] \<rbrakk> \<Longrightarrow> x:Fst(A,R)"
apply(unfold Fst_def, simp)
done

theorem FstE: "\<lbrakk> x:Fst(A,R); x:[[R,Id(A)]] \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold Fst_def, simp)
done

theorem Snd_type: "\<lbrakk> R:A<~>B \<rbrakk> \<Longrightarrow> Snd(C,R):C*A<~>C*B"
apply(unfold Snd_def, typecheck)
done

theorem SndR: "\<lbrakk> R:A<R>B; C:ChTy \<rbrakk> \<Longrightarrow> Snd(C,R):C*A<R>C*B"
apply(unfold Snd_def)
apply(intro RubyR, simp_all)
done

theorem SndI: "\<lbrakk> x:[[Id(A), R]] \<rbrakk> \<Longrightarrow> x:Snd(A,R)"
apply(unfold Snd_def, simp)
done

theorem SndE: "\<lbrakk> x:Snd(A,R); x:[[Id(A), R]] \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold Snd_def, simp)
done

lemma sig_pair_type_sub: "sig(A) \<subseteq> sig(C) \<Longrightarrow> sig(A*B) \<subseteq> sig(C*B)"
apply(rule)
apply(erule sig_pairE, simp)
apply(drule subsetD, simp+)
done

lemma sigma_sub_subset1: "\<lbrakk> A \<subseteq> B; D \<subseteq> C * A \<rbrakk> \<Longrightarrow> D \<subseteq> C * B"
apply(blast)
done

lemma sigma_sub_subset2: "\<lbrakk> A \<subseteq> B; D \<subseteq> A * C \<rbrakk> \<Longrightarrow> D \<subseteq> B * C"
apply(blast)
done

lemma below_below'_typ_rel_S_help:
  "\<lbrakk> R:A*B<~>C*D; S:E*F<~>B*G \<rbrakk> \<Longrightarrow> S:ddtyp(S)*rdtyp(S)<~>rdtyp(R)*rrtyp(S)"
apply(rule, auto)
apply(frule subsetD, simp, auto)
apply(rule sig_sub_func, simp)
apply(simp add: ddtyp_def rdtyp_def)
apply(rule domain_time_range_extension, simp)
apply(frule dtyp_sig, simp, simp)
apply(rule sig_sub_func, simp)
apply(drule apply_funtype, simp) back
apply(auto)
apply(simp add: rdtyp_def dtyp_def)
oops

find_theorems "_:range(_)"

lemma below_below'_typ_rel:
  "\<lbrakk>R \<in> A \<times> B<~>C \<times> De; S \<in> E \<times> F<~>B \<times> G; x \<in> R || S;
    R || S \<in> (ddtyp(R) \<times> ddtyp(S)) \<times> rdtyp(S)<~>drtyp(R) \<times> rrtyp(R) \<times> rrtyp(S)\<rbrakk>
    \<Longrightarrow> x \<in> below'(A, B, C, De, E, F, G, R, S)"
apply(auto, drule subsetD, simp, safe)
apply(elim sig_pairE, simp)
apply(unfold below_def below'_def)
apply(erule compE, typecheck add: Fst_type Snd_type inv_type, simp)
apply(rule sub_ddtyp_rrtyp, simp)
apply(erule compE, typecheck add: Fst_type Snd_type inv_type, simp)
apply(rule sub_ddtyp_rrtyp, simp)
apply(erule compE2, typecheck add: Fst_type Snd_type inv_type, simp)
apply(erule compE, typecheck add: Fst_type Snd_type inv_type, simp)
apply(rule PowD, rule sub_ddtyp_rrtyp, simp)
apply(thin_tac "yc \<in> sig(ddtyp(R) \<times> rdtyp(R) \<times> rrtyp(S))")
apply(elim sig_pairE, simp)
apply(erule reorgE, simp)
apply(erule FstE, simp_all, erule parE, simp_all)
apply(erule invE, erule reorgE, simp_all)
apply(rule PowD, typecheck)
apply(erule reorgE, simp_all)
apply(erule reorgE, simp_all)
apply(erule SndE, erule parE, simp_all)
apply(elim IdE, simp_all)
apply(intro compI)
apply(rule reorgI, simp_all)
apply(rule ddtyp_rel, simp_all)
apply(rule ddtyp_rel, simp_all)
apply(rule rdtyp_rel, simp_all)
apply(subgoal_tac "<<af#<ak#bk>>,<af#<aj#bc>>>:Snd(A,S)", simp)
apply(rule SndI, rule parI, rule IdI)
apply(rule ddtyp_rel, simp_all)
apply(subgoal_tac "<<af#<aj#bc>>, <<af#aj>#bc>>:reorg(A,B,G)~", simp)
apply(rule invI, rule reorgI)
apply(rule ddtyp_rel, simp_all)
apply(subgoal_tac "<<<af#aj>#bc>,<<aa#ac>#bc>>:Fst(G,R)", simp)
apply(rule FstI, rule parI, simp_all)
apply(rule IdI, simp_all)
apply(rule reorgI, simp_all)
apply(rule drtyp_rel, simp_all)
apply(rule rrtyp_rel, simp_all)
done

lemma below_below'_typ_sig:
  "\<lbrakk>R \<in> A \<times> B<~>C \<times> De; S \<in> E \<times> F<~>B \<times> G; x \<in> below'(A, B, C, De, E, F, G, R, S);
    below'(A, B, C, De, E, F, G, R, S) \<in> (A \<times> E) \<times> F<~>C \<times> De \<times> G\<rbrakk>
    \<Longrightarrow> x \<in> R || S"
apply(auto, drule subsetD, simp, safe)
apply(elim sig_pairE, simp)
apply(unfold below_def below'_def)
apply(elim compE, typecheck add: Fst_type Snd_type inv_type, simp_all)
apply(elim sig_pairE, simp)
apply(elim RubyE, simp_all)
apply(elim FstE SndE invE, typecheck)
apply(elim reorgE, simp_all)
apply(elim parE, simp_all)
apply(elim IdE, simp_all)
apply(intro RubyI)
apply(subgoal_tac "\<langle><<af#ak>#bk>,<af#<ak#bk>>\<rangle>:reorg(ddtyp(R), ddtyp(S), rdtyp(S))", simp)
apply(rule reorgI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><af#<ak#bk>>,<af#<aj#bc>>\<rangle>:Snd(ddtyp(R), S)", simp)
apply(rule SndI, rule parI, rule IdI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><af#<aj#bc>>,<<af#aj>#bc>\<rangle>:reorg(ddtyp(R), rdtyp(R), rrtyp(S))~", simp)
apply(rule invI, rule reorgI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><<af#aj>#bc>, <<aa#ac>#bc>\<rangle> \<in> Fst(rrtyp(S), R)", simp)
apply(rule FstI, rule parI, simp_all add: typ_sigs, rule IdI, simp_all add: typ_sigs)
apply(rule reorgI, simp_all add: typ_sigs)
done

theorem below_below'_iff:
  "\<lbrakk> R:A*B<~>C*De; S:E*F<~>B*G \<rbrakk> \<Longrightarrow> R||S = below'(A,B,C,De,E,F,G,R,S)"
apply(rule, rule)
apply(subgoal_tac "R || S:((ddtyp(R)*ddtyp(S))*rdtyp(S))<~>(drtyp(R)*rrtyp(R)*rrtyp(S))")
apply(rule below_below'_typ_rel, blast+)
defer
apply(rule)
apply(subgoal_tac "below'(A, B, C, De, E, F, G, R, S) \<in> (A \<times> E) \<times> F<~>C \<times> De \<times> G")
apply(rule below_below'_typ_sig, blast+)
apply(unfold below_def below'_def)
apply(typecheck add: Fst_type Snd_type inv_type)
done

theorem below_iff2:
  "\<lbrakk> R:A*B<~>C*De; S:E*F<~>B*G \<rbrakk>
    \<Longrightarrow> R||S = reorg(A,E,F);;Snd(A,S);;(reorg(A,B,G)~);;Fst(G,R);;reorg(C,De,G)"
apply(subst below_below'_iff, simp_all)
apply(unfold below'_def, simp)
done

theorem below_type:
  "\<lbrakk> R:A*B<~>C*De; S:E*F<~>B*G \<rbrakk> \<Longrightarrow> R||S:(A*E)*F<~>C*(De*G)"
apply(subst below_below'_iff, blast+)
apply(unfold below'_def, typecheck add: Fst_type Snd_type inv_type)
done

lemma "A \<subseteq> B \<Longrightarrow> C \<subseteq> D \<Longrightarrow> A<~>C \<subseteq> C<~>D"
apply(rule, rule, rule)
oops

lemma sig_pair_type_sub2: "\<lbrakk> sig(A) \<subseteq> sig(C); sig(B) \<subseteq> sig(D) \<rbrakk> \<Longrightarrow> sig(A*B) \<subseteq> sig(C*D)"
apply(rule)
apply(erule sig_pairE, drule subsetD, simp, drule subsetD, simp)
apply(simp)
done

theorem below_type2:
  "\<lbrakk> R:A*B<~>C*De; S:E*F<~>H*G \<rbrakk> \<Longrightarrow> R||S:(A*E)*F<~>C*(De*G)"
apply(unfold below_def below'_def)
apply(typecheck)
apply(subgoal_tac
      "(ddtyp(R) \<times> ddtyp(S)) \<times> rdtyp(S)<~>ddtyp(R) \<times> ddtyp(S) \<times> rdtyp(S)
        \<subseteq> (A \<times> E) \<times> F<~>A \<times> E \<times> F")
apply(rule subsetD, simp, typecheck)
apply(rule Pow_mono)
apply((intro Sigma_mono sig_pair_type_sub2)+)
apply((rule, elim typ_rels, simp)+)
apply(typecheck add: Snd_type)
apply(typecheck add: inv_type)
apply(typecheck add: Fst_type)
apply(subgoal_tac
      "(drtyp(R) \<times> rrtyp(R)) \<times> rrtyp(S)<~>drtyp(R) \<times> rrtyp(R) \<times> rrtyp(S)
        \<subseteq> (C \<times> De) \<times> G<~>C \<times> De \<times> G")
apply(rule subsetD, simp, typecheck)
apply(rule Pow_mono)
apply((intro Sigma_mono sig_pair_type_sub2)+)
apply((rule, elim typ_rels, simp)+)
done

theorem belowR:
  "\<lbrakk> A:ChTy; B:ChTy; C:ChTy; De:ChTy; E:ChTy; F:ChTy; G:ChTy;
    R:A*B<R>C*De; S:E*F<R>B*G \<rbrakk> \<Longrightarrow> R || S:(A*E)*F<R>C*(De*G)"
apply(subst below_below'_iff)
apply(frule rev_subsetD[of R], rule ruby_sub_sig, simp)
apply(frule rev_subsetD[of S], rule ruby_sub_sig, simp)
apply(unfold below'_def)
apply(intro RubyR FstR SndR invR)
apply(((rule RubyR)?, (rule FstR)?, (rule SndR)?, blast+)+)
done

theorem belowI:
  "\<lbrakk> a:sig(A); b:sig(B); c:sig(C); d:sig(De); e:sig(E); f:sig(F);
    g:sig(G); <<a#b>,<c#d>>:R; <<e#f>,<b#g>>:S \<rbrakk>
    \<Longrightarrow> <<<a#e>#f>, <c#<d#g>>>:R||S"
apply(unfold below_def below'_def)
apply(intro RubyI)
apply(subgoal_tac "\<langle><<a#e>#f>, <a#<e#f>>\<rangle> \<in> reorg(ddtyp(R), ddtyp(S), rdtyp(S))", simp)
apply(rule RubyI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><a#<e#f>>, <a#<b#g>>\<rangle> \<in> Snd(ddtyp(R),S)", simp)
apply(rule SndI, rule parI, rule IdI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><a#<b#g>>, <<a#b>#g>\<rangle> \<in> reorg(ddtyp(R), rdtyp(R), rrtyp(S))~", simp)
apply(rule invI, rule reorgI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><<a#b>#g>, <<c#d>#g>\<rangle> \<in> Fst(rrtyp(S), R)", simp)
apply(rule FstI, rule parI, simp_all add: typ_sigs, rule IdI, simp add: typ_sigs)
apply(rule reorgI, simp_all add: typ_sigs)
done

theorem belowE2:
  "\<lbrakk> <<<a#e>#f>,<c#<d#g>>>:R||S;
    \<And>b. \<lbrakk> <<a#b>,<c#d>>:R; <<e#f>,<b#g>>:S; b:sig(B); b:sig(G) \<rbrakk> \<Longrightarrow> P;
    R:A*B<~>C*De; S:E*F<~>G*H;
    a:sig(A'); c:sig(C'); d:sig(De'); e:sig(E'); f:sig(F'); g:sig(G') \<rbrakk> \<Longrightarrow> P"
apply(frule sub_ddtyp_rrtyp)
apply(frule sub_ddtyp_rrtyp) back
apply(rotate_tac 10)
apply(unfold below_def below'_def)
apply(erule compE, typecheck add: Fst_type Snd_type inv_type)
apply(elim sig_pairE, simp)
apply(erule reorgE, typecheck add: Fst_type Snd_type inv_type)
apply(erule compE, typecheck add: Fst_type Snd_type inv_type, simp+)
apply(erule FstE, elim sig_pairE, simp, erule parE, simp_all, erule IdE, simp_all)
apply(erule compE2, typecheck add: Fst_type Snd_type inv_type, simp+)
apply(elim sig_pairE, simp)
apply(erule spair_inject, simp_all)
apply(erule spair_inject, simp_all)
apply((drule PowI)+)
apply(erule invE, typecheck)
apply(elim compE, typecheck add: Snd_type)
apply(elim sig_pairE, simp)
apply(elim SndE reorgE, simp_all)
apply(erule parE, simp_all)
apply(erule IdE, simp)
apply(subgoal_tac "af:sig(B)" "af:sig(G)", simp)
apply(elim typ_rels, simp)
apply(rule rdtyp_rel, simp+)
done

lemma spair_type_rev: "\<lbrakk> <a#b>:sig(A*B); a:sig(A'); b:sig(B') \<rbrakk> \<Longrightarrow> a:sig(A) & b:sig(B)"
apply(elim sig_pairE)
apply(erule spair_inject, simp_all)
done

theorem belowE:
  "\<lbrakk> <<<a#e>#f>,<c#<d#g>>>:R||S;
    \<And>b. \<lbrakk> <<a#b>,<c#d>>:R; <<e#f>,<b#g>>:S; b:sig(B) \<rbrakk> \<Longrightarrow> P;
    R:A*B<~>C*De; S:E*F<~>B*H;
    a:sig(A'); c:sig(C'); d:sig(De'); e:sig(E'); f:sig(F'); g:sig(G')\<rbrakk> \<Longrightarrow> P"
apply(subst (asm) below_below'_iff, blast+)
apply(unfold below'_def)
apply(elim compE, typecheck add: Fst_type Snd_type inv_type)
apply(elim sig_pairE, simp)
apply(elim invE, typecheck)
apply(elim RubyE, typecheck)
apply(elim FstE SndE, elim parE, simp_all, elim IdE, simp)
done

theorem below_iff:
  "\<lbrakk> a:sig(A'); c:sig(C'); d:sig(De'); e:sig(E'); f:sig(F'); g:sig(G');
    R:A*B<~>C*De; S:E*F<~>B*G \<rbrakk> \<Longrightarrow>
    <<<a#e>#f>,<c#<d#g>>>:R||S \<longleftrightarrow>
    (EX b:sig(B). <<a#b>,<c#d>>:R & <<e#f>,<b#g>>:S)"
apply(rule)
apply(erule belowE, simp_all)
apply(erule rev_bexI, simp)
apply(erule bexE, rotate_tac 8)
apply(erule conjE)
apply(rule belowI, simp_all)
done

theorem beside_type:
  "\<lbrakk> R:A*B<~>C*De; S:De*E<~>F*G \<rbrakk> \<Longrightarrow> R <~~> S:A*B*E<~>(C*F)*G"
apply(unfold beside_def)
apply(typecheck add: inv_type below_type)
done

theorem beside_type2:
  "\<lbrakk> R:A*B<~>C*De; S:H*E<~>F*G \<rbrakk> \<Longrightarrow> R <~~> S:A*B*E<~>(C*F)*G"
apply(unfold beside_def)
apply(typecheck add: inv_type below_type2)
done

theorem besideR:
  "\<lbrakk> A:ChTy; B:ChTy; C:ChTy; De:ChTy; E:ChTy; E:ChTy; F:ChTy; G:ChTy;
    R:A*B<R>C*De; S:De*E<R>F*G \<rbrakk> \<Longrightarrow> R<~~>S:A*B*E<R>(C*F)*G"
apply(unfold beside_def)
apply(intro invR belowR, simp_all)
done

theorem besideI:
  "\<lbrakk> d:sig(De); a:sig(A); b:sig(B); c:sig(C); e:sig(E); f:sig(F); g:sig(G);
    <<a#b>,<c#d>>:R; <<d#e>,<f#g>>:S \<rbrakk> \<Longrightarrow> <<a#<b#e>>,<<c#f>#g>>:R<~~>S"
apply(unfold beside_def)
apply(intro invI belowI, simp_all)
done

theorem besideE:
  "\<lbrakk> <<a#<b#e>>, <<c#f>#g>>:R<~~>S;
    \<And>d. \<lbrakk> <<a#b>,<c#d>>:R; <<d#e>,<f#g>>:S; d:sig(De) \<rbrakk> \<Longrightarrow> P;
    R:A*B<~>C*De; S:De*E<~>F*G;
    a:sig(A'); b:sig(B'); c:sig(C'); e:sig(E'); f:sig(F'); g:sig(G') \<rbrakk> \<Longrightarrow> P"
apply(unfold beside_def)
apply(elim invE belowE, typecheck add: below_type inv_type, simp)
done

theorem besideE2:
  "\<lbrakk> <<a#<b#e>>, <<c#f>#g>>:R<~~>S;
    \<And>d. \<lbrakk> <<a#b>,<c#d>>:R; <<d#e>,<f#g>>:S; d:sig(De) \<rbrakk> \<Longrightarrow> P;
    R:A*B<~>C*De; S:H*E<~>F*G;
    a:sig(A'); b:sig(B'); c:sig(C'); e:sig(E'); f:sig(F'); g:sig(G') \<rbrakk> \<Longrightarrow> P"
apply(unfold beside_def)
apply(elim invE belowE2, typecheck add: below_type2 inv_type, simp)
done

theorem beside_iff:
  "\<lbrakk> a:sig(A); b:sig(B); c:sig(C); e:sig(E); f:sig(F); g:sig(G);
    R:A*B<~>C*De; S:De*E<~>F*G \<rbrakk> \<Longrightarrow>
    <<a#<b#e>>,<<c#f>#g>>:R<~~>S \<longleftrightarrow>
    (EX d:sig(De). <<a#b>, <c#d>>:R & <<d#e>, <f#g>>:S)"
apply(rule)
apply(unfold beside_def)
apply(elim invE belowE, typecheck add: inv_type below_type, blast)
apply(erule bexE, rotate_tac 8)
apply(intro invI belowI, simp_all)
done

lemma loop2_loop2'_iff_typ_rel:
  "\<lbrakk> R:A*B<~>C*B; loop2(R):ddtyp(R)<~>drtyp(R); x:loop2(R) \<rbrakk> \<Longrightarrow> x:loop2'(A,B,C,R)"
apply(auto, drule subsetD, simp, safe)
apply(unfold loop2_def loop2'_def)
apply(elim compE2, typecheck add: inv_type Fst_type, simp_all)
apply(thin_tac "yb \<in> sig((C \<times> B) \<times> rdtyp(R))", thin_tac "yc \<in> sig((A \<times> B) \<times> rdtyp(R))")
apply(elim invE FstE, typecheck)
apply(elim sig_pairE, simp)
apply(elim reorgE, simp_all, elim lwirE, simp_all)
apply(elim parE, simp_all, elim IdE, simp)
apply(intro compI)
apply(subgoal_tac "<ac, <ac#<bd#bd>>>:lwir(A,B)", simp)
apply(rule lwirI, (elim typ_rels, simp)+)
apply(rule invI, subgoal_tac "<<<ac#bd>#bd>, <ac#<bd#bd>>>:reorg(A,B,B)", simp)
apply(rule reorgI, (elim typ_rels, simp)+, simp_all)
apply(subgoal_tac "\<langle><<ac#bd>#bd>,<<a#bd>#bd>\<rangle> \<in> Fst(B, R)", simp)
apply(rule FstI, rule parI, simp_all, rule IdI, (elim typ_rels, simp)+)
apply(subgoal_tac "\<langle><<a#bd>#bd>,<a#<bd#bd>>\<rangle> \<in> reorg(C, B, B)", simp)
apply(rule reorgI, (elim typ_rels, simp)+)
apply(rule invI, rule lwirI, (elim typ_rels, simp)+, simp_all)
done

lemma loop2_loop2'_iff_typ_sig:
  "\<lbrakk> R:A*B<~>C*B; loop2'(A,B,C,R):A<~>C; x:loop2'(A,B,C,R) \<rbrakk> \<Longrightarrow> x:loop2(R)"
apply(auto, drule subsetD, simp, safe)
apply(unfold loop2_def loop2'_def)
apply(elim compE, typecheck add: inv_type Fst_type, simp_all)
apply(elim invE, typecheck)
apply(elim sig_pairE, simp)
apply(elim reorgE, simp_all)
apply(elim lwirE, simp_all)
apply(elim FstE parE, simp_all, elim IdE, simp)
apply(intro compI)
apply(subgoal_tac "<ac, <ac#<bd#bd>>>:lwir(ddtyp(R), rdtyp(R))", simp)
apply(rule lwirI, simp_all add: typ_sigs)
apply(rule invI, subgoal_tac "<<<ac#bd>#bd>, <ac#<bd#bd>>>:reorg(ddtyp(R), rdtyp(R), rdtyp(R))", simp)
apply(rule reorgI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><<ac#bd>#bd>,<<a#bd>#bd>\<rangle> \<in> Fst(rdtyp(R), R)", simp)
apply(rule FstI, rule parI, simp_all, rule IdI, simp_all add: typ_sigs)
apply(subgoal_tac "\<langle><<a#bd>#bd>,<a#<bd#bd>>\<rangle> \<in> reorg(drtyp(R), rdtyp(R), rdtyp(R))", simp)
apply(rule reorgI, simp_all add: typ_sigs)
apply(rule invI, rule lwirI, simp_all add: typ_sigs)
done

theorem loop2_loop2'_iff: "R:A*B<~>C*B \<Longrightarrow> loop2(R) = loop2'(A,B,C,R)"
apply(rule, rule)
apply(subgoal_tac "loop2(R):ddtyp(R)<~>drtyp(R)")
apply(rule loop2_loop2'_iff_typ_rel, blast+)
defer
apply(rule)
apply(subgoal_tac "loop2'(A,B,C,R):A<~>C")
apply(rule loop2_loop2'_iff_typ_sig, blast+)
apply(unfold loop2'_def loop2_def)
apply(typecheck add: inv_type Fst_type)
done

theorem loop2_type: "\<lbrakk> R:A*B<~>C*B \<rbrakk> \<Longrightarrow> loop2(R):A<~>C"
apply(subst loop2_loop2'_iff, simp)
apply(unfold loop2'_def)
apply(typecheck add: inv_type Fst_type)
done

theorem loop2R: "\<lbrakk> A:ChTy; B:ChTy; C:ChTy; R:A*B<R>C*B \<rbrakk> \<Longrightarrow> loop2(R):A<R>C"
apply(subst loop2_loop2'_iff)
apply(frule rev_subsetD[of R], rule ruby_sub_sig, simp)
apply(unfold loop2'_def)
apply(intro RubyR FstR invR)
apply(((rule lwirR | rule reorgR | rule FstR), simp+)+)
done

theorem loop2_iff:
  "\<lbrakk> R:A*B<~>C*B; a:sig(A'); c:sig(C') \<rbrakk>
    \<Longrightarrow> <a,c>:loop2(R) \<longleftrightarrow> (EX b:sig(B). <<a#b>, <c#b>>:R)"
apply(subst loop2_loop2'_iff, simp, unfold loop2'_def)
apply(rule)
apply(elim compE, typecheck add: inv_type Fst_type, simp_all)
apply(elim invE, typecheck)
apply(elim sig_pairE, simp)
apply(elim reorgE, simp_all)
apply(elim lwirE, simp_all)
apply(elim FstE parE, simp_all, elim IdE, simp)
apply(rule, simp, simp)
apply(erule bexE)
apply(frule mem_rel_type, simp, erule conjE)
apply(drule spair_type_rev, simp, simp)
apply(drule spair_type_rev, simp)
apply(erule conjE, simp, erule conjE)
apply(intro compI)
apply(subgoal_tac "<a, <a#<b#b>>>:lwir(A,B)", simp)
apply(rule lwirI, simp+)
apply(rule invI, subgoal_tac "<<<a#b>#b>, <a#<b#b>>>:reorg(A,B,B)", simp)
apply(rule reorgI, simp_all)
apply(subgoal_tac "\<langle><<a#b>#b>,<<c#b>#b>\<rangle> \<in> Fst(B, R)", simp)
apply(rule FstI, rule parI, simp_all, rule IdI, simp)
apply(subgoal_tac "\<langle><<c#b>#b>,<c#<b#b>>\<rangle> \<in> reorg(C, B, B)", simp)
apply(rule reorgI, simp_all)
apply(rule invI, rule lwirI, simp_all)
done

theorem loop2I:
"\<lbrakk> <<a#b>, <c#b>>:R; R:A*B<~>C*B;
  a:sig(A'); b:sig(B); c:sig(C') \<rbrakk> \<Longrightarrow> <a,c>:loop2(R)"
apply(drule loop2_iff[of _ _ _ _ a _ c _], auto)
done

theorem loop2E:
  "\<lbrakk> <a,c>:loop2(R);
    \<And>b. \<lbrakk> b:sig(B); <<a#b>,<c#b>>:R \<rbrakk> \<Longrightarrow> P;
    R:A*B<~>C*B; a:sig(A'); c:sig(C') \<rbrakk> \<Longrightarrow> P"
apply(drule loop2_iff[of _ _ _ _ a _ c _], auto)
done

lemma loop4_loop4'_iff_typ_rel:
  "\<lbrakk> R:(A*B)*C<~>De*(E*B); loop4(R):domain(ddtyp(R))*rdtyp(R)<~>drtyp(R)*domain(rrtyp(R));
    x:loop4(R) \<rbrakk> \<Longrightarrow> x:loop4'(A,B,C,De,E,R)"
apply(auto, drule subsetD, simp, safe)
apply(unfold loop4_def loop4'_def)
apply(elim compE, typecheck add: loop2_type inv_type, simp_all)
apply(elim sig_pairE, simp)
apply(erule crossE, simp_all)
apply(erule loop2E, typecheck add: inv_type, simp_all)
apply(erule compE2, typecheck add: inv_type, simp_all)
apply(thin_tac "yb \<in> sig(De \<times> E \<times> B)")
apply(erule invE, typecheck)
apply(elim sig_pairE, simp, erule reorgE, simp_all)
apply(erule compE2, typecheck, simp)
apply(elim sig_pairE, simp)
apply(elim RubyE, typecheck)
apply(elim sig_pairE, simp, elim RubyE, simp_all)
apply(intro RubyI)
apply(subgoal_tac "<<ag#bf>, <bf#ag>>:cross(A, C)", simp)
apply(rule crossI, (elim typ_rels, simp)+, simp)
apply(rule loop2I, typecheck add: inv_type, simp_all)
apply(subgoal_tac
      "\<langle><<bf#ag>#bh>,<<ac#ad>#bh>\<rangle> \<in> reorg(C, A, B);;cross(C, A \<times> B);;R;;reorg(De, E, B)~", simp)
apply(intro RubyI invI)
apply(subgoal_tac "\<langle><<bf#ag>#bh>,<bf#<ag#bh>>\<rangle> \<in> reorg(C, A, B)", simp)
apply(rule reorgI, (elim typ_rels, simp)+, simp+)
apply(subgoal_tac "\<langle><bf#<ag#bh>>,<<ag#bh>#bf>\<rangle> \<in> cross(C, A \<times> B)", simp)
apply(rule crossI, (elim typ_rels, simp)+, simp+)
apply(rule reorgI, (elim typ_rels, simp)+, simp+)
done

lemma loop4_loop4'_iff_typ_sig:
  "\<lbrakk> R:(A*B)*C<~>De*(E*B); loop4'(A,B,C,De,E,R):A*C<~>De*E;
    x:loop4'(A,B,C,De,E,R) \<rbrakk> \<Longrightarrow> x:loop4(R)"
apply(auto, drule subsetD, simp, safe)
apply(elim sig_pairE, simp)
apply(unfold loop4_def loop4'_def)
apply(elim compE, typecheck add: inv_type loop2_type, simp_all)
apply(elim sig_pairE, simp, elim crossE, simp_all)
apply(elim loop2E, typecheck add: inv_type, simp_all)
apply(erule compE, typecheck add: inv_type, simp)
apply(erule invE, typecheck, elim sig_pairE, simp, erule reorgE, simp_all)
apply(erule compE, typecheck, simp, elim sig_pairE, simp)
apply(erule compE, typecheck, elim sig_pairE, simp, erule crossE, simp_all)
apply(erule reorgE, simp_all)
apply(intro RubyI)
apply(subgoal_tac "<<af#bf>, <bf#af>>:cross(domain(ddtyp(R)), rdtyp(R))", simp)
apply(rule crossI, simp_all add: typ_sigs)
apply(rule loop2I, typecheck add: inv_type, simp_all)
apply(subgoal_tac
      "\<langle><<bf#af>#bg>,<<ac#ad>#bg>\<rangle> \<in>
            reorg(rdtyp(R), domain(ddtyp(R)), range(ddtyp(R))) ;;
            cross(rdtyp(R), domain(ddtyp(R)) \<times> range(ddtyp(R))) ;;
            R ;;
            reorg(drtyp(R), domain(rrtyp(R)), range(ddtyp(R)))~", simp)
apply(intro RubyI invI)
apply(subgoal_tac "\<langle><<bf#af>#bg>,<bf#<af#bg>>\<rangle> \<in> reorg(rdtyp(R), domain(ddtyp(R)), range(ddtyp(R)))", simp)
apply(rule reorgI, (simp add: typ_sigs)+)
apply(subgoal_tac "\<langle><bf#<af#bg>>,<<af#bg>#bf>\<rangle> \<in> cross(rdtyp(R), domain(ddtyp(R)) \<times> range(ddtyp(R)))", simp)
apply(rule crossI, (simp add: typ_sigs)+)
apply(typecheck, (simp add: typ_sigs)+)
apply(rule reorgI, simp_all add: typ_sigs)
done

theorem loop4_loop4'_iff:
  "R:(A*B)*C<~>De*(E*B) \<Longrightarrow> loop4(R) = loop4'(A,B,C,De,E,R)"
apply(rule, rule)
apply(subgoal_tac "loop4(R):domain(ddtyp(R))*rdtyp(R)<~>drtyp(R)*domain(rrtyp(R))")
apply(rule loop4_loop4'_iff_typ_rel, blast+)
defer
apply(rule)
apply(subgoal_tac "loop4'(A,B,C,De,E,R):A*C<~>De*E")
apply(rule loop4_loop4'_iff_typ_sig, blast+)
apply(unfold loop4'_def loop4_def)
apply(typecheck add: loop2_type inv_type)
done

theorem loop4_type: "\<lbrakk> R:(A*B)*C<~>De*(E*B) \<rbrakk> \<Longrightarrow> loop4(R):A*C<~>De*E"
apply(subst loop4_loop4'_iff, simp)
apply(unfold loop4'_def, typecheck add: inv_type loop2_type)
done

theorem loop4R:
  "\<lbrakk> A:ChTy; B:ChTy; C:ChTy; De:ChTy; E:ChTy;
    R:(A*B)*C<R>De*(E*B) \<rbrakk> \<Longrightarrow> loop4(R):A*C<R>De*E"
apply(subst loop4_loop4'_iff)
apply(frule rev_subsetD[of R], rule ruby_sub_sig, simp)
apply(unfold loop4'_def)
apply(intro RubyR loop2R[of _ B])
apply(((rule crossR | rule reorgR | rule invR), simp_all add: prod_in_chty)+)
apply(rule invR, rule reorgR, simp+)
done

theorem loop4_iff:
  "\<lbrakk> R:(A*B)*C<~>De*(E*B); a:sig(A'); c:sig(C'); d:sig(De'); e:sig(E') \<rbrakk>
    \<Longrightarrow> <<a#c>,<d#e>>:loop4(R) \<longleftrightarrow> (EX b:sig(B). <<<a#b>#c>,<d#<e#b>>>:R)"
apply(rule)
apply(unfold loop4_def loop4'_def)
apply(elim compE, typecheck add: loop2_type inv_type, simp_all)
apply(elim sig_pairE, simp)
apply(erule crossE, simp_all)
apply(erule loop2E, typecheck add: inv_type, simp_all)
apply(erule compE2, typecheck add: inv_type, simp_all)
apply(erule invE, typecheck)
apply(elim sig_pairE, simp, erule reorgE, simp_all)
apply(erule compE2, typecheck, simp)
apply(elim sig_pairE, simp)
apply(elim RubyE, typecheck)
apply(elim sig_pairE, simp, elim RubyE, simp_all)
apply(blast)
apply(erule bexE)
apply(intro RubyI)
apply(subgoal_tac "<<a#c>, <c#a>>:cross(domain(ddtyp(R)), rdtyp(R))", simp)
apply(rule crossI, simp_all add: typ_sigs)
apply(rule loop2I, typecheck add: inv_type, simp_all)
apply(subgoal_tac
      "\<langle><<c#a>#b>,<<d#e>#b>\<rangle> \<in>
            reorg(rdtyp(R), domain(ddtyp(R)), range(ddtyp(R))) ;;
            cross(rdtyp(R), domain(ddtyp(R)) \<times> range(ddtyp(R))) ;;
            R ;;
            reorg(drtyp(R), domain(rrtyp(R)), range(ddtyp(R)))~", simp)
apply(intro RubyI invI)
apply(subgoal_tac "\<langle><<c#a>#b>,<c#<a#b>>\<rangle> \<in> reorg(rdtyp(R), domain(ddtyp(R)), range(ddtyp(R)))", simp)
apply(rule reorgI, (simp add: typ_sigs)+)
apply(subgoal_tac "\<langle><c#<a#b>>,<<a#b>#c>\<rangle> \<in> cross(rdtyp(R), domain(ddtyp(R)) \<times> range(ddtyp(R)))", simp)
apply(rule crossI, (simp add: typ_sigs)+)
apply(typecheck, (simp add: typ_sigs)+)
apply(rule reorgI, simp_all add: typ_sigs)
done

theorem loop4I:
  "\<lbrakk> R:(A*B)*C<~>De*(E*B); a:sig(A'); b:sig(B); c:sig(C');
    d:sig(De'); e:sig(E'); <<<a#b>#c>,<d#<e#b>>>:R \<rbrakk>
    \<Longrightarrow> <<a#c>,<d#e>>:loop4(R)"
apply(drule loop4_iff[of _ _ _ _ _ _ a _ c _ d _ e], auto)
done

theorem loop4E:
  "\<lbrakk> <<a#c>,<d#e>>:loop4(R);
    R:(A*B)*C<~>De*(E*B); a:sig(A'); c:sig(C'); d:sig(De'); e:sig(E');
    \<And>b. \<lbrakk> b:sig(B); <<<a#b>#c>,<d#<e#b>>>:R \<rbrakk> \<Longrightarrow> P \<rbrakk>
    \<Longrightarrow> P"
apply(drule loop4_iff[of _ _ _ _ _ _ a _ c _ d _ e], auto)
done

lemmas SimpComb_type =
  inv_type Conj_type Fst_type Snd_type
  below_type below_type2 beside_type beside_type2 loop2_type loop4_type

lemmas Ruby_type = Ruby_type SimpComb_type

declare SimpComb_type [TC]

lemmas RubyR = RubyR
  invR ConjR FstR SndR belowR besideR loop2R loop4R

lemmas RubyI = RubyI
  invI ConjI FstI SndI belowI besideI loop2I loop4I

lemmas RubyE = RubyE
  invE ConjE FstE SndE belowE besideE loop2E loop4E

lemmas RubyE2 =
  compE2 belowE2 besideE2

end


(*  Title:      HOL/NanoJava/Equivalence.thy
    Author:     David von Oheimb
    Copyright   2001 Technische Universitaet Muenchen
*)

section "Equivalence of Operational and Axiomatic Semantics"

theory Equivalence imports OpSem AxSem begin

subsection "Validity"

definition valid :: "[assn,stmt, assn] => bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" [3,90,3] 60) where
 "\<Turnstile>  {P} c {Q} \<equiv> \<forall>s   t. P s --> (\<exists>n. s -c  -n\<rightarrow> t) --> Q   t"

definition evalid   :: "[assn,expr,vassn] => bool" ("\<Turnstile>\<^sub>e {(1_)}/ (_)/ {(1_)}" [3,90,3] 60) where
 "\<Turnstile>\<^sub>e {P} e {Q} \<equiv> \<forall>s v t. P s --> (\<exists>n. s -e\<succ>v-n\<rightarrow> t) --> Q v t"

definition nvalid   :: "[nat, triple    ] => bool" ("\<Turnstile>_: _" [61,61] 60) where
 "\<Turnstile>n:  t \<equiv> let (P,c,Q) = t in \<forall>s   t. s -c  -n\<rightarrow> t --> P s --> Q   t"

definition envalid   :: "[nat,etriple    ] => bool" ("\<Turnstile>_:\<^sub>e _" [61,61] 60) where
 "\<Turnstile>n:\<^sub>e t \<equiv> let (P,e,Q) = t in \<forall>s v t. s -e\<succ>v-n\<rightarrow> t --> P s --> Q v t"

definition nvalids :: "[nat,       triple set] => bool" ("|\<Turnstile>_: _" [61,61] 60) where
 "|\<Turnstile>n: T \<equiv> \<forall>t\<in>T. \<Turnstile>n: t"

definition cnvalids :: "[triple set,triple set] => bool" ("_ |\<Turnstile>/ _" [61,61] 60) where
 "A |\<Turnstile>  C \<equiv> \<forall>n. |\<Turnstile>n: A --> |\<Turnstile>n: C"

definition cenvalid  :: "[triple set,etriple   ] => bool" ("_ |\<Turnstile>\<^sub>e/ _"[61,61] 60) where
 "A |\<Turnstile>\<^sub>e t \<equiv> \<forall>n. |\<Turnstile>n: A --> \<Turnstile>n:\<^sub>e t"

lemma nvalid_def2: "\<Turnstile>n: (P,c,Q) \<equiv> \<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q t"
by (simp add: nvalid_def Let_def)

lemma valid_def2: "\<Turnstile> {P} c {Q} = (\<forall>n. \<Turnstile>n: (P,c,Q))"
apply (simp add: valid_def nvalid_def2)
apply blast
done

lemma envalid_def2: "\<Turnstile>n:\<^sub>e (P,e,Q) \<equiv> \<forall>s v t. s -e\<succ>v-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q v t"
by (simp add: envalid_def Let_def)

lemma evalid_def2: "\<Turnstile>\<^sub>e {P} e {Q} = (\<forall>n. \<Turnstile>n:\<^sub>e (P,e,Q))"
apply (simp add: evalid_def envalid_def2)
apply blast
done

lemma cenvalid_def2:
  "A|\<Turnstile>\<^sub>e (P,e,Q) = (\<forall>n. |\<Turnstile>n: A \<longrightarrow> (\<forall>s v t. s -e\<succ>v-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q v t))"
by(simp add: cenvalid_def envalid_def2)

subsection "Soundness"

declare exec_elim_cases [elim!] eval_elim_cases [elim!]

lemma Impl_nvalid_0: "\<Turnstile>0: (P,Impl M,Q)"
by (clarsimp simp add: nvalid_def2)

lemma Impl_nvalid_Suc: "\<Turnstile>n: (P,body M,Q) \<Longrightarrow> \<Turnstile>Suc n: (P,Impl M,Q)"
by (clarsimp simp add: nvalid_def2)

lemma nvalid_SucD: "\<And>t. \<Turnstile>Suc n:t \<Longrightarrow> \<Turnstile>n:t"
by (force simp add: split_paired_all nvalid_def2 intro: exec_mono)

lemma nvalids_SucD: "Ball A (nvalid (Suc n)) \<Longrightarrow>  Ball A (nvalid n)"
by (fast intro: nvalid_SucD)

lemma Loop_sound_lemma [rule_format (no_asm)]:
"\<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> P s \<and> s<x> \<noteq> Null \<longrightarrow> P t \<Longrightarrow>
  (s -c0-n0\<rightarrow> t \<longrightarrow> P s \<longrightarrow> c0 = While (x) c \<longrightarrow> n0 = n \<longrightarrow> P t \<and> t<x> = Null)"
apply (rule_tac ?P2.1="%s e v n t. True" in exec_eval.induct [THEN conjunct1])
apply clarsimp+
done

lemma Impl_sound_lemma:
"\<lbrakk>\<forall>z n. Ball (A \<union> B) (nvalid n) \<longrightarrow> Ball (f z ` Ms) (nvalid n);
  Cm\<in>Ms; Ball A (nvalid na); Ball B (nvalid na)\<rbrakk> \<Longrightarrow> nvalid na (f z Cm)"
by blast

lemma all_conjunct2: "\<forall>l. P' l \<and> P l \<Longrightarrow> \<forall>l. P l"
by fast

lemma all3_conjunct2:
  "\<forall>a p l. (P' a p l \<and> P a p l) \<Longrightarrow> \<forall>a p l. P a p l"
by fast

lemma cnvalid1_eq:
  "A |\<Turnstile> {(P,c,Q)} \<equiv> \<forall>n. |\<Turnstile>n: A \<longrightarrow> (\<forall>s t. s -c-n\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q t)"
by(simp add: cnvalids_def nvalids_def nvalid_def2)

lemma hoare_sound_main:"\<And>t. (A |\<turnstile> C \<longrightarrow> A |\<Turnstile> C) \<and> (A |\<turnstile>\<^sub>e t \<longrightarrow> A |\<Turnstile>\<^sub>e t)"
apply (tactic "split_all_tac \<^context> 1", rename_tac P e Q)
apply (rule hoare_ehoare.induct)
(*18*)
apply (tactic \<open>ALLGOALS (REPEAT o dresolve_tac \<^context> [@{thm all_conjunct2}, @{thm all3_conjunct2}])\<close>)
apply (tactic \<open>ALLGOALS (REPEAT o Rule_Insts.thin_tac \<^context> "hoare _ _" [])\<close>)
apply (tactic \<open>ALLGOALS (REPEAT o Rule_Insts.thin_tac \<^context> "ehoare _ _" [])\<close>)
apply (simp_all only: cnvalid1_eq cenvalid_def2)
                 apply fast
                apply fast
               apply fast
              apply (clarify,tactic "smp_tac \<^context> 1 1",erule(2) Loop_sound_lemma,(rule HOL.refl)+)
             apply fast
            apply fast
           apply fast
          apply fast
         apply fast
        apply fast
       apply (clarsimp del: Meth_elim_cases) (* Call *)
      apply (force del: Impl_elim_cases)
     defer
     prefer 4 apply blast (*  Conseq *)
    prefer 4 apply blast (* eConseq *)
   apply (simp_all (no_asm_use) only: cnvalids_def nvalids_def)
   apply blast
  apply blast
 apply blast
apply (rule allI)
apply (rule_tac x=Z in spec)
apply (induct_tac "n")
 apply  (clarify intro!: Impl_nvalid_0)
apply (clarify  intro!: Impl_nvalid_Suc)
apply (drule nvalids_SucD)
apply (simp only: HOL.all_simps)
apply (erule (1) impE)
apply (drule (2) Impl_sound_lemma)
 apply  blast
apply assumption
done

theorem ehoare_sound: "{} \<turnstile>\<^sub>e {P} e {Q} \<Longrightarrow> \<Turnstile>\<^sub>e {P} e {Q}"
apply (simp only: evalid_def2)
apply (drule hoare_sound_main [THEN conjunct2, rule_format])
apply (unfold cenvalid_def nvalids_def)
apply fast
done

subsection "(Relative) Completeness"

definition MGT :: "stmt => state => triple" where
         "MGT  c Z \<equiv> (\<lambda>s. Z = s, c, \<lambda>  t. \<exists>n. Z -c-  n\<rightarrow> t)"

definition MGT\<^sub>e   :: "expr => state => etriple" where
         "MGT\<^sub>e e Z \<equiv> (\<lambda>s. Z = s, e, \<lambda>v t. \<exists>n. Z -e\<succ>v-n\<rightarrow> t)"

lemma MGF_implies_complete:
 "\<forall>Z. {} |\<turnstile> { MGT c Z} \<Longrightarrow> \<Turnstile>  {P} c {Q} \<Longrightarrow> {} \<turnstile>  {P} c {Q}"
apply (simp only: valid_def2)
apply (unfold MGT_def)
apply (erule hoare_ehoare.Conseq)
apply (clarsimp simp add: nvalid_def2)
done

lemma eMGF_implies_complete:
 "\<forall>Z. {} |\<turnstile>\<^sub>e MGT\<^sub>e e Z \<Longrightarrow> \<Turnstile>\<^sub>e {P} e {Q} \<Longrightarrow> {} \<turnstile>\<^sub>e {P} e {Q}"
apply (simp only: evalid_def2)
apply (unfold MGT\<^sub>e_def)
apply (erule hoare_ehoare.eConseq)
apply (clarsimp simp add: envalid_def2)
done

declare exec_eval.intros[intro!]

lemma MGF_Loop: "\<forall>Z. A \<turnstile> {(=) Z} c {\<lambda>t. \<exists>n. Z -c-n\<rightarrow> t} \<Longrightarrow>
  A \<turnstile> {(=) Z} While (x) c {\<lambda>t. \<exists>n. Z -While (x) c-n\<rightarrow> t}"
apply (rule_tac P' = "\<lambda>Z s. (Z,s) \<in> ({(s,t). \<exists>n. s<x> \<noteq> Null \<and> s -c-n\<rightarrow> t})\<^sup>*"
       in hoare_ehoare.Conseq)
apply  (rule allI)
apply  (rule hoare_ehoare.Loop)
apply  (erule hoare_ehoare.Conseq)
apply  clarsimp
apply  (blast intro:rtrancl_into_rtrancl)
apply (erule thin_rl)
apply clarsimp
apply (erule_tac x = Z in allE)
apply clarsimp
apply (erule converse_rtrancl_induct)
apply  blast
apply clarsimp
apply (drule (1) exec_exec_max)
apply (blast del: exec_elim_cases)
done

lemma MGF_lemma: "\<forall>M Z. A |\<turnstile> {MGT (Impl M) Z} \<Longrightarrow>
 (\<forall>Z. A |\<turnstile> {MGT c Z}) \<and> (\<forall>Z. A |\<turnstile>\<^sub>e MGT\<^sub>e e Z)"
apply (simp add: MGT_def MGT\<^sub>e_def)
apply (rule stmt_expr.induct)
apply (rule_tac [!] allI)

apply (rule Conseq1 [OF hoare_ehoare.Skip])
apply blast

apply (rule hoare_ehoare.Comp)
apply  (erule spec)
apply (erule hoare_ehoare.Conseq)
apply clarsimp
apply (drule (1) exec_exec_max)
apply blast

apply (erule thin_rl)
apply (rule hoare_ehoare.Cond)
apply  (erule spec)
apply (rule allI)
apply (simp)
apply (rule conjI)
apply  (rule impI, erule hoare_ehoare.Conseq, clarsimp, drule (1) eval_exec_max,
        erule thin_rl, erule thin_rl, force)+

apply (erule MGF_Loop)

apply (erule hoare_ehoare.eConseq [THEN hoare_ehoare.LAss])
apply fast

apply (erule thin_rl)
apply (rename_tac expr1 u v Z, rule_tac Q = "\<lambda>a s. \<exists>n. Z -expr1\<succ>Addr a-n\<rightarrow> s" in hoare_ehoare.FAss)
apply  (drule spec)
apply  (erule eConseq2)
apply  fast
apply (rule allI)
apply (erule hoare_ehoare.eConseq)
apply clarsimp
apply (drule (1) eval_eval_max)
apply blast

apply (simp only: split_paired_all)
apply (rule hoare_ehoare.Meth)
apply (rule allI)
apply (drule spec, drule spec, erule hoare_ehoare.Conseq)
apply blast

apply (simp add: split_paired_all)

apply (rule eConseq1 [OF hoare_ehoare.NewC])
apply blast

apply (erule hoare_ehoare.eConseq [THEN hoare_ehoare.Cast])
apply fast

apply (rule eConseq1 [OF hoare_ehoare.LAcc])
apply blast

apply (erule hoare_ehoare.eConseq [THEN hoare_ehoare.FAcc])
apply fast

apply (rename_tac expr1 u expr2 Z)
apply (rule_tac R = "\<lambda>a v s. \<exists>n1 n2 t. Z -expr1\<succ>a-n1\<rightarrow> t \<and> t -expr2\<succ>v-n2\<rightarrow> s" in
                hoare_ehoare.Call)
apply   (erule spec)
apply  (rule allI)
apply  (erule hoare_ehoare.eConseq)
apply  clarsimp
apply  blast
apply (rule allI)+
apply (rule hoare_ehoare.Meth)
apply (rule allI)
apply (drule spec, drule spec, erule hoare_ehoare.Conseq)
apply (erule thin_rl, erule thin_rl)
apply (clarsimp del: Impl_elim_cases)
apply (drule (2) eval_eval_exec_max)
apply (force del: Impl_elim_cases)
done

lemma MGF_Impl: "{} |\<turnstile> {MGT (Impl M) Z}"
apply (unfold MGT_def)
apply (rule Impl1')
apply  (rule_tac [2] UNIV_I)
apply clarsimp
apply (rule hoare_ehoare.ConjI)
apply clarsimp
apply (rule ssubst [OF Impl_body_eq])
apply (fold MGT_def)
apply (rule MGF_lemma [THEN conjunct1, rule_format])
apply (rule hoare_ehoare.Asm)
apply force
done

theorem hoare_relative_complete: "\<Turnstile> {P} c {Q} \<Longrightarrow> {} \<turnstile> {P} c {Q}"
apply (rule MGF_implies_complete)
apply  (erule_tac [2] asm_rl)
apply (rule allI)
apply (rule MGF_lemma [THEN conjunct1, rule_format])
apply (rule MGF_Impl)
done

theorem ehoare_relative_complete: "\<Turnstile>\<^sub>e {P} e {Q} \<Longrightarrow> {} \<turnstile>\<^sub>e {P} e {Q}"
apply (rule eMGF_implies_complete)
apply  (erule_tac [2] asm_rl)
apply (rule allI)
apply (rule MGF_lemma [THEN conjunct2, rule_format])
apply (rule MGF_Impl)
done

lemma cFalse: "A \<turnstile> {\<lambda>s. False} c {Q}"
apply (rule cThin)
apply (rule hoare_relative_complete)
apply (auto simp add: valid_def)
done

lemma eFalse: "A \<turnstile>\<^sub>e {\<lambda>s. False} e {Q}"
apply (rule eThin)
apply (rule ehoare_relative_complete)
apply (auto simp add: evalid_def)
done

end


subsection "Termination-Sensitive Systems"

theory ConcreteSemantics9_2_Sec_TypingT
  imports Main "~~/src/HOL/IMP/Sec_Type_Expr"
begin

subsubsection "A Syntax Directed System"

inductive sec_type :: "nat \<Rightarrow> com \<Rightarrow> bool" ("(_/ \<turnstile> _)" [0,0] 50) where
Skip:
  "l \<turnstile> SKIP"  |
Assign:
  "\<lbrakk> sec x \<ge> sec a;  sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile> x ::= a"  |
Seq:
  "l \<turnstile> c\<^sub>1 \<Longrightarrow> l \<turnstile> c\<^sub>2 \<Longrightarrow> l \<turnstile> c\<^sub>1;;c\<^sub>2"  |
If:
  "\<lbrakk> max (sec b) l \<turnstile> c\<^sub>1;  max (sec b) l \<turnstile> c\<^sub>2 \<rbrakk>
   \<Longrightarrow> l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"  |
While:
  "sec b = 0 \<Longrightarrow> 0 \<turnstile> c \<Longrightarrow> 0 \<turnstile> WHILE b DO c"

code_pred (expected_modes: i => i => bool) sec_type .

inductive_cases [elim!]:
  "l \<turnstile> x ::= a"  "l \<turnstile> c\<^sub>1;;c\<^sub>2"  "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"  "l \<turnstile> WHILE b DO c"

(* Lemma 9.19 (Anti-monotonicity). *)
lemma anti_mono: "l \<turnstile> c \<Longrightarrow> l' \<le> l \<Longrightarrow> l' \<turnstile> c"
  apply(induction arbitrary: l' rule:sec_type.induct)
      apply(simp add: Skip)
     apply(simp add: Assign)
    apply(simp add: Seq)
   apply (simp add: If)
  by(simp add: While)

(* Lemma 9.20 (Confinement). *)
lemma confinement: "(c,s) \<Rightarrow> t \<Longrightarrow> l \<turnstile> c \<Longrightarrow> s = t (< l)"
proof(induction rule: big_step_induct)
  case (Skip s)
  then show ?case by simp
next
  case (Assign x a s)
  then show ?case by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by auto
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then have "max (sec b) l \<turnstile> c\<^sub>1" by blast
  then have "l \<turnstile> c\<^sub>1"
    using anti_mono max.cobounded2 by blast
  then show ?case
    by (simp add: IfTrue.IH)
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then have "max (sec b) l \<turnstile> c\<^sub>2" by blast
  then have "l \<turnstile> c\<^sub>2"
    using anti_mono max.cobounded2 by blast
  then show ?case
    by (simp add: IfFalse.IH)
(*    by (smt anti_mono com.distinct(11) com.distinct(15) com.distinct(19) com.distinct(5) com.inject(3) max.orderI max_def sec_type.simps)*)
next
  case (WhileFalse b s c)
  then show ?case by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case by auto
qed

(* Lemma 9.21 (Termination). *)
lemma termi_if_non0: "l \<turnstile> c \<Longrightarrow> l \<noteq> 0 \<Longrightarrow> \<exists> t. (c,s) \<Rightarrow> t"
  apply(induction arbitrary: s rule: sec_type.induct)
      apply(simp add: big_step.Skip)
  apply auto
   apply blast
  by (metis IfFalse IfTrue max.commute max.strict_coboundedI1)

(* Theorem 9.22 (Noninterference). *)
theorem noninterference: "(c,s) \<Rightarrow> s' \<Longrightarrow> 0 \<turnstile> c \<Longrightarrow>  s = t (\<le> l)
  \<Longrightarrow> \<exists> t'. (c,t) \<Rightarrow> t' \<and> s' = t' (\<le> l)"
proof(induction arbitrary: t rule: big_step_induct)
case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  have "sec a \<le> sec x" using \<open>0 \<turnstile> x ::= a\<close> by auto
  have "(x ::= a, t) \<Rightarrow> t(x := aval a t)" using Assign by auto
  moreover
  have "s(x := aval a s) = t(x := aval a t) (\<le> l)"
    using Assign.prems(2) \<open>sec a \<le> sec x\<close> aval_eq_if_eq_le by auto
  then show ?case
    by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by blast
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
(*    bval b s
    (c\<^sub>1, s) \<Rightarrow> s'
    0 \<turnstile> c\<^sub>1 \<Longrightarrow> s = ?t (\<le> l) \<Longrightarrow> \<exists>t'. (c\<^sub>1, ?t) \<Rightarrow> t' \<and> s' = t' (\<le> l)
    0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2
    s = t (\<le> l)*)
  have "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  obtain t' where t': "(c\<^sub>1, t) \<Rightarrow> t'" "s' = t' (\<le> l)"
    using IfTrue.IH[OF anti_mono[OF \<open>sec b \<turnstile> c\<^sub>1\<close>] \<open>s = t (\<le> l)\<close>] by blast
  show ?case
  proof cases
    assume "sec b \<le> l"
(*\<exists>t'. (IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<Rightarrow> t' \<and> ta__ = t' (\<le> l)*)
    then have "s = t (\<le> sec b)"
      using IfTrue.prems(2) dual_order.trans by blast
    hence "bval b t"
      using IfTrue.hyps(1) bval_eq_if_eq_le by auto
    then show ?thesis
      using t'(1) t'(2) by blast
  next
    assume "\<not> sec b \<le> l"
(*\<exists>t'. (IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<Rightarrow> t' \<and> ta__ = t' (\<le> l)*)
    then have 0: "sec b \<noteq> 0"
      using \<open>\<not> sec b \<le> l\<close> by auto
    have 1: "sec b \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
      by (simp add: If \<open>sec b \<turnstile> c\<^sub>1\<close> \<open>sec b \<turnstile> c\<^sub>2\<close>)
    from confinement[OF big_step.IfTrue[OF IfTrue(1,2)] 1] \<open>\<not> sec b \<le> l\<close>
    have "s = s'(\<le> l)" by auto
    (* we first have to show that the second execution terminates,*)
    moreover obtain t' where t' : "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<Rightarrow> t'"
      by (meson "0" "1" termi_if_non0)
    moreover have "t = t' (\<le> l)"
      using "1" \<open>\<not> sec b \<le> l\<close> confinement t' by auto
(*      using "1" \<open>\<not> sec b \<le> l\<close> confinement by auto*)
    ultimately show ?thesis
      using IfTrue.prems(2) by auto
  qed
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
(*    \<not> bval b s
    (c\<^sub>2, s) \<Rightarrow> ta__
    0 \<turnstile> c\<^sub>2 \<Longrightarrow> s = ?t (\<le> l) \<Longrightarrow> \<exists>t'. (c\<^sub>2, ?t) \<Rightarrow> t' \<and> ta__ = t' (\<le> l)
    0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2
    s = t (\<le> l)*)
  have "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  obtain t' where t': "(c\<^sub>2, t) \<Rightarrow> t'" "s' = t' (\<le> l)"
    using IfFalse.IH[OF anti_mono[OF \<open>sec b \<turnstile> c\<^sub>2\<close>] \<open>s = t (\<le> l)\<close>] by blast
  show ?case
  proof cases
    assume "sec b \<le> l"
(*\<exists>t'. (IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<Rightarrow> t' \<and> ta__ = t' (\<le> l)*)
    then have "s = t (\<le> sec b)"
      using IfFalse.prems(2) dual_order.trans by blast
    hence "\<not> bval b t"
      using IfFalse.hyps(1) bval_eq_if_eq_le by auto
    then show ?thesis
      using t'(1) t'(2) by blast
  next
    assume "\<not> sec b \<le> l"
(*\<exists>t'. (IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<Rightarrow> t' \<and> ta__ = t' (\<le> l)*)
    then have 0: "sec b \<noteq> 0"
      using \<open>\<not> sec b \<le> l\<close> by auto
    have 1: "sec b \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
      by (simp add: If \<open>sec b \<turnstile> c\<^sub>1\<close> \<open>sec b \<turnstile> c\<^sub>2\<close>)
    from confinement[OF big_step.IfFalse[OF IfFalse(1,2)] 1] \<open>\<not> sec b \<le> l\<close>
    have "s = s'(\<le> l)" by auto
    (* we first have to show that the second execution terminates,*)
    moreover obtain t' where t' : "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<Rightarrow> t'"
      by (meson "0" "1" termi_if_non0)
    moreover have "t = t' (\<le> l)"
      using "1" \<open>\<not> sec b \<le> l\<close> confinement t' by auto
(*      using "1" \<open>\<not> sec b \<le> l\<close> confinement by auto*)
    ultimately show ?thesis
      using IfFalse.prems(2) by auto
  qed
next
  case (WhileFalse b s c)
(*  \<not> bval b s
    0 \<turnstile> WHILE b DO c
    s = t (\<le> l)*)
  then have [simp]: "sec b = 0" by auto
  then have "s = t (\<le> l)"
    by (simp add: WhileFalse.prems(2))
  then have "\<not> bval b t"
    using WhileFalse.hyps bval_eq_if_eq_le by auto
  then show ?case
    using WhileFalse.prems(2) by blast
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
(*
this:
    bval b s\<^sub>1
    (c, s\<^sub>1) \<Rightarrow> s\<^sub>2
    (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3
    0 \<turnstile> c \<Longrightarrow> s\<^sub>1 = ?t (\<le> l) \<Longrightarrow> \<exists>t'. (c, ?t) \<Rightarrow> t' \<and> s\<^sub>2 = t' (\<le> l)
    0 \<turnstile> WHILE b DO c \<Longrightarrow> s\<^sub>2 = ?t (\<le> l) \<Longrightarrow> \<exists>t'. (WHILE b DO c, ?t) \<Rightarrow> t' \<and> s\<^sub>3 = t' (\<le> l)
    0 \<turnstile> WHILE b DO c
    s\<^sub>1 = t (\<le> l)

goal (1 subgoal):
 1. \<And>b s\<^sub>1 c s\<^sub>2 s\<^sub>3 t.
       bval b s\<^sub>1 \<Longrightarrow>
       (c, s\<^sub>1) \<Rightarrow> s\<^sub>2 \<Longrightarrow>
       (\<And>t. 0 \<turnstile> c \<Longrightarrow> s\<^sub>1 = t (\<le> l) \<Longrightarrow> \<exists>t'. (c, t) \<Rightarrow> t' \<and> s\<^sub>2 = t' (\<le> l)) \<Longrightarrow>
       (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<Longrightarrow>
       (\<And>t. 0 \<turnstile> WHILE b DO c \<Longrightarrow> s\<^sub>2 = t (\<le> l) \<Longrightarrow> \<exists>t'. (WHILE b DO c, t) \<Rightarrow> t' \<and> s\<^sub>3 = t' (\<le> l)) \<Longrightarrow>
       0 \<turnstile> WHILE b DO c \<Longrightarrow> s\<^sub>1 = t (\<le> l) \<Longrightarrow> \<exists>t'. (WHILE b DO c, t) \<Rightarrow> t' \<and> s\<^sub>3 = t' (\<le> l)
*)
  let ?w = "WHILE b DO c"
  from \<open>0 \<turnstile> ?w\<close> have [simp]: "sec b = 0" by auto
  have "0 \<turnstile> c"
    using WhileTrue.prems(1) by blast
  obtain t'' where t'': "(c, t) \<Rightarrow> t''"  and "s\<^sub>2 = t'' (\<le> l)"
    using WhileTrue.IH(1) WhileTrue.prems(2) \<open>0 \<turnstile> c\<close> by blast
  obtain t' where t' : "(?w, t'') \<Rightarrow> t'" and "s\<^sub>3 = t'(\<le> l)"
    by (meson WhileTrue.IH(2) WhileTrue.prems(1) \<open>s\<^sub>2 = t'' (\<le> l)\<close>)
  have "bval b t"
    using WhileTrue.hyps(1) WhileTrue.prems(2) bval_eq_if_eq_le by auto
  then show ?case
    using \<open>s\<^sub>3 = t' (\<le> l)\<close> t' t'' by blast
qed

subsubsection "The Standard System"

text\<open>The predicate \<^prop>\<open>l \<turnstile> c\<close> is nicely intuitive and executable. The
standard formulation, however, is slightly different, replacing the maximum
computation by an antimonotonicity rule. We introduce the standard system now
and show the equivalence with our formulation.\<close>

inductive sec_type' :: "nat \<Rightarrow> com \<Rightarrow> bool" ("(_/ \<turnstile>'' _)" [0,0] 50) where
Skip':
  "l \<turnstile>' SKIP"  |
Assign':
  "\<lbrakk> sec x \<ge> sec a;  sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile>' x ::= a"  |
Seq':
  "l \<turnstile>' c\<^sub>1 \<Longrightarrow> l \<turnstile>' c\<^sub>2 \<Longrightarrow> l \<turnstile>' c\<^sub>1;;c\<^sub>2"  |
If':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2"  |
While':
  "\<lbrakk> sec b = 0;  0 \<turnstile>' c \<rbrakk> \<Longrightarrow> 0 \<turnstile>' WHILE b DO c"  |
anti_mono':
  "\<lbrakk> l \<turnstile>' c;  l' \<le> l \<rbrakk> \<Longrightarrow> l' \<turnstile>' c"

(* Lemma 9.23 (Equivalence to standard formulation). *)
lemma sec_type_sec_type':
  "l \<turnstile> c \<Longrightarrow> l \<turnstile>' c"
  apply (induction rule: sec_type.induct)
  apply (simp add: Skip')
     apply (simp add: Assign')
    apply (simp add: Seq')
   apply (meson If' anti_mono' max.cobounded1 max.cobounded2)
  by (simp add: While')

lemma sec_type'_sec_type:
  "l \<turnstile>' c \<Longrightarrow> l \<turnstile> c"
  apply (induction rule: sec_type'.induct)
  apply (simp add: Skip)
     apply (simp add: Assign)
    apply (simp add: Seq)
  apply (simp add: If max_def)
   apply (simp add: While)
  using anti_mono by blast

corollary sec_type_eq: "l \<turnstile> c \<longleftrightarrow> l \<turnstile>' c"
  using sec_type'_sec_type sec_type_sec_type' by blast

end


section\<open>Theory of Events for Security Protocols that use smartcards\<close>

theory EventSC
imports
  "../Message"
  "~~/src/HOL/Library/Simps_Case_Conv"
begin

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent => msg set"

datatype card = Card agent

text\<open>Four new events express the traffic between an agent and his card\<close>
datatype
  event = Says  agent agent msg
        | Notes agent       msg
        | Gets  agent       msg
        | Inputs agent card msg (*Agent sends to card and\<dots>*)
        | C_Gets card       msg (*\<dots> card receives it*)
        | Outpts card agent msg (*Card sends to agent and\<dots>*)
        | A_Gets agent      msg (*agent receives it*)

consts
 bad     :: "agent set"  (*compromised agents*)
 stolen    :: "card set" (* stolen smart cards *)
 cloned  :: "card set"   (* cloned smart cards*)
 secureM :: "bool"(*assumption of secure means between agents and their cards*)

abbreviation
  insecureM :: bool where (*certain protocols make no assumption of secure means*)
  "insecureM == \<not>secureM"

text\<open>Spy has access to his own key for spoof messages, but Server is secure\<close>
specification (bad)
  Spy_in_bad     [iff]: "Spy \<in> bad"
  Server_not_bad [iff]: "Server \<notin> bad"
  apply (rule exI [of _ "{Spy}"], simp) done

specification (stolen)
  (*The server's card is secure by assumption\<dots>*)
  Card_Server_not_stolen [iff]: "Card Server \<notin> stolen"
  Card_Spy_not_stolen    [iff]: "Card Spy \<notin> stolen"
  apply blast done

specification (cloned)
  (*\<dots> the spy's card is secure because she already can use it freely*)
  Card_Server_not_cloned [iff]: "Card Server \<notin> cloned"
  Card_Spy_not_cloned    [iff]: "Card Spy \<notin> cloned"
  apply blast done

primrec (*This definition is extended over the new events, subject to the
          assumption of secure means*)
  knows   :: "agent => event list => msg set" (*agents' knowledge*) where
  knows_Nil:   "knows A [] = initState A" |
  knows_Cons:  "knows A (ev # evs) =
         (case ev of
            Says A' B X =>
                if (A=A' | A=Spy) then insert X (knows A evs) else knows A evs
          | Notes A' X  =>
                if (A=A' | (A=Spy & A'\<in>bad)) then insert X (knows A evs)
                                             else knows A evs
          | Gets A' X   =>
                if (A=A' & A \<noteq> Spy) then insert X (knows A evs)
                                     else knows A evs
          | Inputs A' C X =>
              if secureM then
                if A=A' then insert X (knows A evs) else knows A evs
              else
                if (A=A' | A=Spy) then insert X (knows A evs) else knows A evs
          | C_Gets C X   => knows A evs
          | Outpts C A' X =>
              if secureM then
                if A=A' then insert X (knows A evs) else knows A evs
              else
                if A=Spy then insert X (knows A evs) else knows A evs
          | A_Gets A' X   =>
                if (A=A' & A \<noteq> Spy) then insert X (knows A evs)
                                     else knows A evs)"

primrec
  (*The set of items that might be visible to someone is easily extended
    over the new events*)
  used :: "event list => msg set" where
  used_Nil:   "used []         = (UN B. parts (initState B))" |
  used_Cons:  "used (ev # evs) =
                 (case ev of
                    Says A B X => parts {X} \<union> (used evs)
                  | Notes A X  => parts {X} \<union> (used evs)
                  | Gets A X   => used evs
                  | Inputs A C X  => parts{X} \<union> (used evs)
                  | C_Gets C X   => used evs
                  | Outpts C A X  => parts{X} \<union> (used evs)
                  | A_Gets A X   => used evs)"
    \<comment>\<open>@{term Gets} always follows @{term Says} in real protocols.
       Likewise, @{term C_Gets} will always have to follow @{term Inputs}
       and @{term A_Gets} will always have to follow @{term Outpts}\<close>

lemma Notes_imp_used [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma MPair_used [rule_format]:
     "MPair X Y \<in> used evs \<longrightarrow> X \<in> used evs & Y \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

subsection\<open>Function @{term knows}\<close>

(*Simplifying
 parts(insert X (knows Spy evs)) = parts{X} \<union> parts(knows Spy evs).
  This version won't loop with the simplifier.*)
lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

text\<open>Letting the Spy see "bad" agents' notes avoids redundant case-splits
      on whether @{term "A=Spy"} and whether @{term "A\<in>bad"}\<close>
lemma knows_Spy_Notes [simp]:
     "knows Spy (Notes A X # evs) =
          (if A\<in>bad then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Gets [simp]: "knows Spy (Gets A X # evs) = knows Spy evs"
by simp

lemma knows_Spy_Inputs_secureM [simp]:
     "secureM \<Longrightarrow> knows Spy (Inputs A C X # evs) =
        (if A=Spy then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Inputs_insecureM [simp]:
     "insecureM \<Longrightarrow> knows Spy (Inputs A C X # evs) = insert X (knows Spy evs)"
by simp

lemma knows_Spy_C_Gets [simp]: "knows Spy (C_Gets C X # evs) = knows Spy evs"
by simp

lemma knows_Spy_Outpts_secureM [simp]:
      "secureM \<Longrightarrow> knows Spy (Outpts C A X # evs) =
         (if A=Spy then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Outpts_insecureM [simp]:
      "insecureM \<Longrightarrow> knows Spy (Outpts C A X # evs) = insert X (knows Spy evs)"
by simp

lemma knows_Spy_A_Gets [simp]: "knows Spy (A_Gets A X # evs) = knows Spy evs"
by simp

lemma knows_Spy_subset_knows_Spy_Says:
     "knows Spy evs \<subseteq> knows Spy (Says A B X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Notes:
     "knows Spy evs \<subseteq> knows Spy (Notes A X # evs)"
by force

lemma knows_Spy_subset_knows_Spy_Gets:
     "knows Spy evs \<subseteq> knows Spy (Gets A X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Inputs:
     "knows Spy evs \<subseteq> knows Spy (Inputs A C X # evs)"
by auto

lemma knows_Spy_equals_knows_Spy_Gets:
     "knows Spy evs = knows Spy (C_Gets C X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Outpts: "knows Spy evs \<subseteq> knows Spy (Outpts C A X # evs)"
by auto

lemma knows_Spy_subset_knows_Spy_A_Gets: "knows Spy evs \<subseteq> knows Spy (A_Gets A X # evs)"
by (simp add: subset_insertI)

text\<open>Spy sees what is sent on the traffic\<close>
lemma Says_imp_knows_Spy [rule_format]:
     "Says A B X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Notes_imp_knows_Spy [rule_format]:
     "Notes A X \<in> set evs \<longrightarrow> A\<in> bad \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Nothing can be stated on a Gets event*)

lemma Inputs_imp_knows_Spy_secureM [rule_format (no_asm)]:
     "Inputs Spy C X \<in> set evs \<longrightarrow> secureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Inputs_imp_knows_Spy_insecureM [rule_format (no_asm)]:
     "Inputs A C X \<in> set evs \<longrightarrow> insecureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Nothing can be stated on a C_Gets event*)

lemma Outpts_imp_knows_Spy_secureM [rule_format (no_asm)]:
     "Outpts C Spy X \<in> set evs \<longrightarrow> secureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Outpts_imp_knows_Spy_insecureM [rule_format (no_asm)]:
     "Outpts C A X \<in> set evs \<longrightarrow> insecureM \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Nothing can be stated on an A_Gets event*)

text\<open>Elimination rules: derive contradictions from old Says events containing
  items known to be fresh\<close>
lemmas knows_Spy_partsEs =
     Says_imp_knows_Spy [THEN parts.Inj, elim_format]
     parts.Body [elim_format]

subsection\<open>Knowledge of Agents\<close>

lemma knows_Inputs: "knows A (Inputs A C X # evs) = insert X (knows A evs)"
by simp

lemma knows_C_Gets: "knows A (C_Gets C X # evs) = knows A evs"
by simp

lemma knows_Outpts_secureM:
      "secureM \<longrightarrow> knows A (Outpts C A X # evs) = insert X (knows A evs)"
by simp

lemma knows_Outpts_insecureM:
      "insecureM \<longrightarrow> knows Spy (Outpts C A X # evs) = insert X (knows Spy evs)"
by simp
(*somewhat equivalent to knows_Spy_Outpts_insecureM*)

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Inputs: "knows A evs \<subseteq> knows A (Inputs A' C X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_C_Gets: "knows A evs \<subseteq> knows A (C_Gets C X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Outpts: "knows A evs \<subseteq> knows A (Outpts C A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_A_Gets: "knows A evs \<subseteq> knows A (A_Gets A' X # evs)"
by (simp add: subset_insertI)

text\<open>Agents know what they say\<close>
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they note\<close>
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they receive\<close>
lemma Gets_imp_knows_agents [rule_format]:
     "A \<noteq> Spy \<longrightarrow> Gets A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*Agents know what they input to their smart card*)
lemma Inputs_imp_knows_agents [rule_format (no_asm)]:
     "Inputs A (Card A) X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

(*Nothing to prove about C_Gets*)

(*Agents know what they obtain as output of their smart card,
  if the means is secure...*)
lemma Outpts_imp_knows_agents_secureM [rule_format (no_asm)]:
     "secureM \<longrightarrow> Outpts (Card A) A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*otherwise only the spy knows the outputs*)
lemma Outpts_imp_knows_agents_insecureM [rule_format (no_asm)]:
      "insecureM \<longrightarrow> Outpts (Card A) A X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

(*end lemmas about agents' knowledge*)

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A add: event.split, blast)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) \<Longrightarrow> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split: event.split, blast)
done

simps_of_case used_Cons_simps[simp]: used_Cons

lemma used_nil_subset: "used [] \<subseteq> used evs"
apply simp
apply (blast intro: initState_into_used)
done

(*Novel lemmas*)
lemma Says_parts_used [rule_format (no_asm)]:
     "Says A B X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma Notes_parts_used [rule_format (no_asm)]:
     "Notes A X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma Outpts_parts_used [rule_format (no_asm)]:
     "Outpts C A X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma Inputs_parts_used [rule_format (no_asm)]:
     "Inputs A C X \<in> set evs \<longrightarrow> (parts  {X}) \<subseteq> used evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>NOTE REMOVAL--laws above are cleaner, as they don't involve "case"\<close>
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (cases e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

text\<open>For proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "\<lbrakk> K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) \<rbrakk>
      \<Longrightarrow> K \<in> keysFor (parts (G \<union> H)) \<or> Key (invKey K) \<in> parts H"
by (force
    dest!: parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
           analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
    intro: analz_subset_parts [THEN subsetD] parts_mono [THEN [2] rev_subsetD])

end