section \<open>Finite Particular Structures\<close>

theory FiniteParticularStructure
  imports
    "../ParticularStructures/InverseImageMorphismChoice"
    "../Identity/Individuality"
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  We present a theory of sortality in a context that imposes some
  restrictions on the UFO particular theory. Namely, we require
  that the set of particulars of the UFO particular structures
  be \emph{finite} and that all the particulars possess
  \emph{individuality} already, i.e. are non-collapsible.
\<close>
text_raw  \<open>\par\<close>
locale finite_particulars_with_individuality =
    ufo_particular_theory where Typ\<^sub>q = Typ\<^sub>q and Typ\<^sub>p = Typ\<^sub>p
  for
    Typ\<^sub>p :: \<open>'p itself\<close> and
    Typ\<^sub>q :: \<open>'q itself\<close> +
  assumes
    finite_particulars[intro!,simp]: \<open>finite \<P>\<close> and
    particulars_have_individuality: \<open>\<P> = \<P>\<^sub>i\<^sub>n\<^sub>d\<close>
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Under this restriction, any injective morphism
  to an isomorphic structure is also a bijection:
\<close>
text_raw  \<open>\par\<close>

lemma mono_to_iso_is_an_iso:
  assumes
    \<open>particular_struct_injection \<Gamma> \<Gamma>' \<phi>\<close>
    \<open>\<exists>\<sigma>. particular_struct_bijection \<Gamma> \<Gamma>' \<sigma>\<close>
  shows \<open>particular_struct_bijection \<Gamma> \<Gamma>' \<phi>\<close>
proof -
  interpret phi: particular_struct_injection \<Gamma> \<Gamma>' \<phi>
    using assms by simp
  obtain \<sigma> where \<open>particular_struct_bijection \<Gamma> \<Gamma>' \<sigma>\<close>
    using assms by blast
  then interpret sigma: particular_struct_bijection \<Gamma> \<Gamma>' \<sigma>
    by simp
  have A: \<open>finite (particulars \<Gamma>')\<close>
    using finite_particulars sigma.morph_bijective
      sigma.morph_image_def
    by auto
  have \<open>bij_betw \<phi> \<P> phi.tgt.\<P>\<close>
    using sigma.morph_bijective phi.morph_is_injective
    A finite_particulars
    by (metis \<Gamma>_simps(2) bij_betw_def card_image card_mono card_seteq
        phi.morph_image_def phi.morph_scope)
  then show ?thesis
    apply (unfold_locales)
    by (simp add: bij_betw_def)
qed

text \<^marker>\<open>tag bodyonly\<close> \<open>
   Furthermore, any morphism to an isomorphic structure is
   an injection (and thus a bijection).
\<close>
text_raw  \<open>\par\<close>
lemma morphism_to_injective:
  assumes
    \<open>particular_struct_morphism \<Gamma> \<Gamma>' \<phi>\<close>
    \<open>\<exists>\<sigma>. particular_struct_bijection \<Gamma> \<Gamma>' \<sigma>\<close>
  shows \<open>particular_struct_injection \<Gamma> \<Gamma>' \<phi>\<close>
proof -
  interpret phi: particular_struct_morphism \<Gamma> \<Gamma>' \<phi>
    using assms by simp
  obtain \<sigma> where \<open>particular_struct_bijection \<Gamma> \<Gamma>' \<sigma>\<close>
    using assms by blast
  then interpret sigma: particular_struct_bijection \<Gamma> \<Gamma>' \<sigma>
    by simp
  interpret inv_sigma_phi:
    particular_struct_endomorphism \<Gamma> \<open>sigma.inv_morph \<circ> \<phi>\<close>
    apply (simp only: particular_struct_endomorphism_def
        ; intro conjI)
    subgoal by unfold_locales
    subgoal
      apply (intro particular_struct_morphism_comp[of _ \<Gamma>'] conjI)
      subgoal by unfold_locales
      using particular_struct_bijection_def particular_struct_injection_def by blast
    done
  have inv_sigma_phi: \<open>sigma.inv_morph \<circ> \<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close>
    using inv_sigma_phi.particular_struct_endomorphism_axioms
    by blast
  have P1: \<open>finite (particulars \<Gamma>')\<close>
    using finite_particulars sigma.morph_bijective[simplified]
    using bij_betw_finite by blast
  then have P2: \<open>card (particulars \<Gamma>') = card \<P>\<close>
    using finite_particulars sigma.morph_bijective[simplified]
    using bij_betw_same_card by fastforce
  have \<open>inj_on \<phi> \<P>\<close>
  proof (rule ccontr)
    assume \<open>\<not> inj_on \<phi> \<P>\<close>
    then obtain x y where
        AA: \<open>x \<in> \<P>\<close> \<open>y \<in> \<P>\<close> \<open>x \<noteq> y\<close> \<open>\<phi> x = \<phi> y\<close>
      by (meson inj_onI)
    obtain \<upsilon> where BB: \<open>particular_struct_endomorphism \<Gamma> \<upsilon>\<close>
        \<open>\<upsilon> x = y\<close> \<open>\<upsilon> y = y\<close>
      using phi.choice[simplified,OF AA(1,2,4)] by metis
    then have CC: \<open>\<upsilon> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close> by blast
    obtain A: \<open>x \<in> \<P>\<^sub>i\<^sub>n\<^sub>d\<close> \<open>y \<in> \<P>\<^sub>i\<^sub>n\<^sub>d\<close>
      using particulars_have_individuality AA by metis
    then obtain B: \<open>\<not> collapsible x\<close> \<open>\<not> collapsible y\<close>
      using particularsWithIndividualityE by blast
    show False
      using B(1)[simplified,rule_format,
        of \<upsilon>,OF AA(1) CC AA(2)] AA(3) BB(2,3) by metis
  qed
  then show ?thesis
    by (unfold_locales  ; simp)
qed

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Consequently, all endomorphisms are bijective and, thus
  are permutation morphisms:
\<close>
text_raw  \<open>\par\<close>

lemma  all_endomorphisms_are_perms: \<open>EndoMorphs\<^bsub>\<Gamma>\<^esub> \<subseteq> Perms\<^bsub>\<Gamma>\<^esub>\<close>
proof (intro subsetI permutations_I ; drule endomorphisms_D)
  fix \<phi>
  assume A: \<open>particular_struct_endomorphism \<Gamma> \<phi>\<close>
  then interpret phi: particular_struct_endomorphism  \<Gamma> \<phi> .
  have B: \<open>\<exists>\<sigma>. particular_struct_bijection \<Gamma> \<Gamma> \<sigma>\<close>
    apply (intro exI[of _ id])
    using particular_struct_permutation_def by blast
  then have C: \<open>particular_struct_injection \<Gamma> \<Gamma> \<phi>\<close>
    using morphism_to_injective phi.particular_struct_morphism_axioms
    by metis
  then have D: \<open>particular_struct_bijection \<Gamma> \<Gamma> \<phi>\<close>
    using mono_to_iso_is_an_iso B by metis
  then interpret phi_iso: particular_struct_bijection \<Gamma> \<Gamma> \<phi> .
  show \<open>particular_struct_permutation \<Gamma> \<phi>\<close>
    by (intro_locales)
qed

end

end


theory LFIs_closure
  imports "logical_consequence" "../conditions/conditions_relativized_infinitary"
begin

section \<open>Logics of Formal Inconsistency (LFIs)\<close>

(**The LFIs are a family of paraconsistent logics featuring a 'consistency' operator @{text "\<^bold>\<circ>"}
that can be used to recover some classical properties of negation (in particular ECQ).
We show a shallow semantical embedding of logics at least as strong as the LFI RmbC-ciw*)

(*Let us assume a concrete type w (for 'worlds' or 'points')*)
typedecl w
(*Let us assume the following primitive unary operation \<C> (intended as a closure operator)*)
consts \<C>::"w \<sigma> \<Rightarrow> w \<sigma>"

(*From the topological cube of opposition:*)
abbreviation "\<I> \<equiv> \<C>\<^sup>d"
abbreviation "\<B> \<equiv> (\<C>\<^sup>f\<^sup>p)\<^sup>d"
lemma "\<C>\<^sup>- = \<B>\<^sup>f\<^sup>p" by (simp add: ofp_comm_dc1 ofp_invol)

(*let us recall that: *)
lemma "EXPN \<C> = CNTR \<B>" using EXPN_CNTR_dual1 EXPN_fp by blast

(**For LFIs we use the negation previously defined as \<C>\<^sup>- = \<B>\<^sup>f\<^sup>p *)
abbreviation cneg ("\<^bold>\<not>_"[70]71) where "cneg \<equiv> \<C>\<^sup>-"

(**In terms of the border operator the negation looks as follows:*)
lemma cneg_char: "EXPN \<C> \<longrightarrow> \<^bold>\<not>A \<approx> \<^bold>\<midarrow>A \<^bold>\<or> (\<B> A)" by (smt (verit, ccfv_SIG) EXPN_def compl_def dimpl_def join_def ofp_comm_dc2 op_fixpoint_def sdfun_dcompl_def setequ_def subset_def)

abbreviation "CLOSURE \<phi> \<equiv> ADDI \<phi> \<and> EXPN \<phi> \<and> NORM \<phi> \<and> IDEM \<phi>"

(**This negation is of course boldly paraconsistent for local consequence.*)
lemma "CLOSURE \<C> \<longrightarrow> [a, \<^bold>\<not>a \<turnstile> b]" nitpick oops (*countermodel*)
lemma "CLOSURE \<C> \<longrightarrow> [a, \<^bold>\<not>a \<turnstile> \<^bold>\<not>b]" nitpick oops (*countermodel*)

(**This negation is boldly paraconsistent for global consequence unless NORM \<C> holds.*)
lemma "[a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" nitpick oops (*countermodel*)
lemma "[a, \<^bold>\<not>a \<turnstile>\<^sub>g \<^bold>\<not>b]" nitpick oops (*countermodel*)
lemma "NORM \<C> \<longrightarrow> [a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" by (metis (mono_tags, opaque_lifting) NORM_def bottom_def compl_def sdfun_dcompl_def setequ_def setequ_ext)
lemma "NORM \<C> \<longrightarrow> [a, \<^bold>\<not>a \<turnstile>\<^sub>g \<^bold>\<not>b]" by (metis (no_types, opaque_lifting) NORM_def bottom_def compl_def dual_compl_char2 op_dual_def setequ_def setequ_ext svfun_compl_def)

(**We define two pairs of in/consistency operators and show how they relate to each other.
Using LFIs terminology, the minimal logic so encoded corresponds to 'RmbC-ciw' (cf. @{cite RLFI}).*)
abbreviation op_inc_a::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<bullet>\<^sup>A_" [57]58) (* \<bullet> as truth-glut *)
  where "\<bullet>\<^sup>AA \<equiv> A \<^bold>\<and> \<^bold>\<not>A"
abbreviation op_con_a::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<^bold>\<circ>\<^sup>A_" [57]58)
  where "\<^bold>\<circ>\<^sup>AA \<equiv> \<^bold>\<midarrow>\<bullet>\<^sup>AA"
abbreviation op_inc_b::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<bullet>\<^sup>B_" [57]58) (* \<bullet> as border *)
  where "\<bullet>\<^sup>BA \<equiv> \<B> A"
abbreviation op_con_b::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<^bold>\<circ>\<^sup>B_" [57]58)
  where "\<^bold>\<circ>\<^sup>BA \<equiv> \<B>\<^sup>c A"

(**Observe that assumming EXPN \<C> are we allowed to exchange A and B variants.*)
lemma pincAB: "EXPN \<C> \<longrightarrow> \<bullet>\<^sup>AA \<approx> \<bullet>\<^sup>BA" by (smt (verit, ccfv_threshold) cneg_char compl_def dimpl_def join_def meet_def op_dual_def op_fixpoint_def sdfun_dcompl_def setequ_def)
lemma pconAB: "EXPN \<C> \<longrightarrow> \<^bold>\<circ>\<^sup>AA \<approx> \<^bold>\<circ>\<^sup>BA" by (metis pincAB setequ_ext svfun_compl_def)

(**Variants A and B give us slightly different properties (there are countermodels for those not shown).*)
lemma Prop1: "\<^bold>\<circ>\<^sup>BA \<approx> \<I>\<^sup>f\<^sup>p A" by (simp add: dual_compl_char1 ofp_comm_dc1 setequ_ext)
lemma Prop2: "\<^bold>\<circ>\<^sup>AA \<approx> A \<^bold>\<rightarrow> \<I> A" by (simp add: BA_deMorgan2 impl_char op_dual_def sdfun_dcompl_def)
lemma Prop3: "fp \<C> A \<longleftrightarrow> \<^bold>\<circ>\<^sup>B\<^bold>\<midarrow>A \<approx> \<^bold>\<top>" by (metis Prop1 dual_invol fp_d_rel setequ_ext)
lemma Prop4a: "fp \<I> A \<longleftrightarrow> \<^bold>\<circ>\<^sup>BA \<approx> \<^bold>\<top>" by (simp add: dual_compl_char1 fp_rel ofp_comm_dc1)
lemma Prop4b: "fp \<I> A  \<longrightarrow> \<^bold>\<circ>\<^sup>AA \<approx> \<^bold>\<top>" by (metis BA_impl L13 L4 Prop2 fixpoints_def setequ_ext)

(**The 'principle of gentle explosion' works for both variants (both locally and globally)*)
lemma "[\<^bold>\<circ>\<^sup>Aa, a, \<^bold>\<not>a \<turnstile> b]" by (metis (mono_tags, lifting) compl_def meet_def subset_def)
lemma "[\<^bold>\<circ>\<^sup>Aa, a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" by (metis compl_def meet_def)
lemma "[\<^bold>\<circ>\<^sup>Ba, a, \<^bold>\<not>a \<turnstile> b]" by (smt (verit) compl_def dimpl_def dual_compl_char1 meet_def op_fixpoint_def sdfun_dcompl_def subset_def)
lemma "[\<^bold>\<circ>\<^sup>Ba, a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" by (metis ofp_comm_dc2 ofp_fixpoint_compl_def sdiff_def)

(**We show how all (local) contraposition variants (among others) can be recovered using the
 consistency operators.*)

lemma cons_lcop1: "EXPN \<C> \<longrightarrow> [\<^bold>\<circ>\<^sup>Ab, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" by (smt (verit) cneg_char compl_def impl_def join_def meet_def setequ_ext subset_def)
lemma "[\<^bold>\<circ>\<^sup>Bb, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" nitpick oops
lemma cons_lcop2: "EXPN \<C> \<longrightarrow> [\<^bold>\<circ>\<^sup>Bb, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" by (metis cons_lcop1 pconAB setequ_ext)
(*.....*)

(**The following axioms are commonly employed in the literature on LFIs to obtain stronger logics.
We explore under which conditions they can be assumed while keeping the logic boldly paraconsistent.*)
abbreviation cf where "cf \<equiv> \<forall>P. [\<^bold>\<not>\<^bold>\<not>P \<turnstile> P]"
abbreviation ce where "ce \<equiv> \<forall>P. [P \<turnstile> \<^bold>\<not>\<^bold>\<not>P]"
abbreviation ciw_a where "ciw_a \<equiv> \<forall>P. [\<turnstile> \<^bold>\<circ>\<^sup>AP \<^bold>\<or> \<bullet>\<^sup>AP]"
abbreviation ciw_b where "ciw_b \<equiv> \<forall>P. [\<turnstile> \<^bold>\<circ>\<^sup>BP \<^bold>\<or> \<bullet>\<^sup>BP]"
abbreviation ci_a  where  "ci_a \<equiv> \<forall>P. [\<^bold>\<not>(\<^bold>\<circ>\<^sup>AP) \<turnstile> \<bullet>\<^sup>AP]"
abbreviation ci_b  where  "ci_b \<equiv> \<forall>P. [\<^bold>\<not>(\<^bold>\<circ>\<^sup>BP) \<turnstile> \<bullet>\<^sup>BP]"
abbreviation cl_a  where  "cl_a \<equiv> \<forall>P.  [\<^bold>\<not>(\<bullet>\<^sup>AP) \<turnstile> \<^bold>\<circ>\<^sup>AP]"
abbreviation cl_b  where  "cl_b \<equiv> \<forall>P.  [\<^bold>\<not>(\<bullet>\<^sup>BP) \<turnstile> \<^bold>\<circ>\<^sup>BP]"
abbreviation ca_conj_a where "ca_conj_a \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>AP,\<^bold>\<circ>\<^sup>AQ \<turnstile> \<^bold>\<circ>\<^sup>A(P \<^bold>\<and> Q)]"
abbreviation ca_conj_b where "ca_conj_b \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>BP,\<^bold>\<circ>\<^sup>BQ \<turnstile> \<^bold>\<circ>\<^sup>B(P \<^bold>\<and> Q)]"
abbreviation ca_disj_a where "ca_disj_a \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>AP,\<^bold>\<circ>\<^sup>AQ \<turnstile> \<^bold>\<circ>\<^sup>A(P \<^bold>\<or> Q)]"
abbreviation ca_disj_b where "ca_disj_b \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>BP,\<^bold>\<circ>\<^sup>BQ \<turnstile> \<^bold>\<circ>\<^sup>B(P \<^bold>\<or> Q)]"
abbreviation ca_impl_a where "ca_impl_a \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>AP,\<^bold>\<circ>\<^sup>AQ \<turnstile> \<^bold>\<circ>\<^sup>A(P \<^bold>\<rightarrow> Q)]"
abbreviation ca_impl_b where "ca_impl_b \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>BP,\<^bold>\<circ>\<^sup>BQ \<turnstile> \<^bold>\<circ>\<^sup>B(P \<^bold>\<rightarrow> Q)]"
abbreviation ca_a where "ca_a \<equiv> ca_conj_a \<and> ca_disj_a \<and> ca_impl_a"
abbreviation ca_b where "ca_b \<equiv> ca_conj_b \<and> ca_disj_b \<and> ca_impl_b"

(**cf*)
lemma "CLOSURE \<C> \<Longrightarrow> cf" nitpick oops (*countermodel*)

(**ce*)
lemma "CLOSURE \<C> \<Longrightarrow> ce" nitpick oops (*countermodel*)

(**ciw*)
lemma prop_ciw_a: "ciw_a" by (simp add: conn)
lemma prop_ciw_b: "ciw_b" by (simp add: conn svfun_compl_def)

(**ci*)
lemma "CLOSURE \<C> \<Longrightarrow> ci_a" nitpick oops (*countermodel*)
lemma "CLOSURE \<C> \<Longrightarrow> ci_b" nitpick oops (*countermodel*)

(**cl*)
lemma "CLOSURE \<C> \<Longrightarrow> cl_a" nitpick oops (*countermodel*)
lemma "CLOSURE \<C> \<Longrightarrow> cl_b" nitpick oops (*countermodel*)

(**ca_conj*)
lemma prop_ca_conj_b: "EXPN \<C> \<Longrightarrow> ADDI\<^sup>a \<C> = ca_conj_b" by (metis ADDIa_MULTb_dual2 ADDIr_a_cmpl ADDIr_a_equ' ADDIr_a_fpc EXPN_fpc MULT_b_def dual_compl_char1 dual_compl_char2 dual_invol nADDIa_compl nADDIr_a_equ' nEXPN_CNTR_compl)
lemma prop_ca_conj_a: "ADDIr\<^sup>a \<C> = ca_conj_a" (*nitpick*) oops (*TODO: verify*)

(**ca_disj*)
lemma prop_ca_disj_b: "EXPN \<C> \<Longrightarrow> ADDI\<^sup>b \<C> = ca_disj_b" (*nitpick*) oops (*TODO: verify*)
lemma prop_ca_disj_a: "ADDIr\<^sup>b \<C> = ca_disj_a" (*nitpick*) oops (*TODO: verify*)

(**ca_impl*)
lemma "CLOSURE \<C> \<Longrightarrow> ca_impl_a" nitpick oops (*countermodel*)
lemma "CLOSURE \<C> \<Longrightarrow> ca_impl_b" nitpick oops (*countermodel*)

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Agent
  imports Nominal
begin

atom_decl name

nominal_datatype act = actAction name      ("\<lparr>_\<rparr>" 100)
                     | actCoAction name    ("\<langle>_\<rangle>" 100)
                     | actTau              ("\<tau>" 100)

nominal_datatype ccs = CCSNil           ("\<zero>" 115)
                     | Action act ccs   ("_._" [120, 110] 110)
                     | Sum ccs ccs      (infixl "\<oplus>" 90)
                     | Par ccs ccs      (infixl "\<parallel>" 85)
                     | Res "\<guillemotleft>name\<guillemotright> ccs" ("\<lparr>\<nu>_\<rparr>_" [105, 100] 100)
                     | Bang ccs         ("!_" [95])

nominal_primrec coAction :: "act \<Rightarrow> act"
where
  "coAction (\<lparr>a\<rparr>) = (\<langle>a\<rangle>)"
| "coAction (\<langle>a\<rangle>)= (\<lparr>a\<rparr>)"
| "coAction (\<tau>) = \<tau>"
by(rule TrueI)+

lemma coActionEqvt[eqvt]:
  fixes p :: "name prm"
  and   a :: act

  shows "(p \<bullet> coAction a) = coAction(p \<bullet> a)"
by(nominal_induct a rule: act.strong_induct) (auto simp add: eqvts)

lemma coActionSimps[simp]:
  fixes a :: act

  shows "coAction(coAction a) = a"
  and   "(coAction a = \<tau>) = (a = \<tau>)"
by auto (nominal_induct rule: act.strong_induct, auto)+

lemma coActSimp[simp]: shows "coAction \<alpha> \<noteq> \<tau> = (\<alpha> \<noteq> \<tau>)" and "(coAction \<alpha> = \<tau>) = (\<alpha> = \<tau>)"
by(nominal_induct \<alpha> rule: act.strong_induct) auto

lemma coActFresh[simp]:
  fixes x :: name
  and   a :: act

  shows "x \<sharp> coAction a = x \<sharp> a"
by(nominal_induct a rule: act.strong_induct) (auto)

lemma alphaRes:
  fixes y :: name
  and   P :: ccs
  and   x :: name

  assumes "y \<sharp> P"

  shows "\<lparr>\<nu>x\<rparr>P = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P)"
using assms
by(auto simp add: ccs.inject alpha fresh_left calc_atm pt_swap_bij[OF pt_name_inst, OF at_name_inst]pt3[OF pt_name_inst, OF at_ds1[OF at_name_inst]])

inductive semantics :: "ccs \<Rightarrow> act \<Rightarrow> ccs \<Rightarrow> bool"    ("_ \<longmapsto>_ \<prec> _" [80, 80, 80] 80)
where
  Action:   "\<alpha>.(P) \<longmapsto>\<alpha> \<prec> P"
| Sum1:     "P \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> P \<oplus> Q \<longmapsto>\<alpha> \<prec> P'"
| Sum2:     "Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> P \<oplus> Q \<longmapsto>\<alpha> \<prec> Q'"
| Par1:     "P \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> P \<parallel> Q \<longmapsto>\<alpha> \<prec> P' \<parallel> Q"
| Par2:     "Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> P \<parallel> Q \<longmapsto>\<alpha> \<prec> P \<parallel> Q'"
| Comm:     "\<lbrakk>P \<longmapsto>a \<prec> P'; Q \<longmapsto>(coAction a) \<prec> Q'; a \<noteq> \<tau>\<rbrakk> \<Longrightarrow> P \<parallel> Q \<longmapsto>\<tau> \<prec> P' \<parallel> Q'"
| Res:      "\<lbrakk>P \<longmapsto>\<alpha> \<prec> P'; x \<sharp> \<alpha>\<rbrakk> \<Longrightarrow> \<lparr>\<nu>x\<rparr>P \<longmapsto>\<alpha> \<prec> \<lparr>\<nu>x\<rparr>P'"
| Bang:     "P \<parallel> !P \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> !P \<longmapsto>\<alpha> \<prec> P'"

equivariance semantics

nominal_inductive semantics
by(auto simp add: abs_fresh)

lemma semanticsInduct:
"\<lbrakk>R \<longmapsto>\<beta> \<prec> R'; \<And>\<alpha> P \<C>. Prop \<C> (\<alpha>.(P)) \<alpha> P;
 \<And>P \<alpha> P' Q \<C>. \<lbrakk>P \<longmapsto>\<alpha> \<prec> P'; \<And>\<C>. Prop \<C> P \<alpha> P'\<rbrakk> \<Longrightarrow> Prop \<C> (ccs.Sum P Q) \<alpha> P';
 \<And>Q \<alpha> Q' P \<C>. \<lbrakk>Q \<longmapsto>\<alpha> \<prec> Q'; \<And>\<C>. Prop \<C> Q \<alpha> Q'\<rbrakk> \<Longrightarrow> Prop \<C> (ccs.Sum P Q) \<alpha> Q';
 \<And>P \<alpha> P' Q \<C>. \<lbrakk>P \<longmapsto>\<alpha> \<prec> P'; \<And>\<C>. Prop \<C> P \<alpha> P'\<rbrakk> \<Longrightarrow> Prop \<C> (P \<parallel> Q) \<alpha> (P' \<parallel> Q);
 \<And>Q \<alpha> Q' P \<C>. \<lbrakk>Q \<longmapsto>\<alpha> \<prec> Q'; \<And>\<C>. Prop \<C> Q \<alpha> Q'\<rbrakk> \<Longrightarrow> Prop \<C> (P \<parallel> Q) \<alpha> (P \<parallel> Q');
 \<And>P a P' Q Q' \<C>.
    \<lbrakk>P \<longmapsto>a \<prec> P'; \<And>\<C>. Prop \<C> P a P'; Q \<longmapsto>(coAction a) \<prec> Q';
     \<And>\<C>. Prop \<C> Q (coAction a) Q'; a \<noteq> \<tau>\<rbrakk>
    \<Longrightarrow> Prop \<C> (P \<parallel> Q) (\<tau>) (P' \<parallel> Q');
 \<And>P \<alpha> P' x \<C>.
    \<lbrakk>x \<sharp> \<C>; P \<longmapsto>\<alpha> \<prec> P'; \<And>\<C>. Prop \<C> P \<alpha> P'; x \<sharp> \<alpha>\<rbrakk> \<Longrightarrow> Prop \<C> (\<lparr>\<nu>x\<rparr>P) \<alpha> (\<lparr>\<nu>x\<rparr>P');
 \<And>P \<alpha> P' \<C>. \<lbrakk>P \<parallel> !P \<longmapsto>\<alpha> \<prec> P'; \<And>\<C>. Prop \<C> (P \<parallel> !P) \<alpha> P'\<rbrakk> \<Longrightarrow> Prop \<C> !P \<alpha> P'\<rbrakk>

\<Longrightarrow> Prop (\<C>::'a::fs_name) R \<beta> R'"
by(erule_tac z=\<C> in semantics.strong_induct) auto

lemma NilTrans[dest]:
  shows "\<zero> \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> False"
  and   "(\<lparr>b\<rparr>).P \<longmapsto>\<langle>c\<rangle> \<prec> P' \<Longrightarrow> False"
  and   "(\<lparr>b\<rparr>).P \<longmapsto>\<tau> \<prec> P' \<Longrightarrow> False"
  and   "(\<langle>b\<rangle>).P \<longmapsto>\<lparr>c\<rparr> \<prec> P' \<Longrightarrow> False"
  and   "(\<langle>b\<rangle>).P \<longmapsto>\<tau> \<prec> P' \<Longrightarrow> False"
apply(ind_cases "\<zero> \<longmapsto>\<alpha> \<prec> P'")
apply(ind_cases "(\<lparr>b\<rparr>).P \<longmapsto>\<langle>c\<rangle> \<prec> P'", auto simp add: ccs.inject)
apply(ind_cases "(\<lparr>b\<rparr>).P \<longmapsto>\<tau> \<prec> P'", auto simp add: ccs.inject)
apply(ind_cases "(\<langle>b\<rangle>).P \<longmapsto>\<lparr>c\<rparr> \<prec> P'", auto simp add: ccs.inject)
apply(ind_cases "(\<langle>b\<rangle>).P \<longmapsto>\<tau> \<prec> P'", auto simp add: ccs.inject)
done

lemma freshDerivative:
  fixes P  :: ccs
  and   a  :: act
  and   P' :: ccs
  and   x  :: name

  assumes "P \<longmapsto>\<alpha> \<prec> P'"
  and     "x \<sharp> P"

  shows "x \<sharp> \<alpha>" and "x \<sharp> P'"
using assms
by(nominal_induct rule: semantics.strong_induct)
  (auto simp add: ccs.fresh abs_fresh)

lemma actCases[consumes 1, case_names cAct]:
  fixes \<alpha>  :: act
  and   P  :: ccs
  and   \<beta>  :: act
  and   P' :: ccs

  assumes "\<alpha>.(P) \<longmapsto>\<beta> \<prec> P'"
  and     "Prop \<alpha> P"

  shows "Prop \<beta> P'"
using assms
by - (ind_cases "\<alpha>.(P) \<longmapsto>\<beta> \<prec> P'", auto simp add: ccs.inject)

lemma sumCases[consumes 1, case_names cSum1 cSum2]:
  fixes P :: ccs
  and   Q :: ccs
  and   \<alpha> :: act
  and   R :: ccs

  assumes "P \<oplus> Q \<longmapsto>\<alpha> \<prec> R"
  and     "\<And>P'. P \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> Prop P'"
  and     "\<And>Q'. Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> Prop Q'"

  shows "Prop R"
using assms
by - (ind_cases "P \<oplus> Q \<longmapsto>\<alpha> \<prec> R", auto simp add: ccs.inject)

lemma parCases[consumes 1, case_names cPar1 cPar2 cComm]:
  fixes P :: ccs
  and   Q :: ccs
  and   a :: act
  and   R :: ccs

  assumes "P \<parallel> Q \<longmapsto>\<alpha> \<prec> R"
  and     "\<And>P'. P \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> Prop \<alpha> (P' \<parallel> Q)"
  and     "\<And>Q'. Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> Prop \<alpha> (P \<parallel> Q')"
  and     "\<And>P' Q' a. \<lbrakk>P \<longmapsto>a \<prec> P'; Q \<longmapsto>(coAction a) \<prec> Q'; a \<noteq> \<tau>; \<alpha> = \<tau>\<rbrakk> \<Longrightarrow> Prop (\<tau>) (P' \<parallel> Q')"

  shows "Prop \<alpha> R"
using assms
by - (ind_cases "P \<parallel> Q \<longmapsto>\<alpha> \<prec> R", auto simp add: ccs.inject)

lemma resCases[consumes 1, case_names cRes]:
  fixes x  :: name
  and   P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs

  assumes "\<lparr>\<nu>x\<rparr>P \<longmapsto>\<alpha> \<prec> P'"
  and     "\<And>P'. \<lbrakk>P \<longmapsto>\<alpha> \<prec> P'; x \<sharp> \<alpha>\<rbrakk> \<Longrightarrow> Prop (\<lparr>\<nu>x\<rparr>P')"

  shows "Prop P'"
proof -
  from `\<lparr>\<nu>x\<rparr>P \<longmapsto>\<alpha> \<prec> P'` have "x \<sharp> \<alpha>" and "x \<sharp> P'"
    by(auto intro: freshDerivative simp add: abs_fresh)+
  with assms show ?thesis
    by(cases rule: semantics.strong_cases[of _ _ _ _ x])
      (auto simp add: abs_fresh ccs.inject alpha)
qed

inductive bangPred :: "ccs \<Rightarrow> ccs \<Rightarrow> bool"
where
  aux1: "bangPred P (!P)"
| aux2: "bangPred P (P \<parallel> !P)"

lemma bangInduct[consumes 1, case_names cPar1 cPar2 cComm cBang]:
  fixes P  :: ccs
  and   \<alpha>  :: act
  and   P' :: ccs
  and   \<C>  :: "'a::fs_name"

  assumes "!P \<longmapsto>\<alpha> \<prec> P'"
  and     rPar1: "\<And>\<alpha> P' \<C>. \<lbrakk>P \<longmapsto>\<alpha> \<prec> P'\<rbrakk> \<Longrightarrow> Prop \<C> (P \<parallel> !P) \<alpha> (P' \<parallel> !P)"
  and     rPar2: "\<And>\<alpha> P' \<C>. \<lbrakk>!P \<longmapsto>\<alpha> \<prec> P'; \<And>\<C>. Prop \<C> (!P) \<alpha> P'\<rbrakk> \<Longrightarrow> Prop \<C> (P \<parallel> !P) \<alpha> (P \<parallel> P')"
  and     rComm: "\<And>a P' P'' \<C>. \<lbrakk>P \<longmapsto>a \<prec> P'; !P \<longmapsto>(coAction a) \<prec> P''; \<And>\<C>. Prop \<C> (!P) (coAction a) P''; a \<noteq> \<tau>\<rbrakk> \<Longrightarrow> Prop \<C> (P \<parallel> !P) (\<tau>) (P' \<parallel> P'')"
  and     rBang: "\<And>\<alpha> P' \<C>. \<lbrakk>P \<parallel> !P \<longmapsto>\<alpha> \<prec> P'; \<And>\<C>. Prop \<C> (P \<parallel> !P) \<alpha> P'\<rbrakk> \<Longrightarrow> Prop \<C> (!P) \<alpha> P'"

  shows "Prop \<C> (!P) \<alpha> P'"
proof -
  {
    fix X \<alpha> P'
    assume "X \<longmapsto>\<alpha> \<prec> P'" and "bangPred P X"
    hence "Prop \<C> X \<alpha> P'"
    proof(nominal_induct avoiding: \<C> rule: semantics.strong_induct)
      case(Action \<alpha> Pa)
      thus ?case
        by - (ind_cases "bangPred P (\<alpha>.(Pa))")
    next
      case(Sum1 Pa \<alpha> P' Q)
      thus ?case
        by - (ind_cases "bangPred P (Pa \<oplus> Q)")
    next
      case(Sum2 Q \<alpha> Q' Pa)
      thus ?case
        by - (ind_cases "bangPred P (Pa \<oplus> Q)")
    next
      case(Par1 Pa \<alpha> P' Q)
      thus ?case
        apply -
        by(ind_cases "bangPred P (Pa \<parallel> Q)", auto intro: rPar1 simp add: ccs.inject)
    next
      case(Par2 Q \<alpha> P' Pa)
      thus ?case
        apply -
        by(ind_cases "bangPred P (Pa \<parallel> Q)", auto intro: rPar2 aux1 simp add: ccs.inject)
    next
      case(Comm Pa a P' Q Q' C)
      thus ?case
        apply -
        by(ind_cases "bangPred P (Pa \<parallel> Q)", auto intro: rComm aux1 simp add: ccs.inject)
    next
      case(Res Pa \<alpha> P' x)
      thus ?case
        by - (ind_cases "bangPred P (\<lparr>\<nu>x\<rparr>Pa)")
    next
      case(Bang Pa \<alpha> P')
      thus ?case
        apply -
        by(ind_cases "bangPred P (!Pa)", auto intro: rBang aux2 simp add: ccs.inject)
    qed
  }
  with `!P \<longmapsto>\<alpha> \<prec> P'` show ?thesis by(force intro: bangPred.aux1)
qed

inductive_set bangRel :: "(ccs \<times> ccs) set \<Rightarrow> (ccs \<times> ccs) set"
for Rel :: "(ccs \<times> ccs) set"
where
  BRBang: "(P, Q) \<in> Rel \<Longrightarrow> (!P, !Q) \<in> bangRel Rel"
| BRPar: "(R, T) \<in> Rel \<Longrightarrow> (P, Q) \<in> (bangRel Rel) \<Longrightarrow> (R \<parallel> P, T \<parallel> Q) \<in> (bangRel Rel)"

lemma BRBangCases[consumes 1, case_names BRBang]:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   F   :: "ccs \<Rightarrow> bool"

  assumes "(P, !Q) \<in> bangRel Rel"
  and     "\<And>P. (P, Q) \<in> Rel \<Longrightarrow> F (!P)"

  shows "F P"
using assms
by - (ind_cases "(P, !Q) \<in> bangRel Rel", auto simp add: ccs.inject)

lemma BRParCases[consumes 1, case_names BRPar]:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"
  and   F   :: "ccs \<Rightarrow> bool"

  assumes "(P, Q \<parallel> !Q) \<in> bangRel Rel"
  and     "\<And>P R. \<lbrakk>(P, Q) \<in> Rel; (R, !Q) \<in> bangRel Rel\<rbrakk> \<Longrightarrow> F (P \<parallel> R)"

  shows "F P"
using assms
by - (ind_cases "(P, Q \<parallel> !Q) \<in> bangRel Rel", auto simp add: ccs.inject)

lemma bangRelSubset:
  fixes Rel  :: "(ccs \<times> ccs) set"
  and   Rel' :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> bangRel Rel"
  and     "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> (P, Q) \<in> Rel'"

  shows "(P, Q) \<in> bangRel Rel'"
using assms
by(induct rule:  bangRel.induct) (auto intro: BRBang BRPar)

end


section \<open>Renamings for Singletape Turing Machines\<close>

theory STM_Renaming
  imports
    Singletape_TM
begin

locale renaming_of_singletape_tm = singletape_tm Q \<Sigma> \<Gamma> blank LE \<delta> s t r
  for Q :: "'q set" and \<Sigma> :: "'a set" and \<Gamma> blank LE \<delta> s t r
    + fixes ra :: "'a \<Rightarrow> 'b"    (* renaming of tape symbols *)
    and rq :: "'q \<Rightarrow> 'p"    (* renaming of states *)
  assumes ra: "inj_on ra \<Gamma>"
    and rq: "inj_on rq Q"
begin

abbreviation rd where "rd \<equiv> map_prod rq (map_prod ra (map_prod rq (map_prod ra (\<lambda> d :: dir. d))))"

sublocale ren: singletape_tm "rq ` Q" "ra ` \<Sigma>" "ra ` \<Gamma>" "ra blank" "ra LE" "rd ` \<delta>" "rq s" "rq t" "rq r"
proof (unfold_locales; (intro finite_imageI imageI image_mono fin_Q fin_\<Gamma> tm sQ tQ rQ)?)
  show "ra LE \<notin> ra ` \<Sigma>" using ra tm LE by (simp add: inj_on_image_mem_iff)
  show "ra blank \<notin> ra ` \<Sigma>" using ra tm blank by (simp add: inj_on_image_mem_iff)
  show "rq t \<noteq> rq r" using rq tQ rQ tr by (metis inj_on_contraD)
  show "rd ` \<delta> \<subseteq> (rq ` Q - {rq t, rq r}) \<times> ra ` \<Gamma> \<times> rq ` Q \<times> ra ` \<Gamma> \<times> UNIV"
    using \<delta>_set tQ rQ rq by (auto simp: inj_on_def)
  fix p1 p2 b2 d
  assume "(p1, ra LE, p2, b2, d) \<in> rd ` \<delta>"
  then obtain q1 q2 a1 a2 where mem: "(q1, a1, q2, a2, d) \<in> \<delta>" and
    id: "p1 = rq q1" "ra LE = ra a1" "p2 = rq q2" "b2 = ra a2" by auto
  from \<delta>[OF mem] id(2) LE ra have "a1 = LE" by (simp add: inj_onD)
  with \<delta>LE[OF mem[unfolded this]]
  show "b2 = ra LE \<and> d \<in> {dir.N, dir.R}" unfolding id by auto
qed

fun rc :: "('a, 'q) st_config \<Rightarrow> ('b, 'p) st_config" where
  "rc (Config\<^sub>S q tc pos) = Config\<^sub>S (rq q) (ra o tc) pos"

lemma ren_init: "rc (init_config w) = ren.init_config (map ra w)"
  unfolding init_config_def ren.init_config_def rc.simps
  by auto

lemma ren_step: assumes "(c,c') \<in> step"
  shows "(rc c, rc c') \<in> ren.step"
  using assms
proof (cases rule: step.cases)
  case (step q ts n q' a dir)
  from step(3) have mem: "(rq q, ra (ts n), rq q', ra a, dir) \<in> rd ` \<delta>" by force
  show ?thesis unfolding step rc.simps
    by (intro ren.stepI[OF mem], auto)
qed

lemma ren_steps: assumes "(c,c') \<in> step^*"
  shows "(rc c, rc c') \<in> ren.step^*"
  using assms by (induct, insert ren_step, force+)

lemma ren_steps_count: assumes "(c,c') \<in> step^^n"
  shows "(rc c, rc c') \<in> ren.step^^n"
  using assms by (induct n arbitrary: c c', insert ren_step, force+)

lemma ren_Lang_forward: assumes "w \<in> Lang"
  shows "map ra w \<in> ren.Lang"
proof -
  from assms[unfolded Lang_def, simplified]
  obtain w' n where w: "set w \<subseteq> \<Sigma>" and steps: "(init_config w, Config\<^sub>S t w' n) \<in> step^*"
    by auto
  from ren_steps[OF steps, unfolded ren_init, unfolded rc.simps] w
  show "map ra w \<in> ren.Lang" unfolding ren.Lang_def by auto
qed

abbreviation ira where "ira \<equiv> the_inv_into \<Gamma> ra"
abbreviation irq where "irq \<equiv> the_inv_into Q rq"

interpretation inv: renaming_of_singletape_tm "rq ` Q" "ra ` \<Sigma>" "ra ` \<Gamma>" "ra blank" "ra LE" "rd ` \<delta>" "rq s" "rq t" "rq r" ira irq
  by (unfold_locales, insert ra rq inj_on_the_inv_into, auto)

lemmas inv_simps[simp] = the_inv_into_f_f[OF ra] the_inv_into_f_f[OF rq]

lemma inv_ren_Sigma: "ira ` ra ` \<Sigma> = \<Sigma>" using inv_simps(1)[OF set_mp[OF \<Sigma>_sub_\<Gamma>]]
  by (smt (verit, best) equalityI imageE image_subset_iff subsetI)

lemma inv_ren_Gamma: "ira ` ra ` \<Gamma> = \<Gamma>" using inv_simps(1)
  by (smt (verit, best) equalityI imageE image_subset_iff subsetI)

lemma inv_ren_t: "irq (rq t) = t" using tQ by simp
lemma inv_ren_s: "irq (rq s) = s" using sQ by simp
lemma inv_ren_r: "irq (rq r) = r" using rQ by simp
lemma inv_ren_blank: "ira (ra blank) = blank" using tm by simp
lemma inv_ren_LE: "ira (ra LE) = LE" using tm by simp

lemma inv_ren_\<delta>: "inv.rd ` rd ` \<delta> = \<delta>"
proof -
  {
    fix trans :: "('q \<times> 'a \<times> 'q \<times> 'a \<times> dir)"
    obtain q a p b d where trans: "trans = (q,a,p,b,d)" by (cases trans, auto)
    {
      assume t: "trans \<in> \<delta>"
      note mem = \<delta>[OF this[unfolded trans]]
      from t have "inv.rd (rd trans) \<in> inv.rd ` rd ` \<delta>" by blast
      also have "inv.rd (rd trans) = trans" unfolding trans using mem by auto
      finally have "trans \<in> inv.rd ` rd ` \<delta>" .
    }
    moreover
    {
      assume t: "trans \<in> inv.rd ` rd ` \<delta>"
      then obtain t' where t'd: "t' \<in> \<delta>" and tra: "trans = inv.rd (rd t')" by auto
      obtain q' a' p' b' d' where t': "t' = (q',a',p',b',d')" by (cases t', auto)
      note mem = \<delta>[OF t'd[unfolded t']]
      from tra[unfolded trans t'] mem
      have id: "q' = q" "a' = a" "p' = p" "b' = b" "d' = d" by auto
      with trans t'd t' have "trans \<in> \<delta>" by auto
    }
    ultimately have "trans \<in> inv.rd ` rd ` \<delta> \<longleftrightarrow> trans \<in> \<delta>" by blast
  }
  thus ?thesis by blast
qed

lemmas inv_ren = inv_ren_t inv_ren_s inv_ren_r inv_ren_\<delta> inv_ren_Gamma inv_ren_Sigma inv_ren_blank inv_ren_LE

lemma inv_ren_Lang: "inv.ren.Lang = Lang" unfolding inv_ren ..

lemma ren_Lang_backward: assumes "v \<in> ren.Lang"
  shows "\<exists> w. v = map ra w \<and> w \<in> Lang"
proof (intro exI conjI)
  let ?w = "map ira v"
  from inv.ren_Lang_forward[OF assms, unfolded inv_ren_Lang]
  show "?w \<in> Lang" .
  show "v = map ra ?w" unfolding map_map o_def
  proof (subst map_idI)
    fix b
    assume "b \<in> set v"
    with assms[unfolded ren.Lang_def] \<Sigma>_sub_\<Gamma> obtain a where a: "a \<in> \<Gamma>" and b: "b = ra a" by blast
    show "ra (ira b) = b" unfolding b using a by simp
  qed auto
qed

lemma ren_Lang: "ren.Lang = map ra ` Lang"
proof
  show "map ra ` Lang \<subseteq> ren.Lang" using ren_Lang_forward by blast
  show "ren.Lang \<subseteq> map ra ` Lang" using ren_Lang_backward by blast
qed

lemma ren_det: assumes "deterministic"
  shows "ren.deterministic"
  unfolding ren.deterministic_def
proof (intro allI impI, goal_cases)
  case (1 q a p1 b1 d1 p2 b2 d2)
  let ?t1 = "(q, a, p1, b1, d1)"
  let ?t2 = "(q, a, p2, b2, d2)"
  from 1 have t1: "inv.rd ?t1 \<in> inv.rd ` rd ` \<delta>" by force
  from 1 have t2: "inv.rd ?t2 \<in> inv.rd ` rd ` \<delta>" by force
  from t1 t2 have "(irq q, ira a, irq p1, ira b1, d1) \<in> \<delta>"  "(irq q, ira a, irq p2, ira b2, d2) \<in> \<delta>"
    unfolding inv_ren by auto
  from assms[unfolded deterministic_def, rule_format, OF this]
  have id: "irq p1 = irq p2" "ira b1 = ira b2" and d: "d1 = d2" by auto
  from inj_onD[OF inv.rq id(1)] ren.\<delta>[OF 1(1)] ren.\<delta>[OF 1(2)]
  have p: "p1 = p2" by auto
  from inj_onD[OF inv.ra id(2)] ren.\<delta>[OF 1(1)] ren.\<delta>[OF 1(2)]
  have b: "b1 = b2" by auto
  show ?case unfolding b p d by simp
qed

lemma ren_upper_time: assumes "upper_time_bound f"
  shows "ren.upper_time_bound f"
  unfolding ren.upper_time_bound_def
proof (intro allI impI)
  fix w c n
  assume w: "set w \<subseteq> ra ` \<Sigma>" and steps: "(ren.init_config w, c) \<in> ren.step ^^ n"
  define v where "v = map ira w"
  from w have v: "set v \<subseteq> \<Sigma>" unfolding v_def
    using inv_ren_Sigma by fastforce
  from inv.ren_steps_count[OF steps]
  have "(inv.rc (ren.init_config w), inv.rc c) \<in> inv.ren.step ^^ n" .
  also have "inv.ren.step = step" using inv_ren_\<delta> by presburger
  also have "inv.rc (ren.init_config w) = init_config v" unfolding v_def using v w
    by (simp add: inv.ren_init inv_ren_LE inv_ren_blank inv_ren_s)
  finally have "(init_config v, inv.rc c) \<in> step ^^ n" .
  with assms[unfolded upper_time_bound_def] v have "n \<le> f (length v)" by simp
  thus "n \<le> f (length w)" unfolding v_def by auto
qed

end

lemma tm_renaming: assumes "valid_tm (tm :: ('q,'a)tm)"
  and "inj_on (ra :: 'a \<Rightarrow> 'b) (\<Gamma>_tm tm)"
  and "inj_on (rq :: 'q \<Rightarrow> 'p) (Q_tm tm)"
shows "\<exists> tm' :: ('p,'b)tm.
  valid_tm tm' \<and>
  Lang_tm tm' = map ra ` Lang_tm tm \<and>
  (det_tm tm \<longrightarrow> det_tm tm') \<and>
  (\<forall> f. upperb_time_tm tm f \<longrightarrow> upperb_time_tm tm' f)"
proof (cases tm)
  case (TM Q \<Sigma> \<Gamma> bl le \<delta> s t r)
  with assms interpret singletape_tm Q \<Sigma> \<Gamma> bl le \<delta> s t r by auto
  interpret renaming_of_singletape_tm Q \<Sigma> \<Gamma> bl le \<delta> s t r ra rq
    by (unfold_locales, insert assms TM, auto)
  let ?tm' = "TM (rq ` Q) (ra ` \<Sigma>) (ra ` \<Gamma>) (ra bl) (ra le) (rd ` \<delta>) (rq s) (rq t) (rq r)"
  show ?thesis
    by (rule exI[where x = ?tm'])
       (simp add: TM ren.singletape_tm_axioms ren_Lang ren_det ren_upper_time)
qed

end


(*
  Title:    Preference_Profiles_Cmd.thy
  Author:   Manuel Eberl, TU München

  Provides the preference_profile command that defines preference profiles,
  proves well-formedness, and provides some useful lemmas for them.
*)

section \<open>Automatic definition of Preference Profiles\<close>

theory Preference_Profile_Cmd
imports
  Complex_Main
  "../Elections"
keywords
  "preference_profile" :: thy_goal
begin

ML_file \<open>preference_profiles.ML\<close>

context election
begin

lemma preferred_alts_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs" "i \<in> set (map fst xs)"
  shows   "preferred_alts (prefs_from_table xs i) x =
             of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x"
proof -
  interpret pref_profile_wf agents alts "prefs_from_table xs"
    by (intro pref_profile_from_tableI assms)
  from assms have [simp]: "i \<in> agents" by (auto simp: prefs_from_table_wf_def)
  have "of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x =
          Collect (of_weak_ranking (the (map_of xs i)) x)"
    by (rule eval_Collect_of_weak_ranking [symmetric])
  also from assms(2) have "the (map_of xs i) \<in> set (map snd xs)"
    by (cases "map_of xs i") (force simp: map_of_eq_None_iff dest: map_of_SomeD)+
  from prefs_from_table_wfD(5)[OF assms(1) this]
    have "Collect (of_weak_ranking (the (map_of xs i)) x) =
            {y\<in>alts. of_weak_ranking (the (map_of xs i)) x y}"
    by safe (force elim!: of_weak_ranking.cases)
  also from assms
    have "of_weak_ranking (the (map_of xs i)) = prefs_from_table xs i"
    by (subst prefs_from_table_map_of[OF assms(1)])
       (auto simp: prefs_from_table_wf_def)
  finally show ?thesis by (simp add: of_weak_ranking_Collect_ge_def preferred_alts_altdef)
qed

lemma favorites_prefs_from_table:
  assumes wf: "prefs_from_table_wf agents alts xs" and i: "i \<in> agents"
  shows   "favorites (prefs_from_table xs) i = hd (the (map_of xs i))"
proof (cases "map_of xs i")
  case None
  with assms show ?thesis
    by (auto simp: map_of_eq_None_iff prefs_from_table_wf_def)
next
  case (Some y)
  with assms have "is_finite_weak_ranking y" "y \<noteq> []"
    by (auto simp: prefs_from_table_wf_def)
  with Some show ?thesis
    unfolding favorites_def using assms
    by (simp add: prefs_from_table_def is_finite_weak_ranking_def
                  Max_wrt_of_weak_ranking prefs_from_table_wfD)
qed

lemma has_unique_favorites_prefs_from_table:
  assumes wf: "prefs_from_table_wf agents alts xs"
  shows   "has_unique_favorites (prefs_from_table xs) =
             list_all (\<lambda>z. is_singleton (hd (snd z))) xs"
proof -
  interpret pref_profile_wf agents alts "prefs_from_table xs"
    by (intro pref_profile_from_tableI assms)
  from wf have "agents = set (map fst xs)" "distinct (map fst xs)"
    by (auto simp: prefs_from_table_wf_def)
  thus ?thesis
    unfolding has_unique_favorites_altdef using assms
    by (auto simp: favorites_prefs_from_table list_all_iff)
qed

end

subsection \<open>Automatic definition of preference profiles from tables\<close>

function favorites_prefs_from_table where
  "i = j \<Longrightarrow> favorites_prefs_from_table ((j,x)#xs) i = hd x"
| "i \<noteq> j \<Longrightarrow> favorites_prefs_from_table ((j,x)#xs) i =
               favorites_prefs_from_table xs i"
| "favorites_prefs_from_table [] i = {}"
  by (metis list.exhaust old.prod.exhaust) auto
termination by lexicographic_order

lemma (in election) eval_favorites_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs"
  shows   "favorites_prefs_from_table xs i =
             favorites (prefs_from_table xs) i"
proof (cases "i \<in> agents")
  assume i: "i \<in> agents"
  with assms have "favorites (prefs_from_table xs) i = hd (the (map_of xs i))"
    by (simp add: favorites_prefs_from_table)
  also from assms i have "i \<in> set (map fst xs)"
    by (auto simp: prefs_from_table_wf_def)
  hence "hd (the (map_of xs i)) = favorites_prefs_from_table xs i"
    by (induction xs i rule: favorites_prefs_from_table.induct) simp_all
  finally show ?thesis ..
next
  assume i: "i \<notin> agents"
  with assms have i': "i \<notin> set (map fst xs)"
    by (simp add: prefs_from_table_wf_def)
  hence "map_of xs i = None"
    by (simp add: map_of_eq_None_iff)
  hence "prefs_from_table xs i = (\<lambda>_ _. False)"
    by (intro ext) (auto simp: prefs_from_table_def)
  hence "favorites (prefs_from_table xs) i = {}"
    by (simp add: favorites_def Max_wrt_altdef)
  also from i' have "\<dots> = favorites_prefs_from_table xs i"
    by (induction xs i rule: favorites_prefs_from_table.induct) simp_all
  finally show ?thesis ..
qed

function weak_ranking_prefs_from_table where
  "i \<noteq> j \<Longrightarrow> weak_ranking_prefs_from_table ((i,x)#xs) j = weak_ranking_prefs_from_table xs j"
| "i = j \<Longrightarrow> weak_ranking_prefs_from_table ((i,x)#xs) j = x"
| "weak_ranking_prefs_from_table [] j = []"
  by (metis list.exhaust old.prod.exhaust) auto
termination by lexicographic_order

lemma eval_weak_ranking_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs"
  shows   "weak_ranking_prefs_from_table xs i = weak_ranking (prefs_from_table xs i)"
proof (cases "i \<in> agents")
  assume i: "i \<in> agents"
  with assms have "weak_ranking (prefs_from_table xs i) = the (map_of xs i)"
    by (auto simp: prefs_from_table_def prefs_from_table_wf_def weak_ranking_of_weak_ranking
             split: option.splits)
  also from assms i have "i \<in> set (map fst xs)"
    by (auto simp: prefs_from_table_wf_def)
  hence "the (map_of xs i) = weak_ranking_prefs_from_table xs i"
    by (induction xs i rule: weak_ranking_prefs_from_table.induct) simp_all
  finally show ?thesis ..
next
  assume i: "i \<notin> agents"
  with assms have i': "i \<notin> set (map fst xs)"
    by (simp add: prefs_from_table_wf_def)
  hence "map_of xs i = None"
    by (simp add: map_of_eq_None_iff)
  hence "prefs_from_table xs i = (\<lambda>_ _. False)"
    by (intro ext) (auto simp: prefs_from_table_def)
  hence "weak_ranking (prefs_from_table xs i) = []" by simp
  also from i' have "\<dots> = weak_ranking_prefs_from_table xs i"
    by (induction xs i rule: weak_ranking_prefs_from_table.induct) simp_all
  finally show ?thesis ..
qed

lemma eval_prefs_from_table_aux:
  assumes "R \<equiv> prefs_from_table xs" "prefs_from_table_wf agents alts xs"
  shows   "R i a b \<longleftrightarrow> prefs_from_table xs i a b"
          "a \<prec>[R i] b \<longleftrightarrow> prefs_from_table xs i a b \<and> \<not>prefs_from_table xs i b a"
          "anonymous_profile R = mset (map snd xs)"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             preferred_alts (R i) x =
             of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             favorites R i = favorites_prefs_from_table xs i"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             weak_ranking (R i) = weak_ranking_prefs_from_table xs i"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             favorite R i = the_elem (favorites_prefs_from_table xs i)"
          "election agents alts \<Longrightarrow>
             has_unique_favorites R \<longleftrightarrow> list_all (\<lambda>z. is_singleton (hd (snd z))) xs"
  using assms prefs_from_table_wfD[OF assms(2)]
  by (simp_all add: strongly_preferred_def favorite_def anonymise_prefs_from_table
        election.preferred_alts_prefs_from_table election.eval_favorites_prefs_from_table
        election.has_unique_favorites_prefs_from_table eval_weak_ranking_prefs_from_table)

lemma pref_profile_from_tableI':
  assumes "R1 \<equiv> prefs_from_table xss" "prefs_from_table_wf agents alts xss"
  shows   "pref_profile_wf agents alts R1"
  using assms by (simp add: pref_profile_from_tableI)

ML \<open>

signature PREFERENCE_PROFILES_CMD =
sig

type info

val preference_profile :
  (term * term) * ((binding * (term * term list list) list) list) -> Proof.context -> Proof.state

val preference_profile_cmd :
  (string * string) * ((binding * (string * string list list) list) list) ->
    Proof.context -> Proof.state

val get_info : term -> Proof.context -> info
val add_info : term -> info -> Context.generic -> Context.generic
val transform_info : info -> morphism -> info

end

structure Preference_Profiles_Cmd : PREFERENCE_PROFILES_CMD =
struct

open Preference_Profiles

type info =
  { term : term, def_thm : thm, wf_thm : thm, wf_raw_thm : thm, binding : binding,
    raw : (term * term list list) list, eval_thms : thm list }

fun transform_info ({term = t, binding, def_thm, wf_thm, wf_raw_thm, raw, eval_thms} : info) phi =
    let
      val thm = Morphism.thm phi
      val fact = Morphism.fact phi
      val term = Morphism.term phi
      val bdg = Morphism.binding phi
    in
      { term = term t, binding = bdg binding, def_thm = thm def_thm, wf_thm = thm wf_thm,
        wf_raw_thm = thm wf_raw_thm, raw = map (fn (a, bss) => (term a, map (map term) bss)) raw,
        eval_thms = fact eval_thms }
    end

structure Data = Generic_Data
(
  type T = (term * info) Item_Net.T
  val empty = Item_Net.init (op aconv o apply2 fst) (single o fst)
  val extend = I
  val merge = Item_Net.merge
);

fun get_info term lthy =
  Item_Net.retrieve (Data.get (Context.Proof lthy)) term |> the_single |> snd

fun add_info term info lthy =
  Data.map (Item_Net.update (term, info)) lthy

fun add_infos infos lthy =
  Data.map (fold Item_Net.update infos) lthy

fun preference_profile_aux agents alts (binding, args) lthy =
  let
    val dest_Type' = Term.dest_Type #> snd #> hd
    val (agentT, altT) = apply2 (dest_Type' o fastype_of) (agents, alts)
    val alt_setT = HOLogic.mk_setT altT
    fun define t =
      Local_Theory.define ((binding, NoSyn),
        ((Binding.suffix_name "_def" binding, @{attributes [code]}), t)) lthy
    val ty = HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT))
    val args' =
      args |> map (fn x => x ||> map (HOLogic.mk_set altT) ||> HOLogic.mk_list alt_setT)
    val t_raw =
      args'
        |> map HOLogic.mk_prod
        |> HOLogic.mk_list ty
    val t = Const (@{const_name prefs_from_table},
              HOLogic.listT ty --> pref_profileT agentT altT) $ t_raw
    val ((prefs, prefs_def), lthy) = define t
    val prefs_from_table_wf_const =
      Const (@{const_name prefs_from_table_wf}, HOLogic.mk_setT agentT --> HOLogic.mk_setT altT -->
          HOLogic.listT (HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT))) -->
          HOLogic.boolT)
    val wf_prop = (prefs_from_table_wf_const $ agents $ alts $ t_raw) |> HOLogic.mk_Trueprop

  in
    ((prefs, wf_prop, prefs_def), lthy)
  end

fun fold_accum f xs s =
  let
    fun fold_accum_aux _ [] s acc = (rev acc, s)
      | fold_accum_aux f (x::xs) s acc =
          case f x s of (y, s') => fold_accum_aux f xs s' (y::acc)
  in
    fold_accum_aux f xs s []
  end

fun preference_profile ((agents, alts), args) lthy =
  let
    fun qualify pref suff = Binding.qualify true (Binding.name_of pref) (Binding.name suff)
    val (results, lthy) = fold_accum (preference_profile_aux agents alts) args lthy
    val prefs_terms = map #1 results
    val wf_props = map #2 results
    val defs = map (snd o #3) results
    val raws = map snd args
    val bindings = map fst args

    fun tac lthy =
       let
         val lthy' = put_simpset HOL_ss lthy addsimps
           @{thms list.set Union_insert Un_insert_left insert_not_empty Int_empty_left Int_empty_right
              insert_commute Un_empty_left Un_empty_right insert_absorb2 Union_empty
              is_weak_ranking_Cons is_weak_ranking_Nil finite_insert finite.emptyI
              Set.singleton_iff Set.empty_iff Set.ball_simps}
        in
          Local_Defs.unfold_tac lthy defs
            THEN ALLGOALS (resolve_tac lthy [@{thm prefs_from_table_wfI}])
            THEN Local_Defs.unfold_tac lthy @{thms is_finite_weak_ranking_def list.set insert_iff
               empty_iff simp_thms list.map snd_conv fst_conv}
            THEN ALLGOALS (TRY o REPEAT_ALL_NEW (eresolve_tac lthy @{thms disjE}))
            THEN ALLGOALS (TRY o Hypsubst.hyp_subst_tac lthy)
            THEN ALLGOALS (Simplifier.asm_full_simp_tac lthy')
            THEN ALLGOALS (TRY o REPEAT_ALL_NEW (resolve_tac lthy @{thms conjI}))
            THEN distinct_subgoals_tac
        end

    fun after_qed [wf_thms_raw] lthy =
      let
        fun prep_thms attrs suffix (thms : thm list) binding =
          (((qualify binding suffix, attrs), [(thms,[])]))
        fun prep_thmss simp suffix thmss = map2 (prep_thms simp suffix) thmss bindings
        fun notes thmss suffix attrs lthy =
            Local_Theory.notes (prep_thmss attrs suffix thmss) lthy |> snd
        fun note thms suffix attrs lthy = notes (map single thms) suffix attrs lthy
        val eval_thmss = map2 (fn def => fn wf =>
          map (fn thm => thm OF [def, wf]) @{thms eval_prefs_from_table_aux})
          defs wf_thms_raw
        val wf_thms = map2 (fn def => fn wf =>
          @{thm pref_profile_from_tableI'} OF [def, wf]) defs wf_thms_raw
        val mk_infos =
          let
            fun aux acc (bdg::bdgs) (t::ts) (r::raws) (def::def_thms) (wf::wf_thms)
                   (wf_raw::wf_raw_thms) (evals::eval_thmss) =
              aux ((t, {binding = bdg, term = t, raw = r, def_thm = def, wf_thm = wf,
                 wf_raw_thm = wf_raw, eval_thms = evals}) :: acc)
                 bdgs ts raws def_thms wf_thms wf_raw_thms eval_thmss
            | aux acc [] _ _ _ _ _ _ = (acc : (term * info) list)
            | aux _ _ _ _ _ _ _ _ = raise Match
          in
            aux []
          end
        val infos = mk_infos bindings prefs_terms raws defs wf_thms wf_thms_raw eval_thmss
      in
        lthy
        |> note wf_thms_raw "wf_raw" []
        |> note wf_thms "wf" @{attributes [simp]}
        |> notes eval_thmss "eval" []
        |> Local_Theory.declaration {syntax = false, pervasive = false}
             (fn m => add_infos (map (fn (t,i) => (Morphism.term m t, transform_info i m)) infos))
      end
    | after_qed _ _ = raise Match

  in
    Proof.theorem NONE after_qed [map (fn prop => (prop, [])) wf_props] lthy
    |> Proof.refine_singleton (Method.Basic (SIMPLE_METHOD o tac))
  end

fun preference_profile_cmd ((agents, alts), argss) lthy =
  let
    val read = Syntax.read_term lthy
    fun read' ty t = Syntax.parse_term lthy t |> Type.constraint ty |> Syntax.check_term lthy
    val agents' = read agents
    val alts' = read alts
    val agentT = agents' |> fastype_of |> dest_Type |> snd |> hd
    val altT = alts' |> fastype_of |> dest_Type |> snd |> hd
    fun read_pref_elem ts = map (read' altT) ts
    fun read_prefs prefs = map read_pref_elem prefs
    fun prep (binding, args) =
      (binding, map (fn (agent, prefs) => (read' agentT agent, read_prefs prefs)) args)
  in
    preference_profile ((agents', alts'), map prep argss) lthy
  end

val parse_prefs =
  let
    val parse_pref_elem =
      (Args.bracks (Parse.list1 Parse.term)) ||
      Parse.term >> single
  in
    Parse.list1 parse_pref_elem
  end

val parse_pref_profile =
  Parse.binding --| Args.$$$ "=" -- Scan.repeat1 (Parse.term --| Args.colon -- parse_prefs)

val _ =
  Outer_Syntax.local_theory_to_proof @{command_keyword preference_profile}
    "construct preference profiles from a table"
    (Args.$$$ "agents" |-- Args.colon |-- Parse.term --| Args.$$$ "alts" --| Args.colon
       -- Parse.term --| Args.$$$ "where" --
     Parse.and_list1 parse_pref_profile >> preference_profile_cmd);

end
\<close>

end