(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

theory utp_rec_total
  imports  "../AlgebraicLaws/Algebraic_Laws"
begin
text {*The following lemma explains the intuition behind lifting operators from predicates to relations.
       While in relational setting both, input and output state are evaluated. A predicate
       evaluate only on a single state. To unify predicates and relations such a lifting is necessary.
       This gives a way to express Hoare logic in relational calculus.*}

lemma "\<lbrakk>\<lceil>p\<rceil>\<^sub><\<Rightarrow> \<lceil>q\<rceil>\<^sub>>\<rbrakk>\<^sub>e (s,s') = (\<lbrakk>\<lceil>p\<rceil>\<^sub><\<rbrakk>\<^sub>e(s,UNIV) \<longrightarrow> \<lbrakk>\<lceil>q\<rceil>\<^sub>>\<rbrakk>\<^sub>e (UNIV, s'))"
  by rel_auto

section {*Noetherian induction instantiation*}

(*The following generalization was used by Tobias Nipkow in .. and Peter Lammich  in Refine_Monadic*)

lemma  wf_fixp_uinduct_pure_ueq_gen:
  assumes fixp_unfold: "fp F = F (fp F)"
  and              WF: "wf R"
  and     induct_step:
          "\<And>f st. \<lbrakk>\<And>st'. (st',st) \<in>R  \<Longrightarrow> (\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st'\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> f\<rbrakk>
               \<Longrightarrow> fp F = f \<Longrightarrow>(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> (F f)"
        shows "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> fp F"
 proof -
   { fix st
    have "(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> (fp F)"
      using WF
      apply (induction rule: wf_induct_rule)
      apply (subst fixp_unfold)
      apply (rule induct_step)
      apply blast
      apply simp
      done
     }
    thus ?thesis
    by pred_simp
qed

text {*The next lemma shows that using substitution also work. However it is not that generic
       nor practical for proof automation ...*}

lemma refine_usubst_to_ueq:
  "vwb_lens e \<Longrightarrow>(p \<Rightarrow> q)\<lbrakk>\<guillemotleft>st'\<guillemotright>/$e\<rbrakk> \<sqsubseteq> f\<lbrakk>\<guillemotleft>st'\<guillemotright>/$e\<rbrakk> = (((p \<and> $e =\<^sub>u \<guillemotleft>st'\<guillemotright>) \<Rightarrow> q) \<sqsubseteq> f)"
  apply rel_auto
  apply (metis vwb_lens_wb wb_lens.get_put)
done

text {*By instantiation of @{thm wf_fixp_uinduct_pure_ueq_gen} with @{term \<mu>}and lifting of the
       well-founded relation we have ...*}

lemma  mu_rec_total_pure_rule:
  assumes WF: "wf R"
    and     M: "mono F"
    and     induct_step:
    "\<And> f st. \<lbrakk>(\<lceil>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> f\<rbrakk> \<Longrightarrow> \<mu> F = f \<Longrightarrow>(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> (F f)"
  shows "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> \<mu> F"
proof (induction rule:  wf_fixp_uinduct_pure_ueq_gen[where fp=\<mu> and p=p and F=F and e = e and R = R])
  case 1
  then show ?case using M by (rule gfp_unfold)
next
  case 2
  then show ?case using WF .
next
  case (3 f st)
  then show ?case
    apply hypsubst
    apply (rule induct_step)
     apply pred_simp+
    done
qed

text {*Since @{term "F (p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright> \<Rightarrow> q) \<sqsubseteq> F (\<mu> F)"} and
      @{term "mono F"}, thus,  @{thm mu_rec_total_pure_rule} can be expressed as follows*}

lemma mu_rec_total_utp_rule:
  assumes           WF: "wf R"
  assumes            M: "mono F"
  assumes  induct_step:
    "\<And>st. (\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> F (\<lceil>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)"
  shows "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> \<mu> F"
proof -
  { fix st
    have "(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> (\<mu> F)"
      using WF
    proof (induction rule: wf_induct_rule)
      case (less x)
      hence 0:"(\<lceil>p \<and> (e,\<guillemotleft>x\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow>\<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> (\<mu> F)"
        by rel_blast
      hence 1: "F (\<lceil>p \<and> (e,\<guillemotleft>x\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> F(\<mu> F)"
        by (rule monoD[OF M])
      have 2: "(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>x\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> ..."
        by (simp add: induct_step)
      then show ?case
        using order_trans [OF 1 2]
      proof (subst gfp_unfold[OF M], goal_cases)
        case 1
        assume 01:"(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>x\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> F (\<lceil>p \<and> (e,\<guillemotleft>x\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)"
        assume 02:"(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>x\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> F (\<mu> F)"
        show ?case using 01 02
          by simp
      qed

    qed
  }
  thus ?thesis
    by pred_simp
qed

lemma nu_rec_total_utp_rule:
  assumes           WF: "wf R"
  assumes            M: "mono F"
  assumes  induct_step:
    "\<And>st. (\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> F (\<lceil>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)"
  shows "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> \<nu> F"
proof -
  { fix st
    have "(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> (\<nu> F)"
      using WF
    proof (induction rule: wf_induct_rule)
      case (less x)
      hence 0:"(\<lceil>p \<and> (e,\<guillemotleft>x\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow>\<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> (\<nu> F)"
        by rel_blast
      hence 1: "F (\<lceil>p \<and> (e,\<guillemotleft>x\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)\<sqsubseteq> F(\<nu> F)"
        by (rule monoD[OF M])
      have 2: "(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>x\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> ..."
        by (simp add: induct_step)
      then show ?case
        using order_trans [OF 1 2]
      proof (subst lfp_unfold[OF M], goal_cases)
        case 1
        assume 01:"(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>x\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> F (\<lceil>p \<and> (e,\<guillemotleft>x\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)"
        assume 02:"(\<lceil>p \<and> e =\<^sub>u \<guillemotleft>x\<guillemotright>\<rceil>\<^sub>< \<Rightarrow> \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> F (\<nu> F)"
        show ?case using 01 02
          by simp
      qed

    qed
  }
  thus ?thesis
    by pred_simp
qed

section {*Examples*}

(*The lemma total_rec_utp_test shows how rec_total_utp_rule improves automation wrt
  rec_total_pure_rule which was used for the same example in  total_rec_test*)
lemma total_rec_utp_test:
  "vwb_lens x \<Longrightarrow>
   (\<lceil>true\<rceil>\<^sub><\<Rightarrow> \<lceil>&x \<le>\<^sub>u \<guillemotleft>0::int\<guillemotright>\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> R \<bullet> ((x :== (&x - \<guillemotleft>1\<guillemotright>)) ;; R) \<triangleleft> &x >\<^sub>u \<guillemotleft>0::int\<guillemotright> \<triangleright>\<^sub>r II)"
  apply (rule mu_rec_total_utp_rule[where R="measure (nat o \<lbrakk>&x\<rbrakk>\<^sub>e)"and e = "&\<Sigma>"])
    apply simp
   apply (simp add: cond_mono monoI seqr_mono)
  apply (rule  cond_refine_rel)
   prefer 2
   apply pred_simp+
  done

lemma total_rec_test:
  "vwb_lens x \<Longrightarrow>
   (\<lceil>true\<rceil>\<^sub><\<Rightarrow> \<lceil>&x \<le>\<^sub>u \<guillemotleft>0::int\<guillemotright>\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> R \<bullet> ((x :== (&x - \<guillemotleft>1\<guillemotright>)) ;; R) \<triangleleft> &x >\<^sub>u \<guillemotleft>0::int\<guillemotright> \<triangleright>\<^sub>r II)"
  apply (rule mu_rec_total_pure_rule[where R="measure (nat o \<lbrakk>&x\<rbrakk>\<^sub>e)" and e = "&\<Sigma>"])
    apply simp
   apply (simp add: cond_mono monoI seqr_mono)
  apply (rule  cond_refine_rel)
   prefer 2
   apply pred_simp
  subgoal premises prems for f st
    apply (rule seq_refine_unrest[where s="0 \<le>\<^sub>u &x \<and> &\<Sigma> =\<^sub>u \<guillemotleft>([x\<mapsto>\<^sub>s &x-1] st)\<guillemotright>"])
       apply pred_simp
      apply pred_simp
    using prems(1) apply pred_simp
    apply (rule pre_weak_rel[rotated])
     apply (rule prems(2))
    using prems(1) apply pred_simp
    done
  done

end


section \<open>Interchange\<close>

theory Partial_Semigroup_Interchange
imports Partial_Semigroups Binary_Modalities
begin

class cancellative_pas = pas + cancellative_partial_semigroup

context cancellative_pas
begin
lemma "D w x \<Longrightarrow> D y z \<Longrightarrow> y \<preceq>\<^sub>R w \<Longrightarrow> z \<preceq>\<^sub>R x \<Longrightarrow> rquot (w \<cdot> x) (y \<cdot> z) = (rquot w y) \<cdot> (rquot x z)"
  by (smt local.add_assoc local.add_assocD_var2 local.add_canc2 local.add_comm local.gR_rel_defined local.rquot_prop)

thm add_canc2

thm add_canc1 rquot_prop

lemma cpas_interchange: "D w x \<Longrightarrow> y \<preceq>\<^sub>R w \<Longrightarrow> z \<preceq>\<^sub>R x \<Longrightarrow> rquot (w \<oplus> x) (y \<oplus> z) = (rquot w y) \<oplus> (rquot x z)"
proof -
  assume d: "D w x"
    and o1: " y \<preceq>\<^sub>R w"
   and o2: "z \<preceq>\<^sub>R x"
  have "w \<oplus> x = ((rquot w y) \<oplus> y) \<oplus> ((rquot x z) \<oplus> z)"
    by (metis add_canc2 add_comm' gR_rel_defined o1 o2)
  hence "w \<oplus> x = (rquot w y) \<oplus> (rquot x z) \<oplus> (y \<oplus> z)"
    by (smt d local.add_assocD local.add_assoc_var local.add_canc2 local.add_comm local.gR_rel_defined o1 o2)
  thus ?thesis
    by (smt d local.add_assocD_var2 local.add_assoc_var local.add_comm local.quotr_unique local.rquot_prop o1 o2)
qed
end

context quantale
begin
lemma bres_canc1: "y \<le> x \<rightarrow> (x \<cdot> y)"
  by (simp add: local.bres_galois_imp)

lemma bres_canc2: "x \<cdot> (x \<rightarrow> z) \<le> z"
  by (simp add: local.bres_galois)

lemma fres_canc1: "x \<le> (x \<cdot> y) \<leftarrow> y"
  using local.fres_galois by blast

lemma fres_canc2: "(z \<leftarrow> y) \<cdot> y \<le> z"
  by (simp add: local.fres_galois)
end

context ab_quantale
begin
lemma quantale_interchange: "(w \<rightarrow> y) \<cdot> (x \<rightarrow> z) \<le> (w \<cdot> x) \<rightarrow> (y \<cdot> z)"
proof -
  have "(w \<cdot> x) \<cdot> (w \<rightarrow> y) \<cdot> (x \<rightarrow> z) = (w \<cdot> (w \<rightarrow> y)) \<cdot> (x \<cdot> (x \<rightarrow> z))"
    by (metis mult_assoc mult_commute)
  also have "... \<le> (y \<cdot> z)"
    using local.bres_canc2 local.mult_isol local.mult_isor local.order.trans by blast
  finally show ?thesis
    by (simp add: local.bres_galois_imp mult_assoc)
qed

lemma "(w \<rightarrow> y) \<cdot> (x \<rightarrow> z) = (w \<cdot> x) \<rightarrow> (y \<cdot> z)"
  nitpick
  oops
end

class res_asg = semigroup_mult +
  fixes preord :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    and sbres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes preord_refl: "preord x x"
    and preord_trans: "preord x y \<Longrightarrow> preord y z \<Longrightarrow> preord x z"
    and mult_comm: "x * y = y * x"
    and sbres_galois: "preord (x * y) z \<longleftrightarrow> preord y (sbres x z)"
begin
lemma bres_canc1: "preord y (sbres x (x * y))"
  using local.preord_refl local.sbres_galois by blast

lemma bres_canc2: "preord (x * (sbres x z)) z"
  by (simp add: local.preord_refl local.sbres_galois)

lemma mult_iso: "preord x y \<Longrightarrow> preord (z * x) (z * y)"
  using local.bres_canc1 local.preord_trans local.sbres_galois by blast

lemma res_asg_interchange: "preord ((sbres w y) * (sbres x z)) (sbres (w * x) (y * z))"
  by (smt bres_canc1 bres_canc2 mult.semigroup_axioms mult_comm preord_trans sbres_galois semigroup.assoc)
end

class res_asg_test = monoid_mult +
  fixes preord :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    and sbres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes preord_refl: "preord x x"
    and preord_trans: "preord x y \<Longrightarrow> preord y z \<Longrightarrow> preord x z"
    and preord_antisym: "preord x y \<Longrightarrow> preord y x"
    and mult_comm: "x * y = y * x"
    and mult_iso: "preord x y \<Longrightarrow> preord (z * x) (z * y)"
    and "preord ((sbres w y) * (sbres x z)) (sbres (w * x) (y * z))"
begin
lemma sbres_galois: "preord (x * y) z \<longleftrightarrow> preord y (sbres x z)"
  nitpick
  oops
end
end


           (*-------------------------------------------*
            |  The Dining Mathematicians in CSP-Prover  |
            |               August 2004                 |
            |             December 2004 (modified)      |
            |             November 2005 (modified)      |
            |                March 2007  (modified)     |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DM3_hide
imports DM2_para
begin

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

         1. expands hiding operators in Imp
         2.
         3.
         4.

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

(******************** Hiding ********************)

(*** Back0 VAR Back1 HIDE ***)

lemma Back0_VAR_Back1_HIDE:
  "(Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                        |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F

        Back0 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                     -- (CH0 Un CH1))
        [+]
        Back1 -> ((Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                     -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules24)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules24)+
done

lemmas Back0_VAR_Back1_HIDE_simp = Back0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules25 = unfold_Imp_rules24 Back0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules25 = fold_Imp_rules24 Back0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Eat0 VAR Back1 HIDE ***)

lemma Eat0_VAR_Back1_HIDE:
  "EVEN n ==>
   (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F

        Eat0 -> ((($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1))
        [+]
        Back1 -> ((Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules25)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules25)+
done

lemmas Eat0_VAR_Back1_HIDE_simp = Eat0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules26 = unfold_Imp_rules25 Eat0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules26 = fold_Imp_rules25 Eat0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Back0 VAR Eat1 HIDE ***)

lemma Back0_VAR_Eat1_HIDE:
  "ODD n ==>
   (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        Eat1 -> ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                        |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1))
        [+]
        Back0 -> ((($TH0) |[CH0]| ($(VAR n))
                                |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules26)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules26)+
done

lemmas Back0_VAR_Eat1_HIDE_simp = Back0_VAR_Eat1_HIDE[simplified]
lemmas unfold_Imp_rules27 = unfold_Imp_rules26 Back0_VAR_Eat1_HIDE_simp
lemmas fold_Imp_rules27 = fold_Imp_rules26 Back0_VAR_Eat1_HIDE_simp[THEN cspF_sym]

(*** EAT0 VAR Back1 HIDE ***)

lemma EAT0_VAR_Back1_HIDE:
  "EVEN n ==>
   (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        End0 -> ((WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1))
        [+]
        Back1 -> ((($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules27)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules27)+
done

lemmas EAT0_VAR_Back1_HIDE_simp = EAT0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules28 = unfold_Imp_rules27 EAT0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules28 = fold_Imp_rules27 EAT0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Back0 VAR EAT1 HIDE ***)

lemma Back0_VAR_EAT1_HIDE:
  "ODD n ==>
   (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        End1 -> ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                 |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                  -- (CH0 Un CH1))
        [+]
        Back0 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                  -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules28)
apply (cspF_step)+
apply (auto)
apply (cspF_simp fold_Imp_rules28)+
done

lemmas Back0_VAR_EAT1_HIDE_simp = Back0_VAR_EAT1_HIDE[simplified]
lemmas unfold_Imp_rules29 = unfold_Imp_rules28 Back0_VAR_EAT1_HIDE_simp
lemmas fold_Imp_rules29 = fold_Imp_rules28 Back0_VAR_EAT1_HIDE_simp[THEN cspF_sym]

(**************************)
(*** Back0 VAR TH1 HIDE ***)

lemma Back0_VAR_TH1_HIDE:
  "(Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back0 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        IF ODD n
        THEN ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| Eat1 -> ($(EAT1 n)))
              -- (CH0 Un CH1))
        ELSE ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules29)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)

apply (subgoal_tac "{Back0, (RD1 n)} Int (CH0 Un CH1) = {(RD1 n)}")
apply (case_tac "ODD n")
apply (cspF_simp fold_Imp_rules29)+
done

lemmas Back0_VAR_TH1_HIDE_simp = Back0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules30 = unfold_Imp_rules29 Back0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules30 = fold_Imp_rules29 Back0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(**************************)
(*** TH0 VAR Back1 HIDE ***)

lemma TH0_VAR_Back1_HIDE:
  "(($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back1 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        IF EVEN n
        THEN ((Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                         |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1))
        ELSE ((Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1))"
apply (cspF_simp unfold_Imp_rules30)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
apply (subgoal_tac "{Back1, (RD0 n)} Int (CH0 Un CH1) = {(RD0 n)}")
apply (case_tac "ODD n")
apply (cspF_simp fold_Imp_rules30)+
done

lemmas TH0_VAR_Back1_HIDE_simp = TH0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules31 = unfold_Imp_rules30 TH0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules31 = fold_Imp_rules30 TH0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Eat0 VAR TH1 HIDE ***)

lemma Eat0_VAR_TH1_HIDE:
  "EVEN n ==>
   (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1)
   =F
        Eat0 -> ((($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
         -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules31)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas Eat0_VAR_TH1_HIDE_simp = Eat0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules32 = unfold_Imp_rules31 Eat0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules32 = fold_Imp_rules31 Eat0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR Eat1 HIDE ***)

lemma TH0_VAR_Eat1_HIDE:
  "ODD n ==>
   (($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        Eat1 -> ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1))
        [>
        (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
                 -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules32)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas TH0_VAR_Eat1_HIDE_simp = TH0_VAR_Eat1_HIDE[simplified]
lemmas unfold_Imp_rules33 = unfold_Imp_rules32 TH0_VAR_Eat1_HIDE_simp
lemmas fold_Imp_rules33 = fold_Imp_rules32 TH0_VAR_Eat1_HIDE_simp[THEN cspF_sym]

(*** EAT0 VAR TH1 HIDE ***)

lemma EAT0_VAR_TH1_HIDE:
  "EVEN n ==>
   (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                 -- (CH0 Un CH1)
   =F
        End0 -> ((WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| ($TH1))
                 -- (CH0 Un CH1))
        [>
        (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
         -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules33)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas EAT0_VAR_TH1_HIDE_simp = EAT0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules34 = unfold_Imp_rules33 EAT0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules34 = fold_Imp_rules33 EAT0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR EAT1 HIDE ***)

lemma TH0_VAR_EAT1_HIDE:
  "ODD n ==>
   (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
                 -- (CH0 Un CH1)
   =F
        End1 -> ((($TH0) |[CH0]| ($(VAR n))
                               |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                 -- (CH0 Un CH1))
        [>
        (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
         -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules34)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas TH0_VAR_EAT1_HIDE_simp = TH0_VAR_EAT1_HIDE[simplified]
lemmas unfold_Imp_rules35 = unfold_Imp_rules34 TH0_VAR_EAT1_HIDE_simp
lemmas fold_Imp_rules35 = fold_Imp_rules34 TH0_VAR_EAT1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR TH1 HIDE step 1 ***)

lemma TH0_VAR_TH1_HIDE:
  "(($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
         -- (CH0 Un CH1)
   =F
       (IF EVEN n
        THEN ((Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
              -- (CH0 Un CH1))
        ELSE ((Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
              -- (CH0 Un CH1)))
        |~|
       (IF ODD n
        THEN ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
              -- (CH0 Un CH1))
        ELSE ((($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
              -- (CH0 Un CH1)))"
apply (cspF_simp_left unfold_Imp_rules35)
apply (cspF_step_left)+
apply (rule cspF_ref_eq)

 (* <= *)
 apply (rule)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD0 n" in exI)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+

  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD1 n" in exI)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+

(* => *)
 apply (subgoal_tac "{(RD0 n), (RD1 n)} Int (CH0 Un CH1) = {(RD0 n), (RD1 n)}")
 apply (auto)

  apply (rule cspF_Int_choice_left1)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+

  apply (rule cspF_Int_choice_left2)
  apply (case_tac "ODD n")
  apply (simp)
  apply (cspF_simp)+
done

lemmas TH0_VAR_TH1_HIDE_simp = TH0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules36 = unfold_Imp_rules35 TH0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules36 = fold_Imp_rules35 TH0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** WR0 VAR Back1 HIDE ***)

lemma WR0_VAR_Back1_HIDE:
  "EVEN n ==>
   (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back1 -> ((WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                 |[CH1]| ($TH1))
                  -- (CH0 Un CH1))
        [>
        (($TH0) |[CH0]| ($(VAR (n div 2))) |[CH1]| Back1 -> ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules36)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas WR0_VAR_Back1_HIDE_simp = WR0_VAR_Back1_HIDE[simplified]
lemmas unfold_Imp_rules37 = unfold_Imp_rules36 WR0_VAR_Back1_HIDE_simp
lemmas fold_Imp_rules37 = fold_Imp_rules36 WR0_VAR_Back1_HIDE_simp[THEN cspF_sym]

(*** Back0 VAR WR1 HIDE ***)

lemma Back0_VAR_WR1_HIDE:
  "ODD n ==>
   (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                 -- (CH0 Un CH1)
   =F
        Back0 -> ((($TH0) |[CH0]| ($(VAR n))
                                |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                 -- (CH0 Un CH1))
        [>
        (Back0 -> ($TH0) |[CH0]| ($(VAR (3 * n + 1))) |[CH1]| ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules37)
apply (cspF_step_left)+
apply (cspF_step_right)+
apply (rule cspF_decompo)+
apply (auto)
done

lemmas Back0_VAR_WR1_HIDE_simp = Back0_VAR_WR1_HIDE[simplified]
lemmas unfold_Imp_rules38 = unfold_Imp_rules37 Back0_VAR_WR1_HIDE_simp
lemmas fold_Imp_rules38 = fold_Imp_rules37 Back0_VAR_WR1_HIDE_simp[THEN cspF_sym]

(*** WR0 VAR TH1 HIDE ***)

lemma WR0_VAR_TH1_HIDE:
  "EVEN n ==>
   (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
                -- (CH0 Un CH1)
   =F
        (($TH0)  |[CH0]| ($(VAR (n div 2))) |[CH1]| ($TH1))
         -- (CH0 Un CH1)
        |~|
        (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                       |[CH1]| Back1 -> ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules38)
apply (cspF_step_left)+
apply (rule cspF_ref_eq)

 (* <= *)
 apply (rule)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="WR0 (n div 2)" in exI)
  apply (simp, cspF_simp)+

  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD1 n" in exI)
  apply (simp, cspF_simp)+

(* => *)
 apply (subgoal_tac "{(WR0 (n div 2)), (RD1 n)} Int (CH0 Un CH1) =
                     {(WR0 (n div 2)), (RD1 n)}")
 apply (auto)

  apply (rule cspF_Int_choice_left1)
  apply (cspF_simp)+
  apply (rule cspF_Int_choice_left2)
  apply (cspF_simp)+
done

lemmas WR0_VAR_TH1_HIDE_simp = WR0_VAR_TH1_HIDE[simplified]
lemmas unfold_Imp_rules39 = unfold_Imp_rules38 WR0_VAR_TH1_HIDE_simp
lemmas fold_Imp_rules39 = fold_Imp_rules38 WR0_VAR_TH1_HIDE_simp[THEN cspF_sym]

(*** TH0 VAR WR1 HIDE ***)

lemma TH0_VAR_WR1_HIDE:
  "ODD n ==>
   (($TH0) |[CH0]| ($(VAR n)) |[CH1]| WR1 (3 * n + 1) -> ($TH1))
                  -- (CH0 Un CH1)
   =F
        (($TH0) |[CH0]| ($(VAR (3 * n + 1))) |[CH1]| ($TH1))
        -- (CH0 Un CH1)
        |~|
        (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                               |[CH1]| WR1 (3 * n + 1) -> ($TH1))
        -- (CH0 Un CH1)"
apply (cspF_simp_left unfold_Imp_rules39)
apply (cspF_step_left)+
apply (rule cspF_ref_eq)

 (* <= *)
 apply (rule)
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="WR1 (3 * n + 1)" in exI)
  apply (simp, cspF_simp)+
  apply (rule cspF_Rep_int_choice_left)
  apply (rule_tac x="RD0 n" in exI)
  apply (simp, cspF_simp)+

(* => *)
 apply (subgoal_tac "{(WR1 (3 * n + 1)), (RD0 n)} Int (CH0 Un CH1) =
                     {(WR1 (3 * n + 1)), (RD0 n)}")
 apply (auto)

  apply (rule cspF_Int_choice_left1)
  apply (cspF_simp)+
  apply (rule cspF_Int_choice_left2)
  apply (cspF_simp)+
done

lemmas TH0_VAR_WR1_HIDE_simp = TH0_VAR_WR1_HIDE[simplified]
lemmas unfold_Imp_rules = unfold_Imp_rules39 TH0_VAR_WR1_HIDE_simp
lemmas fold_Imp_rules = fold_Imp_rules39 TH0_VAR_WR1_HIDE_simp[THEN cspF_sym]

end


theory Proof_5_4
  imports Requirements VCTheoryLemmas
begin

abbreviation s where "s s0 requestButton_value \<equiv>(toEnv (setPstate (setVarAny s0 requestButton_value) Ctrl redAfterMinimalRed)) "

lemma VC4_R5_aux1: "toEnvP s2 \<and> toEnvP s0 \<and> substate s2 s0 \<and> toEnvNum s2 s3 < T1 \<and> s3 = s s0 requestButton_value \<Longrightarrow>
toEnvNum s2 s0 < T1"
  apply auto
  apply(simp split: if_splits)
  using substate_refl substate_asym[of s0 "s s0 requestButton_value"] by  auto

lemma VC4_R5: "  (toEnvP s0 \<and>
        (\<forall>s1 s2 s3.
            substate s1 s2 \<and>
            substate s2 s3 \<and>
            substate s3 s0 \<and>
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            toEnvP s3 \<and>
            toEnvNum s1 s2 = Ctrl \<and>
            toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<longrightarrow>
            getVarBool s3 minimalRed = NOT_PRESSED)) \<and>
       env (setVarAny s0 requestButton_value) requestButton_value \<and>
       getPstate (setVarAny s0 requestButton_value) Ctrl = minimalRed \<and>
       \<not> getVarBool (setVarAny s0 requestButton_value) Ctrl \<and>
       MINIMAL_RED_TIME_LIMIT \<le> ltimeEnv (setVarAny s0 requestButton_value) Ctrl \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2 s3 \<and>
       substate s3 (s s0 requestButton_value) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvP s3 \<and>
       toEnvNum s1 s2 = Ctrl \<and>
       toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<Longrightarrow>
       getVarBool s3 minimalRed = NOT_PRESSED"
  apply(cases "s3 = s s0 requestButton_value")
   apply(cases "s2 = s s0 requestButton_value")
    apply blast
   apply(rule cut_rl[of "substate s2 s0"])
    apply(rule cut_rl[of "getVarBool s0 trafficLight = RED"])
  apply (metis getVarBool.simps(2) getVarBool.simps(4) getVarBool.simps(6) getVarBool.simps(7) numeral_eq_iff one_eq_numeral_iff semiring_norm(85) semiring_norm(89))
    apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule allE[of _ s1])
     prefer 2
  apply assumption
   apply(drule allE[of _ s2])
     prefer 2
     apply assumption
apply(drule allE[of _ s0])
     prefer 2
     apply assumption
    apply(rule cut_rl[of "toEnvNum s2 s0 < T1"])
  using substate_refl apply fast
    apply((rule VC4_R5_aux1);fast)
  apply (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))
  apply(rule cut_rl [of "substate s3 s0"])
   apply blast
  by (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))

theorem proof_5_3: "VC4 R5 s0 requestButton_value"
  apply(simp only: VC4_def R5_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  apply((rule allI);(rule allI);(rule allI))
  apply(rule impI)
  by ((rule VC4_R5);assumption)


theory ETCS_Summation
  imports ETCS_Add
begin

definition indexed_sum :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" where
  "indexed_sum f low = (THE u. u : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c
    \<and> u \<circ>\<^sub>c zero = \<langle>low, f \<circ>\<^sub>c low\<rangle>
    \<and> \<langle>successor \<circ>\<^sub>c left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c, add2 \<circ>\<^sub>c (f \<times>\<^sub>f id \<nat>\<^sub>c)\<rangle> \<circ>\<^sub>c u = u \<circ>\<^sub>c successor)"

lemma indexed_sum_def2:
  assumes f_type[type_rule]: "f : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and low_type[type_rule]: "low \<in>\<^sub>c \<nat>\<^sub>c"
  shows "indexed_sum f low : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c
    \<and> indexed_sum f low \<circ>\<^sub>c zero = \<langle>low, f \<circ>\<^sub>c low\<rangle>
    \<and> \<langle>successor \<circ>\<^sub>c left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c, add2 \<circ>\<^sub>c (f \<times>\<^sub>f id \<nat>\<^sub>c)\<rangle> \<circ>\<^sub>c indexed_sum f low = indexed_sum f low \<circ>\<^sub>c successor"
  unfolding indexed_sum_def
  by (rule theI', typecheck_cfuncs, simp add: natural_number_object_property2)

lemma indexed_sum_type[type_rule]:
  assumes f_type[type_rule]: "f : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and low_type[type_rule]: "low \<in>\<^sub>c \<nat>\<^sub>c"
  shows "indexed_sum f low : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c \<times>\<^sub>c \<nat>\<^sub>c"
  using indexed_sum_def2 assms by auto

lemma indexed_sum_zero:
  assumes f_type[type_rule]: "f : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and low_type[type_rule]: "low \<in>\<^sub>c \<nat>\<^sub>c"
  shows "indexed_sum f low \<circ>\<^sub>c zero = \<langle>low, f \<circ>\<^sub>c low\<rangle>"
  using indexed_sum_def2 assms by auto

lemma indexed_sum_successor:
  assumes f_type[type_rule]: "f : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and low_type[type_rule]: "low \<in>\<^sub>c \<nat>\<^sub>c"
  shows "indexed_sum f low \<circ>\<^sub>c successor
    = \<langle>successor \<circ>\<^sub>c left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c, add2 \<circ>\<^sub>c (f \<times>\<^sub>f id \<nat>\<^sub>c)\<rangle> \<circ>\<^sub>c indexed_sum f low"
  using indexed_sum_def2 assms by auto

lemma
  assumes f_type[type_rule]: "f : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and low_type[type_rule]: "low \<in>\<^sub>c \<nat>\<^sub>c"
  assumes n_type[type_rule]: "n \<in>\<^sub>c \<nat>\<^sub>c"
  shows "left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low = (add1 \<circ>\<^sub>c low)\<^sup>\<flat> \<circ>\<^sub>c \<langle>id \<nat>\<^sub>c, \<beta>\<^bsub>\<nat>\<^sub>c\<^esub>\<rangle>"
proof (rule natural_number_object_func_unique[where X="\<nat>\<^sub>c", where f=successor])
  show "left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c"
    by typecheck_cfuncs
  show "(add1 \<circ>\<^sub>c low)\<^sup>\<flat> \<circ>\<^sub>c \<langle>id\<^sub>c \<nat>\<^sub>c,\<beta>\<^bsub>\<nat>\<^sub>c\<^esub>\<rangle> : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c"
    by typecheck_cfuncs
  show "successor : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c"
    by typecheck_cfuncs

  show "(left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low) \<circ>\<^sub>c zero = ((add1 \<circ>\<^sub>c low)\<^sup>\<flat> \<circ>\<^sub>c \<langle>id\<^sub>c \<nat>\<^sub>c,\<beta>\<^bsub>\<nat>\<^sub>c\<^esub>\<rangle>) \<circ>\<^sub>c zero"
    sorry

  show "(left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low) \<circ>\<^sub>c successor = successor \<circ>\<^sub>c left_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low"
    sorry

  show "((add1 \<circ>\<^sub>c low)\<^sup>\<flat> \<circ>\<^sub>c \<langle>id\<^sub>c \<nat>\<^sub>c,\<beta>\<^bsub>\<nat>\<^sub>c\<^esub>\<rangle>) \<circ>\<^sub>c successor = successor \<circ>\<^sub>c (add1 \<circ>\<^sub>c low)\<^sup>\<flat> \<circ>\<^sub>c \<langle>id\<^sub>c \<nat>\<^sub>c,\<beta>\<^bsub>\<nat>\<^sub>c\<^esub>\<rangle>"
    sorry
qed

lemma add_indexed_sum:
  assumes f_type[type_rule]: "f : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and low_type[type_rule]: "low \<in>\<^sub>c \<nat>\<^sub>c"
  assumes n1_type[type_rule]: "n1 \<in>\<^sub>c \<nat>\<^sub>c" and n2_type[type_rule]: "n2 \<in>\<^sub>c \<nat>\<^sub>c"
  shows "(right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low \<circ>\<^sub>c n1)
          +\<^sub>\<nat> (right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f (successor \<circ>\<^sub>c add2 \<circ>\<^sub>c \<langle>low, n1\<rangle>) \<circ>\<^sub>c n2)
      = right_cart_proj \<nat>\<^sub>c \<nat>\<^sub>c \<circ>\<^sub>c indexed_sum f low \<circ>\<^sub>c add2 \<circ>\<^sub>c \<langle>n1, n2\<rangle>"
proof -
  have "add2 \<circ>\<^sub>c \<langle>indexed_sum f low \<circ>\<^sub>c n1 \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c\<^esub>, indexed_sum f (successor \<circ>\<^sub>c add2 \<circ>\<^sub>c \<langle>low, n1\<rangle>)\<rangle>
      = indexed_sum f low \<circ>\<^sub>c add2 \<circ>\<^sub>c \<langle>n1 \<circ>\<^sub>c \<beta>\<^bsub>\<nat>\<^sub>c\<^esub>, id \<nat>\<^sub>c\<rangle>"
  proof (rule natural_number_object_func_unique)
    oops

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Galois Relator\<close>
theory Transport_Compositions_Generic_Galois_Relator
  imports
    HOL_Basics.Galois_Equivalences
    Transport_Compositions_Generic_Base
begin

context transport_comp
begin

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1
  rewrites "flip.t2.unit \<equiv> \<epsilon>\<^sub>1"
  by (simp only: t1.flip_unit_eq_counit)

lemma Galois_le_Galois_rel_compI:
  assumes mono_r1: "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and galois_prop1: "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and preorder_R1: "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and rel_comp_le: "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and mono_in_codom_r2: "([in_codom (\<le>\<^bsub>R\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>R1\<^esub>)) r2"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) \<le> ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
proof (rule le_relI)
  fix x z assume "x \<^bsub>L\<^esub>\<lessapprox> z"
  then have "in_codom (\<le>\<^bsub>R\<^esub>) z" "x \<le>\<^bsub>L\<^esub> r z" by auto
  with galois_prop1 obtain y y' where
    "in_dom (\<le>\<^bsub>L1\<^esub>) x" "l1 x \<le>\<^bsub>R1\<^esub> y" "y \<le>\<^bsub>L2\<^esub> y'" "y' \<le>\<^bsub>R1\<^esub> \<epsilon>\<^sub>1 (r2 z)"
    by (auto elim!: left_relE t1.half_galois_prop_left_GaloisE flip.t2.GaloisE)
  moreover  have "\<epsilon>\<^sub>1 (r2 z) \<le>\<^bsub>R1\<^esub> r2 z"
  proof -
    from mono_in_codom_r2 \<open>in_codom (\<le>\<^bsub>R\<^esub>) z\<close> have "in_codom (\<le>\<^bsub>R1\<^esub>) (r2 z)" by blast
    with mono_r1 galois_prop1 preorder_R1 show ?thesis by (blast intro!:
      t1.counit_rel_if_reflexive_on_if_half_galois_prop_left_if_mono_wrt_rel)
  qed
  ultimately have "y' \<le>\<^bsub>R1\<^esub> r2 z" using preorder_R1 by blast
  with \<open>l1 x \<le>\<^bsub>R1\<^esub> y\<close> \<open>y \<le>\<^bsub>L2\<^esub> y'\<close> have "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) (l1 x) (r2 z)"
    by blast
  with rel_comp_le obtain y'' where "l1 x \<le>\<^bsub>R1\<^esub> y''" "y'' \<le>\<^bsub>L2\<^esub> r2 z" by blast
  with galois_prop1 \<open>in_dom (\<le>\<^bsub>L1\<^esub>) x\<close>  have "x \<^bsub>L1\<^esub>\<lessapprox> y''"
    by (intro t1.Galois_if_left_right_rel_if_in_dom_if_half_galois_prop_right)
    auto
  moreover from \<open>in_codom (\<le>\<^bsub>R\<^esub>) z\<close> \<open>y'' \<le>\<^bsub>L2\<^esub> r2 z\<close> have "y'' \<^bsub>L2\<^esub>\<lessapprox> z"
    by (intro t2.GaloisI) auto
  ultimately show "((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) x z" by blast
qed

lemma Galois_rel_comp_le_GaloisI:
  assumes mono_r1: "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and half_galois_prop_left1: "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and half_galois_prop_right1: "((\<le>\<^bsub>R1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and refl_R1: "reflexive_on (in_codom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and mono_l2: "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and refl_L2: "reflexive_on (in_dom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and in_codom_rel_comp_le: "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) \<le> (\<^bsub>L\<^esub>\<lessapprox>)"
proof (intro le_relI GaloisI)
  fix x z assume "((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) x z"
  from \<open>((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) x z\<close> obtain y where "x \<^bsub>L1\<^esub>\<lessapprox> y" "y \<^bsub>L2\<^esub>\<lessapprox> z" by blast
  with half_galois_prop_left1 have "l1 x \<le>\<^bsub>R1\<^esub> y" "y \<le>\<^bsub>L2\<^esub> r2 z" by auto
  with refl_R1 refl_L2 have "y \<le>\<^bsub>R1\<^esub> y" "y \<le>\<^bsub>L2\<^esub> y" by auto
  show "in_codom (\<le>\<^bsub>R\<^esub>) z"
  proof (intro in_codomI flip.left_relI)
    from mono_l2 \<open>y \<le>\<^bsub>L2\<^esub> y\<close> show "l2 y \<^bsub>R2\<^esub>\<lessapprox> y" by blast
    show "y \<le>\<^bsub>R1\<^esub> y" "y \<^bsub>L2\<^esub>\<lessapprox> z" by fact+
  qed
  show "x \<le>\<^bsub>L\<^esub> r z"
  proof (intro left_relI)
    show "x \<^bsub>L1\<^esub>\<lessapprox> y" "y \<le>\<^bsub>L2\<^esub> r2 z" by fact+
    show "r2 z \<^bsub>R1\<^esub>\<lessapprox> r z"
    proof (intro flip.t2.GaloisI)
      from \<open>y \<le>\<^bsub>L2\<^esub> y\<close> \<open>y \<le>\<^bsub>R1\<^esub> y\<close> \<open>y \<le>\<^bsub>L2\<^esub> r2 z\<close> have "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) y (r2 z)"
        by blast
      with in_codom_rel_comp_le have "in_codom (\<le>\<^bsub>R1\<^esub>) (r2 z)" by blast
      with refl_R1 have "r2 z \<le>\<^bsub>R1\<^esub> r2 z" by blast
      with mono_r1 show "in_codom (\<le>\<^bsub>L1\<^esub>) (r z)" by auto
      with \<open>r2 z \<le>\<^bsub>R1\<^esub> r2 z\<close>  half_galois_prop_right1 mono_r1
        show "r2 z \<le>\<^bsub>R1\<^esub> l1 (r z)" by (auto intro:
        flip.t2.rel_unit_if_left_rel_if_half_galois_prop_right_if_mono_wrt_rel)
    qed
  qed
qed

corollary Galois_eq_Galois_rel_compI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "reflexive_on (in_dom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and "([in_codom (\<le>\<^bsub>R\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>R1\<^esub>)) r2"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms
  by (intro antisym Galois_le_Galois_rel_compI Galois_rel_comp_le_GaloisI)
  (auto elim!: preorder_on_in_fieldE
    intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_codom)

corollary Galois_eq_Galois_rel_compI':
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>R2\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "reflexive_on (in_dom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro Galois_eq_Galois_rel_compI
    flip.mono_in_codom_left_rel_left1_if_in_codom_rel_comp_le)
  auto

theorem Galois_eq_Galois_rel_comp_if_galois_connection_if_galois_equivalenceI':
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<stileturn> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "reflexive_on (in_dom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro Galois_eq_Galois_rel_compI')
  (auto elim!: t1.galois_equivalenceE)

corollary Galois_eq_Galois_rel_comp_if_galois_connection_if_galois_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<stileturn> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "reflexive_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms
  by (intro Galois_eq_Galois_rel_comp_if_galois_connection_if_galois_equivalenceI'
    flip.left2_right1_left2_le_left2_right1_if_right1_left2_right1_le_left2_right1)
  auto

corollary Galois_eq_Galois_rel_comp_if_preorder_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R2\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  and "(\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<le> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)"
  and "in_codom ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>)) \<le> in_codom (\<le>\<^bsub>R1\<^esub>)"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro
    Galois_eq_Galois_rel_comp_if_galois_connection_if_galois_equivalenceI)
  auto

end

end


(*  Title:       The Ipurge Unwinding Theorem for CSP Noninterference Security
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "The Ipurge Unwinding Theorem for deterministic and trace set processes"

theory DeterministicProcesses
imports IpurgeUnwinding
begin

text \<open>
\null

In accordance with Hoare's formal definition of deterministic processes \<^cite>\<open>"R3"\<close>, this section
shows that a process is deterministic just in case it is a \emph{trace set process}, i.e. it may be
identified by means of a trace set alone, matching the set of its traces, in place of a
failures-divergences pair. Then, variants of the Ipurge Unwinding Theorem are proven for
deterministic processes and trace set processes.
\<close>

subsection "Deterministic processes"

text \<open>
Here below are the definitions of predicates \<open>d_future_consistent\<close> and
\<open>d_weakly_future_consistent\<close>, which are variants of predicates @{term future_consistent} and
@{term weakly_future_consistent} meant for applying to deterministic processes. In some detail,
being deterministic processes such that refused events are completely specified by accepted events
(cf. \<^cite>\<open>"R3"\<close>, \<^cite>\<open>"R1"\<close>), the new predicates are such that their truth values can be determined
by just considering the accepted events of the process taken as input.

Then, it is proven that these predicates are characterized by the same connection as that of their
general-purpose counterparts, viz. \<open>d_future_consistent\<close> implies
\<open>d_weakly_future_consistent\<close>, and they are equivalent for domain-relation map
@{term rel_ipurge}. Finally, the predicates are shown to be equivalent to their general-purpose
counterparts in the case of a deterministic process.

\null
\<close>

definition d_future_consistent ::
 "'a process \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('a, 'd) dom_rel_map \<Rightarrow> bool" where
"d_future_consistent P D R \<equiv>
  \<forall>u \<in> range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"

definition d_weakly_future_consistent ::
 "'a process \<Rightarrow> ('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('a, 'd) dom_rel_map \<Rightarrow> bool" where
"d_weakly_future_consistent P I D R \<equiv>
  \<forall>u \<in> range D \<inter> (-I) `` range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"

lemma dfc_implies_dwfc:
 "d_future_consistent P D R \<Longrightarrow> d_weakly_future_consistent P I D R"
by (simp only: d_future_consistent_def d_weakly_future_consistent_def, blast)

lemma dfc_equals_dwfc_rel_ipurge:
 "d_future_consistent P D (rel_ipurge P I D) =
  d_weakly_future_consistent P I D (rel_ipurge P I D)"
proof (rule iffI, erule dfc_implies_dwfc,
 simp only: d_future_consistent_def d_weakly_future_consistent_def,
 rule ballI, (rule allI)+, rule impI)
  fix u xs ys
  assume
    A: "\<forall>u \<in> range D \<inter> (-I) `` range D. \<forall>xs ys. (xs, ys) \<in> rel_ipurge P I D u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" and
    B: "u \<in> range D" and
    C: "(xs, ys) \<in> rel_ipurge P I D u"
  show "(xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"
  proof (cases "u \<in> range D \<inter> (-I) `` range D")
    case True
    with A have "\<forall>xs ys. (xs, ys) \<in> rel_ipurge P I D u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    hence "(xs, ys) \<in> rel_ipurge P I D u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys"
     by blast
    thus ?thesis using C ..
  next
    case False
    hence D: "u \<notin> (-I) `` range D" using B by simp
    have "ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys"
     using C by (simp add: rel_ipurge_def)
    moreover have "\<forall>zs. ipurge_tr_rev I D u zs = zs"
    proof (rule allI, rule ipurge_tr_rev_all, rule ballI, erule imageE, rule ccontr)
      fix v x
      assume "(v, u) \<notin> I"
      hence "(v, u) \<in> -I" by simp
      moreover assume "v = D x"
      hence "v \<in> range D" by simp
      ultimately have "u \<in> (-I) `` range D" ..
      thus False using D by contradiction
    qed
    ultimately show ?thesis by simp
  qed
qed

lemma d_fc_equals_dfc:
  assumes A: "deterministic P"
  shows "future_consistent P D R = d_future_consistent P D R"
proof (rule iffI, simp_all only: d_future_consistent_def,
 rule ballI, (rule allI)+, rule impI, rule conjI, rule fc_traces, assumption+,
 simp_all add: future_consistent_def del: ball_simps)
  assume B: "\<forall>u \<in> range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"
  show "\<forall>u \<in> range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    ref_dom_events P D u xs = ref_dom_events P D u ys"
  proof (rule ballI, (rule allI)+, rule impI,
   simp add: ref_dom_events_def set_eq_iff, rule allI)
    fix u xs ys x
    assume "u \<in> range D"
    with B have "\<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    hence "(xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys"
     by blast
    moreover assume "(xs, ys) \<in> R u"
    ultimately have C: "(xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    show "(u = D x \<and> {x} \<in> refusals P xs) = (u = D x \<and> {x} \<in> refusals P ys)"
    proof (cases "u = D x", simp_all, cases "xs \<in> traces P")
      assume D: "u = D x" and E: "xs \<in> traces P"
      have
        A': "\<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
       using A by (simp add: deterministic_def)
      hence "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" using E ..
      hence "{x} \<in> refusals P xs = ({x} \<inter> next_events P xs = {})" ..
      moreover have "ys \<in> traces P" using C and E by simp
      with A' have "\<forall>X. X \<in> refusals P ys = (X \<inter> next_events P ys = {})" ..
      hence "{x} \<in> refusals P ys = ({x} \<inter> next_events P ys = {})" ..
      moreover have "{x} \<inter> next_events P xs = {x} \<inter> next_events P ys"
      proof (simp add: set_eq_iff, rule allI, rule iffI, erule_tac [!] conjE, simp_all)
        assume "x \<in> next_events P xs"
        hence "x \<in> next_dom_events P D u xs" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u ys" using C by simp
        thus "x \<in> next_events P ys" by (simp add: next_dom_events_def)
      next
        assume "x \<in> next_events P ys"
        hence "x \<in> next_dom_events P D u ys" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u xs" using C by simp
        thus "x \<in> next_events P xs" by (simp add: next_dom_events_def)
      qed
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    next
      assume D: "xs \<notin> traces P"
      hence "\<forall>X. (xs, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P xs = {}" by (rule_tac equals0I, simp add: refusals_def)
      moreover have "ys \<notin> traces P" using C and D by simp
      hence "\<forall>X. (ys, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P ys = {}" by (rule_tac equals0I, simp add: refusals_def)
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    qed
  qed
qed

lemma d_wfc_equals_dwfc:
  assumes A: "deterministic P"
  shows "weakly_future_consistent P I D R = d_weakly_future_consistent P I D R"
proof (rule iffI, simp_all only: d_weakly_future_consistent_def,
 rule ballI, (rule allI)+, rule impI, rule conjI, rule wfc_traces, assumption+,
 simp_all add: weakly_future_consistent_def del: ball_simps)
  assume B: "\<forall>u \<in> range D \<inter> (- I) `` range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"
  show "\<forall>u \<in> range D \<inter> (- I) `` range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    ref_dom_events P D u xs = ref_dom_events P D u ys"
  proof (rule ballI, (rule allI)+, rule impI,
   simp (no_asm_simp) add: ref_dom_events_def set_eq_iff, rule allI)
    fix u xs ys x
    assume "u \<in> range D \<inter> (- I) `` range D"
    with B have "\<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    hence "(xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys"
     by blast
    moreover assume "(xs, ys) \<in> R u"
    ultimately have C: "(xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    show "(u = D x \<and> {x} \<in> refusals P xs) = (u = D x \<and> {x} \<in> refusals P ys)"
    proof (cases "u = D x", simp_all, cases "xs \<in> traces P")
      assume D: "u = D x" and E: "xs \<in> traces P"
      have A': "\<forall>xs \<in> traces P. \<forall>X.
        X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
       using A by (simp add: deterministic_def)
      hence "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" using E ..
      hence "{x} \<in> refusals P xs = ({x} \<inter> next_events P xs = {})" ..
      moreover have "ys \<in> traces P" using C and E by simp
      with A' have "\<forall>X. X \<in> refusals P ys = (X \<inter> next_events P ys = {})" ..
      hence "{x} \<in> refusals P ys = ({x} \<inter> next_events P ys = {})" ..
      moreover have "{x} \<inter> next_events P xs = {x} \<inter> next_events P ys"
      proof (simp add: set_eq_iff, rule allI, rule iffI, erule_tac [!] conjE, simp_all)
        assume "x \<in> next_events P xs"
        hence "x \<in> next_dom_events P D u xs" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u ys" using C by simp
        thus "x \<in> next_events P ys" by (simp add: next_dom_events_def)
      next
        assume "x \<in> next_events P ys"
        hence "x \<in> next_dom_events P D u ys" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u xs" using C by simp
        thus "x \<in> next_events P xs" by (simp add: next_dom_events_def)
      qed
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    next
      assume D: "xs \<notin> traces P"
      hence "\<forall>X. (xs, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P xs = {}" by (rule_tac equals0I, simp add: refusals_def)
      moreover have "ys \<notin> traces P" using C and D by simp
      hence "\<forall>X. (ys, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P ys = {}" by (rule_tac equals0I, simp add: refusals_def)
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    qed
  qed
qed

text \<open>
\null

Here below is the proof of a variant of the Ipurge Unwinding Theorem applying to deterministic
processes. Unsurprisingly, its enunciation contains predicate @{term d_weakly_future_consistent} in
place of @{term weakly_future_consistent}. Furthermore, the assumption that the process be refusals
union closed is replaced by the assumption that it be deterministic, since the former property is
shown to be entailed by the latter.

\null
\<close>

lemma d_implies_ruc:
  assumes A: "deterministic P"
  shows "ref_union_closed P"
proof (subst ref_union_closed_def, (rule allI)+, (rule impI)+, erule exE)
  fix xs A X
  have "\<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
   using A by (simp add: deterministic_def)
  moreover assume B: "\<forall>X \<in> A. (xs, X) \<in> failures P" and "X \<in> A"
  hence "(xs, X) \<in> failures P" ..
  hence "xs \<in> traces P" by (rule failures_traces)
  ultimately have C: "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" ..
  have D: "\<forall>X \<in> A. X \<inter> next_events P xs = {}"
  proof
    fix X
    assume "X \<in> A"
    with B have "(xs, X) \<in> failures P" ..
    hence "X \<in> refusals P xs" by (simp add: refusals_def)
    thus "X \<inter> next_events P xs = {}" using C by simp
  qed
  have "(\<Union>X \<in> A. X) \<in> refusals P xs = ((\<Union>X \<in> A. X) \<inter> next_events P xs = {})"
   using C ..
  hence E: "(xs, \<Union>X \<in> A. X) \<in> failures P =
    ((\<Union>X \<in> A. X) \<inter> next_events P xs = {})"
   by (simp add: refusals_def)
  show "(xs, \<Union>X \<in> A. X) \<in> failures P"
  proof (rule ssubst [OF E], rule equals0I, erule IntE, erule UN_E)
    fix x X
    assume "X \<in> A"
    with D have "X \<inter> next_events P xs = {}" ..
    moreover assume "x \<in> X" and "x \<in> next_events P xs"
    hence "x \<in> X \<inter> next_events P xs" ..
    hence "\<exists>x. x \<in> X \<inter> next_events P xs" ..
    hence "X \<inter> next_events P xs \<noteq> {}" by (subst ex_in_conv [symmetric])
    ultimately show False by contradiction
  qed
qed

theorem d_ipurge_unwinding:
  assumes A: "deterministic P"
  shows "secure P I D = d_weakly_future_consistent P I D (rel_ipurge P I D)"
proof (insert d_wfc_equals_dwfc [of P I D "rel_ipurge P I D", OF A], erule subst)
qed (insert d_implies_ruc [OF A], rule ipurge_unwinding)

subsection "Trace set processes"

text \<open>
In \<^cite>\<open>"R3"\<close>, section 2.8, Hoare formulates a simplified definition of a deterministic process,
identified with a \emph{trace set}, i.e. a set of event lists containing the empty list and any
prefix of each of its elements. Of course, this is consistent with the definition of determinism
applying to processes identified with failures-divergences pairs, which implies that their refusals
are completely specified by their traces (cf. \<^cite>\<open>"R3"\<close>, \<^cite>\<open>"R1"\<close>).

Here below are the definitions of a function \<open>ts_process\<close>, converting the input set of lists
into a process, and a predicate \<open>trace_set\<close>, returning @{term True} just in case the input set
of lists has the aforesaid properties. An analysis is then conducted about the output of the
functions defined in \<^cite>\<open>"R1"\<close>, section 1.1, when acting on a \emph{trace set process}, i.e. a
process that may be expressed as \<open>ts_process T\<close> where \<open>trace_set T\<close> matches
@{term True}.

\null
\<close>

definition ts_process :: "'a list set \<Rightarrow> 'a process" where
"ts_process T \<equiv> Abs_process ({(xs, X). xs \<in> T \<and> (\<forall>x \<in> X. xs @ [x] \<notin> T)}, {})"

definition trace_set :: "'a list set \<Rightarrow> bool" where
"trace_set T \<equiv> [] \<in> T \<and> (\<forall>xs x. xs @ [x] \<in> T \<longrightarrow> xs \<in> T)"

lemma ts_process_rep:
  assumes A: "trace_set T"
  shows "Rep_process (ts_process T) =
    ({(xs, X). xs \<in> T \<and> (\<forall>x \<in> X. xs @ [x] \<notin> T)}, {})"
proof (subst ts_process_def, rule Abs_process_inverse, simp add: process_set_def,
 (subst conj_assoc [symmetric])+, (rule conjI)+, simp_all add:
 process_prop_1_def
 process_prop_2_def
 process_prop_3_def
 process_prop_4_def
 process_prop_5_def
 process_prop_6_def)
  show "[] \<in> T" using A by (simp add: trace_set_def)
next
  show "\<forall>xs. (\<exists>x. xs @ [x] \<in> T \<and> (\<exists>X. \<forall>x' \<in> X. xs @ [x, x'] \<notin> T)) \<longrightarrow> xs \<in> T"
  proof (rule allI, rule impI, erule exE, erule conjE)
    fix xs x
    have "\<forall>xs x. xs @ [x] \<in> T \<longrightarrow> xs \<in> T" using A by (simp add: trace_set_def)
    hence "xs @ [x] \<in> T \<longrightarrow> xs \<in> T" by blast
    moreover assume "xs @ [x] \<in> T"
    ultimately show "xs \<in> T" ..
  qed
next
  show "\<forall>xs X. xs \<in> T \<and> (\<exists>Y. (\<forall>x \<in> Y. xs @ [x] \<notin> T) \<and> X \<subseteq> Y) \<longrightarrow>
    (\<forall>x \<in> X. xs @ [x] \<notin> T)"
  proof ((rule allI)+, rule impI, (erule conjE, (erule exE)?)+, rule ballI)
    fix xs x X Y
    assume "\<forall>x \<in> Y. xs @ [x] \<notin> T"
    moreover assume "X \<subseteq> Y" and "x \<in> X"
    hence "x \<in> Y" ..
    ultimately show "xs @ [x] \<notin> T" ..
  qed
qed

lemma ts_process_failures:
 "trace_set T \<Longrightarrow>
  failures (ts_process T) = {(xs, X). xs \<in> T \<and> (\<forall>x \<in> X. xs @ [x] \<notin> T)}"
by (drule ts_process_rep, simp add: failures_def)

lemma ts_process_futures:
 "trace_set T \<Longrightarrow>
  futures (ts_process T) xs =
  {(ys, Y). xs @ ys \<in> T \<and> (\<forall>y \<in> Y. xs @ ys @ [y] \<notin> T)}"
by (simp add: futures_def ts_process_failures)

lemma ts_process_traces:
 "trace_set T \<Longrightarrow> traces (ts_process T) = T"
proof (drule ts_process_failures, simp add: traces_def, rule set_eqI, rule iffI, simp_all)
qed (rule_tac x = "{}" in exI, simp)

lemma ts_process_refusals:
 "trace_set T \<Longrightarrow> xs \<in> T \<Longrightarrow>
  refusals (ts_process T) xs = {X. \<forall>x \<in> X. xs @ [x] \<notin> T}"
by (drule ts_process_failures, simp add: refusals_def)

lemma ts_process_next_events:
 "trace_set T \<Longrightarrow> (x \<in> next_events (ts_process T) xs) = (xs @ [x] \<in> T)"
by (drule ts_process_traces, simp add: next_events_def)

text \<open>
\null

In what follows, the proof is given of two results which provide a connection between the notions of
deterministic and trace set processes: any trace set process is deterministic, and any process is
deterministic just in case it is equal to the trace set process corresponding to the set of its
traces.

\null
\<close>

lemma ts_process_d:
 "trace_set T \<Longrightarrow> deterministic (ts_process T)"
proof (frule ts_process_traces, simp add: deterministic_def, rule ballI,
 drule ts_process_refusals, assumption, simp add: next_events_def,
 rule allI, rule iffI)
  fix xs X
  assume "\<forall>x \<in> X. xs @ [x] \<notin> T"
  thus "X \<inter> {x. xs @ [x] \<in> T} = {}"
  by (rule_tac equals0I, erule_tac IntE, simp)
next
  fix xs X
  assume A: "X \<inter> {x. xs @ [x] \<in> T} = {}"
  show "\<forall>x \<in> X. xs @ [x] \<notin> T"
  proof (rule ballI, rule notI)
    fix x
    assume "x \<in> X" and "xs @ [x] \<in> T"
    hence "x \<in> X \<inter> {x. xs @ [x] \<in> T}" by simp
    moreover have "x \<notin> X \<inter> {x. xs @ [x] \<in> T}" using A by (rule equals0D)
    ultimately show False by contradiction
  qed
qed

definition divergences :: "'a process \<Rightarrow> 'a list set" where
"divergences P \<equiv> snd (Rep_process P)"

lemma d_divergences:
  assumes A: "deterministic P"
  shows "divergences P = {}"
proof (subst divergences_def, rule equals0I)
  fix xs
  have B: "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs. \<exists>x. xs \<in> snd ?P' \<longrightarrow> xs @ [x] \<in> snd ?P'"
   by (simp add: process_set_def process_prop_5_def)
  hence "\<exists>x. xs \<in> snd ?P' \<longrightarrow> xs @ [x] \<in> snd ?P'" ..
  then obtain x where "xs \<in> snd ?P' \<longrightarrow> xs @ [x] \<in> snd ?P'" ..
  moreover assume C: "xs \<in> snd ?P'"
  ultimately have D: "xs @ [x] \<in> snd ?P'" ..
  have E: "\<forall>xs X. xs \<in> snd ?P' \<longrightarrow> (xs, X) \<in> fst ?P'"
   using B by (simp add: process_set_def process_prop_6_def)
  hence "xs \<in> snd ?P' \<longrightarrow> (xs, {x}) \<in> fst ?P'" by blast
  hence "{x} \<in> refusals P xs"
   using C by (drule_tac mp, simp_all add: failures_def refusals_def)
  moreover have "xs @ [x] \<in> snd ?P' \<longrightarrow> (xs @ [x], {}) \<in> fst ?P'"
   using E by blast
  hence "(xs @ [x], {}) \<in> failures P"
   using D by (drule_tac mp, simp_all add: failures_def)
  hence F: "xs @ [x] \<in> traces P" by (rule failures_traces)
  hence "{x} \<inter> next_events P xs \<noteq> {}" by (simp add: next_events_def)
  ultimately have G: "({x} \<in> refusals P xs) \<noteq> ({x} \<inter> next_events P xs = {})"
   by simp
  have "\<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
   using A by (simp add: deterministic_def)
  moreover have "xs \<in> traces P" using F by (rule process_rule_2_traces)
  ultimately have "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" ..
  hence "{x} \<in> refusals P xs = ({x} \<inter> next_events P xs = {})" ..
  thus False using G by contradiction
qed

lemma trace_set_traces:
 "trace_set (traces P)"
proof (simp only: trace_set_def traces_def failures_def Domain_iff,
 rule conjI, (rule_tac [2] allI)+, rule_tac [2] impI, erule_tac [2] exE)
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "([], {}) \<in> fst ?P'" by (simp add: process_set_def process_prop_1_def)
  thus "\<exists>X. ([], X) \<in> fst ?P'" ..
next
  fix xs x X
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs x X. (xs @ [x], X) \<in> fst ?P' \<longrightarrow> (xs, {}) \<in> fst ?P'"
   by (simp add: process_set_def process_prop_2_def)
  hence "(xs @ [x], X) \<in> fst ?P' \<longrightarrow> (xs, {}) \<in> fst ?P'" by blast
  moreover assume "(xs @ [x], X) \<in> fst ?P'"
  ultimately have "(xs, {}) \<in> fst ?P'" ..
  thus "\<exists>X. (xs, X) \<in> fst ?P'" ..
qed

lemma d_implies_ts_process_traces:
 "deterministic P \<Longrightarrow> ts_process (traces P) = P"
proof (simp add: Rep_process_inject [symmetric] prod_eq_iff failures_def [symmetric],
 insert trace_set_traces [of P], frule ts_process_rep, frule d_divergences,
 simp add: divergences_def deterministic_def)
  assume A: "\<forall>xs \<in> traces P. \<forall>X.
    (X \<in> refusals P xs) = (X \<inter> next_events P xs = {})"
  assume B: "trace_set (traces P)"
  hence C: "traces (ts_process (traces P)) = traces P" by (rule ts_process_traces)
  show "failures (ts_process (traces P)) = failures P"
  proof (rule equalityI, rule_tac [!] subsetI, simp_all only: split_paired_all)
    fix xs X
    assume D: "(xs, X) \<in> failures (ts_process (traces P))"
    hence "xs \<in> traces (ts_process (traces P))" by (rule failures_traces)
    hence E: "xs \<in> traces P" using C by simp
    with B have
     "refusals (ts_process (traces P)) xs = {X. \<forall>x \<in> X. xs @ [x] \<notin> traces P}"
     by (rule ts_process_refusals)
    moreover have "X \<in> refusals (ts_process (traces P)) xs"
     using D by (simp add: refusals_def)
    ultimately have "\<forall>x \<in> X. xs @ [x] \<notin> traces P" by simp
    hence "X \<inter> next_events P xs = {}"
     by (rule_tac equals0I, erule_tac IntE, simp add: next_events_def)
    moreover have "\<forall>X. (X \<in> refusals P xs) = (X \<inter> next_events P xs = {})"
     using A and E ..
    hence "(X \<in> refusals P xs) = (X \<inter> next_events P xs = {})" ..
    ultimately have "X \<in> refusals P xs" by simp
    thus "(xs, X) \<in> failures P" by (simp add: refusals_def)
  next
    fix xs X
    assume D: "(xs, X) \<in> failures P"
    hence E: "xs \<in> traces P" by (rule failures_traces)
    with A have "\<forall>X. (X \<in> refusals P xs) = (X \<inter> next_events P xs = {})" ..
    hence "(X \<in> refusals P xs) = (X \<inter> next_events P xs = {})" ..
    moreover have "X \<in> refusals P xs" using D by (simp add: refusals_def)
    ultimately have F: "X \<inter> {x. xs @ [x] \<in> traces P} = {}"
     by (simp add: next_events_def)
    have "\<forall>x \<in> X. xs @ [x] \<notin> traces P"
    proof (rule ballI, rule notI)
      fix x
      assume "x \<in> X" and "xs @ [x] \<in> traces P"
      hence "x \<in> X \<inter> {x. xs @ [x] \<in> traces P}" by simp
      moreover have "x \<notin> X \<inter> {x. xs @ [x] \<in> traces P}" using F by (rule equals0D)
      ultimately show False by contradiction
    qed
    moreover have
     "refusals (ts_process (traces P)) xs = {X. \<forall>x \<in> X. xs @ [x] \<notin> traces P}"
     using B and E by (rule ts_process_refusals)
    ultimately have "X \<in> refusals (ts_process (traces P)) xs" by simp
    thus "(xs, X) \<in> failures (ts_process (traces P))" by (simp add: refusals_def)
  qed
qed

lemma ts_process_traces_implies_d:
 "ts_process (traces P) = P \<Longrightarrow> deterministic P"
by (insert trace_set_traces [of P], drule ts_process_d, simp)

lemma d_equals_ts_process_traces:
 "deterministic P = (ts_process (traces P) = P)"
by (rule iffI, erule d_implies_ts_process_traces, rule ts_process_traces_implies_d)

text \<open>
\null

Finally, a variant of the Ipurge Unwinding Theorem applying to trace set processes is derived from
the variant for deterministic processes. Particularly, the assumption that the process be
deterministic is replaced by the assumption that it be a trace set process,
since the former property is entailed by the latter (cf. above).

\null
\<close>

theorem ts_ipurge_unwinding:
 "trace_set T \<Longrightarrow>
  secure (ts_process T) I D =
  d_weakly_future_consistent (ts_process T) I D (rel_ipurge (ts_process T) I D)"
by (rule d_ipurge_unwinding, rule ts_process_d)

end


(*
This file is a part of IsarMathLib -
a library of formalized mathematics for Isabelle/Isar.

Copyright (C) 2005 - 2008  Slawomir Kolodynski

This program is free software; Redistribution and use in source and binary forms,
with or without modification, are permitted provided that the
following conditions are met:

1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Monoids\<close>

theory Monoid_ZF imports func_ZF Loop_ZF

begin

text\<open>This theory provides basic facts about monoids.\<close>

subsection\<open>Definition and basic properties\<close>

text\<open>In this section we talk about monoids.
  The notion of a monoid is similar to the notion of a semigroup
  except that we require the existence of a neutral element.
  It is also similar to the notion of group except that
  we don't require existence of the inverse.\<close>

text\<open>Monoid is a set $G$ with an associative operation and a neutral element.
  The operation is a function on $G\times G$ with values in $G$.
  In the context of ZF set theory this means that it is a set of pairs
  $\langle x,y \rangle$, where $x\in G\times G$ and $y\in G$. In other words
  the operation is a certain subset of $(G\times G)\times G$. We express
  all this by defing a predicate \<open>IsAmonoid(G,f)\<close>. Here $G$ is the
 ''carrier'' of the monoid and $f$ is the binary operation on it.
\<close>

definition
  "IsAmonoid(G,f) \<equiv>
  f {is associative on} G \<and>
  (\<exists>e\<in>G. (\<forall>g\<in>G. ( (f`(\<langle>e,g\<rangle>) = g) \<and> (f`(\<langle>g,e\<rangle>) = g))))"

text\<open>The next locale called ''monoid0'' defines a context for theorems
  that concern monoids. In this contex we assume that the pair $(G,f)$
  is a monoid.  We will use
  the \<open>\<oplus>\<close> symbol to denote the monoid operation (for
  no particular reason).\<close>

locale monoid0 =
  fixes G f
  assumes monoidAssum: "IsAmonoid(G,f)"

  fixes monoper (infixl "\<oplus>" 70)
  defines monoper_def [simp]: "a \<oplus> b \<equiv> f`\<langle>a,b\<rangle>"

text\<open>The result of the monoid operation is in the monoid (carrier).\<close>

lemma (in monoid0) group0_1_L1:
  assumes "a\<in>G"  "b\<in>G" shows "a\<oplus>b \<in> G"
  using assms monoidAssum IsAmonoid_def IsAssociative_def apply_funtype
  by auto

text\<open>There is only one neutral element in a monoid.\<close>

lemma (in monoid0) group0_1_L2: shows
  "\<exists>!e. e\<in>G \<and> (\<forall> g\<in>G. ( (e\<oplus>g = g) \<and> g\<oplus>e = g))"
proof
  fix e y
  assume "e \<in> G \<and> (\<forall>g\<in>G. e \<oplus> g = g \<and> g \<oplus> e = g)"
    and "y \<in> G \<and> (\<forall>g\<in>G. y \<oplus> g = g \<and> g \<oplus> y = g)"
  then have "y\<oplus>e = y" "y\<oplus>e = e" by auto
  thus "e = y" by simp
next from monoidAssum show
    "\<exists>e. e\<in> G \<and> (\<forall> g\<in>G. e\<oplus>g = g \<and> g\<oplus>e = g)"
    using IsAmonoid_def by auto
qed

text\<open>The neutral element is neutral.\<close>

lemma (in monoid0) unit_is_neutral:
  assumes A1: "e = TheNeutralElement(G,f)"
  shows "e \<in> G \<and> (\<forall>g\<in>G. e \<oplus> g = g \<and> g \<oplus> e = g)"
proof -
  let ?n = "THE b. b\<in> G \<and> (\<forall> g\<in>G. b\<oplus>g = g \<and> g\<oplus>b = g)"
  have "\<exists>!b. b\<in> G \<and> (\<forall> g\<in>G. b\<oplus>g = g \<and> g\<oplus>b = g)"
    using group0_1_L2 by simp
  then have "?n\<in> G \<and> (\<forall> g\<in>G. ?n\<oplus>g = g \<and> g\<oplus>?n = g)"
    by (rule theI)
  with A1 show ?thesis
    using TheNeutralElement_def by simp
qed

text\<open>The monoid carrier is not empty.\<close>

lemma (in monoid0) group0_1_L3A: shows "G\<noteq>0"
proof -
  have "TheNeutralElement(G,f) \<in> G" using unit_is_neutral
    by simp
  thus ?thesis by auto
qed

text\<open>The range of the monoid operation is the whole monoid carrier.\<close>

lemma (in monoid0) group0_1_L3B: shows "range(f) = G"
proof
  from monoidAssum have "f : G\<times>G\<rightarrow>G"
     using IsAmonoid_def IsAssociative_def by simp
  then show "range(f) \<subseteq> G"
    using func1_1_L5B by simp
  show "G \<subseteq> range(f)"
  proof
    fix g assume A1: "g\<in>G"
    let ?e = "TheNeutralElement(G,f)"
    from A1 have "\<langle>?e,g\<rangle> \<in> G\<times>G" "g = f`\<langle>?e,g\<rangle>"
      using unit_is_neutral by auto
    with \<open>f : G\<times>G\<rightarrow>G\<close> show "g \<in> range(f)"
      using func1_1_L5A by blast
  qed
qed

text\<open>Another way to state that the range of the monoid operation
  is the whole monoid carrier.\<close>

lemma (in monoid0) range_carr: shows "f``(G\<times>G) = G"
  using monoidAssum IsAmonoid_def IsAssociative_def
    group0_1_L3B range_image_domain by auto

text\<open>In a monoid any neutral element is the neutral element.\<close>

lemma (in monoid0) group0_1_L4:
  assumes A1: "e \<in> G \<and> (\<forall>g\<in>G. e \<oplus> g = g \<and> g \<oplus> e = g)"
  shows "e = TheNeutralElement(G,f)"
proof -
  let ?n = "THE b. b\<in> G \<and> (\<forall> g\<in>G. b\<oplus>g = g \<and> g\<oplus>b = g)"
  have "\<exists>!b. b\<in> G \<and> (\<forall> g\<in>G. b\<oplus>g = g \<and> g\<oplus>b = g)"
    using group0_1_L2 by simp
  moreover note A1
  ultimately have "?n = e" by (rule the_equality2)
  then show ?thesis using TheNeutralElement_def by simp
qed

text\<open>The next lemma shows that if the if we restrict the monoid operation to
  a subset of $G$ that contains the neutral element, then the
  neutral element of the monoid operation is also neutral with the
  restricted operation.
\<close>

lemma (in monoid0) group0_1_L5:
  assumes A1: "\<forall>x\<in>H.\<forall>y\<in>H. x\<oplus>y \<in> H"
  and A2: "H\<subseteq>G"
  and A3: "e = TheNeutralElement(G,f)"
  and A4: "g = restrict(f,H\<times>H)"
  and A5: "e\<in>H"
  and A6: "h\<in>H"
  shows "g`\<langle>e,h\<rangle> = h \<and> g`\<langle>h,e\<rangle> = h"
proof -
  from A4 A6 A5 have
    "g`\<langle>e,h\<rangle> = e\<oplus>h \<and> g`\<langle>h,e\<rangle> = h\<oplus>e"
    using restrict_if by simp
  with A3 A4 A6 A2 show
    "g`\<langle>e,h\<rangle> = h \<and> g`\<langle>h,e\<rangle> = h"
    using  unit_is_neutral by auto
qed

text\<open>The next theorem shows that if the monoid operation is closed
  on a subset of $G$ then this set is a (sub)monoid (although
  we do not define this notion). This fact will be
  useful when we study subgroups.\<close>

theorem (in monoid0) group0_1_T1:
  assumes A1: "H {is closed under} f"
  and A2: "H\<subseteq>G"
  and A3: "TheNeutralElement(G,f) \<in> H"
  shows  "IsAmonoid(H,restrict(f,H\<times>H))"
proof -
  let ?g = "restrict(f,H\<times>H)"
  let ?e = "TheNeutralElement(G,f)"
  from monoidAssum have "f \<in> G\<times>G\<rightarrow>G"
    using IsAmonoid_def IsAssociative_def by simp
  moreover from A2 have "H\<times>H \<subseteq> G\<times>G" by auto
  moreover from A1 have "\<forall>p \<in> H\<times>H. f`(p) \<in> H"
    using IsOpClosed_def by auto
  ultimately have "?g \<in> H\<times>H\<rightarrow>H"
    using func1_2_L4 by simp
  moreover have "\<forall>x\<in>H.\<forall>y\<in>H.\<forall>z\<in>H.
    ?g`\<langle>?g`\<langle>x,y\<rangle> ,z\<rangle> = ?g`\<langle>x,?g`\<langle>y,z\<rangle>\<rangle>"
  proof -
    from A1 have "\<forall>x\<in>H.\<forall>y\<in>H.\<forall>z\<in>H.
      ?g`\<langle>?g`\<langle>x,y\<rangle>,z\<rangle> = x\<oplus>y\<oplus>z"
      using IsOpClosed_def restrict_if by simp
    moreover have "\<forall>x\<in>H.\<forall>y\<in>H.\<forall>z\<in>H. x\<oplus>y\<oplus>z = x\<oplus>(y\<oplus>z)"
    proof -
      from monoidAssum have
	"\<forall>x\<in>G.\<forall>y\<in>G.\<forall>z\<in>G. x\<oplus>y\<oplus>z = x\<oplus>(y\<oplus>z)"
	using IsAmonoid_def IsAssociative_def
	by simp
      with A2 show ?thesis by auto
    qed
    moreover from A1 have
      "\<forall>x\<in>H.\<forall>y\<in>H.\<forall>z\<in>H. x\<oplus>(y\<oplus>z) = ?g`\<langle> x,?g`\<langle>y,z\<rangle> \<rangle>"
      using IsOpClosed_def restrict_if by simp
    ultimately show ?thesis by simp
  qed
  moreover have
    "\<exists>n\<in>H. (\<forall>h\<in>H. ?g`\<langle>n,h\<rangle> = h \<and> ?g`\<langle>h,n\<rangle> = h)"
  proof -
    from A1 have "\<forall>x\<in>H.\<forall>y\<in>H. x\<oplus>y \<in> H"
      using IsOpClosed_def by simp
    with A2 A3 have
      "\<forall> h\<in>H. ?g`\<langle>?e,h\<rangle> = h \<and> ?g`\<langle>h,?e\<rangle> = h"
      using group0_1_L5 by blast
    with A3 show ?thesis by auto
  qed
  ultimately show ?thesis using IsAmonoid_def IsAssociative_def
    by simp
qed

text\<open>Under the assumptions of \<open> group0_1_T1\<close>
  the neutral element of a
  submonoid is the same as that of the monoid.\<close>

lemma group0_1_L6:
  assumes A1: "IsAmonoid(G,f)"
  and A2: "H {is closed under} f"
  and A3: "H\<subseteq>G"
  and A4: "TheNeutralElement(G,f) \<in> H"
  shows "TheNeutralElement(H,restrict(f,H\<times>H)) = TheNeutralElement(G,f)"
proof -
  let ?e = "TheNeutralElement(G,f)"
  let ?g = "restrict(f,H\<times>H)"
  from assms have "monoid0(H,?g)"
    using monoid0_def monoid0.group0_1_T1
    by simp
  moreover have
    "?e \<in> H \<and> (\<forall>h\<in>H. ?g`\<langle>?e,h\<rangle> = h \<and> ?g`\<langle>h,?e\<rangle> = h)"
  proof -
    { fix h assume "h \<in> H"
      with assms have
	"monoid0(G,f)"  "\<forall>x\<in>H.\<forall>y\<in>H. f`\<langle>x,y\<rangle> \<in> H"
	"H\<subseteq>G"  "?e = TheNeutralElement(G,f)"  "?g = restrict(f,H\<times>H)"
	"?e \<in> H"  "h \<in> H"
	using monoid0_def IsOpClosed_def by auto
      then have "?g`\<langle>?e,h\<rangle> = h \<and> ?g`\<langle>h,?e\<rangle> = h"
	by (rule monoid0.group0_1_L5)
    } hence "\<forall>h\<in>H. ?g`\<langle>?e,h\<rangle> = h \<and> ?g`\<langle>h,?e\<rangle> = h" by simp
    with A4 show ?thesis by simp
  qed
  ultimately have "?e =  TheNeutralElement(H,?g)"
    by (rule monoid0.group0_1_L4)
  thus ?thesis by simp
qed

text\<open>If a sum of two elements is not zero,
  then at least one has to be nonzero.\<close>

lemma (in monoid0) sum_nonzero_elmnt_nonzero:
  assumes "a \<oplus> b \<noteq> TheNeutralElement(G,f)"
  shows "a \<noteq> TheNeutralElement(G,f) \<or> b \<noteq> TheNeutralElement(G,f)"
  using assms unit_is_neutral by auto

text\<open>The monoid operation is associative.\<close>

lemma (in monoid0) sum_associative:
  assumes "a\<in>G" "b\<in>G" "c\<in>G"
  shows "(a\<oplus>b)\<oplus>c = a\<oplus>(b\<oplus>c)"
  using assms monoidAssum unfolding IsAmonoid_def IsAssociative_def
  by auto

end