theory Bisim_Subst
   imports Bisim_Struct_Cong Close_Subst
begin

context env begin

abbreviation
  bisim_subst_judge ("_ \<rhd> _ \<sim>\<^sub>s _" [70, 70, 70] 65) where "\<Psi> \<rhd> P \<sim>\<^sub>s Q \<equiv> (\<Psi>, P, Q) \<in> close_subst bisim"
abbreviation
  bisim_subst_nil_judge ("_ \<sim>\<^sub>s _" [70, 70] 65) where "P \<sim>\<^sub>s Q \<equiv> S_bottom' \<rhd> P \<sim>\<^sub>s Q"

lemmas bisim_subst_closed[eqvt] = close_subst_closed[OF bisim_eqvt]
lemmas bisim_subst_eqvt[simp] = close_subst_eqvt[OF bisim_eqvt]

lemma bisim_subst_output_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   M :: 'a
  and   N :: 'a

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"

  shows "\<Psi> \<rhd> M\<langle>N\<rangle>.P \<sim>\<^sub>s M\<langle>N\<rangle>.Q"
  using assms
by(force intro!: close_substI intro: close_substE bisim_output_pres)

lemma seq_subst_input_chain[simp]:
  fixes xvec :: "name list"
  and   N    :: "'a"
  and   P    :: "('a, 'b, 'c) psi"
  and   \<sigma>    :: "(name list \<times> 'a list) list"

  assumes "xvec \<sharp>* \<sigma>"

  shows "seq_subs' (input_chain xvec N P) \<sigma> = input_chain xvec (subst_term.seq_subst N \<sigma>) (seq_subs P \<sigma>)"
using assms
by(induct xvec) auto

lemma bisim_subst_input_pres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     "xvec \<sharp>* \<Psi>"
  and     "distinct xvec"

  shows "\<Psi> \<rhd> M\<lparr>\<lambda>*xvec N\<rparr>.P \<sim>\<^sub>s M\<lparr>\<lambda>*xvec N\<rparr>.Q"
proof(rule_tac close_substI)
  fix \<sigma>::"(name list \<times> 'a list) list"
  assume wf: "well_formed_subst \<sigma>"

  obtain p where "(p \<bullet> xvec) \<sharp>* \<sigma>"
             and "(p \<bullet> xvec) \<sharp>* P" and "(p \<bullet> xvec) \<sharp>* Q" and "(p \<bullet> xvec) \<sharp>* \<Psi>" and "(p \<bullet> xvec) \<sharp>* N"
             and S: "set p \<subseteq> set xvec \<times> set (p \<bullet> xvec)"
      by(rule_tac c="(\<sigma>, P, Q, \<Psi>, N)" in name_list_avoiding) auto

  from `\<Psi> \<rhd> P \<sim>\<^sub>s Q` have "(p \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<sim>\<^sub>s (p \<bullet> Q)"
    by(rule bisim_subst_closed)
  with `xvec \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>` S have "\<Psi> \<rhd> (p \<bullet> P) \<sim>\<^sub>s (p \<bullet> Q)"
    by simp

  {
    fix Tvec :: "'a list"
    from `\<Psi> \<rhd> (p \<bullet> P) \<sim>\<^sub>s (p \<bullet> Q)` have "\<Psi> \<rhd> (p \<bullet> P)[<\<sigma>>] \<sim>\<^sub>s (p \<bullet> Q)[<\<sigma>>]" using wf
      by(rule close_subst_unfold)
    moreover assume "length xvec = length Tvec" and "distinct xvec"
    ultimately have "\<Psi> \<rhd> ((p \<bullet> P)[<\<sigma>>])[(p \<bullet> xvec)::=Tvec] \<sim> ((p \<bullet> Q)[<\<sigma>>])[(p \<bullet> xvec)::=Tvec]"
      by(drule_tac close_substE[where \<sigma>="[((p \<bullet> xvec), Tvec)]"]) auto
  }

  with `(p \<bullet> xvec) \<sharp>* \<sigma>` `distinct xvec`
  have "\<Psi> \<rhd> (M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> P))[<\<sigma>>] \<sim> (M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> Q))[<\<sigma>>]"
    by(force intro: bisim_input_pres)
  moreover from `(p \<bullet> xvec) \<sharp>* N` `(p \<bullet> xvec) \<sharp>* P` S have "M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> P) = M\<lparr>\<lambda>*xvec N\<rparr>.P"
    apply(simp add: psi.inject) by(rule input_chain_alpha[symmetric]) auto
  moreover from `(p \<bullet> xvec) \<sharp>* N` `(p \<bullet> xvec) \<sharp>* Q` S have "M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> Q) = M\<lparr>\<lambda>*xvec N\<rparr>.Q"
    apply(simp add: psi.inject) by(rule input_chain_alpha[symmetric]) auto
  ultimately show "\<Psi> \<rhd> (M\<lparr>\<lambda>*xvec N\<rparr>.P)[<\<sigma>>] \<sim> (M\<lparr>\<lambda>*xvec N\<rparr>.Q)[<\<sigma>>]"
    by force
qed

lemma bisim_subst_case_pres_aux:
  fixes \<Psi>   :: 'b
  and   CsP :: "('c \<times> ('a, 'b, 'c) psi) list"
  and   CsQ :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes C1: "\<And>\<phi> P. (\<phi>, P) mem CsP \<Longrightarrow> \<exists>Q. (\<phi>, Q) mem CsQ \<and> guarded Q \<and> \<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     C2: "\<And>\<phi> Q. (\<phi>, Q) mem CsQ \<Longrightarrow> \<exists>P. (\<phi>, P) mem CsP \<and> guarded P \<and> \<Psi> \<rhd> P \<sim>\<^sub>s Q"

  shows "\<Psi> \<rhd> Cases CsP \<sim>\<^sub>s Cases CsQ"
proof -
  {
    fix \<sigma> :: "(name list \<times> 'a list) list"
    assume wf: "well_formed_subst \<sigma>"

    have "\<Psi> \<rhd> Cases(case_list_seq_subst CsP \<sigma>) \<sim> Cases(case_list_seq_subst CsQ \<sigma>)"
    proof(rule bisim_case_pres)
      fix \<phi> P
      assume "(\<phi>, P) mem (case_list_seq_subst CsP \<sigma>)"
      then obtain \<phi>' P' where "(\<phi>', P') mem CsP" and "\<phi> = subst_cond.seq_subst \<phi>' \<sigma>" and Peq_p': "P = (P'[<\<sigma>>])"
	by(induct CsP) force+
      from `(\<phi>', P') mem CsP` obtain Q' where "(\<phi>', Q') mem CsQ" and "guarded Q'" and "\<Psi> \<rhd> P' \<sim>\<^sub>s Q'" by(blast dest: C1)
      from `(\<phi>', Q') mem CsQ` `\<phi> = subst_cond.seq_subst \<phi>' \<sigma>` obtain Q where "(\<phi>, Q) mem (case_list_seq_subst CsQ \<sigma>)" and "Q = Q'[<\<sigma>>]"
	by(induct CsQ) auto
      with Peq_p' `guarded Q'` `\<Psi> \<rhd> P' \<sim>\<^sub>s Q'` show "\<exists>Q. (\<phi>, Q) mem (case_list_seq_subst CsQ \<sigma>) \<and> guarded Q \<and> \<Psi> \<rhd> P \<sim> Q" using wf
	by(blast dest: close_substE guarded_seq_subst)
    next
      fix \<phi> Q
      assume "(\<phi>, Q) mem (case_list_seq_subst CsQ \<sigma>)"
      then obtain \<phi>' Q' where "(\<phi>', Q') mem CsQ" and "\<phi> = subst_cond.seq_subst \<phi>' \<sigma>" and Qeq_q': "Q = Q'[<\<sigma>>]"
	by(induct CsQ) force+
      from `(\<phi>', Q') mem CsQ` obtain P' where "(\<phi>', P') mem CsP" and "guarded P'" and "\<Psi> \<rhd> P' \<sim>\<^sub>s Q'" by(blast dest: C2)
      from `(\<phi>', P') mem CsP` `\<phi> = subst_cond.seq_subst \<phi>' \<sigma>` obtain P where "(\<phi>, P) mem (case_list_seq_subst CsP \<sigma>)" and "P = P'[<\<sigma>>]"
	by(induct CsP) auto
      with Qeq_q' `guarded P'` `\<Psi> \<rhd> P' \<sim>\<^sub>s Q'` show "\<exists>P. (\<phi>, P) mem (case_list_seq_subst CsP \<sigma>) \<and> guarded P \<and> \<Psi> \<rhd> P \<sim> Q" using wf
	by(blast dest: close_substE guarded_seq_subst)
    qed
  }
  thus ?thesis
    by(rule_tac close_substI) auto
qed

lemma bisim_subst_reflexive:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<sim>\<^sub>s P"
by(auto intro: close_substI bisim_reflexive)

lemma bisim_subst_transitive:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     "\<Psi> \<rhd> Q \<sim>\<^sub>s R"

  shows "\<Psi> \<rhd> P \<sim>\<^sub>s R"
using assms
by(auto intro: close_substI close_substE bisim_transitive)

lemma bisim_subst_symmetric:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"

  shows "\<Psi> \<rhd> Q \<sim>\<^sub>s P"
using assms
by(auto intro: close_substI close_substE bisimE)
(*
lemma bisim_subst_case_pres:
  fixes \<Psi>   :: 'b
  and   CsP :: "('c \<times> ('a, 'b, 'c) psi) list"
  and   CsQ :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "length CsP = length CsQ"
  and     C: "\<And>(i::nat) \<phi> P \<phi>' Q. \<lbrakk>i <= length CsP; (\<phi>, P) = nth CsP i; (\<phi>', Q) = nth CsQ i\<rbrakk> \<Longrightarrow> \<phi> = \<phi>' \<and> \<Psi> \<rhd> P \<sim> Q"
  shows "\<Psi> \<rhd> Cases CsP \<sim>\<^sub>s Cases CsQ"
proof -
  {
    fix \<phi>
    and P
    assume "(\<phi>, P) mem CsP"
    with `length CsP = length CsQ` have "\<exists>Q. (\<phi>, Q) mem CsQ \<and> \<Psi> \<rhd> P \<sim>\<^sub>s Q"
      apply(induct n=="length CsP" arbitrary: CsP CsQ rule: nat.induct)
      apply simp
      apply simp
      apply auto
  }
using `length CsP = length CsQ`
proof(induct n=="length CsP" rule: nat.induct)
  case zero
  thus ?case by(force intro: bisim_subst_reflexive)
next
  case(Suc n)
next
apply auto
apply(blast intro: bisim_subst_reflexive)
apply auto
apply(simp add: nth.simps)
apply(auto simp add: nth.simps)
apply blast
apply(rule_tac bisim_subst_case_pres_aux)
apply auto
*)
lemma bisim_subst_par_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<sim>\<^sub>s Q \<parallel> R"
using assms
by(force intro!: close_substI intro: close_substE bisim_par_pres)

lemma bisim_subst_res_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   x :: name

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     "x \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<sim>\<^sub>s \<lparr>\<nu>x\<rparr>Q"
proof(rule_tac close_substI)
  fix \<sigma> :: "(name list \<times> 'a list) list"
  assume wf: "well_formed_subst \<sigma>"

  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<sigma>"
    by(generate_fresh "name") (auto simp add: fresh_prod)

  from `\<Psi> \<rhd> P \<sim>\<^sub>s Q` have "([(x, y)] \<bullet> \<Psi>) \<rhd> ([(x, y)] \<bullet> P) \<sim>\<^sub>s ([(x, y)] \<bullet> Q)"
    by(rule bisim_subst_closed)
  with `x \<sharp> \<Psi>` `y \<sharp> \<Psi>` have "\<Psi> \<rhd> ([(x, y)] \<bullet> P) \<sim>\<^sub>s ([(x, y)] \<bullet> Q)"
    by simp
  hence "\<Psi> \<rhd> ([(x, y)] \<bullet> P)[<\<sigma>>] \<sim> ([(x, y)] \<bullet> Q)[<\<sigma>>]" using wf
    by(rule close_substE)
  hence "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> P)[<\<sigma>>]) \<sim> \<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> Q)[<\<sigma>>])" using `y \<sharp> \<Psi>`
    by(rule bisim_res_pres)
  with `y \<sharp> P` `y \<sharp> Q` `y \<sharp> \<sigma>`
  show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>P)[<\<sigma>>] \<sim> (\<lparr>\<nu>x\<rparr>Q)[<\<sigma>>]"
    by(simp add: alpha_res)
qed

lemma bisim_subst_bang_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     "guarded P"
  and     "guarded Q"

  shows "\<Psi> \<rhd> !P \<sim>\<^sub>s !Q"
using assms
by(force intro!: close_substI intro: close_substE bisim_bang_pres guarded_seq_subst)

lemma subst_nil[simp]:
  fixes xvec :: "name list"
  and   Tvec :: "'a list"

  assumes "well_formed_subst \<sigma>"
  and     "distinct xvec"

  shows "(\<zero>[<\<sigma>>]) = \<zero>"
using assms
by simp

lemma bisim_subst_par_nil:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> \<zero> \<sim>\<^sub>s P"
by(force intro: close_substI bisim_par_nil)

lemma bisim_subst_par_comm:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> Q \<sim>\<^sub>s Q \<parallel> P"
apply(rule close_substI)
by(force intro: close_substI bisim_par_comm)

lemma bisim_subst_par_assoc:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> (P \<parallel> Q) \<parallel> R \<sim>\<^sub>s P \<parallel> (Q \<parallel> R)"
apply(rule close_substI)
by(force intro: close_substI bisim_par_assoc)

lemma bisim_subst_res_nil:
  fixes \<Psi> :: 'b
  and   x :: name

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>\<zero> \<sim>\<^sub>s \<zero>"
proof(rule close_substI)
  fix \<sigma>:: "(name list \<times> 'a list) list"

  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> \<sigma>"
    by(generate_fresh "name") (auto simp add: fresh_prod)
  have "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>\<zero> \<sim> \<zero>" by(rule bisim_res_nil)
  with `y \<sharp> \<sigma>`  show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>\<zero>)[<\<sigma>>] \<sim> \<zero>[<\<sigma>>]"
    by(subst alpha_res[of y]) auto
qed

lemma seq_subst2:
  fixes x :: name
  and   P :: "('a, 'b, 'c) psi"
  and \<sigma> :: "(name list \<times> 'a list) list"

  assumes "x \<sharp> \<sigma>"
  and     "x \<sharp> P"

  shows "x \<sharp> P[<\<sigma>>]"
  using assms
proof(induct \<sigma> arbitrary: P)
  case Nil
  then show ?case by simp
next
  case (Cons a \<sigma>)
  then show ?case
    by(cases a) auto
qed

notation subst_term.seq_subst ("_[<_>]" [100, 100] 100)

lemma bisim_subst_scope_ext:
  fixes \<Psi> :: 'b
  and   x :: name
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<sim>\<^sub>s P \<parallel> \<lparr>\<nu>x\<rparr>Q"
proof(rule close_substI)
  fix \<sigma>:: "(name list \<times> 'a list) list"

  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> \<sigma>" and "y \<sharp> P" and "y \<sharp> Q"
    by(generate_fresh "name") (auto simp add: fresh_prod)
  moreover from  `y \<sharp> \<sigma>` `y \<sharp> P` have "y \<sharp> P[<\<sigma>>]"
    by(rule seq_subst2)
  hence "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>((P[<\<sigma>>]) \<parallel> (([(x, y)] \<bullet> Q)[<\<sigma>>])) \<sim> (P[<\<sigma>>]) \<parallel> \<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> Q)[<\<sigma>>])"
    by(rule bisim_scope_ext)
  with `x \<sharp> P` `y \<sharp> P` `y \<sharp> Q` `y \<sharp> \<sigma>` show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>(P \<parallel> Q))[<\<sigma>>] \<sim> (P \<parallel> \<lparr>\<nu>x\<rparr>Q)[<\<sigma>>]"
    apply(subst alpha_res[of y], simp)
    apply(subst alpha_res[of y Q], simp)
    by(simp add: eqvts)
qed

lemma bisim_subst_case_push_res:
  fixes x  :: name
  and   \<Psi>  :: 'b
  and   Cs :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "x \<sharp> map fst Cs"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(Cases Cs) \<sim>\<^sub>s Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs"
proof(rule close_substI)
  fix \<sigma>:: "(name list \<times> 'a list) list"

  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> \<sigma>" and "y \<sharp> Cs"
    by(generate_fresh "name") (auto simp add: fresh_prod)

  {
    fix x    :: name
    and Cs   :: "('c \<times> ('a, 'b, 'c) psi) list"
    and \<sigma>    :: "(name list \<times> 'a list) list"

    assume "x \<sharp> \<sigma>"

    hence "(Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs)[<\<sigma>>] = Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) (case_list_seq_subst Cs \<sigma>)"
      by(induct Cs) auto
  }
  note C1 = this

  {
    fix x    :: name
    and y    :: name
    and Cs   :: "('c \<times> ('a, 'b, 'c) psi) list"

    assume "x \<sharp> map fst Cs"
    and    "y \<sharp> map fst Cs"
    and    "y \<sharp> Cs"

    hence "(Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs) = Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>y\<rparr>P)) ([(x, y)] \<bullet> Cs)"
      by(induct Cs) (auto simp add: fresh_list_cons alpha_res)
  }
  note C2 = this

  from `y \<sharp> Cs` have "y \<sharp> map fst Cs" by(induct Cs) (auto simp add: fresh_list_cons fresh_list_nil)
  from `y \<sharp> Cs` `y \<sharp> \<sigma>` `x \<sharp> map fst Cs`  have "y \<sharp> map fst (case_list_seq_subst ([(x, y)] \<bullet> Cs) \<sigma>)"
    by(induct Cs) (auto intro: subst_cond.seq_subst2 simp add: fresh_list_cons fresh_list_nil fresh_prod)
  hence "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>(Cases(case_list_seq_subst ([(x, y)] \<bullet> Cs) \<sigma>)) \<sim> Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>y\<rparr>P)) (case_list_seq_subst ([(x, y)] \<bullet> Cs) \<sigma>)"
    by(rule bisim_case_push_res)

  with `y \<sharp> Cs` `x \<sharp> map fst Cs` `y \<sharp> map fst Cs` `y \<sharp> \<sigma>`
  show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>(Cases Cs))[<\<sigma>>] \<sim> (Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs)[<\<sigma>>]"
    apply(subst C2[of x Cs y])
    apply assumption+
    apply(subst C1)
    apply assumption+
    apply(subst alpha_res[of y], simp)
    by(simp add: eqvts)
qed

lemma bisim_subst_output_push_res:
  fixes x :: name
  and   \<Psi> :: 'b
  and   M :: 'a
  and   N :: 'a
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> M"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<langle>N\<rangle>.P) \<sim>\<^sub>s M\<langle>N\<rangle>.\<lparr>\<nu>x\<rparr>P"
proof(rule close_substI)
  fix \<sigma>:: "(name list \<times> 'a list) list"

  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> \<sigma>" and "y \<sharp> P" and "y \<sharp> M" and "y \<sharp> N"
    by(generate_fresh "name") (auto simp add: fresh_prod)
  from `y \<sharp> M` `y \<sharp> \<sigma>` have "y \<sharp> M[<\<sigma>>]" by auto
  moreover from `y \<sharp> N` `y \<sharp> \<sigma>` have "y \<sharp> N[<\<sigma>>]" by auto
  ultimately have "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>((M[<\<sigma>>])\<langle>(N[<\<sigma>>])\<rangle>.(([(x, y)] \<bullet> P)[<\<sigma>>])) \<sim> (M[<\<sigma>>])\<langle>(N[<\<sigma>>])\<rangle>.(\<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> P)[<\<sigma>>]))"
    by(rule bisim_output_push_res)
  with `y \<sharp> M` `y \<sharp> N` `y \<sharp> P` `x \<sharp> M` `x \<sharp> N` `y \<sharp> \<sigma>`
  show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>(M\<langle>N\<rangle>.P))[<\<sigma>>] \<sim> (M\<langle>N\<rangle>.\<lparr>\<nu>x\<rparr>P)[<\<sigma>>]"
    apply(subst alpha_res[of y], simp)
    apply(subst alpha_res[of y P], simp)
    by(simp add: eqvts)
qed

lemma bisim_subst_input_push_res:
  fixes x    :: name
  and   \<Psi>    :: 'b
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<lparr>\<lambda>*xvec N\<rparr>.P) \<sim>\<^sub>s M\<lparr>\<lambda>*xvec N\<rparr>.\<lparr>\<nu>x\<rparr>P"
proof(rule close_substI)
  fix \<sigma>:: "(name list \<times> 'a list) list"

  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> \<sigma>" and "y \<sharp> P" and "y \<sharp> M" and "y \<sharp> xvec" and "y \<sharp> N"
    by(generate_fresh "name") (auto simp add: fresh_prod)
  obtain p::"name prm" where "(p \<bullet> xvec) \<sharp>* N" and  "(p \<bullet> xvec) \<sharp>* P" and "x \<sharp> (p \<bullet> xvec)" and "y \<sharp> (p \<bullet> xvec)" and "(p \<bullet> xvec) \<sharp>* \<sigma>"
                         and S: "set p \<subseteq> set xvec \<times> set(p \<bullet> xvec)"
   by(rule_tac c="(N, P, x, y, \<sigma>)" in name_list_avoiding) auto

  from `y \<sharp> M` `y \<sharp> \<sigma> ` have "y \<sharp> M[<\<sigma>>]" by auto
  moreover note `y \<sharp> (p \<bullet> xvec)`
  moreover from `y \<sharp> N` have "(p \<bullet> y) \<sharp> (p \<bullet> N)" by(simp add: pt_fresh_bij[OF pt_name_inst, OF at_name_inst])
  with `y \<sharp> xvec` `y \<sharp> (p \<bullet> xvec)` S have "y \<sharp> p \<bullet> N" by simp
  hence "y \<sharp> (p \<bullet> N)[<\<sigma>>]" using `y \<sharp> \<sigma>`
    by auto
  ultimately have "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>((M[<\<sigma>>])\<lparr>\<lambda>*(p \<bullet> xvec) ((p \<bullet> N)[<\<sigma>>])\<rparr>.(([(x, y)] \<bullet> (p \<bullet> P))[<\<sigma>>])) \<sim> (M[<\<sigma>>])\<lparr>\<lambda>*(p \<bullet> xvec) ((p \<bullet> N)[<\<sigma>>])\<rparr>.(\<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> p \<bullet> P)[<\<sigma>>]))"
    by(rule bisim_input_push_res)
  with `y \<sharp> M` `y \<sharp> N` `y \<sharp> P` `x \<sharp> M` `x \<sharp> N` `y \<sharp> xvec` `x \<sharp> xvec` `(p \<bullet> xvec) \<sharp>* N` `(p \<bullet> xvec) \<sharp>* P`
       `x \<sharp> (p \<bullet> xvec)` `y \<sharp> (p \<bullet> xvec)` `y \<sharp> \<sigma>` `(p \<bullet> xvec) \<sharp>* \<sigma>` S
  show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>(M\<lparr>\<lambda>*xvec N\<rparr>.P))[<\<sigma>>] \<sim> (M\<lparr>\<lambda>*xvec N\<rparr>.\<lparr>\<nu>x\<rparr>P)[<\<sigma>>]"
    apply(subst input_chain_alpha')
    apply assumption+
    apply(subst input_chain_alpha'[of p xvec])
    apply(simp add: abs_fresh_star)
    apply assumption+
    apply(simp add: eqvts)
    apply(subst alpha_res[of y], simp)
    apply(simp add: input_chain_fresh)
    apply(simp add: fresh_chain_simps)
    apply(subst alpha_res[of y "(p \<bullet> P)"])
    apply(simp add: fresh_chain_simps)
    by(simp add: fresh_chain_simps eqvts)
qed

lemma bisim_subst_res_comm:
  fixes x :: name
  and   y :: name

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P) \<sim>\<^sub>s \<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P)"
proof(case_tac "x = y")
  assume "x = y"
  thus ?thesis by(force intro: bisim_subst_reflexive)
next
  assume "x \<noteq> y"
  show ?thesis
  proof(rule close_substI)
  fix \<sigma>:: "(name list \<times> 'a list) list"

    obtain x'::name where "x' \<sharp>  \<Psi>" and "x' \<sharp> \<sigma>" and "x' \<sharp> P" and "x \<noteq> x'" and "y \<noteq> x'"
      by(generate_fresh "name") (auto simp add: fresh_prod)
    obtain y'::name where "y' \<sharp>  \<Psi>" and "y' \<sharp> \<sigma>" and "y' \<sharp> P" and "x \<noteq> y'" and "y \<noteq> y'" and "x' \<noteq> y'"
      by(generate_fresh "name") (auto simp add: fresh_prod)

    have "\<Psi> \<rhd> \<lparr>\<nu>x'\<rparr>(\<lparr>\<nu>y'\<rparr>(([(x, x')] \<bullet> [(y, y')] \<bullet> P)[<\<sigma>>])) \<sim> \<lparr>\<nu>y'\<rparr>(\<lparr>\<nu>x'\<rparr>(([(x, x')] \<bullet> [(y, y')] \<bullet> P)[<\<sigma>>]))"
      by(rule bisim_res_comm)
    moreover from `x' \<sharp> P` `y' \<sharp> P` `x \<noteq> y'` `x' \<noteq> y'` have "\<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P) = \<lparr>\<nu>x'\<rparr>(\<lparr>\<nu>y'\<rparr>(([(x, x')] \<bullet> [(y, y')] \<bullet> P)))"
      apply(subst alpha_res[of y' P], simp)
      by(subst alpha_res[of x']) (auto simp add: abs_fresh fresh_left calc_atm eqvts)
    moreover from `x' \<sharp> P` `y' \<sharp> P` `y \<noteq> x'` `x \<noteq> y'` `x' \<noteq> y'` `x \<noteq> x'` `x \<noteq> y` have "\<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P) = \<lparr>\<nu>y'\<rparr>(\<lparr>\<nu>x'\<rparr>(([(x, x')] \<bullet> [(y, y')] \<bullet> P)))"
      apply(subst alpha_res[of x' P], simp)
      apply(subst alpha_res[of y'], simp add: abs_fresh fresh_left calc_atm)
      apply(simp add: eqvts calc_atm)
      by(subst perm_compose) (simp add: calc_atm)

    ultimately show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P))[<\<sigma>>] \<sim> (\<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P))[<\<sigma>>]"
      using  `x' \<sharp> \<sigma>` `y' \<sharp> \<sigma>`
      by simp
  qed
qed

lemma bisim_subst_ext_bang:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

  shows "\<Psi> \<rhd> !P \<sim>\<^sub>s P \<parallel> !P"
using assms
by(force intro: close_substI bang_ext guarded_seq_subst)

lemma struct_cong_bisim_subst:
  fixes P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<sim>\<^sub>s Q"
using assms
by(induct rule: struct_cong.induct)
  (auto intro: bisim_subst_reflexive bisim_subst_symmetric bisim_subst_transitive bisim_subst_par_comm bisim_subst_par_assoc bisim_subst_par_nil bisim_subst_res_nil bisim_subst_res_comm bisim_subst_scope_ext bisim_subst_case_push_res bisim_subst_input_push_res bisim_subst_output_push_res bisim_subst_ext_bang)

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
 * Tactic for solving monadic equalities, such as:
 *
 * (liftE (return 3) = returnOk 3
 *
 * Theorems of the form:
 *
 *   ((a, s') \<in> fst (A s)) = P a s s'
 *
 * and
 *
 *   snd (A s) = P s
 *
 * are added to the "monad_eq" set.
 *)
theory MonadEq
  imports
    In_Monad
    NonDetMonadVCG
begin

(* Setup "monad_eq" attributes. *)
ML \<open>
structure MonadEqThms = Named_Thms (
    val name = Binding.name "monad_eq"
    val description = "monad equality-prover theorems"
    )
\<close>
attribute_setup monad_eq = \<open>
  Attrib.add_del
    (Thm.declaration_attribute MonadEqThms.add_thm)
    (Thm.declaration_attribute MonadEqThms.del_thm)\<close>
  "Monad equality-prover theorems"

(* Setup tactic. *)

ML \<open>
fun monad_eq_tac ctxt =
let
  (* Set a simpset as being hidden, so warnings are not printed from it. *)
  val ctxt' = Context_Position.set_visible false ctxt
in
  CHANGED (clarsimp_tac (ctxt' addsimps (MonadEqThms.get ctxt')) 1)
end
\<close>

method_setup monad_eq = \<open>
    Method.sections Clasimp.clasimp_modifiers >> (K (SIMPLE_METHOD o monad_eq_tac))\<close>
  "prove equality on monads"

lemma monad_eq_simp_state[monad_eq]:
  "((A :: ('s, 'a) nondet_monad) s = B s') =
      ((\<forall>r t. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s'))
         \<and> (\<forall>r t. (r, t) \<in> fst (B s') \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (snd (A s) = snd (B s')))"
  by (auto intro!: set_eqI prod_eqI)

lemma monad_eq_simp[monad_eq]:
  "((A :: ('s, 'a) nondet_monad) = B) =
      ((\<forall>r t s. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s))
         \<and> (\<forall>r t s. (r, t) \<in> fst (B s) \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (\<forall>x. snd (A x) = snd (B x)))"
  by (auto intro!: set_eqI prod_eqI)

declare in_monad[monad_eq]
declare in_bindE[monad_eq]

(* Test *)
lemma "returnOk 3 = liftE (return 3)"
  apply monad_eq
  oops

end


(*  Title:      HOL/Auth/n_moesi_lemma_inv__3_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_moesi Protocol Case Study*}

theory n_moesi_lemma_inv__3_on_rules imports n_moesi_lemma_on_inv__3
begin
section{*All lemmas on causal relation between inv__3*}
lemma lemma_inv__3_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__3  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_rule_t1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rule_t2 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t3 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t4 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t5 N i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rule_t1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rule_t1Vsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rule_t2 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rule_t2Vsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t3 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t3Vsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t4 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t4Vsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t5 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t5Vsinv__3) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005 (modified)    |
            |              September 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |               November 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2008         |
            |                   June 2008  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_contraction
imports CSP_F_domain CSP_T.CSP_T_contraction
begin

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

         1. contraction failuresfun
         2. contraction failuresFun
         3. contraction [[ ]]Ffun
         4. contraction [[ ]]FFun

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

(*=============================================================*
 |                      traces fstF                            |
 *=============================================================*)

lemma non_expanding_traces_fstF:
   "noHide P ==> non_expanding (%M. traces P (fstF o M))"
(* apply (subgoal_tac "(%M. traces P (fstF o M)) = (traces P) o (op o fstF)") *)
apply (subgoal_tac "(%M. traces P (fstF o M)) = (traces P) o ((o) fstF)")
apply (simp)
apply (rule compo_non_expand)
apply (simp add: non_expanding_traces)
apply (simp add: non_expanding_op_fstF)
apply (simp add: fun_eq_iff)
done

lemma contraction_alpha_traces_fstF:
   "guarded P ==> contraction_alpha (%M. traces P (fstF o M)) (1/2)"
(* apply (subgoal_tac "(%M. traces P (fstF o M)) = (traces P) o (op o fstF)") *)
apply (subgoal_tac "(%M. traces P (fstF o M)) = (traces P) o ((o) fstF)")
apply (simp)
apply (rule compo_contra_alpha_non_expand)
apply (simp add: contraction_alpha_traces)
apply (simp add: non_expanding_op_fstF)
apply (simp add: fun_eq_iff)
done

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

(*** STOP ***)

lemma map_alpha_failures_STOP:
  "0 <= alpha ==> map_alpha (failures (STOP)) alpha"
by (simp add: failures_iff map_alpha_Constant)

lemma non_expanding_failures_STOP:
  "non_expanding (failures (STOP))"
by (simp add: non_expanding_def map_alpha_failures_STOP)

lemma contraction_alpha_failures_STOP:
  "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (failures (STOP)) alpha"
by (simp add: failures_iff contraction_alpha_Constant)

(*** SKIP ***)

lemma map_alpha_failures_SKIP:
  "0 <= alpha ==> map_alpha (failures (SKIP)) alpha"
by (simp add: failures_iff map_alpha_Constant)

lemma non_expanding_failures_SKIP:
  "non_expanding (failures (SKIP))"
by (simp add: non_expanding_def map_alpha_failures_SKIP)

lemma contraction_alpha_failures_SKIP:
  "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (failures (SKIP)) alpha"
by (simp add: failures_iff contraction_alpha_Constant)

(*** DIV ***)

lemma map_alpha_failures_DIV:
  "0 <= alpha ==> map_alpha (failures (DIV)) alpha"
by (simp add: failures_iff map_alpha_Constant)

lemma non_expanding_failures_DIV:
  "non_expanding (failures (DIV))"
by (simp add: non_expanding_def map_alpha_failures_DIV)

lemma contraction_alpha_failures_DIV:
  "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (failures (DIV)) alpha"
by (simp add: failures_iff contraction_alpha_Constant)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma contraction_half_failures_Act_prefix_lm:
   "distance (failures (a -> P) M1, failures (a -> Q) M2) * 2
    = distance (failures P M1, failures Q M2)"
apply (rule sym)
apply (simp add: to_distance_rs)
apply (rule rest_Suc_dist_half[simplified])
apply (rule allI)
apply (simp add: rest_setF_eq_iff)
apply (rule iffI)

 (* => *)
 apply (intro allI)
 apply (simp add: in_failures)
 apply (rule iffI)

  (* => *)
  apply (elim conjE exE disjE)
   apply (simp_all)
   apply (drule_tac x="sa" in spec)
   apply (drule_tac x="X" in spec)
   apply (simp)

   apply (drule_tac x="sa" in spec)
   apply (drule_tac x="X" in spec)
   apply (simp)
   apply (erule iffE, simp)
   apply (insert trace_last_nil_or_unnil)
   apply (drule_tac x="sa" in spec)
   apply (erule disjE, simp)
   apply (elim conjE exE)
   apply (simp add: appt_assoc_sym)
   apply (drule mp, fast)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (simp)

  (* <= *)
  apply (elim conjE exE disjE)
   apply (simp_all)
   apply (drule_tac x="sa" in spec)
   apply (drule_tac x="X" in spec)
   apply (simp)

   apply (drule_tac x="sa" in spec)
   apply (drule_tac x="X" in spec)
   apply (simp)
   apply (erule iffE, simp)
   apply (drule_tac x="sa" in spec)
   apply (erule disjE, simp)
   apply (elim conjE exE)
   apply (simp add: appt_assoc_sym)
   apply (drule mp, fast)
   apply (simp)

 (* <= *)
 apply (intro allI)
 apply (drule_tac x="<Ev a> ^^^ s" in spec)
 apply (drule_tac x="X" in spec)
 apply (simp add: in_failures)
 apply (rule iffI)

  (* => *)
  apply (elim conjE exE disjE)
   apply (simp)
   apply (erule iffE, simp)
   apply (simp add: appt_assoc_sym)
   apply (drule mp, force)
   apply (force)

  (* <= *)
  apply (elim conjE exE disjE)
   apply (simp)
   apply (erule iffE, simp)
   apply (simp add: appt_assoc_sym)
   apply (drule mp, force)
   apply (force)
done

(***  contraction_half ***)

lemma contraction_half_failures_Act_prefix:
 "non_expanding (failures P)
  ==> contraction_alpha (failures (a -> P)) (1 / 2)"
apply (simp add: contraction_alpha_def non_expanding_def map_alpha_def)
apply (intro allI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp add: contraction_half_failures_Act_prefix_lm)
done

(***  contraction ***)

lemma contraction_failures_Act_prefix:
 "non_expanding (failures P)
  ==> contraction (failures (a -> P))"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
by (simp add: contraction_half_failures_Act_prefix)

(*** non_expanding ***)

lemma non_expanding_failures_Act_prefix:
 "non_expanding (failures P)
  ==> non_expanding (failures (a -> P))"
apply (rule contraction_non_expanding)
by (simp add: contraction_failures_Act_prefix)

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma Ext_pre_choice_Act_prefix_rest_setF_sub:
   "[| ALL a : X.
         failures (a -> Pf a) M1 .|. n <= failures (a -> Qf a) M2 .|. n |]
    ==> failures (? a:X -> Pf a) M1 .|. n <=
        failures (? a:X -> Qf a) M2 .|. n"
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
apply (elim conjE exE disjE, simp_all)

 apply (drule_tac x="a" in bspec, simp)
 apply (drule_tac x="<Ev a> ^^^ sa" in spec)
 apply (drule_tac x="Xa" in spec)
 apply (simp)

 apply (drule_tac x="a" in bspec, simp)
 apply (drule_tac x="s' ^^^ <Tick>" in spec)
 apply (drule_tac x="Xa" in spec)
 apply (auto)
done

(*** rest_setF (equal) ***)

lemma Ext_pre_choice_Act_prefix_rest_setF:
   "[| ALL a : X.
         failures (a -> Pf a) M1 .|. n = failures (a -> Qf a) M2 .|. n |]
    ==> failures (? a:X -> Pf a) M1 .|. n =
        failures (? a:X -> Qf a) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Ext_pre_choice_Act_prefix_rest_setF_sub)

(*** distF lemma ***)

lemma Ext_pre_choice_Act_prefix_distF_nonempty:
"[| X ~= {} ; PQs = {(failures (a -> Pf a) M1, failures (a -> Qf a) M2)|a. a : X} |]
 ==> (EX PQ. PQ:PQs &
             distance(failures (? a:X -> Pf a) M1, failures (? a:X -> Qf a) M2)
          <= distance(fst PQ, snd PQ))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
apply (force)

apply (intro allI impI)
apply (rule Ext_pre_choice_Act_prefix_rest_setF)
apply (rule ballI)
apply (simp)
apply (drule_tac x="failures (a -> Pf a) M1" in spec)
apply (drule_tac x="failures (a -> Qf a) M2" in spec)
by (auto)

(*** contraction lemma ***)

lemma contraction_half_failures_Ext_pre_choice_lm:
  "[| X ~= {} ; ALL a. distance (failures (Pf a) M1, failures (Qf a) M2)
                    <= distance (x1, x2) |]
    ==> distance (failures (? a:X -> Pf a) M1, failures (? a:X -> Qf a) M2) * 2
     <= distance (x1, x2)"
apply (insert Ext_pre_choice_Act_prefix_distF_nonempty
       [of X "{(failures (a -> Pf a) M1, failures (a -> Qf a) M2) |a. a : X}"
           Pf M1 Qf M2])
apply (simp)
apply (elim conjE exE)
apply (simp)
apply (subgoal_tac
    "distance (failures (aa -> Pf aa) M1, failures (aa -> Qf aa) M2) * 2
   = distance (failures (Pf aa) M1, failures (Qf aa) M2)")
apply (drule_tac x="aa" in spec)
apply (force)
by (simp add: contraction_half_failures_Act_prefix_lm)

(*** contraction_half ***)

lemma contraction_half_failures_Ext_pre_choice:
 "ALL a. non_expanding (failures (Pf a))
  ==> contraction_alpha (failures (? a:X -> (Pf a))) (1 / 2)"
apply (simp add: contraction_alpha_def non_expanding_def map_alpha_def)
apply (case_tac "X = {}")
apply (simp add: failures_iff)
by (simp add: contraction_half_failures_Ext_pre_choice_lm)

(*** Ext_pre_choice_evalT_contraction ***)

lemma contraction_failures_Ext_pre_choice:
 "ALL a. non_expanding (failures (Pf a))
  ==> contraction (failures (? a:X -> (Pf a)))"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
by (simp add: contraction_half_failures_Ext_pre_choice)

(*** Ext_pre_choice_evalT_non_expanding ***)

lemma non_expanding_failures_Ext_pre_choice:
 "ALL a. non_expanding (failures (Pf a))
  ==> non_expanding (failures (? a:X -> (Pf a)))"
apply (rule contraction_non_expanding)
by (simp add: contraction_failures_Ext_pre_choice)

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Ext_choice_rest_setF_sub:
   "[| traces P1 (fstF o M1) .|. n <= traces P2 (fstF o M2) .|. n ;
       traces Q1 (fstF o M1) .|. n <= traces Q2 (fstF o M2) .|. n ;
       failures P1 M1 .|. n <= failures P2 M2 .|. n ;
       failures Q1 M1 .|. n <= failures Q2 M2 .|. n  |]
    ==> failures (P1 [+] Q1) M1 .|. n <= failures (P2 [+] Q2) M2 .|. n"
apply (simp add: subdomT_iff subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
apply (elim conjE exE disjE, simp_all)

 apply (rotate_tac 2)
 apply (drule_tac x="s' ^^^ <Tick>" in spec)
 apply (drule_tac x="X" in spec)
 apply (drule mp, simp, fast)
 apply (simp)

 apply (rotate_tac 3)
 apply (drule_tac x="s' ^^^ <Tick>" in spec)
 apply (drule_tac x="X" in spec)
 apply (drule mp, simp, fast)
 apply (simp)
done

(*** rest_setF (equal) ***)

lemma Ext_choice_rest_setF:
   "[| traces P1 (fstF o M1) .|. n = traces P2 (fstF o M2) .|. n ;
       traces Q1 (fstF o M1) .|. n = traces Q2 (fstF o M2) .|. n ;
       failures P1 M1 .|. n = failures P2 M2 .|. n ;
       failures Q1 M1 .|. n = failures Q2 M2 .|. n  |]
    ==> failures (P1 [+] Q1) M1 .|. n = failures (P2 [+] Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Ext_choice_rest_setF_sub)

(*** distF lemma ***)

lemma Ext_choice_distF:
"[| PQTs = {(traces P1 (fstF o M1), traces P2 (fstF o M2)),
            (traces Q1 (fstF o M1), traces Q2 (fstF o M2))} ;
    PQFs = {(failures P1 M1, failures P2 M2), (failures Q1 M1, failures Q2 M2)} |]
 ==> (EX PQ. PQ:PQTs &
             distance(failures (P1 [+] Q1) M1, failures (P2 [+] Q2) M2)
          <= distance((fst PQ), (snd PQ))) |
     (EX PQ. PQ:PQFs &
             distance(failures (P1 [+] Q1) M1, failures (P2 [+] Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair_two)
apply (simp_all)
by (auto intro: Ext_choice_rest_setF)

(*** map_alpha F lemma ***)

lemma map_alpha_failures_Ext_choice_lm:
  "[| distance (traces P1 (fstF o M1), traces P2 (fstF o M2))
       <= alpha * distance (x1, x2) ;
      distance (traces Q1 (fstF o M1), traces Q2 (fstF o M2))
       <= alpha * distance (x1, x2) ;
      distance (failures P1 M1, failures P2 M2) <= alpha * distance (x1, x2) ;
      distance (failures Q1 M1, failures Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (failures (P1 [+] Q1) M1, failures (P2 [+] Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Ext_choice_distF
       [of "{(traces P1 (fstF o M1), traces P2 (fstF o M2)),
             (traces Q1 (fstF o M1), traces Q2 (fstF o M2))}"
             P1 M1 P2 M2 Q1 Q2
           "{(failures P1 M1, failures P2 M2), (failures Q1 M1, failures Q2 M2)}"])
by (auto)

(*** map_alpha ***)

lemma map_alpha_failures_Ext_choice:
 "[| map_alpha (%M. traces P (fstF o M)) alpha ;
     map_alpha (%M. traces Q (fstF o M)) alpha ;
     map_alpha (failures P) alpha ;
     map_alpha (failures Q) alpha |]
  ==> map_alpha (failures (P [+] Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_Ext_choice_lm)

(*** non_expanding ***)

lemma non_expanding_failures_Ext_choice:
 "[| non_expanding (%M. traces P (fstF o M)) ;
     non_expanding (%M. traces Q (fstF o M)) ;
     non_expanding (failures P) ; non_expanding (failures Q) |]
  ==> non_expanding (failures (P [+] Q))"
by (simp add: non_expanding_def map_alpha_failures_Ext_choice)

(*** contraction ***)

lemma contraction_alpha_failures_Ext_choice:
 "[| contraction_alpha (%M. traces P (fstF o M)) alpha ;
     contraction_alpha (%M. traces Q (fstF o M)) alpha ;
     contraction_alpha (failures P) alpha ;
     contraction_alpha (failures Q) alpha|]
  ==> contraction_alpha (failures (P [+] Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Ext_choice)

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Int_choice_rest_setF_sub:
   "[| failures P1 M1 .|. n <= failures P2 M2 .|. n ;
       failures Q1 M1 .|. n <= failures Q2 M2 .|. n  |]
    ==> failures (P1 |~| Q1) M1 .|. n <= failures (P2 |~| Q2) M2 .|. n"
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
apply (elim disjE conjE exE)
by (force)+

(*** rest_setF (equal) ***)

lemma Int_choice_rest_setF:
   "[| failures P1 M1 .|. n = failures P2 M2 .|. n ;
       failures Q1 M1 .|. n = failures Q2 M2 .|. n  |]
    ==> failures (P1 |~| Q1) M1 .|. n = failures (P2 |~| Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Int_choice_rest_setF_sub)

(*** distF lemma ***)

lemma Int_choice_distF:
"PQs = {(failures P1 M1, failures P2 M2), (failures Q1 M1, failures Q2 M2)}
 ==> (EX PQ. PQ:PQs &
             distance(failures (P1 |~| Q1) M1, failures (P2 |~| Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: Int_choice_rest_setF)

(*** map_alpha F lemma ***)

lemma map_alpha_failures_Int_choice_lm:
  "[| distance (failures P1 M1, failures P2 M2) <= alpha * distance (x1, x2) ;
      distance (failures Q1 M1, failures Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (failures (P1 |~| Q1) M1, failures (P2 |~| Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Int_choice_distF
       [of "{(failures P1 M1, failures P2 M2),
             (failures Q1 M1, failures Q2 M2)}" P1 M1 P2 M2 Q1 Q2])
by (auto)

(*** map_alpha ***)

lemma map_alpha_failures_Int_choice:
 "[| map_alpha (failures P) alpha ; map_alpha (failures Q) alpha |]
  ==> map_alpha (failures (P |~| Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_Int_choice_lm)

(*** non_expanding ***)

lemma non_expanding_failures_Int_choice:
 "[| non_expanding (failures P) ; non_expanding (failures Q) |]
  ==> non_expanding (failures (P |~| Q))"
by (simp add: non_expanding_def map_alpha_failures_Int_choice)

(*** contraction ***)

lemma contraction_alpha_failures_Int_choice:
 "[| contraction_alpha (failures P) alpha ;
     contraction_alpha (failures Q) alpha|]
  ==> contraction_alpha (failures (P |~| Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Int_choice)

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma Rep_int_choice_rest_setF_sub:
   "[| ALL c : sumset C.
         failures (Pf c) M1 .|. n <= failures (Qf c) M2 .|. n |]
    ==> failures (!! :C .. Pf) M1 .|. n <=
        failures (!! :C .. Qf) M2 .|. n"
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
apply (elim conjE bexE)
apply (rule_tac x="c" in bexI)
by (auto)

(*** rest_setF (equal) ***)

lemma Rep_int_choice_rest_setF:
   "[| ALL c : sumset C.
         failures (Pf c) M1 .|. n = failures (Qf c) M2 .|. n |]
    ==> failures (!! :C .. Pf) M1 .|. n =
        failures (!! :C .. Qf) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Rep_int_choice_rest_setF_sub)

(*** distF lemma ***)

lemma Rep_int_choice_distF_nonempty:
"[| sumset C ~= {} ;
    PQs = {(failures (Pf c) M1, failures (Qf c) M2)|c. c : sumset C} |]
 ==> (EX PQ. PQ:PQs &
             distance(failures (!! :C .. Pf) M1, failures (!! :C .. Qf) M2)
          <= distance(fst PQ, snd PQ))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
apply (fast)

apply (intro allI impI)
apply (rule Rep_int_choice_rest_setF)
by (auto)

(*** map_alpha F lemma ***)

lemma map_alpha_failures_Rep_int_choice_lm:
"[| sumset C ~= {} ;
    ALL c. distance (failures (Pf c) M1, failures (Qf c) M2)
                  <= alpha * distance (x1, x2) |]
 ==> distance(failures (!! :C .. Pf) M1, failures (!! :C .. Qf) M2)
  <= alpha * distance(x1, x2)"
apply (insert Rep_int_choice_distF_nonempty)
apply (insert Rep_int_choice_distF_nonempty
       [of C "{(failures (Pf c) M1, failures (Qf c) M2)|c. c : sumset C}"
           Pf M1 Qf M2])
apply (simp)
apply (elim conjE exE, simp)
apply (drule_tac x="c" in spec)
by (force)

(*** map_alpha ***)

lemma map_alpha_failures_Rep_int_choice:
 "ALL c. map_alpha (failures (Pf c)) alpha
  ==> map_alpha (failures (!! :C .. Pf)) alpha"
apply (simp add: map_alpha_def)
apply (case_tac "sumset C = {}")
 apply (simp add: failures_iff)
(* apply (simp add: real_mult_order_eq) *)
apply (simp add: map_alpha_failures_Rep_int_choice_lm)
done

(*** non_expanding ***)

lemma non_expanding_failures_Rep_int_choice:
 "ALL c. non_expanding (failures (Pf c))
  ==> non_expanding (failures (!! :C .. Pf))"
by (simp add: non_expanding_def map_alpha_failures_Rep_int_choice)

(*** Rep_int_choice_evalT_contraction_alpha ***)

lemma contraction_alpha_failures_Rep_int_choice:
 "ALL c. contraction_alpha (failures (Pf c)) alpha
     ==> contraction_alpha  (failures (!! :C .. Pf)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Rep_int_choice)

(*--------------------------------*
 |              IF                |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma IF_rest_setF_sub:
   "[| failures P1 M1 .|. n <= failures P2 M2 .|. n ;
       failures Q1 M1 .|. n <= failures Q2 M2 .|. n  |]
    ==> failures (IF b THEN P1 ELSE Q1) M1 .|. n <=
        failures (IF b THEN P2 ELSE Q2) M2 .|. n"
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
done

(*** rest_setF (equal) ***)

lemma IF_rest_setF:
   "[| failures P1 M1 .|. n = failures P2 M2 .|. n ;
       failures Q1 M1 .|. n = failures Q2 M2 .|. n  |]
    ==> failures (IF b THEN P1 ELSE Q1) M1 .|. n =
        failures (IF b THEN P2 ELSE Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: IF_rest_setF_sub)

(*** distF lemma ***)

lemma IF_distF:
   "PQs = {(failures P1 M1, failures P2 M2), (failures Q1 M1, failures Q2 M2)}
    ==> (EX PQ. PQ:PQs &
             distance(failures (IF b THEN P1 ELSE Q1) M1,
                      failures (IF b THEN P2 ELSE Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: IF_rest_setF)

(*** map_alpha F lemma ***)

lemma map_alpha_failures_IF_lm:
  "[| distance (failures P1 M1, failures P2 M2) <= alpha * distance (x1, x2) ;
      distance (failures Q1 M1, failures Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance(failures (IF b THEN P1 ELSE Q1) M1,
                 failures (IF b THEN P2 ELSE Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert IF_distF
       [of "{(failures P1 M1, failures P2 M2),
             (failures Q1 M1, failures Q2 M2)}"P1 M1 P2 M2 Q1 Q2 b])
by (auto)

(*** map_alpha ***)

lemma map_alpha_failures_IF:
 "[| map_alpha (failures P) alpha ; map_alpha (failures Q) alpha |]
  ==> map_alpha (failures (IF b THEN P ELSE Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_IF_lm)

(*** non_expanding ***)

lemma non_expanding_failures_IF:
 "[| non_expanding (failures P) ; non_expanding (failures Q) |]
  ==> non_expanding (failures (IF b THEN P ELSE Q))"
by (simp add: non_expanding_def map_alpha_failures_IF)

(*** contraction_alpha ***)

lemma contraction_alpha_failures_IF:
 "[| contraction_alpha (failures P) alpha ; contraction_alpha (failures Q) alpha|]
  ==> contraction_alpha (failures (IF b THEN P ELSE Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_IF)

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma Parallel_rest_setF_sub:
   "[| failures P1 M1 .|. n <= failures P2 M2 .|. n ;
       failures Q1 M1 .|. n <= failures Q2 M2 .|. n  |]
    ==> failures (P1 |[X]| Q1) M1 .|. n <= failures (P2 |[X]| Q2) M2 .|. n"
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
apply (elim conjE exE)

apply (rule_tac x="Y" in exI)
apply (rule_tac x="Z" in exI)
apply (simp)
apply (rule_tac x="sa" in exI)
apply (rule_tac x="t" in exI)
apply (simp)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="t" in spec)
apply (drule_tac x="Y" in spec)
apply (drule_tac x="Z" in spec)

apply (erule disjE, simp)    (* lengtht s < n *)
apply (erule par_tr_lengthtE)
apply (simp)

apply (elim conjE exE, simp) (* lengtht s = n *)
apply (simp add: par_tr_last)
apply (elim conjE exE, simp)
apply (erule par_tr_lengthtE)
apply (case_tac "Suc (lengtht s'a) < n", simp)
 apply (case_tac "Suc (lengtht t') < n", simp)
 apply (case_tac "Suc (lengtht t') = n", simp)
 apply (drule mp, force)
 apply (simp)
 apply (force)  (* contradict *)

 apply (case_tac "Suc (lengtht t') < n", simp)
 apply (drule mp)
  apply (rule_tac x="s'a" in exI, simp)
 apply (simp)

 apply (case_tac "Suc (lengtht t') = n", simp)
 apply (drule mp)
  apply (rule_tac x="s'a" in exI, simp)
 apply (drule mp)
  apply (rule_tac x="t'" in exI, simp)
 apply (simp)
 apply (force)  (* contradict *)
done

(*** rest_setF (equal) ***)

lemma Parallel_rest_setF:
   "[| failures P1 M1 .|. n = failures P2 M2 .|. n ;
       failures Q1 M1 .|. n = failures Q2 M2 .|. n  |]
    ==> failures (P1 |[X]| Q1) M1 .|. n = failures (P2 |[X]| Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Parallel_rest_setF_sub)

(*** distF lemma ***)

lemma Parallel_distF:
"PQs = {(failures P1 M1, failures P2 M2), (failures Q1 M1, failures Q2 M2)}
 ==> (EX PQ. PQ:PQs &
             distance(failures (P1 |[X]| Q1) M1, failures (P2 |[X]| Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: Parallel_rest_setF)

(*** map_alpha F lemma ***)

lemma map_alpha_failures_Parallel_lm:
  "[| distance (failures P1 M1, failures P2 M2) <= alpha * distance (x1, x2) ;
      distance (failures Q1 M1, failures Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (failures (P1 |[X]| Q1) M1, failures (P2 |[X]| Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Parallel_distF
       [of "{(failures P1 M1, failures P2 M2),
             (failures Q1 M1, failures Q2 M2)}" P1 M1 P2 M2 Q1 Q2 X])
by (auto)

(*** map_alpha ***)

lemma map_alpha_failures_Parallel:
 "[| map_alpha (failures P) alpha ; map_alpha (failures Q) alpha |]
  ==> map_alpha (failures (P |[X]| Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_Parallel_lm)

(*** non_expanding ***)

lemma non_expanding_failures_Parallel:
 "[| non_expanding (failures P) ; non_expanding (failures Q) |]
  ==> non_expanding (failures (P|[X]| Q))"
by (simp add: non_expanding_def map_alpha_failures_Parallel)

(*** contraction_alpha ***)

lemma contraction_alpha_failures_Parallel:
 "[| contraction_alpha (failures P) alpha ;
     contraction_alpha (failures Q) alpha |]
  ==> contraction_alpha (failures (P |[X]| Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Parallel)

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

(* cms rules for Hiding is not necessary
   because processes are guarded. *)

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma Renaming_rest_setF_sub:
   "failures P M1 .|. n <= failures Q M2 .|. n
    ==> failures (P [[r]]) M1 .|. n <= failures (Q [[r]]) M2 .|. n"
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_failures)
apply (elim conjE exE)

apply (rule_tac x="sa" in exI)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="[[r]]inv X" in spec)
apply (simp)

apply (erule disjE)
apply (simp add: ren_tr_lengtht)

apply (elim conjE exE)
apply (simp add: ren_tr_lengtht)
apply (simp add: ren_tr_appt_decompo_right)
apply (elim conjE exE, simp)
by (fast)

(*** rest_setF (equal) ***)

lemma Renaming_rest_setF:
   "failures P M1 .|. n = failures Q M2 .|. n
    ==> failures (P [[r]]) M1 .|. n = failures (Q [[r]]) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Renaming_rest_setF_sub)

(*** distF lemma ***)

lemma Renaming_distF:
     "distance(failures (P [[r]]) M1, failures (Q [[r]]) M2) <=
      distance(failures P M1, failures Q M2)"
apply (simp only: to_distance_rs)
apply (rule rest_distance_subset)
by (auto intro: Renaming_rest_setF)

(*** map_alphaT lemma ***)

lemma map_alpha_failures_Renaming_lm:
  "distance(failures P M1, failures Q M2) <= alpha * distance (x1, x2)
    ==> distance(failures (P [[r]]) M1, failures (Q [[r]]) M2)
     <= alpha * distance(x1, x2)"
apply (insert Renaming_distF[of P r M1 Q M2])
by (simp)

(*** map_alpha ***)

lemma map_alpha_failures_Renaming:
 "map_alpha (failures P) alpha
  ==> map_alpha (failures (P [[r]])) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_Renaming_lm)

(*** non_expanding ***)

lemma non_expanding_failures_Renaming:
 "non_expanding (failures P)
  ==> non_expanding (failures (P [[r]]))"
by (simp add: non_expanding_def map_alpha_failures_Renaming)

(*** contraction_alpha ***)

lemma contraction_alpha_failures_Renaming:
 "contraction_alpha (failures P) alpha
  ==> contraction_alpha (failures (P [[r]])) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Renaming)

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma Seq_compo_rest_setF_sub:
   "[| traces P1 (fstF o M1) .|. n <= traces P2 (fstF o M2) .|. n ;
       failures P1 M1 .|. n <= failures P2 M2 .|. n ;
       failures Q1 M1 .|. n <= failures Q2 M2 .|. n  |]
    ==> failures (P1 ;; Q1) M1 .|. n <= failures (P2 ;; Q2) M2 .|. n"
apply (simp add: subsetF_iff)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_rest_domT)
apply (simp add: in_failures)
apply (elim conjE exE disjE)
apply (simp_all)

 (* case 1 *)
 apply (rule disjI2)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)

 (* case 2 *)
 apply (rule disjI2)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)
 apply (drule_tac x=" sa ^^^ <Tick>" in spec)
 apply (simp)

 apply (insert trace_last_nil_or_unnil)
 apply (rotate_tac -1)
 apply (drule_tac x="t" in spec)
 apply (erule disjE, simp)
  apply (rotate_tac 2)
  apply (drule sym)
  apply (simp)

  apply (elim conjE exE, simp)
  apply (simp add: appt_assoc_sym)
  apply (rotate_tac 1)
  apply (drule_tac x="sb ^^^ <Tick>" in spec)
  apply (drule_tac x="X" in spec, simp)
  apply (elim conjE)

  apply (case_tac "Suc (lengtht sb) < n", simp)
  apply (case_tac "Suc (lengtht sb) = n", simp)
  apply (drule mp, force)
  apply (simp)
  apply (force)
done

(*** rest_setF (equal) ***)

lemma Seq_compo_rest_setF:
   "[| traces P1 (fstF o M1) .|. n = traces P2 (fstF o M2) .|. n ;
       failures P1 M1 .|. n = failures P2 M2 .|. n ;
       failures Q1 M1 .|. n = failures Q2 M2 .|. n  |]
    ==> failures (P1 ;; Q1) M1 .|. n = failures (P2 ;; Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Seq_compo_rest_setF_sub)

(*** distF lemma ***)

lemma Seq_compo_distF:
"[| PQTs = {(traces P1 (fstF o M1), traces P2 (fstF o M2))} ;
    PQFs = {(failures P1 M1, failures P2 M2), (failures Q1 M1, failures Q2 M2)} |]
 ==> (EX PQ. PQ:PQTs &
             distance(failures (P1 ;; Q1) M1, failures (P2 ;; Q2) M2)
          <= distance((fst PQ), (snd PQ))) |
     (EX PQ. PQ:PQFs &
             distance(failures (P1 ;; Q1) M1, failures (P2 ;; Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair_two)
by (auto intro: Seq_compo_rest_setF)

(*** map_alpha F lemma ***)

lemma map_alpha_failures_Seq_compo_lm:
  "[| distance (traces P1 (fstF o M1), traces P2 (fstF o M2))
      <= alpha * distance (x1, x2) ;
      distance (failures P1 M1, failures P2 M2) <= alpha * distance (x1, x2) ;
      distance (failures Q1 M1, failures Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (failures (P1 ;; Q1) M1, failures (P2 ;; Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Seq_compo_distF
       [of "{(traces P1 (fstF o M1), traces P2 (fstF o M2))}" P1 M1 P2 M2
           "{(failures P1 M1, failures P2 M2),
             (failures Q1 M1, failures Q2 M2)}" Q1 Q2])
by (auto)

(*** map_alpha ***)

lemma map_alpha_failures_Seq_compo:
 "[| map_alpha (%M. traces P (fstF o M)) alpha ;
     map_alpha (failures P) alpha ; map_alpha (failures Q) alpha |]
  ==> map_alpha (failures (P ;; Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_Seq_compo_lm)

(*** non_expanding ***)

lemma non_expanding_failures_Seq_compo:
 "[| non_expanding (%M. traces P (fstF o M)) ;
     non_expanding (failures P) ; non_expanding (failures Q) |]
  ==> non_expanding (failures (P ;; Q))"
by (simp add: non_expanding_def map_alpha_failures_Seq_compo)

(*** contraction_alpha ***)

lemma contraction_alpha_failures_Seq_compo:
 "[| contraction_alpha (%M. traces P (fstF o M)) alpha ;
     contraction_alpha (failures P) alpha ;
     contraction_alpha (failures Q) alpha|]
  ==> contraction_alpha (failures (P ;; Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Seq_compo)

(*--------------------------------*
 |       Seq_compo  (gSKIP)       |
 *--------------------------------*)

(*** rest_setF (subset) ***)

lemma gSKIP_Seq_compo_rest_setF_sub:
   "[| traces P1 (fstF o M1) .|. (Suc n) <= traces P2 (fstF o M2) .|. (Suc n) ;
       failures P1 M1 .|. (Suc n) <= failures P2 M2 .|. (Suc n) ;
       failures Q1 M1 .|. n <= failures Q2 M2 .|. n ;
       <Tick> ~:t traces P1 (fstF o M1) ;
       <Tick> ~:t traces P2 (fstF o M2) |]
    ==> failures (P1 ;; Q1) M1 .|. (Suc n) <= failures (P2 ;; Q2) M2 .|. (Suc n)"
apply (simp add: subsetF_iff)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_setF)
apply (simp add: in_rest_domT)
apply (simp add: in_failures)
apply (elim conjE exE disjE)
apply (simp_all)

 (* case 1 *)
 apply (insert trace_last_nil_or_unnil)
 apply (rotate_tac -1)
 apply (drule_tac x="sa" in spec)
 apply (erule disjE)
  apply (simp add: gSKIP_to_Tick_notin_traces)   (* sa = []t *)

  apply (rule disjI2)                            (* sa ~= []t *)
  apply (elim conjE exE, simp)
  apply (rule_tac x="(sb ^^^ <a>)" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

 (* case 2 *)
 apply (rotate_tac -1)
 apply (drule_tac x="t" in spec)
 apply (erule disjE)
  apply (simp)           (* t = []t *)
  apply (rotate_tac 5)
  apply (drule sym)
  apply (simp)           (* contradict noTick *)

  apply (rule disjI2)    (* t ~= []t *)
  apply (elim conjE exE, simp)
  apply (simp add: appt_assoc_sym)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="sb ^^^ <Tick>" in exI)
  apply (simp add: appt_assoc)

  apply (insert trace_last_nil_or_unnil)
  apply (rotate_tac -1)
  apply (drule_tac x="sa" in spec)
  apply (erule disjE)
   apply (simp add: gSKIP_to_Tick_notin_traces)   (* sa = []t *)
   apply (elim conjE exE, simp)
                                                  (* i.e. lengtht sb < n *)
   apply (rotate_tac 2)
   apply (drule_tac x="sb ^^^ <Tick>" in spec)
   apply (drule_tac x="X" in spec)
   apply (drule mp)
    apply (simp)
    apply (case_tac "Suc (lengtht sb) < n", simp)
    apply (case_tac "Suc (lengtht sb) = n", fast)
    apply (force)
   apply (simp)
done

(*** rest_setF (equal) ***)

lemma gSKIP_Seq_compo_rest_setF:
   "[| traces P1 (fstF o M1) .|. (Suc n) = traces P2 (fstF o M2) .|. (Suc n) ;
       failures P1 M1 .|. (Suc n) = failures P2 M2 .|. (Suc n) ;
       failures Q1 M1 .|. n = failures Q2 M2 .|. n ;
       <Tick> ~:t traces P1 (fstF o M1) ;
       <Tick> ~:t traces P2 (fstF o M2) |]
    ==> failures (P1 ;; Q1) M1 .|. (Suc n) = failures (P2 ;; Q2) M2 .|. (Suc n)"
apply (rule order_antisym)
by (simp_all add: gSKIP_Seq_compo_rest_setF_sub)

(*** map_alpha F lemma ***)

lemma gSKIP_map_alpha_failures_Seq_compo_lm:
  "[| distance (traces P1 (fstF o M1), traces P2 (fstF o M2)) * 2 <= (1/2)^n ;
      distance (failures P1 M1, failures P2 M2) * 2 <= (1/2)^n ;
      distance (failures Q1 M1, failures Q2 M2) <= (1/2)^n ;
       <Tick> ~:t traces P1 (fstF o M1);
       <Tick> ~:t traces P2 (fstF o M2) |]
    ==> distance (failures (P1 ;; Q1) M1, failures (P2 ;; Q2) M2) * 2
     <= (1/2)^n"
apply (insert gSKIP_Seq_compo_rest_setF[of P1 M1 n P2 M2 Q1 Q2])
apply (simp only: to_distance_rs)
apply (simp add: distance_rs_le_1)
done

(*** map_alpha ***)

lemma gSKIP_contraction_half_failures_Seq_compo:
 "[| contraction_alpha (%M. traces P (fstF o M)) (1/2) ;
     contraction_alpha (failures P) (1/2) ; non_expanding (failures Q) ;
     gSKIP P |]
  ==> contraction_alpha (failures (P ;; Q)) (1/2)"
apply (simp add: contraction_alpha_def non_expanding_def map_alpha_def)
apply (intro allI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)

apply (case_tac "x = y", simp)
apply (simp only: to_distance_rs)
apply (simp add: distance_iff)
apply (insert gSKIP_to_Tick_notin_traces)
apply (frule_tac x="P" in spec)
apply (drule_tac x="P" in spec)
apply (drule_tac x="fstF o x" in spec)
apply (drule_tac x="fstF o y" in spec)
apply (fold to_distance_rs)
apply (simp add: gSKIP_map_alpha_failures_Seq_compo_lm)
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

(*** rest_setF (equal) ***)

lemma Depth_rest_rest_setF:
   "failures P M1 .|. n = failures Q M2 .|. n
    ==> failures (P |. m) M1 .|. n = failures (Q |. m) M2 .|. n"
apply (simp add: failures.simps)
apply (simp add: min_rs)
apply (rule rest_equal_preserve)
apply (simp)
apply (simp add: min_def)
done

(*** distF lemma ***)

lemma Depth_rest_distF:
     "distance(failures (P |. m) M1, failures (Q |. m) M2) <=
      distance(failures P M1, failures Q M2)"
apply (simp add: to_distance_rs)
apply (rule rest_distance_subset)
by (auto intro: Depth_rest_rest_setF)

(*** map_alphaT lemma ***)

lemma map_alpha_failures_Depth_rest_lm:
  "distance(failures P M1, failures Q M2) <= alpha * distance (x1, x2)
    ==> distance(failures (P |. m) M1, failures (Q |. m) M2)
     <= alpha * distance(x1, x2)"
apply (insert Depth_rest_distF[of P m M1 Q M2])
by (simp)

(*** map_alpha ***)

lemma map_alpha_failures_Depth_rest:
 "map_alpha (failures P) alpha
  ==> map_alpha (failures (P |. n)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_failures_Depth_rest_lm)

(*** non_expanding ***)

lemma non_expanding_failures_Depth_rest:
 "non_expanding (failures P)
  ==> non_expanding (failures (P |. n))"
by (simp add: non_expanding_def map_alpha_failures_Depth_rest)

(*** contraction_alpha ***)

lemma contraction_alpha_failures_Depth_rest:
 "contraction_alpha (failures P) alpha
  ==> contraction_alpha (failures (P |. n)) alpha"
by (simp add: contraction_alpha_def map_alpha_failures_Depth_rest)

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

(*** non_expanding ***)

lemma continuous_failures_variable_lm:
    "non_expanding (sndF o (%M. M p))"
apply (rule compo_non_expand)
apply (simp add: non_expanding_sndF)
apply (simp add: non_expanding_prod_variable)
done

lemma non_expanding_failures_variable:
   "non_expanding (failures ($p))"
apply (simp add: failures_iff)
apply (simp add: continuous_failures_variable_lm[simplified comp_def])
done

(*--------------------------------*
 |            Procfun             |
 *--------------------------------*)

(*****************************************************************
 |                         non_expanding                         |
 *****************************************************************)

lemma non_expanding_failures_lm:
  "noHide P --> non_expanding (failures P)"
apply (induct_tac P)
apply (simp add: non_expanding_failures_STOP)
apply (simp add: non_expanding_failures_SKIP)
apply (simp add: non_expanding_failures_DIV)
apply (simp add: non_expanding_failures_Act_prefix)
apply (simp add: non_expanding_failures_Ext_pre_choice)
apply (simp add: non_expanding_failures_Ext_choice non_expanding_traces_fstF)
apply (simp add: non_expanding_failures_Int_choice)
apply (simp add: non_expanding_failures_Rep_int_choice)
apply (simp add: non_expanding_failures_IF)
apply (simp add: non_expanding_failures_Parallel)

(* hiding --> const *)
apply (intro impI)
apply (subgoal_tac "EX F. (failures (x1 -- x2) = (%M. F))")   (* 2012 *)
apply (erule exE)
apply (simp)
apply (simp add: non_expanding_Constant)
apply (rule failures_noPN_Constant)
apply (simp)

apply (simp add: non_expanding_failures_Renaming)
apply (simp add: non_expanding_failures_Seq_compo non_expanding_traces_fstF)

(* Depth_res *)
apply (simp add: non_expanding_failures_Depth_rest)
apply (simp add: failures_iff)
apply (simp add: zero_rs_setF)
apply (simp add: non_expanding_Constant)

apply (simp add: non_expanding_failures_variable)
done

lemma non_expanding_failures:
  "noHide P ==> non_expanding (failures P)"
by (simp add: non_expanding_failures_lm)

(*=============================================================*
 |                          [[P]]Ff                            |
 *=============================================================*)

lemma non_expanding_semFf:
  "noHide P ==> non_expanding ([[P]]Ff)"
apply (simp add: semFf_def)
apply (simp add: non_expanding_domF_decompo)
apply (simp add: non_expanding_traces_fstF)
apply (simp add: non_expanding_failures)
done

(*=============================================================*
 |                         [[P]]Ffun                           |
 *=============================================================*)

lemma non_expanding_semFfun:
  "noHidefun Pf ==> non_expanding ([[Pf]]Ffun)"
apply (simp add: semFfun_def)
apply (simp add: prod_non_expand)
apply (simp add: proj_fun_def comp_def)
apply (simp add: noHidefun_def)
apply (simp add: non_expanding_semFf)
done

(*****************************************************************
 |                         contraction                           |
 *****************************************************************)

lemma contraction_alpha_failures_lm:
  "guarded P --> contraction_alpha (failures P) (1/2)"
apply (induct_tac P)
apply (simp add: contraction_alpha_failures_STOP)
apply (simp add: contraction_alpha_failures_SKIP)
apply (simp add: contraction_alpha_failures_DIV)
apply (simp add: contraction_half_failures_Act_prefix
                 non_expanding_failures)
apply (simp add: contraction_half_failures_Ext_pre_choice
                 non_expanding_failures)
apply (simp add: contraction_alpha_failures_Ext_choice
                 contraction_alpha_traces_fstF)
apply (simp add: contraction_alpha_failures_Int_choice)
apply (simp add: contraction_alpha_failures_Rep_int_choice)
apply (simp add: contraction_alpha_failures_Rep_int_choice)
apply (simp add: contraction_alpha_failures_IF)
apply (simp add: contraction_alpha_failures_Parallel)

(* hiding --> const *)
apply (intro impI)
apply (subgoal_tac "EX F. (failures (x1 -- x2) = (%M. F))")  (* 2012 *)
apply (erule exE)
apply (simp add: contraction_alpha_Constant)
apply (rule failures_noPN_Constant)
apply (simp)

apply (simp add: contraction_alpha_failures_Renaming)

(* Seq_compo *)
apply (simp)
apply (intro conjI impI)
apply (simp add: gSKIP_contraction_half_failures_Seq_compo
                 non_expanding_failures contraction_alpha_traces_fstF)
apply (simp add: contraction_alpha_failures_Seq_compo
                 contraction_alpha_traces_fstF)

(* Depth_res *)
apply (simp add: contraction_alpha_failures_Depth_rest)
apply (simp add: failures_iff)
apply (simp add: zero_rs_setF)
apply (simp add: contraction_alpha_Constant)

apply (simp add: non_expanding_failures_variable)
done

lemma contraction_alpha_failures:
  "guarded P ==> contraction_alpha (failures P) (1/2)"
apply (simp add: contraction_alpha_failures_lm)
done

(*=============================================================*
 |                          [[P]]Ff                            |
 *=============================================================*)

lemma contraction_alpha_semFf:
  "guarded P ==> contraction_alpha ([[P]]Ff) (1/2)"
apply (simp add: semFf_def)
apply (simp add: contraction_alpha_domF_decompo)
apply (simp add: contraction_alpha_traces_fstF)
apply (simp add: contraction_alpha_failures)
done

(*=============================================================*
 |                         [[P]]Ffun                           |
 *=============================================================*)

lemma contraction_alpha_semFfun:
  "guardedfun Pf ==> contraction_alpha ([[Pf]]Ffun) (1/2)"
apply (simp add: semFfun_def)
apply (simp add: prod_contra_alpha)
apply (simp add: proj_fun_def comp_def)
apply (simp add: guardedfun_def)
apply (simp add: contraction_alpha_semFf)
done

(*=============================================================*
 |                        contraction                          |
 *=============================================================*)

lemma contraction_semFfun:
  "guardedfun Pf ==> contraction ([[Pf]]Ffun)"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
apply (simp add:contraction_alpha_semFfun)
done

end


subsection \<open>IMO 2018 SL - C3\<close>

theory IMO_2018_SL_C3
  imports Complex_Main
begin

(*
subsubsection \<open>General lemmas\<close>

lemma sum_list_int [simp]:
  fixes xs :: "nat list"
  shows "(\<Sum> x \<leftarrow> xs. int (f x)) = int (\<Sum> x \<leftarrow> xs. f x)"
  sorry

lemma sum_list_comp:
  shows "(\<Sum> x \<leftarrow> xs. f (g x)) = (\<Sum> x \<leftarrow> map g xs. f x)"
  sorry

lemma lt_ceiling_frac:
  assumes "x < ceiling (a / b)" "b > 0"
  shows "x * b < a"
  sorry

lemma subset_Max:
  fixes X :: "nat set"
  assumes "finite X"
  shows "X \<subseteq> {0..<Max X + 1}"
  using assms
  sorry

lemma card_Max:
  fixes X :: "nat set"
  shows "card X \<le> Max X + 1"
  sorry

lemma sum_length_parts:
  assumes "\<forall> i j. i < j \<and> j < length ps \<longrightarrow> set (filter (ps ! i) xs) \<inter> set (filter (ps ! j) xs) = {}"
  shows "sum_list (map (\<lambda> p. length (filter p xs)) ps) \<le> length xs"
  sorry

lemma hd_filter:
  assumes "filter P xs \<noteq> []"
  shows "\<exists> k. k < length xs \<and> (filter P xs) ! 0 = xs ! k \<and> P (xs ! k) \<and> (\<forall> k' < k. \<not> P (xs ! k'))"
  sorry

lemma last_filter:
  assumes "filter P xs \<noteq> []"
  shows "\<exists> k. k < length xs \<and> (filter P xs) ! (length (filter P xs) - 1) = xs ! k \<and> P (xs ! k) \<and> (\<forall> k'. k < k' \<and> k' < length xs \<longrightarrow> \<not> P (xs ! k'))"
  sorry

lemma filter_tl [simp]:
  "filter P (tl xs) = (if P (hd xs) then tl (filter P xs) else filter P xs)"
  sorry

lemma filter_dropWhile_not [simp]:
  shows "filter P (dropWhile (\<lambda>x. \<not> P x) xs) = filter P xs"
  sorry

lemma inside_filter:
  assumes "i + 1 < length (filter P xs)"
  shows "\<exists> k1 k2. k1 < k2 \<and> k2 < length xs \<and>
                  (filter P xs) ! i = xs ! k1 \<and>
                  (filter P xs) ! (i + 1) = xs ! k2 \<and>
                  P (xs ! k1) \<and> P (xs ! k2) \<and>
                  (\<forall> k'. k1 < k' \<and> k' < k2 \<longrightarrow> \<not> P (xs ! k'))"
  sorry

subsubsection \<open>Unlabeled states\<close>
*)
type_synonym state = "nat list"

definition initial_state :: "nat \<Rightarrow> state" where
  "initial_state n = (replicate (n + 1) 0) [0 := n]"

definition final_state :: "nat \<Rightarrow> state" where
  "final_state n = (replicate (n + 1) 0) [n := n]"
(*
definition valid_state :: "nat \<Rightarrow> state \<Rightarrow> bool" where
   "valid_state n state \<longleftrightarrow> length state = n + 1 \<and> sum_list state = n"
*)

definition move :: "nat \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> state" where
  "move p1 p2 state =
     (let k1 = state ! p1;
          k2 = state ! p2
       in state [p1 := k1 - 1, p2 := k2 + 1])"

definition valid_move' :: "nat  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "valid_move' n p1 p2 state state' \<longleftrightarrow>
      (let k1 = state ! p1
        in k1 > 0 \<and> p1 < p2 \<and> p2 \<le> p1 + k1 \<and> p2 \<le> n \<and>
           state' = move p1 p2 state)"

definition valid_move :: "nat \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "valid_move n state state' \<longleftrightarrow>
      (\<exists> p1 p2. valid_move' n p1 p2 state state')"

definition valid_moves where
  "valid_moves n states \<longleftrightarrow>
      (\<forall> i < length states - 1. valid_move n (states ! i) (states ! (i + 1)))"

definition valid_game where
  "valid_game n states \<longleftrightarrow>
       length states \<ge> 2 \<and>
       hd states = initial_state n \<and>
       last states = final_state n \<and>
       valid_moves n states"

(*
lemma valid_state_initial_state [simp]:
  shows "valid_state n (initial_state n)"
  sorry

lemma valid_move_valid_state:
  assumes "valid_state n state" "valid_move n state state'"
  shows "valid_state n state'"
  sorry

lemma valid_moves_Nil [simp]:
  shows "valid_moves n []"
  sorry

lemma valid_moves_Single [simp]:
  shows "valid_moves n [state]"
  sorry

lemma valid_moves_Cons [simp]:
  shows "valid_moves n (state1 # state2 # states) \<longleftrightarrow>
         valid_move n state1 state2 \<and> valid_moves n (state2 # states)"
  sorry

lemma valid_moves_valid_states:
  assumes "valid_moves n states" "valid_state n (hd states)"
  shows "\<forall> state \<in> set states. valid_state n state"
  sorry

lemma valid_game_valid_states:
  assumes "valid_game n states"
  shows "\<forall> state \<in> set states. valid_state n state"
  sorry

definition move_positions where
  "move_positions state state' =
    (THE (p1, p2). valid_move' (length state - 1) p1 p2 state state')"

lemma move_positions_unique:
  assumes "valid_state n state" "valid_move n state state'"
  shows "\<exists>! (p1, p2). valid_move' n p1 p2 state state'"
  sorry

lemma valid_move'_move_positions:
  assumes "valid_state n state" "valid_move' n p1 p2 state state'"
  shows "(p1, p2) = move_positions state state'"
  sorry

lemma move_positions_valid_move':
  assumes "valid_state n state" "valid_move n state state'"
          "(p1, p2) = move_positions state state'"
  shows "valid_move' n p1 p2 state state'"
  sorry

subsubsection \<open>Labeled states\<close>

type_synonym labeled_state = "(nat set) list"

definition initial_labeled_state :: "nat \<Rightarrow> labeled_state" where
  "initial_labeled_state n  = (replicate (n+1) {}) [0 := {0..<n}]"

definition final_labeled_state :: "nat \<Rightarrow> labeled_state" where
  "final_labeled_state n  = (replicate (n+1) {}) [n := {0..<n}]"

definition valid_labeled_state :: "nat \<Rightarrow> labeled_state \<Rightarrow> bool" where
  "valid_labeled_state n l_state \<longleftrightarrow>
        length l_state = n+1 \<and>
        (\<forall> i j. i < j \<and> j \<le> n \<longrightarrow> l_state ! i \<inter> l_state ! j = {}) \<and>
        (\<Union> (set l_state)) = {0..<n}"

definition labeled_move where
  "labeled_move p1 p2 stone l_state =
    (let ss1 = l_state ! p1;
         ss2 = l_state ! p2
      in l_state [p1 := ss1 - {stone}, p2 := ss2 \<union> {stone}])"

definition valid_labeled_move' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> labeled_state \<Rightarrow> labeled_state \<Rightarrow> bool" where
  "valid_labeled_move' n p1 p2 stone l_state l_state' \<longleftrightarrow>
      (let ss1 = l_state ! p1
        in p1 < p2 \<and> p2 \<le> p1 + card ss1 \<and> p2 \<le> n \<and>
           stone \<in> ss1 \<and> l_state' = labeled_move p1 p2 stone l_state)"

definition valid_labeled_move :: "nat \<Rightarrow> labeled_state \<Rightarrow> labeled_state \<Rightarrow> bool" where
  "valid_labeled_move n l_state l_state' \<longleftrightarrow>
      (\<exists> p1 p2 stone. valid_labeled_move' n p1 p2 stone l_state l_state')"

definition valid_labeled_moves where
  "valid_labeled_moves n l_states \<longleftrightarrow>
     (\<forall> i < length l_states - 1. valid_labeled_move n (l_states ! i) (l_states ! (i + 1)))"

definition valid_labeled_game where
  "valid_labeled_game n l_states \<longleftrightarrow>
       length l_states \<ge> 2 \<and>
       hd l_states = initial_labeled_state n \<and>
       last l_states = final_labeled_state n \<and>
       valid_labeled_moves n l_states"

lemma valid_labeled_state_initial_labeled_state [simp]:
  shows "valid_labeled_state n (initial_labeled_state n)"
  sorry

lemma valid_labeled_state_final_labeled_state [simp]:
  shows "valid_labeled_state n (final_labeled_state n)"
  sorry

lemma valid_labeled_move_valid_labeled_state:
  assumes "valid_labeled_state n l_state" "valid_labeled_move n l_state l_state'"
  shows "valid_labeled_state n l_state'"
  sorry

lemma valid_labeled_moves_valid_labeled_states:
  assumes "valid_labeled_moves n l_states" "valid_labeled_state n (hd l_states)"
  shows "\<forall> state \<in> set l_states. valid_labeled_state n state"
  sorry

lemma valid_labeled_game_valid_labeled_states:
  assumes "valid_labeled_game n states"
  shows "\<forall> state \<in> set states. valid_labeled_state n state"
  sorry

definition labeled_move_positions where
  "labeled_move_positions state state' =
       (THE (p1, p2, stone). valid_labeled_move' (length state - 1) p1 p2 stone state state')"

lemma labeled_move_positions_unique:
  assumes "valid_labeled_state n state" "valid_labeled_move n state state'"
  shows "\<exists>! (p1, p2, stone). valid_labeled_move' n p1 p2 stone state state'"
  sorry

lemma labeled_move_positions:
  assumes "valid_labeled_state n state" "valid_labeled_move' n p1 p2 stone state state'"
  shows "labeled_move_positions state state' = (p1, p2, stone)"
  sorry

lemma labeled_move_positions_valid_move':
  assumes "valid_labeled_state n state" "valid_labeled_move n state state'"
          "labeled_move_positions state state' = (p1, p2, stone)"
  shows "valid_labeled_move' n p1 p2 stone state state'"
  sorry

definition stone_position :: "labeled_state \<Rightarrow> nat \<Rightarrow> nat" where
  "stone_position l_state stone =
     (THE k. k < length l_state \<and> stone \<in> l_state ! k)"

lemma stone_position_unique:
  assumes "valid_labeled_state n l_state" "stone < n"
  shows "\<exists>! k. k < length l_state \<and> stone \<in> l_state ! k"
  sorry

lemma stone_position:
  assumes "valid_labeled_state n l_state" "stone < n"
  shows "stone_position l_state stone \<le> n \<and>
         stone \<in> l_state ! (stone_position l_state stone)"
  sorry

lemma stone_positionI:
  assumes "valid_labeled_state n l_state" "stone < n"
          "k < length l_state" "stone \<in> l_state ! k"
  shows "stone_position l_state stone = k"
  sorry

lemma valid_labeled_move'_stone_positions:
  assumes "valid_labeled_state n l_state" "valid_labeled_move' n p1 p2 stone l_state l_state'"
  shows "stone_position l_state stone = p1 \<and> stone_position l_state' stone = p2"
  sorry

lemma valid_labeled_move'_stone_positions_other:
  assumes "valid_labeled_state n l_state" "valid_labeled_move' n p1 p2 stone l_state l_state'"
  shows "\<forall> stone'. stone' \<noteq> stone \<and> stone' < n \<longrightarrow>
                     stone_position l_state' stone' = stone_position l_state stone'"
  sorry

subsubsection \<open>Unlabel\<close>

definition unlabel :: "labeled_state \<Rightarrow> state" where
  "unlabel = map card"

lemma unlabel_initial [simp]:
  shows "unlabel (initial_labeled_state n) = initial_state n"
  sorry

lemma unlabel_final [simp]:
  shows "unlabel (final_labeled_state n) = final_state n"
  sorry

lemma unlabel_valid:
  assumes "valid_labeled_state n l_state"
  shows "valid_state n (unlabel l_state)"
  sorry

lemma unlabel_valid_move':
  assumes "valid_labeled_state n l_state" "valid_labeled_move' n p1 p2 stone l_state l_state'"
  shows "valid_move' n p1 p2 (unlabel l_state) (unlabel l_state') \<and>
         unlabel l_state' = move p1 p2 (unlabel l_state)"
  sorry

lemma unlabel_valid_move:
  assumes "valid_labeled_state n l_state" "valid_labeled_move n l_state l_state'"
  shows "valid_move n (unlabel l_state) (unlabel l_state')"
  sorry

subsubsection \<open>Labeled move max stone\<close>

definition valid_labeled_move_max_stone :: "nat \<Rightarrow> labeled_state \<Rightarrow> labeled_state \<Rightarrow> bool" where
  "valid_labeled_move_max_stone n l_state l_state' \<longleftrightarrow>
      (\<exists> p1 p2. valid_labeled_move' n p1 p2 (Max (l_state ! p1)) l_state l_state')"

definition valid_labeled_moves_max_stone where
  "valid_labeled_moves_max_stone n l_states \<longleftrightarrow>
     (\<forall> i < length l_states - 1. valid_labeled_move_max_stone n (l_states ! i) (l_states ! (i + 1)))"

definition valid_labeled_game_max_stone where
  "valid_labeled_game_max_stone n l_states \<longleftrightarrow>
       length l_states \<ge> 2 \<and>
       hd l_states = initial_labeled_state n \<and>
       last l_states = final_labeled_state n \<and>
       valid_labeled_moves_max_stone n l_states"

lemma valid_labeled_moves_max_stone_Cons:
  assumes "valid_labeled_moves_max_stone n states" "valid_labeled_move_max_stone n state (hd states)"
  shows "valid_labeled_moves_max_stone n (state # states)"
  sorry

lemma valid_labeled_game_max_stone_valid_labeled_game:
  assumes "valid_labeled_game_max_stone n states"
  shows "valid_labeled_game n states"
  sorry

lemma valid_labeled_move_move_max_stone:
  assumes "valid_labeled_state n l_state"
          "unlabel l_state = state" "valid_move' n p1 p2 state state'"
          "l_state' = labeled_move p1 p2 (Max (l_state ! p1)) l_state"
        shows "valid_labeled_move' n p1 p2 (Max (l_state ! p1)) l_state l_state'"
  sorry

primrec label_moves_max_stone where
  "label_moves_max_stone l_state [] = [l_state]"
| "label_moves_max_stone l_state (state' # states) =
     (let state = unlabel l_state;
          (p1, p2) = move_positions state state';
          l_state' = labeled_move p1 p2 (Max (l_state ! p1)) l_state
       in l_state # label_moves_max_stone l_state' states)"

lemma hd_label_moves_max_stone [simp]:
  shows "hd (label_moves_max_stone l_state states) = l_state"
  sorry

lemma valid_states_label_moves_max_stone:
  assumes "valid_labeled_state n l_state" "valid_moves n (unlabel l_state # states)"
  shows "\<forall> l_state' \<in> set (label_moves_max_stone l_state states). valid_labeled_state n l_state'"
  sorry

lemma unlabel_label_moves_max_stone:
  assumes "valid_labeled_state n l_state"  "valid_moves n (unlabel l_state # states)"
  shows "map unlabel (label_moves_max_stone l_state states) = unlabel l_state # states"
  sorry

lemma label_moves_max_stone_length [simp]:
  shows "length (label_moves_max_stone l_state states) = length states + 1"
  sorry

lemma label_moves_max_stone_valid_moves:
  assumes "valid_labeled_state n l_state" "valid_moves n (unlabel l_state # states)"
  shows "valid_labeled_moves_max_stone n (label_moves_max_stone l_state states)"
  sorry

lemma final_labeled_state_unique:
  assumes "unlabel l_state = final_state n" "valid_labeled_state n l_state"
  shows "l_state = final_labeled_state n"
  sorry

lemma labeled_game_max_stone_length [simp]:
  assumes "valid_game n states"
  shows "length (label_moves_max_stone (initial_labeled_state n) (tl states)) = length states"
  sorry

lemma valid_labeled_game_max_stone:
  assumes "valid_game n states"
  shows "valid_labeled_game_max_stone n (label_moves_max_stone (initial_labeled_state n) (tl states))"
  sorry

subsubsection \<open>Valid labeled game move max stone length\<close>

lemma moved_from:
  assumes "valid_labeled_state n (hd l_states)" "valid_labeled_moves n l_states"
          "i < j" "j < length l_states" "stone < n"
          "stone_position (l_states ! i) stone \<noteq> stone_position (l_states ! j) stone"
  shows "(\<exists> k. i \<le> k \<and> k < j \<and>
         (let (p1, p2, stone') = labeled_move_positions (l_states ! k) (l_states ! (k + 1)) in
          stone' = stone \<and> p1 = stone_position (l_states ! i) stone))"
  sorry

lemma valid_labeled_game_max_stone_min_length:
  assumes "valid_labeled_game_max_stone n l_states"
  shows "length l_states \<ge> (\<Sum> k \<leftarrow> [1..<n+1]. (ceiling (n / k))) + 1"
  sorry

subsubsection \<open>Valid game length\<close>
*)
theorem IMO2018SL_C3:
  assumes "valid_game n states"
  shows "length states \<ge> (\<Sum> k \<leftarrow> [1..<n+1]. (ceiling (n / k))) + 1"
  sorry

end