(* Title:      HOL/Presburger.thy
   Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Decision Procedure for Presburger Arithmetic\<close>

theory Presburger
imports Groebner_Basis Set_Interval
keywords "try0" :: diag
begin

ML_file \<open>Tools/Qelim/qelim.ML\<close>
ML_file \<open>Tools/Qelim/cooper_procedure.ML\<close>

subsection\<open>The \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Properties\<close>

lemma minf:
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x = t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<noteq> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x < t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<le> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x > t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<ge> t) = False"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (d dvd x + s) = (d dvd x + s)"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
  "\<exists>z.\<forall>x<z. F = F"
proof safe
  fix z1 z2
  assume "\<forall>x<z1. P x = P' x" and "\<forall>x<z2. Q x = Q' x"
  then have "\<forall>x < min z1 z2. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by blast
next
  fix z1 z2
  assume "\<forall>x<z1. P x = P' x" and "\<forall>x<z2. Q x = Q' x"
  then have "\<forall>x < min z1 z2. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by blast
next
  have "\<forall>x<t. x \<le> t"
    by fastforce
  then show "\<exists>z. \<forall>x<z. (x \<le> t) = True"
    by auto
next
  have "\<forall>x<t. \<not> t < x"
    by fastforce
  then show "\<exists>z. \<forall>x<z. (t < x) = False"
    by auto
next
  have "\<forall>x<t. \<not> t \<le> x"
    by fastforce
  then show "\<exists>z. \<forall>x<z. (t \<le> x) = False"
    by auto
qed auto

lemma pinf:
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x = t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<noteq> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x < t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<le> t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x > t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<ge> t) = True"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (d dvd x + s) = (d dvd x + s)"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
  "\<exists>z.\<forall>x>z. F = F"
proof safe
  fix z1 z2
  assume "\<forall>x>z1. P x = P' x" and "\<forall>x>z2. Q x = Q' x"
  then have "\<forall>x > max z1 z2. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by blast
next
  fix z1 z2
  assume "\<forall>x>z1. P x = P' x" and "\<forall>x>z2. Q x = Q' x"
  then have "\<forall>x > max z1 z2. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by blast
next
  have "\<forall>x>t. \<not> x < t"
    by fastforce
  then show "\<exists>z. \<forall>x>z. x < t = False"
    by blast
next
  have "\<forall>x>t. \<not> x \<le> t"
    by fastforce
  then show "\<exists>z. \<forall>x>z. x \<le> t = False"
    by blast
next
  have "\<forall>x>t. t \<le> x"
    by fastforce
  then show "\<exists>z. \<forall>x>z. t \<le> x = True"
    by blast
qed auto

lemma inf_period:
  "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
    \<Longrightarrow> \<forall>x k. (P x \<and> Q x) = (P (x - k*D) \<and> Q (x - k*D))"
  "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
    \<Longrightarrow> \<forall>x k. (P x \<or> Q x) = (P (x - k*D) \<or> Q (x - k*D))"
  "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (d dvd x + t) = (d dvd (x - k*D) + t)"
  "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (\<not>d dvd x + t) = (\<not>d dvd (x - k*D) + t)"
  "\<forall>x k. F = F"
apply (auto elim!: dvdE simp add: algebra_simps)
unfolding mult.assoc [symmetric] distrib_right [symmetric] left_diff_distrib [symmetric]
unfolding dvd_def mult.commute [of d]
by auto

subsection\<open>The A and B sets\<close>
lemma bset:
  "\<lbrakk>\<forall>x.(\<forall>j \<in> {1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x - D) \<and> Q (x - D))"
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x - D) \<or> Q (x - D))"
  "\<lbrakk>D>0; t - 1\<in> B\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
  "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
  "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))"
  "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t))"
  "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t))"
  "\<lbrakk>D>0 ; t - 1 \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x - D) + t))"
  "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> F \<longrightarrow> F"
proof (blast, blast)
  assume dp: "D > 0" and tB: "t - 1\<in> B"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
    apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t - 1"])
    apply algebra using dp tB by simp_all
next
  assume dp: "D > 0" and tB: "t \<in> B"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
    apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
    apply algebra
    using dp tB by simp_all
next
  assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))" by arith
next
  assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t)" by arith
next
  assume dp: "D > 0" and tB:"t \<in> B"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x > t" and ng: "\<not> (x - D) > t"
    hence "x -t \<le> D" and "1 \<le> x - t" by simp+
      hence "\<exists>j \<in> {1 .. D}. x - t = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = t + j" by (simp add: algebra_simps)
      with nob tB have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t)" by blast
next
  assume dp: "D > 0" and tB:"t - 1\<in> B"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x \<ge> t" and ng: "\<not> (x - D) \<ge> t"
    hence "x - (t - 1) \<le> D" and "1 \<le> x - (t - 1)" by simp+
      hence "\<exists>j \<in> {1 .. D}. x - (t - 1) = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = (t - 1) + j" by (simp add: algebra_simps)
      with nob tB have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t)" by blast
next
  assume d: "d dvd D"
  {fix x assume H: "d dvd x + t" with d have "d dvd (x - D) + t" by algebra}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t)" by simp
next
  assume d: "d dvd D"
  {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not> d dvd (x - D) + t"
      by (clarsimp simp add: dvd_def,erule_tac x= "ka + k" in allE,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x - D) + t)" by auto
qed blast

lemma aset:
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x + D) \<and> Q (x + D))"
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x + D) \<or> Q (x + D))"
  "\<lbrakk>D>0; t + 1\<in> A\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
  "\<lbrakk>D>0 ; t \<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
  "\<lbrakk>D>0; t\<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int). (\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t))"
  "\<lbrakk>D>0; t + 1 \<in> A\<rbrakk> \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t))"
  "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))"
  "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x + D) + t))"
  "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> F \<longrightarrow> F"
proof (blast, blast)
  assume dp: "D > 0" and tA: "t + 1 \<in> A"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
    apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t + 1"])
    using dp tA by simp_all
next
  assume dp: "D > 0" and tA: "t \<in> A"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
    apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
    using dp tA by simp_all
next
  assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))" by arith
next
  assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t)" by arith
next
  assume dp: "D > 0" and tA:"t \<in> A"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x < t" and ng: "\<not> (x + D) < t"
    hence "t - x \<le> D" and "1 \<le> t - x" by simp+
      hence "\<exists>j \<in> {1 .. D}. t - x = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = t - j" by (auto simp add: algebra_simps)
      with nob tA have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t)" by blast
next
  assume dp: "D > 0" and tA:"t + 1\<in> A"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x \<le> t" and ng: "\<not> (x + D) \<le> t"
    hence "(t + 1) - x \<le> D" and "1 \<le> (t + 1) - x" by (simp_all add: algebra_simps)
      hence "\<exists>j \<in> {1 .. D}. (t + 1) - x = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = (t + 1) - j" by (auto simp add: algebra_simps)
      with nob tA have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t)" by blast
next
  assume d: "d dvd D"
  have "\<And>x. d dvd x + t \<Longrightarrow> d dvd x + D + t"
  proof -
    fix x
    assume H: "d dvd x + t"
    then obtain ka where "x + t = d * ka"
      unfolding dvd_def by blast
    moreover from d obtain k where *:"D = d * k"
      unfolding dvd_def by blast
    ultimately have "x + d * k + t = d * (ka + k)"
      by (simp add: algebra_simps)
    then show "d dvd (x + D) + t"
      using * unfolding dvd_def by blast
  qed
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t)" by simp
next
  assume d: "d dvd D"
  {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not>d dvd (x + D) + t"
      by (clarsimp simp add: dvd_def,erule_tac x= "ka - k" in allE,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x + D) + t)" by auto
qed blast

subsection\<open>Cooper's Theorem \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Version\<close>

subsubsection\<open>First some trivial facts about periodic sets or predicates\<close>
lemma periodic_finite_ex:
  assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
  shows "(\<exists>x. P x) = (\<exists>j \<in> {1..d}. P j)"
  (is "?LHS = ?RHS")
proof
  assume ?LHS
  then obtain x where P: "P x" ..
  have "x mod d = x - (x div d)*d" by(simp add:mult_div_mod_eq [symmetric] ac_simps eq_diff_eq)
  hence Pmod: "P x = P(x mod d)" using modd by simp
  show ?RHS
  proof (cases)
    assume "x mod d = 0"
    hence "P 0" using P Pmod by simp
    moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
    ultimately have "P d" by simp
    moreover have "d \<in> {1..d}" using dpos by simp
    ultimately show ?RHS ..
  next
    assume not0: "x mod d \<noteq> 0"
    have "P(x mod d)" using dpos P Pmod by simp
    moreover have "x mod d \<in> {1..d}"
    proof -
      from dpos have "0 \<le> x mod d" by(rule pos_mod_sign)
      moreover from dpos have "x mod d < d" by(rule pos_mod_bound)
      ultimately show ?thesis using not0 by simp
    qed
    ultimately show ?RHS ..
  qed
qed auto

subsubsection\<open>The \<open>-\<infinity>\<close> Version\<close>

lemma decr_lemma: "0 < (d::int) \<Longrightarrow> x - (\<bar>x - z\<bar> + 1) * d < z"
  by (induct rule: int_gr_induct) (simp_all add: int_distrib)

lemma incr_lemma: "0 < (d::int) \<Longrightarrow> z < x + (\<bar>x - z\<bar> + 1) * d"
  by (induct rule: int_gr_induct) (simp_all add: int_distrib)

lemma decr_mult_lemma:
  assumes dpos: "(0::int) < d" and minus: "\<forall>x. P x \<longrightarrow> P(x - d)" and knneg: "0 <= k"
  shows "\<forall>x. P x \<longrightarrow> P(x - k*d)"
using knneg
proof (induct rule:int_ge_induct)
  case base thus ?case by simp
next
  case (step i)
  {fix x
    have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
    also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)" using minus[THEN spec, of "x - i * d"]
      by (simp add: algebra_simps)
    ultimately have "P x \<longrightarrow> P(x - (i + 1) * d)" by blast}
  thus ?case ..
qed

lemma  minusinfinity:
  assumes dpos: "0 < d" and
    P1eqP1: "\<forall>x k. P1 x = P1(x - k*d)" and ePeqP1: "\<exists>z::int. \<forall>x. x < z \<longrightarrow> (P x = P1 x)"
  shows "(\<exists>x. P1 x) \<longrightarrow> (\<exists>x. P x)"
proof
  assume eP1: "\<exists>x. P1 x"
  then obtain x where P1: "P1 x" ..
  from ePeqP1 obtain z where P1eqP: "\<forall>x. x < z \<longrightarrow> (P x = P1 x)" ..
  let ?w = "x - (\<bar>x - z\<bar> + 1) * d"
  from dpos have w: "?w < z" by(rule decr_lemma)
  have "P1 x = P1 ?w" using P1eqP1 by blast
  also have "\<dots> = P(?w)" using w P1eqP by blast
  finally have "P ?w" using P1 by blast
  thus "\<exists>x. P x" ..
qed

lemma cpmi:
  assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x< z. P x = P' x"
  and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> B. x \<noteq> b+j) \<longrightarrow> P (x) \<longrightarrow> P (x - D)"
  and pd: "\<forall> x k. P' x = P' (x-k*D)"
  shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists>j \<in> {1..D}. \<exists> b \<in> B. P (b+j)))"
         (is "?L = (?R1 \<or> ?R2)")
proof-
 {assume "?R2" hence "?L"  by blast}
 moreover
 {assume H:"?R1" hence "?L" using minusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
 moreover
 { fix x
   assume P: "P x" and H: "\<not> ?R2"
   {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>B. P (b + j))" and P: "P y"
     hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. y = b+j)" by auto
     with nb P  have "P (y - D)" by auto }
   hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)" by blast
   with H P have th: " \<forall>x. P x \<longrightarrow> P (x - D)" by auto
   from p1 obtain z where z: "\<forall>x. x < z \<longrightarrow> (P x = P' x)" by blast
   let ?y = "x - (\<bar>x - z\<bar> + 1)*D"
   have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
   from dp have yz: "?y < z" using decr_lemma[OF dp] by simp
   from z[rule_format, OF yz] decr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
   with periodic_finite_ex[OF dp pd]
   have "?R1" by blast}
 ultimately show ?thesis by blast
qed

subsubsection \<open>The \<open>+\<infinity>\<close> Version\<close>

lemma  plusinfinity:
  assumes dpos: "(0::int) < d" and
    P1eqP1: "\<forall>x k. P' x = P'(x - k*d)" and ePeqP1: "\<exists> z. \<forall> x>z. P x = P' x"
  shows "(\<exists> x. P' x) \<longrightarrow> (\<exists> x. P x)"
proof
  assume eP1: "\<exists>x. P' x"
  then obtain x where P1: "P' x" ..
  from ePeqP1 obtain z where P1eqP: "\<forall>x>z. P x = P' x" ..
  let ?w' = "x + (\<bar>x - z\<bar> + 1) * d"
  let ?w = "x - (- (\<bar>x - z\<bar> + 1)) * d"
  have ww'[simp]: "?w = ?w'" by (simp add: algebra_simps)
  from dpos have w: "?w > z" by(simp only: ww' incr_lemma)
  hence "P' x = P' ?w" using P1eqP1 by blast
  also have "\<dots> = P(?w)" using w P1eqP by blast
  finally have "P ?w" using P1 by blast
  thus "\<exists>x. P x" ..
qed

lemma incr_mult_lemma:
  assumes dpos: "(0::int) < d" and plus: "\<forall>x::int. P x \<longrightarrow> P(x + d)" and knneg: "0 <= k"
  shows "\<forall>x. P x \<longrightarrow> P(x + k*d)"
using knneg
proof (induct rule:int_ge_induct)
  case base thus ?case by simp
next
  case (step i)
  {fix x
    have "P x \<longrightarrow> P (x + i * d)" using step.hyps by blast
    also have "\<dots> \<longrightarrow> P(x + (i + 1) * d)" using plus[THEN spec, of "x + i * d"]
      by (simp add:int_distrib ac_simps)
    ultimately have "P x \<longrightarrow> P(x + (i + 1) * d)" by blast}
  thus ?case ..
qed

lemma cppi:
  assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x> z. P x = P' x"
  and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> A. x \<noteq> b - j) \<longrightarrow> P (x) \<longrightarrow> P (x + D)"
  and pd: "\<forall> x k. P' x= P' (x-k*D)"
  shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists> j \<in> {1..D}. \<exists> b\<in> A. P (b - j)))" (is "?L = (?R1 \<or> ?R2)")
proof-
 {assume "?R2" hence "?L"  by blast}
 moreover
 {assume H:"?R1" hence "?L" using plusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
 moreover
 { fix x
   assume P: "P x" and H: "\<not> ?R2"
   {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>A. P (b - j))" and P: "P y"
     hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. y = b - j)" by auto
     with nb P  have "P (y + D)" by auto }
   hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. P(b-j)) \<longrightarrow> P (x) \<longrightarrow> P (x + D)" by blast
   with H P have th: " \<forall>x. P x \<longrightarrow> P (x + D)" by auto
   from p1 obtain z where z: "\<forall>x. x > z \<longrightarrow> (P x = P' x)" by blast
   let ?y = "x + (\<bar>x - z\<bar> + 1)*D"
   have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
   from dp have yz: "?y > z" using incr_lemma[OF dp] by simp
   from z[rule_format, OF yz] incr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
   with periodic_finite_ex[OF dp pd]
   have "?R1" by blast}
 ultimately show ?thesis by blast
qed

lemma simp_from_to: "{i..j::int} = (if j < i then {} else insert i {i+1..j})"
apply(simp add:atLeastAtMost_def atLeast_def atMost_def)
apply(fastforce)
done

theorem unity_coeff_ex: "(\<exists>(x::'a::{semiring_0,Rings.dvd}). P (l * x)) \<equiv> (\<exists>x. l dvd (x + 0) \<and> P x)"
  unfolding dvd_def by (rule eq_reflection, rule iffI) auto

lemma zdvd_mono:
  fixes k m t :: int
  assumes "k \<noteq> 0"
  shows "m dvd t \<equiv> k * m dvd k * t"
  using assms by simp

lemma uminus_dvd_conv:
  fixes d t :: int
  shows "d dvd t \<equiv> - d dvd t" and "d dvd t \<equiv> d dvd - t"
  by simp_all

text \<open>\bigskip Theorems for transforming predicates on nat to predicates on \<open>int\<close>\<close>

lemma zdiff_int_split: "P (int (x - y)) =
  ((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
  by (cases "y \<le> x") (simp_all add: of_nat_diff)

text \<open>
  \medskip Specific instances of congruence rules, to prevent
  simplifier from looping.\<close>

theorem imp_le_cong:
  "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<longrightarrow> P) = (0 \<le> x' \<longrightarrow> P')"
  by simp

theorem conj_le_cong:
  "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<and> P) = (0 \<le> x' \<and> P')"
  by (simp cong: conj_cong)

ML_file \<open>Tools/Qelim/cooper.ML\<close>

method_setup presburger = \<open>
  let
    fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
    fun simple_keyword k = Scan.lift (Args.$$$ k) >> K ()
    val addN = "add"
    val delN = "del"
    val elimN = "elim"
    val any_keyword = keyword addN || keyword delN || simple_keyword elimN
    val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm)
  in
    Scan.optional (simple_keyword elimN >> K false) true --
    Scan.optional (keyword addN |-- thms) [] --
    Scan.optional (keyword delN |-- thms) [] >>
    (fn ((elim, add_ths), del_ths) => fn ctxt =>
      SIMPLE_METHOD' (Cooper.tac elim add_ths del_ths ctxt))
  end
\<close> "Cooper's algorithm for Presburger arithmetic"

declare mod_eq_0_iff_dvd [presburger]
declare mod_by_Suc_0 [presburger]
declare mod_0 [presburger]
declare mod_by_1 [presburger]
declare mod_self [presburger]
declare div_by_0 [presburger]
declare mod_by_0 [presburger]
declare mod_div_trivial [presburger]
declare mult_div_mod_eq [presburger]
declare div_mult_mod_eq [presburger]
declare mod_mult_self1 [presburger]
declare mod_mult_self2 [presburger]
declare mod2_Suc_Suc [presburger]
declare not_mod_2_eq_0_eq_1 [presburger]
declare nat_zero_less_power_iff [presburger]

lemma [presburger, algebra]: "m mod 2 = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod 2 = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod 2 = (1::int) \<longleftrightarrow> \<not> 2 dvd m " by presburger

context semiring_parity
begin

declare even_mult_iff [presburger]

declare even_power [presburger]

lemma [presburger]:
  "even (a + b) \<longleftrightarrow> even a \<and> even b \<or> odd a \<and> odd b"
  by auto

end

context ring_parity
begin

declare even_minus [presburger]

end

context linordered_idom
begin

declare zero_le_power_eq [presburger]

declare zero_less_power_eq [presburger]

declare power_less_zero_eq [presburger]

declare power_le_zero_eq [presburger]

end

declare even_Suc [presburger]

lemma [presburger]:
  "Suc n div Suc (Suc 0) = n div Suc (Suc 0) \<longleftrightarrow> even n"
  by presburger

declare even_diff_nat [presburger]

lemma [presburger]:
  fixes k :: int
  shows "(k + 1) div 2 = k div 2 \<longleftrightarrow> even k"
  by presburger

lemma [presburger]:
  fixes k :: int
  shows "(k + 1) div 2 = k div 2 + 1 \<longleftrightarrow> odd k"
  by presburger

lemma [presburger]:
  "even n \<longleftrightarrow> even (int n)"
  by simp

subsection \<open>Nice facts about division by \<^term>\<open>4\<close>\<close>

lemma even_even_mod_4_iff:
  "even (n::nat) \<longleftrightarrow> even (n mod 4)"
  by presburger

lemma odd_mod_4_div_2:
  "n mod 4 = (3::nat) \<Longrightarrow> odd ((n - Suc 0) div 2)"
  by presburger

lemma even_mod_4_div_2:
  "n mod 4 = Suc 0 \<Longrightarrow> even ((n - Suc 0) div 2)"
  by presburger

subsection \<open>Try0\<close>

ML_file \<open>Tools/try0.ML\<close>

end


theory Proof_5_36
  imports Proofs_5
begin

theorem proof_5_8: "VC36 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC36_def inv5_def R5_def extraInv_def)
  apply(rule impI)
  apply((drule conjE)+)
                      prefer 22
                      apply assumption
                      prefer 21
                      apply assumption
                     prefer 20
                     apply assumption
                    prefer 19
                    apply assumption
                   prefer 18
                   apply assumption
                  prefer 17
                  apply assumption
                 prefer 16
                 apply assumption
                prefer 15
                apply assumption
               prefer 14
               apply assumption
              prefer 13
              apply assumption
             prefer 12
             apply assumption
            prefer 11
            apply assumption
           prefer 10
           apply assumption
          prefer 9
          apply assumption
         prefer 8
         apply assumption
        prefer 7
        apply assumption
       prefer 6
       apply assumption
      prefer 5
      apply assumption
     prefer 4
     apply assumption
    prefer 3
    apply assumption
   prefer 2
   apply assumption
  by (metis One_nat_def Suc_1 Zero_not_Suc getPstate.simps(9) numeral_3_eq_3 substate_refl zero_neq_numeral)


(*  Title:      Presburger-Automata/Exec.thy
    Author:     Stefan Berghofer, TU Muenchen, 2008-2009
*)

theory Exec
imports Presburger_Automata "~~/src/HOL/Library/Code_Target_Numeral"
begin

declare gen_dfs_simps [code]

lemma [code_unfold]: "op \<longrightarrow> = (\<lambda>P. op \<or> (\<not> P))"
  by (simp add: fun_eq_iff)

lemma "\<forall>x. (\<exists>xa. int xa - int x = 5) \<or> (\<forall>xa xb. \<not> 6 \<le> int xb \<longrightarrow> int xb + (6 * int xa - int x) = 0 \<longrightarrow> int xa = 1)"
proof -
  have "?thesis = eval_pf (Forall (Exist (Or (Eq [1, -1] 5)
    (Forall (Forall (Imp (Neg (Le [-1, 0] (- 6))) (Imp (Eq [1, 6, 0, -1] 0) (Eq [0, 1] 1)))))))) []"
    (is "_ = eval_pf ?P []")
    by simp
  also have "\<dots> = dfa_accepts (dfa_of_pf 0 ?P) []"
    by (simp add: dfa_of_pf_correctness del: dfa_of_pf.simps)
  also have "\<dots>" by eval
  finally show ?thesis .
qed

lemma "\<forall>x xa xb. \<not> 2 \<le> int xb \<longrightarrow> int xb + (2 * int xa - int x) = 1 \<longrightarrow>
  (\<forall>xb xc. \<not> 2 \<le> int xc \<longrightarrow> int xc + (2 * int xb - int x) = 0 \<longrightarrow> (\<exists>xa. 2 * int xa = int x) \<longrightarrow> xb = xa)"
proof -
  have "?thesis = eval_pf (Forall (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
    (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
      (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [2, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))) []"
    (is "_ = eval_pf ?P []")
    by simp
  also have "\<dots> = dfa_accepts (dfa_of_pf 0 ?P) []"
    by (simp add: dfa_of_pf_correctness del: dfa_of_pf.simps)
  also have "\<dots>" by eval
  finally show ?thesis .
qed

definition "mk_dfa = dfa_of_pf 0"

definition "stamp = Forall (Imp (Le [-1] (- 8)) (Exist (Exist (Eq [5, 3, -1] 0))))"
definition "stamp_false = Forall (Imp (Le [-1] (- 7)) (Exist (Exist (Eq [5, 3, -1] 0))))"
definition "example = Forall (Exist (Or (Eq [1, -1] 5)
  (Forall (Forall (Imp (Neg (Le [-1, 0] (- 6))) (Imp (Eq [1, 6, 0, -1] 0) (Eq [0, 1] 1)))))))"
definition "example2 = Forall (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
  (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
    (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [2, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))"
definition "example2_false = Forall (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
  (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
    (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [3, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))"
definition "harrison1 = Exist (Forall (Imp (Le [-1, 1] 0) (Exist (Exist
  (And (Le [0, -1] 0) (And (Le [-1] 0) (Eq [8, 3, -1] 0)))))))"
definition "harrison2 = Exist (Forall (Imp (Le [-1, 1] 0) (Exist (Exist
  (And (Le [0, -1] 0) (And (Le [-1] 0) (Eq [8, 7, -1] 0)))))))"

value "mk_dfa stamp"
value "min_dfa (mk_dfa stamp)"
value "mk_dfa stamp_false"
value "mk_dfa example"
value "mk_dfa example2"
value "mk_dfa example2_false"
value "mk_dfa harrison1"
value "mk_dfa harrison2"

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Pre-Conway Algebra with Tests\<close>

theory Conway_Tests
  imports Kleene_Algebra.Conway Test_Dioid

begin

class near_conway_zerol_tests = near_conway_zerol + test_near_semiring_zerol_distrib

begin

lemma n_preserve1_var: "n x \<cdot> y \<le> n x \<cdot> y \<cdot> n x \<Longrightarrow> n x \<cdot> (n x \<cdot> y + t x \<cdot> z)\<^sup>\<dagger> \<le> (n x \<cdot> y)\<^sup>\<dagger> \<cdot> n x"
proof -
  assume a: "n x \<cdot> y \<le> n x \<cdot> y \<cdot> n x"
  have "n x \<cdot> (n x \<cdot> y + t x \<cdot> z) = n x \<cdot> y"
    by (metis (no_types) local.add_zeror local.annil local.n_left_distrib local.n_mult_idem local.test_mult_comp mult_assoc)
  hence "n x \<cdot> (n x \<cdot> y + t x \<cdot> z) \<le> n x \<cdot> y \<cdot> n x"
    by (simp add: a)
  thus " n x \<cdot> (n x \<cdot> y + t x \<cdot> z)\<^sup>\<dagger> \<le> (n x \<cdot> y)\<^sup>\<dagger> \<cdot> n x"
    by (simp add: local.dagger_simr)
qed

lemma test_preserve1_var: "test p \<Longrightarrow> p \<cdot> x \<le> p \<cdot> x \<cdot> p \<Longrightarrow> p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<le> (p \<cdot> x)\<^sup>\<dagger> \<cdot> p"
  by (metis local.test_double_comp_var n_preserve1_var)

end

class test_pre_conway = pre_conway + test_pre_dioid_zerol

begin

subclass near_conway_zerol_tests
  by (unfold_locales)

lemma test_preserve: "test p \<Longrightarrow>  p \<cdot> x \<le> p \<cdot> x \<cdot> p  \<Longrightarrow> p \<cdot> x\<^sup>\<dagger> = (p \<cdot> x)\<^sup>\<dagger> \<cdot> p"
  using local.preservation1_eq local.test_restrictr by auto

lemma test_preserve2: "test p \<Longrightarrow> p \<cdot> x \<cdot> p = p \<cdot> x \<Longrightarrow> p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by (metis (no_types) local.eq_refl local.test_restrictl test_preserve test_preserve1)

end

end


theory propositional_Sound
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Form =  "Form" "Form" | Not "Form" | Var "int"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun or3 :: "bool list => bool" where
"or3 (Nil2) = False"
| "or3 (Cons2 y xs) = or2 y (or3 xs)"

fun models3 :: "int => ((int, bool) Pair2) list => bool list" where
"models3 x (Nil2) = Nil2"
| "models3 x (Cons2 (Pair y2 True) x2) = models3 x x2"
| "models3 x (Cons2 (Pair y2 False) x2) =
     Cons2 (x = y2) (models3 x x2)"

fun fst :: "('a, 'b) Pair2 => 'a" where
"fst (Pair y z) = y"

fun filter :: "('t => bool) => 't list => 't list" where
"filter p (Nil2) = Nil2"
| "filter p (Cons2 y z) =
     (if p y then Cons2 y (filter p z) else filter p z)"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun all :: "('t => bool) => 't list => bool" where
"all x (Nil2) = True"
| "all x (Cons2 z xs) = and2 (x z) (all x xs)"

fun 3 :: "int => ((int, bool) Pair2) list => bool list" where
"3 x (Nil2) = Nil2"
| "3 x (Cons2 (Pair y2 True) x2) = Cons2 (x = y2) (3 x x2)"
| "3 x (Cons2 (Pair y2 False) x2) = 3 x x2"

function models :: "Form => ((int, bool) Pair2) list =>
                  (((int, bool) Pair2) list) list"
         and
           models2 :: "Form => (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list"
         and
           models4 :: "Form => (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list" where
"models ( p q) y = models2 q (models p y)"
| "models (Not ( p2 q2)) y =
     append (models (Not p2) y) (models ( p2 (Not q2)) y)"
| "models (Not (Not p3)) y = models p3 y"
| "models (Not (Var x2)) y =
     (if ~ (or3 (3 x2 y)) then
        Cons2
          (Cons2
             (Pair x2 False)
             (filter
                (% (x3 :: (int, bool) Pair2) =>
                   dot
                     (% (x4 :: int) => x2 ~= x4) (% (x5 :: (int, bool) Pair2) => fst x5)
                     x3)
                y))
          (Nil2)
        else
        Nil2)"
| "models (Var x6) y =
     (if ~ (or3 (models3 x6 y)) then
        Cons2
          (Cons2
             (Pair x6 True)
             (filter
                (% (x7 :: (int, bool) Pair2) =>
                   dot
                     (% (x8 :: int) => x6 ~= x8) (% (x9 :: (int, bool) Pair2) => fst x9)
                     x7)
                y))
          (Nil2)
        else
        Nil2)"
| "models2 q (Nil2) = Nil2"
| "models2 q (Cons2 y z) = models4 q z (models q y)"
| "models4 q x (Nil2) = models2 q x"
| "models4 q x (Cons2 z x2) = Cons2 z (models4 q x x2)"
by pat_completeness auto

fun 2 :: "((int, bool) Pair2) list => Form => bool" where
"2 x ( p q) = and2 (2 x p) (2 x q)"
| "2 x (Not p2) = ~ (2 x p2)"
| "2 x (Var z) = or3 (3 z x)"

(*hipster or2
          or3
          models3
          fst
          filter
          dot
          append
          and2
          all
          3
          models
          models2
          models4
          2 *)

theorem x0 :
  "!! (p :: Form) .
     all (% (x :: ((int, bool) Pair2) list) => 2 x p) (models p (Nil2))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_mccarthy91_M2
imports "../../Test_Base"
begin

(*fun did not finish the proof*)
function m :: "int => int" where
"m x = (if x > 100 then x - 10 else m (m (x + 11)))"
by pat_completeness auto

theorem property0 :
  "((n >= 101) ==> ((m n) = (n - 10)))"
  oops

end


theory Lappend_inf
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

inductive lfinite :: "'a Llist \<Rightarrow> bool"
where
  lfinite_LNil:  "lfinite LNil"
| lfinite_LConsI: "lfinite xs \<Longrightarrow> lfinite (LCons x xs)"

(* hipster lappend lfinite
Fails because: No code equations for lfinite
*)
theorem  "\<not> lfinite xs \<Longrightarrow> lappend xs ys = xs"
  by hipster_coinduct_sledgehammer
end


(*  Title:      HOL/SET_Protocol/Public_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>The Public-Key Theory, Modified for SET\<close>

theory Public_SET
imports Event_SET
begin

subsection\<open>Symmetric and Asymmetric Keys\<close>

text\<open>definitions influenced by the wish to assign asymmetric keys
  - since the beginning - only to RCA and CAs, namely we need a partial
  function on type Agent\<close>

text\<open>The SET specs mention two signature keys for CAs - we only have one\<close>

consts
  publicKey :: "[bool, agent] \<Rightarrow> key"
    \<comment> \<open>the boolean is TRUE if a signing key\<close>

abbreviation "pubEK == publicKey False"
abbreviation "pubSK == publicKey True"

(*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
abbreviation "priEK A == invKey (pubEK A)"
abbreviation "priSK A == invKey (pubSK A)"

text\<open>By freeness of agents, no two agents have the same key. Since
 \<^term>\<open>True\<noteq>False\<close>, no agent has the same signing and encryption keys.\<close>

specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' \<Longrightarrow> b=c \<and> A=A'"
(*<*)
   apply (rule exI [of _ "%b A. 2 * nat_of_agent A + (if b then 1 else 0)"])
   apply (auto simp add: inj_on_def inj_nat_of_agent [THEN inj_eq] split: agent.split)
   apply (drule_tac f="%x. x mod 2" in arg_cong, simp add: mod_Suc)+
(*or this, but presburger won't abstract out the function applications
   apply presburger+
*)
   done
(*>*)

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]:
      "invKey (publicKey b A) \<noteq> publicKey b' A'"

declare privateKey_neq_publicKey [THEN not_sym, iff]

subsection\<open>Initial Knowledge\<close>

text\<open>This information is not necessary.  Each protocol distributes any needed
certificates, and anyway our proofs require a formalization of the Spy's
knowledge only.  However, the initial knowledge is as follows:
   All agents know RCA's public keys;
   RCA and CAs know their own respective keys;
   RCA (has already certified and therefore) knows all CAs public keys;
   Spy knows all keys of all bad agents.\<close>

overloading initState \<equiv> "initState"
begin

primrec initState where
(*<*)
  initState_CA:
    "initState (CA i)  =
       (if i=0 then Key ` ({priEK RCA, priSK RCA} \<union>
                            pubEK ` (range CA) \<union> pubSK ` (range CA))
        else {Key (priEK (CA i)), Key (priSK (CA i)),
              Key (pubEK (CA i)), Key (pubSK (CA i)),
              Key (pubEK RCA), Key (pubSK RCA)})"

| initState_Cardholder:
    "initState (Cardholder i)  =
       {Key (priEK (Cardholder i)), Key (priSK (Cardholder i)),
        Key (pubEK (Cardholder i)), Key (pubSK (Cardholder i)),
        Key (pubEK RCA), Key (pubSK RCA)}"

| initState_Merchant:
    "initState (Merchant i)  =
       {Key (priEK (Merchant i)), Key (priSK (Merchant i)),
        Key (pubEK (Merchant i)), Key (pubSK (Merchant i)),
        Key (pubEK RCA), Key (pubSK RCA)}"

| initState_PG:
    "initState (PG i)  =
       {Key (priEK (PG i)), Key (priSK (PG i)),
        Key (pubEK (PG i)), Key (pubSK (PG i)),
        Key (pubEK RCA), Key (pubSK RCA)}"
(*>*)
| initState_Spy:
    "initState Spy = Key ` (invKey ` pubEK ` bad \<union>
                            invKey ` pubSK ` bad \<union>
                            range pubEK \<union> range pubSK)"

end

text\<open>Injective mapping from agents to PANs: an agent can have only one card\<close>

consts  pan :: "agent \<Rightarrow> nat"

specification (pan)
  inj_pan: "inj pan"
  \<comment> \<open>No two agents have the same PAN\<close>
(*<*)
   apply (rule exI [of _ "nat_of_agent"])
   apply (simp add: inj_on_def inj_nat_of_agent [THEN inj_eq])
   done
(*>*)

declare inj_pan [THEN inj_eq, iff]

consts
  XOR :: "nat*nat \<Rightarrow> nat"  \<comment> \<open>no properties are assumed of exclusive-or\<close>

subsection\<open>Signature Primitives\<close>

definition
 (* Signature = Message + signed Digest *)
  sign :: "[key, msg]\<Rightarrow>msg"
  where "sign K X = \<lbrace>X, Crypt K (Hash X) \<rbrace>"

definition
 (* Signature Only = signed Digest Only *)
  signOnly :: "[key, msg]\<Rightarrow>msg"
  where "signOnly K X = Crypt K (Hash X)"

definition
 (* Signature for Certificates = Message + signed Message *)
  signCert :: "[key, msg]\<Rightarrow>msg"
  where "signCert K X = \<lbrace>X, Crypt K X \<rbrace>"

definition
 (* Certification Authority's Certificate.
    Contains agent name, a key, a number specifying the key's target use,
              a key to sign the entire certificate.

    Should prove if signK=priSK RCA and C=CA i,
                  then Ka=pubEK i or pubSK i depending on T  ??
 *)
  cert :: "[agent, key, msg, key] \<Rightarrow> msg"
  where "cert A Ka T signK = signCert signK \<lbrace>Agent A, Key Ka, T\<rbrace>"

definition
 (* Cardholder's Certificate.
    Contains a PAN, the certified key Ka, the PANSecret PS,
    a number specifying the target use for Ka, the signing key signK.
 *)
  certC :: "[nat, key, nat, msg, key] \<Rightarrow> msg"
  where "certC PAN Ka PS T signK =
    signCert signK \<lbrace>Hash \<lbrace>Nonce PS, Pan PAN\<rbrace>, Key Ka, T\<rbrace>"

(*cert and certA have no repeated elements, so they could be abbreviations,
  but that's tricky and makes proofs slower*)

abbreviation "onlyEnc == Number 0"
abbreviation "onlySig == Number (Suc 0)"
abbreviation "authCode == Number (Suc (Suc 0))"

subsection\<open>Encryption Primitives\<close>

definition EXcrypt :: "[key,key,msg,msg] \<Rightarrow> msg" where
  \<comment> \<open>Extra Encryption\<close>
    (*K: the symmetric key   EK: the public encryption key*)
    "EXcrypt K EK M m =
       \<lbrace>Crypt K \<lbrace>M, Hash m\<rbrace>, Crypt EK \<lbrace>Key K, m\<rbrace>\<rbrace>"

definition EXHcrypt :: "[key,key,msg,msg] \<Rightarrow> msg" where
  \<comment> \<open>Extra Encryption with Hashing\<close>
    (*K: the symmetric key   EK: the public encryption key*)
    "EXHcrypt K EK M m =
       \<lbrace>Crypt K \<lbrace>M, Hash m\<rbrace>, Crypt EK \<lbrace>Key K, m, Hash M\<rbrace>\<rbrace>"

definition Enc :: "[key,key,key,msg] \<Rightarrow> msg" where
  \<comment> \<open>Simple Encapsulation with SIGNATURE\<close>
    (*SK: the sender's signing key
      K: the symmetric key
      EK: the public encryption key*)
    "Enc SK K EK M =
       \<lbrace>Crypt K (sign SK M), Crypt EK (Key K)\<rbrace>"

definition EncB :: "[key,key,key,msg,msg] \<Rightarrow> msg" where
  \<comment> \<open>Encapsulation with Baggage.  Keys as above, and baggage b.\<close>
    "EncB SK K EK M b =
       \<lbrace>Enc SK K EK \<lbrace>M, Hash b\<rbrace>, b\<rbrace>"

subsection\<open>Basic Properties of pubEK, pubSK, priEK and priSK\<close>

lemma publicKey_eq_iff [iff]:
     "(publicKey b A = publicKey b' A') = (b=b' \<and> A=A')"
by (blast dest: injective_publicKey)

lemma privateKey_eq_iff [iff]:
     "(invKey (publicKey b A) = invKey (publicKey b' A')) = (b=b' \<and> A=A')"
by auto

lemma not_symKeys_publicKey [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_privateKey [iff]: "invKey (publicKey b A) \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKeys_invKey_eq [simp]: "K \<in> symKeys \<Longrightarrow> invKey K = K"
by (simp add: symKeys_def)

lemma symKeys_invKey_iff [simp]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

text\<open>Can be slow (or even loop) as a simprule\<close>
lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) \<Longrightarrow> K \<noteq> K'"
by blast

text\<open>These alternatives to \<open>symKeys_neq_imp_neq\<close> don't seem any better
in practice.\<close>
lemma publicKey_neq_symKey: "K \<in> symKeys \<Longrightarrow> publicKey b A \<noteq> K"
by blast

lemma symKey_neq_publicKey: "K \<in> symKeys \<Longrightarrow> K \<noteq> publicKey b A"
by blast

lemma privateKey_neq_symKey: "K \<in> symKeys \<Longrightarrow> invKey (publicKey b A) \<noteq> K"
by blast

lemma symKey_neq_privateKey: "K \<in> symKeys \<Longrightarrow> K \<noteq> invKey (publicKey b A)"
by blast

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by auto

subsection\<open>"Image" Equations That Hold for Injective Functions\<close>

lemma invKey_image_eq [iff]: "(invKey x \<in> invKey`A) = (x\<in>A)"
by auto

text\<open>holds because invKey is injective\<close>
lemma publicKey_image_eq [iff]:
     "(publicKey b A \<in> publicKey c ` AS) = (b=c \<and> A\<in>AS)"
by auto

lemma privateKey_image_eq [iff]:
     "(invKey (publicKey b A) \<in> invKey ` publicKey c ` AS) = (b=c \<and> A\<in>AS)"
by auto

lemma privateKey_notin_image_publicKey [iff]:
     "invKey (publicKey b A) \<notin> publicKey c ` AS"
by auto

lemma publicKey_notin_image_privateKey [iff]:
     "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (simp add: keysFor_def)
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

text\<open>for proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X H));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts H) | Key (invKey K) \<in> parts H"
by (force dest!:
         parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
         analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
            intro: analz_into_parts)

lemma Crypt_imp_keysFor [intro]:
     "[|K \<in> symKeys; Crypt K X \<in> H|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text\<open>Agents see their own private keys!\<close>
lemma privateKey_in_initStateCA [iff]:
     "Key (invKey (publicKey b A)) \<in> initState A"
by (case_tac "A", auto)

text\<open>Agents see their own public keys!\<close>
lemma publicKey_in_initStateCA [iff]: "Key (publicKey b A) \<in> initState A"
by (case_tac "A", auto)

text\<open>RCA sees CAs' public keys!\<close>
lemma pubK_CA_in_initState_RCA [iff]:
     "Key (publicKey b (CA i)) \<in> initState RCA"
by auto

text\<open>Spy knows all public keys\<close>
lemma knows_Spy_pubEK_i [iff]: "Key (publicKey b A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all add: imageI knows_Cons split: event.split)
done

declare knows_Spy_pubEK_i [THEN analz.Inj, iff]
                            (*needed????*)

text\<open>Spy sees private keys of bad agents! [and obviously public keys too]\<close>
lemma knows_Spy_bad_privateKey [intro!]:
     "A \<in> bad \<Longrightarrow> Key (invKey (publicKey b A)) \<in> knows Spy evs"
by (rule initState_subset_knows [THEN subsetD], simp)

subsection\<open>Fresh Nonces for Possibility Theorems\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

text\<open>In any trace, there is an upper bound N on the greatest nonce in use.\<close>
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all add: used_Cons split: event.split, safe)
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection\<open>Specialized Methods for Possibility Theorems\<close>

ML
\<open>
(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt delsimps [@{thm used_Says}, @{thm used_Notes}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as SET_CR!), where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))
\<close>

method_setup possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o possibility_tac)\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o basic_possibility_tac)\<close>
    "for proving possibility theorems"

subsection\<open>Specialized Rewriting for Theorems About \<^term>\<open>analz\<close> and Image\<close>

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image:
     "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

text\<open>Needed for \<open>DK_fresh_not_KeyCryptKey\<close>\<close>
lemma publicKey_in_used [iff]: "Key (publicKey b A) \<in> used evs"
by auto

lemma privateKey_in_used [iff]: "Key (invKey (publicKey b A)) \<in> used evs"
by (blast intro!: initState_into_used)

text\<open>Reverse the normal simplification of "image" to build up (not break down)
  the set of keys.  Based on \<open>analz_image_freshK_ss\<close>, but simpler.\<close>
lemmas analz_image_keys_simps =
       simp_thms mem_simps \<comment> \<open>these two allow its use with \<open>only:\<close>\<close>
       image_insert [THEN sym] image_Un [THEN sym]
       rangeI symKeys_neq_imp_neq
       insert_Key_singleton insert_Key_image Un_assoc [THEN sym]

(*General lemmas proved by Larry*)

subsection\<open>Controlled Unfolding of Abbreviations\<close>

text\<open>A set is expanded only if a relation is applied to it\<close>
lemma def_abbrev_simp_relation:
     "A = B \<Longrightarrow> (A \<in> X) = (B \<in> X) \<and>
                 (u = A) = (u = B) \<and>
                 (A = u) = (B = u)"
by auto

text\<open>A set is expanded only if one of the given functions is applied to it\<close>
lemma def_abbrev_simp_function:
     "A = B
      \<Longrightarrow> parts (insert A X) = parts (insert B X) \<and>
          analz (insert A X) = analz (insert B X) \<and>
          keysFor (insert A X) = keysFor (insert B X)"
by auto

subsubsection\<open>Special Simplification Rules for \<^term>\<open>signCert\<close>\<close>

text\<open>Avoids duplicating X and its components!\<close>
lemma parts_insert_signCert:
     "parts (insert (signCert K X) H) =
      insert \<lbrace>X, Crypt K X\<rbrace> (parts (insert (Crypt K X) H))"
by (simp add: signCert_def insert_commute [of X])

text\<open>Avoids a case split! [X is always available]\<close>
lemma analz_insert_signCert:
     "analz (insert (signCert K X) H) =
      insert \<lbrace>X, Crypt K X\<rbrace> (insert (Crypt K X) (analz (insert X H)))"
by (simp add: signCert_def insert_commute [of X])

lemma keysFor_insert_signCert: "keysFor (insert (signCert K X) H) = keysFor H"
by (simp add: signCert_def)

text\<open>Controlled rewrite rules for \<^term>\<open>signCert\<close>, just the definitions
  of the others. Encryption primitives are just expanded, despite their huge
  redundancy!\<close>
lemmas abbrev_simps [simp] =
    parts_insert_signCert analz_insert_signCert keysFor_insert_signCert
    sign_def     [THEN def_abbrev_simp_relation]
    sign_def     [THEN def_abbrev_simp_function]
    signCert_def [THEN def_abbrev_simp_relation]
    signCert_def [THEN def_abbrev_simp_function]
    certC_def    [THEN def_abbrev_simp_relation]
    certC_def    [THEN def_abbrev_simp_function]
    cert_def     [THEN def_abbrev_simp_relation]
    cert_def     [THEN def_abbrev_simp_function]
    EXcrypt_def  [THEN def_abbrev_simp_relation]
    EXcrypt_def  [THEN def_abbrev_simp_function]
    EXHcrypt_def [THEN def_abbrev_simp_relation]
    EXHcrypt_def [THEN def_abbrev_simp_function]
    Enc_def      [THEN def_abbrev_simp_relation]
    Enc_def      [THEN def_abbrev_simp_function]
    EncB_def     [THEN def_abbrev_simp_relation]
    EncB_def     [THEN def_abbrev_simp_function]

subsubsection\<open>Elimination Rules for Controlled Rewriting\<close>

lemma Enc_partsE:
     "!!R. [|Enc SK K EK M \<in> parts H;
             [|Crypt K (sign SK M) \<in> parts H;
               Crypt EK (Key K) \<in> parts H|] ==> R|]
           ==> R"

by (unfold Enc_def, blast)

lemma EncB_partsE:
     "!!R. [|EncB SK K EK M b \<in> parts H;
             [|Crypt K (sign SK \<lbrace>M, Hash b\<rbrace>) \<in> parts H;
               Crypt EK (Key K) \<in> parts H;
               b \<in> parts H|] ==> R|]
           ==> R"
by (unfold EncB_def Enc_def, blast)

lemma EXcrypt_partsE:
     "!!R. [|EXcrypt K EK M m \<in> parts H;
             [|Crypt K \<lbrace>M, Hash m\<rbrace> \<in> parts H;
               Crypt EK \<lbrace>Key K, m\<rbrace> \<in> parts H|] ==> R|]
           ==> R"
by (unfold EXcrypt_def, blast)

subsection\<open>Lemmas to Simplify Expressions Involving \<^term>\<open>analz\<close>\<close>

lemma analz_knows_absorb:
     "Key K \<in> analz (knows Spy evs)
      ==> analz (Key ` (insert K H) \<union> knows Spy evs) =
          analz (Key ` H \<union> knows Spy evs)"
by (simp add: analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD])

lemma analz_knows_absorb2:
     "Key K \<in> analz (knows Spy evs)
      ==> analz (Key ` (insert X (insert K H)) \<union> knows Spy evs) =
          analz (Key ` (insert X H) \<union> knows Spy evs)"
apply (subst insert_commute)
apply (erule analz_knows_absorb)
done

lemma analz_insert_subset_eq:
     "[|X \<in> analz (knows Spy evs);  knows Spy evs \<subseteq> H|]
      ==> analz (insert X H) = analz H"
apply (rule analz_insert_eq)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])
done

lemmas analz_insert_simps =
         analz_insert_subset_eq Un_upper2
         subset_insertI [THEN [2] subset_trans]

subsection\<open>Freshness Lemmas\<close>

lemma in_parts_Says_imp_used:
     "[|Key K \<in> parts {X}; Says A B X \<in> set evs|] ==> Key K \<in> used evs"
by (blast intro: parts_trans dest!: Says_imp_knows_Spy [THEN parts.Inj])

text\<open>A useful rewrite rule with \<^term>\<open>analz_image_keys_simps\<close>\<close>
lemma Crypt_notin_image_Key: "Crypt K X \<notin> Key ` KK"
by auto

lemma fresh_notin_analz_knows_Spy:
     "Key K \<notin> used evs \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (auto dest: analz_into_parts)

end


theory "necessity_of_"
  imports Main "../QML"
begin

axiomatization where refl :"(\<forall>x. x r x)"
axiomatization where symm : "(\<forall>x y. x r y \<longrightarrow> y r x)"
axiomatization where transitive :"(\<forall>x y z. ((x r y) \<and> (y r z) \<longrightarrow> (x r z)))"
axiomatization where euclidean :"(\<forall>x y z. ((x r y) \<and> (x r z) \<longrightarrow> (y r z)))"

consts makeTable ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("T")

lemma
  assumes compossibilty1: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))))\<rfloor>"
  assumes origin_uniqueness: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))))\<rfloor>"
  assumes sufficiency1: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<diamond>(T x' y) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x y) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx')))\<rfloor>"
  shows independence: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>(((\<^bold>\<not>(y\<^bold>=\<^sup>Lz)) \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z)))\<rfloor>"
  oops

lemma necessity_of_distinctness_leib: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>=\<^sup>L y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>=\<^sup>L y))\<rfloor>"
  by auto

lemma necessity_of_identity_leib: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. ((x \<^bold>=\<^sup>L y)) \<^bold>\<rightarrow> \<^bold>\<box>((x \<^bold>=\<^sup>L y))\<rfloor>"
  by auto

lemma
  assumes indiscernibility_of_identicals: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)\<rfloor>"
  shows necessity_of_identity: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)\<rfloor>"
proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
    proof (rule allI)
      fix y
      show "((x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
      proof (rule impI)
        assume "(x \<^bold>\<leftrightarrow> y) w"
        show "(\<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
        proof (rule allI)
          fix v
          show "w r v \<longrightarrow> ((x \<^bold>\<leftrightarrow> y) v)"
          proof (rule impI)
            assume "w r v"
            show "(x \<^bold>\<leftrightarrow> y) v"
            proof(rule iffI)
              from indiscernibility_of_identicals have "(\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v"..
              then have "(\<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "((x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "(x \<^bold>\<leftrightarrow> y) v" by (rule conjE)
              then show "(y v \<Longrightarrow> x v)" by simp
            next  (* show "(x v \<Longrightarrow> y v)" using `(x \<^bold>\<leftrightarrow> y) v` by simp *)
              from indiscernibility_of_identicals have "(\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v"..
              then have "(\<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "((x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "(x \<^bold>\<leftrightarrow> y) v" by (rule conjE)
              then show "(x v \<Longrightarrow> y v)" by simp
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma
  assumes necessity_of_identity: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)\<rfloor>"
  shows necessity_of_distinctness: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))\<rfloor>"
proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
      proof (rule impI)
        assume possibility: "(\<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
        show "\<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) w"
        proof (rule allI)
          fix v
          show "w r v \<longrightarrow> ((\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) v)"
          proof (rule impI)
            assume "w r v"
            show "(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) v"
            proof (rule notI)
              assume "((x \<^bold>\<leftrightarrow> y)) v"

              from possibility have "(\<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w" by simp
              then have "\<^bold>\<not>(x \<^bold>\<leftrightarrow> y) v"
                by (smt `w r v` local.necessity_of_identity symm)
              then show "False" using `(x \<^bold>\<leftrightarrow> y) v` by (rule notE)
            qed
          qed
        qed
      qed
    qed
  qed
qed

end


theory Scratch_crel_mono
  imports "../DP_CRelVS"
begin

context dp_consistency
begin

lemma crel_vs_mono:
  fixes R0 R1
  assumes "R0 \<le> R1"
  shows "crel_vs R0 \<le> crel_vs R1"
  using assms by (fastforce intro: crel_vs_intro elim: crel_vs_elim)

end

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>Par\<close>\<close>
theory CZH_ECAT_Par
  imports
    CZH_Foundations.CZH_SMC_Par
    CZH_ECAT_Rel
    CZH_ECAT_Subcategory
begin

subsection\<open>Background\<close>

text\<open>
The methodology chosen for the exposition of \<open>Par\<close> as a category is
analogous to the one used in \<^cite>\<open>"milehins_category_2021"\<close>
for the exposition of \<open>Par\<close> as a semicategory.
\<close>

named_theorems cat_Par_cs_simps
named_theorems cat_Par_cs_intros

lemmas (in arr_Par) [cat_Par_cs_simps] =
  dg_Rel_shared_cs_simps

lemmas (in arr_Par) [cat_cs_intros, cat_Par_cs_intros] =
  arr_Par_axioms'

lemmas [cat_Par_cs_simps] =
  dg_Rel_shared_cs_simps
  arr_Par.arr_Par_length
  arr_Par_comp_Par_id_Par_left
  arr_Par_comp_Par_id_Par_right

lemmas [cat_Par_cs_intros] =
  arr_Par_comp_Par

subsection\<open>\<open>Par\<close> as a category\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition cat_Par :: "V \<Rightarrow> V"
  where "cat_Par \<alpha> =
    [
      Vset \<alpha>,
      set {T. arr_Par \<alpha> T},
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>),
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>),
      (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>),
      VLambda (Vset \<alpha>) id_Par
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma cat_Par_components:
  shows "cat_Par \<alpha>\<lparr>Obj\<rparr> = Vset \<alpha>"
    and "cat_Par \<alpha>\<lparr>Arr\<rparr> = set {T. arr_Par \<alpha> T}"
    and "cat_Par \<alpha>\<lparr>Dom\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>)"
    and "cat_Par \<alpha>\<lparr>Cod\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>)"
    and "cat_Par \<alpha>\<lparr>Comp\<rparr> = (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>P\<^sub>a\<^sub>r ST\<lparr>1\<^sub>\<nat>\<rparr>)"
    and "cat_Par \<alpha>\<lparr>CId\<rparr> = VLambda (Vset \<alpha>) id_Par"
  unfolding cat_Par_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma cat_smc_cat_Par: "cat_smc (cat_Par \<alpha>) = smc_Par \<alpha>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> (cat_smc (cat_Par \<alpha>)) = 5\<^sub>\<nat>"
    unfolding cat_smc_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (smc_Par \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_Par_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (cat_smc (cat_Par \<alpha>)) = \<D>\<^sub>\<circ> (smc_Par \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_smc (cat_Par \<alpha>)) \<Longrightarrow> cat_smc (cat_Par \<alpha>)\<lparr>a\<rparr> = smc_Par \<alpha>\<lparr>a\<rparr>"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold cat_smc_def dg_field_simps cat_Par_def smc_Par_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: cat_smc_def smc_Par_def)

lemmas_with [folded cat_smc_cat_Par, unfolded slicing_simps]:
  cat_Par_Obj_iff = smc_Par_Obj_iff
  and cat_Par_Arr_iff[cat_Par_cs_simps] = smc_Par_Arr_iff
  and cat_Par_Dom_vsv[cat_Par_cs_intros] = smc_Par_Dom_vsv
  and cat_Par_Dom_vdomain[cat_Par_cs_simps] = smc_Par_Dom_vdomain
  and cat_Par_Dom_vrange = smc_Par_Dom_vrange
  and cat_Par_Dom_app[cat_Par_cs_simps] = smc_Par_Dom_app
  and cat_Par_Cod_vsv[cat_Par_cs_intros] = smc_Par_Cod_vsv
  and cat_Par_Cod_vdomain[cat_Par_cs_simps] = smc_Par_Cod_vdomain
  and cat_Par_Cod_vrange = smc_Par_Cod_vrange
  and cat_Par_Cod_app[cat_Par_cs_simps] = smc_Par_Cod_app
  and cat_Par_is_arrI = smc_Par_is_arrI
  and cat_Par_is_arrD = smc_Par_is_arrD
  and cat_Par_is_arrE = smc_Par_is_arrE

lemmas_with [folded cat_smc_cat_Par, unfolded slicing_simps]:
  cat_Par_composable_arrs_dg_Par = smc_Par_composable_arrs_dg_Par
  and cat_Par_Comp = smc_Par_Comp
  and cat_Par_Comp_app[cat_Par_cs_simps] = smc_Par_Comp_app
  and cat_Par_Comp_vdomain[cat_Par_cs_simps] = smc_Par_Comp_vdomain
  and cat_Par_is_monic_arrI = smc_Par_is_monic_arrI
  and cat_Par_is_monic_arrD = smc_Par_is_monic_arrD
  and cat_Par_is_monic_arr = smc_Par_is_monic_arr
  and cat_Par_is_epic_arrI = smc_Par_is_epic_arrI
  and cat_Par_is_epic_arrD = smc_Par_is_epic_arrD
  and cat_Par_is_epic_arr = smc_Par_is_epic_arr

lemmas [cat_cs_simps] = cat_Par_is_arrD(2,3)

lemmas [cat_Par_cs_intros] = cat_Par_is_arrI

lemmas_with (in \<Z>) [folded cat_smc_cat_Par, unfolded slicing_simps]:
  cat_Par_Hom_vifunion_in_Vset = smc_Par_Hom_vifunion_in_Vset
  and cat_Par_incl_Par_is_arr = smc_Par_incl_Par_is_arr
  and cat_Par_incl_Par_is_arr'[cat_Par_cs_intros] = smc_Par_incl_Par_is_arr'
  and cat_Par_Comp_vrange = smc_Par_Comp_vrange
  and cat_Par_obj_terminal = smc_Par_obj_terminal
  and cat_Par_obj_initial = smc_Par_obj_initial
  and cat_Par_obj_terminal_obj_initial = smc_Par_obj_terminal_obj_initial
  and cat_Par_obj_null = smc_Par_obj_null
  and cat_Par_is_zero_arr = smc_Par_is_zero_arr

lemmas [cat_Par_cs_intros] = \<Z>.cat_Par_incl_Par_is_arr'

subsubsection\<open>Identity\<close>

lemma cat_Par_CId_app[cat_Par_cs_simps]:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr> = id_Par A"
  using assms unfolding cat_Par_components by simp

lemma id_Par_CId_app_app[cat_cs_simps]:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>" and "a \<in>\<^sub>\<circ> A"
  shows "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr>\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> = a"
  unfolding cat_Par_CId_app[OF assms(1)] id_Rel_ArrVal_app[OF assms(2)] by simp

subsubsection\<open>\<open>Par\<close> is a category\<close>

lemma (in \<Z>) category_cat_Par: "category \<alpha> (cat_Par \<alpha>)"
proof(intro categoryI, unfold cat_smc_cat_Rel cat_smc_cat_Par cat_op_simps)

  interpret Par: semicategory \<alpha> \<open>cat_smc (cat_Par \<alpha>)\<close>
    unfolding cat_smc_cat_Par by (simp add: semicategory_smc_Par)

  show "vfsequence (cat_Par \<alpha>)" unfolding cat_Par_def by simp
  show "vcard (cat_Par \<alpha>) = 6\<^sub>\<nat>"
    unfolding cat_Par_def by (simp add: nat_omega_simps)
  show "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr> : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> A" if "A \<in>\<^sub>\<circ> cat_Par \<alpha>\<lparr>Obj\<rparr>" for A
    using that
    unfolding cat_Par_Obj_iff
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_Par_cs_simps cs_intro: cat_Par_cs_intros arr_Par_id_ParI
      )

  show "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>B\<rparr> \<circ>\<^sub>A\<^bsub>cat_Par \<alpha>\<^esub> F = F"
    if "F : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B" for F A B
  proof-
    from that have "arr_Par \<alpha> F" "B \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto elim: cat_Par_is_arrE simp: cat_Par_cs_simps)
    with that \<Z>_axioms show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_Par_cs_simps
            cs_intro: cat_Par_cs_intros arr_Par_id_ParI
        )
  qed

  show "F \<circ>\<^sub>A\<^bsub>cat_Par \<alpha>\<^esub> cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>B\<rparr> = F"
    if "F : B \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> C" for F B C
  proof-
    from that have "arr_Par \<alpha> F" "B \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto elim: cat_Par_is_arrE simp: cat_Par_cs_simps)
    with that show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_Par_cs_simps
            cs_intro: cat_Par_cs_intros arr_Par_id_ParI
        )
  qed

qed (auto simp: semicategory_smc_Par cat_Par_components)

subsubsection\<open>\<open>Par\<close> is a wide replete subcategory of \<open>Rel\<close>\<close>

lemma (in \<Z>) wide_replete_subcategory_cat_Par_cat_Rel:
  "cat_Par \<alpha> \<subseteq>\<^sub>C\<^sub>.\<^sub>w\<^sub>r\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
proof(intro wide_replete_subcategoryI)
  show wide_subcategory_cat_Par_cat_Rel: "cat_Par \<alpha> \<subseteq>\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
  proof(intro wide_subcategoryI, unfold cat_smc_cat_Rel cat_smc_cat_Par)
    interpret Rel: category \<alpha> \<open>cat_Rel \<alpha>\<close> by (rule category_cat_Rel)
    interpret Par: category \<alpha> \<open>cat_Par \<alpha>\<close> by (rule category_cat_Par)
    interpret wide_subsemicategory \<alpha> \<open>smc_Par \<alpha>\<close> \<open>smc_Rel \<alpha>\<close>
      by (simp add: wide_subsemicategory_smc_Par_smc_Rel)
    show "cat_Par \<alpha> \<subseteq>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
    proof(intro subcategoryI, unfold cat_smc_cat_Rel cat_smc_cat_Par)
      show "smc_Par \<alpha> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_Rel \<alpha>" by (simp add: subsemicategory_axioms)
      fix A assume "A \<in>\<^sub>\<circ> cat_Par \<alpha>\<lparr>Obj\<rparr>"
      then show "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr> = cat_Rel \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr>"
        unfolding cat_Par_components cat_Rel_components by simp
    qed
      (
        auto simp:
          subsemicategory_axioms Rel.category_axioms Par.category_axioms
      )
  qed (rule wide_subsemicategory_smc_Par_smc_Rel)
  show "cat_Par \<alpha> \<subseteq>\<^sub>C\<^sub>.\<^sub>r\<^sub>e\<^sub>p\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
  proof(intro replete_subcategoryI)
    interpret wide_subcategory \<alpha> \<open>cat_Par \<alpha>\<close> \<open>cat_Rel \<alpha>\<close>
      by (rule wide_subcategory_cat_Par_cat_Rel)
    show "cat_Par \<alpha> \<subseteq>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>" by (rule subcategory_axioms)
    fix A B F assume prems: "A \<in>\<^sub>\<circ> cat_Par \<alpha>\<lparr>Obj\<rparr>" "F : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    note arr_Rel = cat_Rel_is_iso_arrD[OF prems(2)]
    from arr_Rel(2) show "F : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B"
      by (intro cat_Par_is_arrI arr_Par_arr_RelI cat_Rel_is_arrD[OF arr_Rel(1)])
        auto
  qed
qed

subsection\<open>Isomorphism\<close>

lemma cat_Par_is_iso_arrI[intro]:
  assumes "T : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B"
    and "v11 (T\<lparr>ArrVal\<rparr>)"
    and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
    and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  shows "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
proof-
  interpret T: arr_Par \<alpha> T by (intro cat_Par_is_arrD(1)[OF assms(1)])
  note [cat_cs_intros] = cat_Rel_is_iso_arrI
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms have
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    by (cs_concl cs_intro: cat_cs_intros cat_sub_cs_intros cat_sub_fw_cs_intros)
  with T.wide_replete_subcategory_cat_Par_cat_Rel assms show
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
    by (cs_concl cs_shallow cs_simp: cat_sub_bw_cs_simps)
qed

lemma cat_Par_is_iso_arrD[dest]:
  assumes "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
  shows "T : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B"
    and "v11 (T\<lparr>ArrVal\<rparr>)"
    and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
    and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
proof-
  interpret T: arr_Par \<alpha> T
    by (intro cat_Par_is_arrD(1)[OF is_iso_arrD(1)[OF assms(1)]])
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms have T:
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    by (cs_concl cs_shallow cs_intro: cat_sub_cs_intros cat_sub_fw_cs_intros)
  show "v11 (T\<lparr>ArrVal\<rparr>)" "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A" "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
    by (intro cat_Rel_is_iso_arrD[OF T])+
qed (rule is_iso_arrD(1)[OF assms])

lemma cat_Par_is_iso_arr:
  "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B \<longleftrightarrow>
    T : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B \<and>
    v11 (T\<lparr>ArrVal\<rparr>) \<and>
    \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A \<and>
    \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  by auto

subsection\<open>The inverse arrow\<close>

abbreviation (input) converse_Par :: "V \<Rightarrow> V" ("(_\<inverse>\<^sub>P\<^sub>a\<^sub>r)" [1000] 999)
  where "a\<inverse>\<^sub>P\<^sub>a\<^sub>r \<equiv> a\<inverse>\<^sub>R\<^sub>e\<^sub>l"

lemma cat_Par_the_inverse[cat_Par_cs_simps]:
  assumes "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
  shows "T\<inverse>\<^sub>C\<^bsub>cat_Par \<alpha>\<^esub> = T\<inverse>\<^sub>P\<^sub>a\<^sub>r"
proof-
  interpret T: arr_Par \<alpha> T
    by (intro cat_Par_is_arrD(1)[OF is_iso_arrD(1)[OF assms(1)]])
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms have T:
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    by (cs_concl cs_shallow cs_intro: cat_sub_cs_intros cat_sub_fw_cs_intros)
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms
  have [symmetric, cat_cs_simps]: "T\<inverse>\<^sub>C\<^bsub>cat_Rel \<alpha>\<^esub> = T\<inverse>\<^sub>C\<^bsub>cat_Par \<alpha>\<^esub>"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_sub_bw_cs_simps cs_intro: cat_sub_cs_intros
      )
  from T show "T\<inverse>\<^sub>C\<^bsub>cat_Par \<alpha>\<^esub> = T\<inverse>\<^sub>P\<^sub>a\<^sub>r"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_Rel_cs_simps cat_cs_simps cs_intro: cat_cs_intros
      )
qed

text\<open>\newpage\<close>

end