section \<open>Infimum nat lemmas \label{S:infimum-nat}\<close>

theory Infimum_Nat
imports
  Refinement_Lattice
begin

locale infimum_nat
begin

lemma INF_partition_nat3:
  fixes f :: "nat \<Rightarrow> nat \<Rightarrow> 'a::refinement_lattice"
  shows "(\<Sqinter>j. f i j) =
    (\<Sqinter>j\<in>{j. i = j}. f i j) \<sqinter>
    (\<Sqinter>j\<in>{j. i < j}. f i j) \<sqinter>
    (\<Sqinter>j\<in>{j. j < i}. f i j)"
proof -
  have univ_part: "UNIV = {j. i = j} \<union> {j. i < j} \<union> {j. j < i}" by auto
  have "(\<Sqinter>j \<in> {j. i = j} \<union> {j. i < j} \<union> {j. j < i}. f i j) =
          (\<Sqinter>j\<in>{j. i = j}. f i j) \<sqinter>
          (\<Sqinter>j\<in>{j. i < j}. f i j) \<sqinter>
          (\<Sqinter>j\<in>{j. j < i}. f i j)" by (metis INF_union)
  with univ_part show ?thesis by simp
qed

lemma INF_INF_partition_nat3:
  fixes f :: "nat \<Rightarrow> nat \<Rightarrow> 'a::refinement_lattice"
  shows "(\<Sqinter>i. \<Sqinter>j. f i j) =
    (\<Sqinter>i. \<Sqinter>j\<in>{j. i = j}. f i j) \<sqinter>
    (\<Sqinter>i. \<Sqinter>j\<in>{j. i < j}. f i j) \<sqinter>
    (\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f i j)"
proof -
  have "(\<Sqinter>i. \<Sqinter>j. f i j) = (\<Sqinter>i. ((\<Sqinter>j\<in>{j. i = j}. f i j) \<sqinter>
                                  (\<Sqinter>j\<in>{j. i < j}. f i j) \<sqinter>
                                  (\<Sqinter>j\<in>{j. j < i}. f i j)))"
    by (simp add: INF_partition_nat3)
  also have "... = (\<Sqinter>i. \<Sqinter>j\<in>{j. i = j}. f i j) \<sqinter>
                   (\<Sqinter>i. \<Sqinter>j\<in>{j. i < j}. f i j) \<sqinter>
                   (\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f i j)"
    by (simp add: INF_inf_distrib)
  finally show ?thesis .
qed

lemma INF_nat_shift: "(\<Sqinter>i\<in>{i. 0 < i}. f i) = (\<Sqinter>i. f (Suc i))"
  by (metis greaterThan_0 greaterThan_def range_composition)

lemma INF_nat_minus:
  fixes f :: "nat \<Rightarrow> 'a::refinement_lattice"
  shows "(\<Sqinter>j\<in>{j. i < j}. f (j - i)) = (\<Sqinter>k\<in>{k. 0 < k}. f k)"
  apply (rule antisym)
  apply (rule INF_mono, simp)
  apply (metis add.right_neutral add_diff_cancel_left' add_less_cancel_left order_refl)
  apply (rule INF_mono, simp)
  by (meson order_refl zero_less_diff)

(* TODO: generalise to P j i? *)
lemma INF_INF_guarded_switch:
  fixes f :: "nat \<Rightarrow> nat \<Rightarrow> 'a::refinement_lattice"
  shows "(\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f j (i - j)) = (\<Sqinter>j. \<Sqinter>i\<in>{i. j < i}. f j (i - j))"
proof (rule antisym)
  have "\<And>jj ii. jj < ii \<Longrightarrow> \<exists>i. \<exists>j<i. f j (i - j) \<sqsubseteq> f jj (ii - jj)"
    by blast
  then have "\<And>jj ii. jj < ii \<Longrightarrow> \<exists>i. (\<Sqinter>j\<in>{j. j < i}. f j (i - j)) \<sqsubseteq> f jj (ii - jj)"
    by (meson INF_lower mem_Collect_eq)
  then have "\<And>jj ii. jj < ii \<Longrightarrow> (\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f j (i - j)) \<sqsubseteq> f jj (ii - jj)"
    by (meson UNIV_I INF_lower dual_order.trans)
  then have "\<And>jj. (\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f j (i - j)) \<sqsubseteq> (\<Sqinter>ii\<in>{ii. jj < ii}. f jj (ii - jj))"
    by (metis (mono_tags, lifting) INF_greatest mem_Collect_eq)
  then have "(\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f j (i - j)) \<sqsubseteq> (\<Sqinter>jj. \<Sqinter>ii\<in>{ii. jj < ii}. f jj (ii - jj))"
    by (simp add: INF_greatest)
  then show "(\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f j (i - j)) \<sqsubseteq> (\<Sqinter>j. \<Sqinter>i\<in>{i. j < i}. f j (i - j))"
    by simp
next
  have "\<And>ii jj. jj < ii \<Longrightarrow> \<exists>j. \<exists>i>j. f j (i - j) \<sqsubseteq> f jj (ii - jj)"
    by blast
  then have "\<And>ii jj. jj < ii \<Longrightarrow> \<exists>j. (\<Sqinter>i\<in>{i. j < i}. f j (i - j)) \<sqsubseteq> f jj (ii - jj)"
    by (meson INF_lower mem_Collect_eq)
  then have "\<And>ii jj. jj < ii \<Longrightarrow> (\<Sqinter>j. \<Sqinter>i\<in>{i. j < i}. f j (i - j)) \<sqsubseteq> f jj (ii - jj)"
    by (meson UNIV_I INF_lower dual_order.trans)
  then have "\<And>ii. (\<Sqinter>j. \<Sqinter>i\<in>{i. j < i}. f j (i - j)) \<sqsubseteq> (\<Sqinter>jj\<in>{jj. jj < ii}. f jj (ii - jj))"
    by (metis (mono_tags, lifting) INF_greatest mem_Collect_eq)
  then have "(\<Sqinter>j. \<Sqinter>i\<in>{i. j < i}. f j (i - j)) \<sqsubseteq> (\<Sqinter>ii. \<Sqinter>jj\<in>{jj. jj < ii}. f jj (ii - jj))"
    by (simp add: INF_greatest)
  then show "(\<Sqinter>j. \<Sqinter>i\<in>{i. j < i}. f j (i - j)) \<sqsubseteq> (\<Sqinter>i. \<Sqinter>j\<in>{j. j < i}. f j (i - j))"
    by simp
qed

end

end


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

section \<open>Some examples for Presburger Arithmetic\<close>

theory PresburgerEx
imports Main
begin

lemma "\<And>m n ja ia. \<lbrakk>\<not> m \<le> j; \<not> (n::nat) \<le> i; (e::nat) \<noteq> 0; Suc j \<le> ja\<rbrakk> \<Longrightarrow> \<exists>m. \<forall>ja ia. m \<le> ja \<longrightarrow> (if j = ja \<and> i = ia then e else 0) = 0" by presburger
lemma "(0::nat) < emBits mod 8 \<Longrightarrow> 8 + emBits div 8 * 8 - emBits = 8 - emBits mod 8"
by presburger
lemma "(0::nat) < emBits mod 8 \<Longrightarrow> 8 + emBits div 8 * 8 - emBits = 8 - emBits mod 8"
by presburger

theorem "(\<forall>(y::int). 3 dvd y) ==> \<forall>(x::int). b < x --> a \<le> x"
  by presburger

theorem "!! (y::int) (z::int) (n::int). 3 dvd z ==> 2 dvd (y::int) ==>
  (\<exists>(x::int).  2*x =  y) & (\<exists>(k::int). 3*k = z)"
  by presburger

theorem "!! (y::int) (z::int) n. Suc(n::nat) < 6 ==>  3 dvd z ==>
  2 dvd (y::int) ==> (\<exists>(x::int).  2*x =  y) & (\<exists>(k::int). 3*k = z)"
  by presburger

theorem "\<forall>(x::nat). \<exists>(y::nat). (0::nat) \<le> 5 --> y = 5 + x "
  by presburger

text\<open>Slow: about 7 seconds on a 1.6GHz machine.\<close>
theorem "\<forall>(x::nat). \<exists>(y::nat). y = 5 + x | x div 6 + 1= 2"
  by presburger

theorem "\<exists>(x::int). 0 < x"
  by presburger

theorem "\<forall>(x::int) y. x < y --> 2 * x + 1 < 2 * y"
  by presburger

theorem "\<forall>(x::int) y. 2 * x + 1 \<noteq> 2 * y"
  by presburger

theorem "\<exists>(x::int) y. 0 < x  & 0 \<le> y  & 3 * x - 5 * y = 1"
  by presburger

theorem "~ (\<exists>(x::int) (y::int) (z::int). 4*x + (-6::int)*y = 1)"
  by presburger

theorem "\<forall>(x::int). b < x --> a \<le> x"
  apply (presburger elim)
  oops

theorem "~ (\<exists>(x::int). False)"
  by presburger

theorem "\<forall>(x::int). (a::int) < 3 * x --> b < 3 * x"
  apply (presburger elim)
  oops

theorem "\<forall>(x::int). (2 dvd x) --> (\<exists>(y::int). x = 2*y)"
  by presburger

theorem "\<forall>(x::int). (2 dvd x) --> (\<exists>(y::int). x = 2*y)"
  by presburger

theorem "\<forall>(x::int). (2 dvd x) = (\<exists>(y::int). x = 2*y)"
  by presburger

theorem "\<forall>(x::int). ((2 dvd x) = (\<forall>(y::int). x \<noteq> 2*y + 1))"
  by presburger

theorem "~ (\<forall>(x::int).
            ((2 dvd x) = (\<forall>(y::int). x \<noteq> 2*y+1) |
             (\<exists>(q::int) (u::int) i. 3*i + 2*q - u < 17)
             --> 0 < x | ((~ 3 dvd x) &(x + 8 = 0))))"
  by presburger

theorem "~ (\<forall>(i::int). 4 \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i))"
  by presburger

theorem "\<forall>(i::int). 8 \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i)"
  by presburger

theorem "\<exists>(j::int). \<forall>i. j \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i)"
  by presburger

theorem "~ (\<forall>j (i::int). j \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i))"
  by presburger

theorem "(\<exists>m::nat. n = 2 * m) --> (n + 1) div 2 = n div 2"
  by presburger

text\<open>This following theorem proves that all solutions to the
recurrence relation $x_{i+2} = |x_{i+1}| - x_i$ are periodic with
period 9.  The example was brought to our attention by John
Harrison. It does does not require Presburger arithmetic but merely
quantifier-free linear arithmetic and holds for the rationals as well.

Warning: it takes (in 2006) over 4.2 minutes!\<close>

lemma "\<lbrakk> x3 = \<bar>x2\<bar> - x1; x4 = \<bar>x3\<bar> - x2; x5 = \<bar>x4\<bar> - x3;
         x6 = \<bar>x5\<bar> - x4; x7 = \<bar>x6\<bar> - x5; x8 = \<bar>x7\<bar> - x6;
         x9 = \<bar>x8\<bar> - x7; x10 = \<bar>x9\<bar> - x8; x11 = \<bar>x10\<bar> - x9 \<rbrakk>
 \<Longrightarrow> x1 = x10 & x2 = (x11::int)"
by arith

end


theory T170
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory T115
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T87
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T182
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Exercises2_05
  imports Main
begin

(*---------------- Exercise 2.5----------------*)
(* sum function *)
fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto (Suc n) = (Suc n) + sum_upto n"

theorem correct_sum : "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
   apply(auto)
  done

end


theory Proofs
  imports Main
begin

(* Problem: *)
lemma
  assumes "\<forall>x. \<forall>y. x + y = y + x"
    and "\<forall>x. \<forall>y. \<forall>z. x + (y + z) = (x + y) + z"
    and "\<forall>x. 0 + x = x"
  shows "u + v = 0 \<longrightarrow> (v + w) + u = w"
  term u
proof
  (* from assms(3) have "0 + x = x" *)
  from assms(3) have "0 + (x::'c) = x" by (rule allE)
  oops

(* vollständig manuell *)
lemma
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<oplus>" 80)
    and e :: 'a
  assumes "\<forall>x. \<forall>y. x \<oplus> y = y \<oplus> x"
    and "\<forall>x. \<forall>y. \<forall>z. x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
    and "\<forall>x. e \<oplus> x = x"
  shows "u \<oplus> v = e \<longrightarrow> (v \<oplus> w) \<oplus> u = w"
proof
  assume A: "u \<oplus> v = e"

  thm assms
  thm assms(1)

  (* -------------------------------------------------- *)
  from assms(1) have "\<forall>y. u \<oplus> y = y \<oplus> u" by (rule allE)
  then have comm1: "u \<oplus> v = v \<oplus> u" by (rule allE)

  from assms(1) have "\<forall>y. u \<oplus> y = y \<oplus> u" by (rule allE)
  then have comm2: "u \<oplus> w = w \<oplus> u" by (rule allE)

  from assms(2) have "\<forall>y. \<forall>z. v \<oplus> (y \<oplus> z) = (v \<oplus> y) \<oplus> z" by (rule allE)
  then have "\<forall>z. v \<oplus> (u \<oplus> z) = (v \<oplus> u) \<oplus> z" by (rule allE)
  then have assoc1: "v \<oplus> (u \<oplus> w) = (v \<oplus> u) \<oplus> w" by (rule allE)

  from assms(2) have "\<forall>y. \<forall>z. v \<oplus> (y \<oplus> z) = (v \<oplus> y) \<oplus> z" by (rule allE)
  then have "\<forall>z. v \<oplus> (w \<oplus> z) = (v \<oplus> w) \<oplus> z" by (rule allE)
  then have assoc2: "v \<oplus> (w \<oplus> u) = (v \<oplus> w) \<oplus> u" by (rule allE)
  (* -------------------------------------------------- *)

  from assms(3) have "e \<oplus> w = w" by (rule allE)
  with A have "(u \<oplus> v) \<oplus> w = w" by (rule ssubst)
  with comm1 have "(v \<oplus> u) \<oplus> w = w" by (rule subst)
  with assoc1 have "v \<oplus> u \<oplus> w = w" by (rule ssubst)
  with comm2 have "v \<oplus> (w \<oplus> u) = w" by (rule subst)
  with assoc2 show "(v \<oplus> w) \<oplus> u = w" by (rule subst)
qed

(* mehr automatisiert *)
lemma
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<oplus>" 80)
    and e :: 'a
  assumes "\<forall>x. \<forall>y. x \<oplus> y = y \<oplus> x"
    and "\<forall>x. \<forall>y. \<forall>z. x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
    and "\<forall>x. e \<oplus> x = x"
  shows "u \<oplus> v = e \<longrightarrow> (v \<oplus> w) \<oplus> u = w"
proof
  assume A: "u \<oplus> v = e"

  from assms(3) have "e \<oplus> w = w" ..
  then have "(u \<oplus> v) \<oplus> w = w"
    by (simp add: A)
  then have "(v \<oplus> u) \<oplus> w = w"
    by (simp add: assms(1))
  then have "v \<oplus> u \<oplus> w = w"
    by (simp add: assms(2))
  then have "v \<oplus> (w \<oplus> u) = w"
    by (simp add: assms(1))
  then show "(v \<oplus> w) \<oplus> u = w"
    by (simp add: assms(2))
qed

(* vollständig automatisiert *)
lemma
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<oplus>" 80)
    and e :: 'a
  assumes "\<forall>x. \<forall>y. x \<oplus> y = y \<oplus> x"
    and "\<forall>x. \<forall>y. \<forall>z. x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
    and "\<forall>x. e \<oplus> x = x"
  shows "u \<oplus> v = e \<longrightarrow> (v \<oplus> w) \<oplus> u = w"
  by (simp add: assms)

end


theory Disjunction
imports
  Formula
  Validity
begin

section \<open>Disjunction\<close>

definition Disj :: "('idx,'pred::fs,'act::bn) formula set['idx] \<Rightarrow> ('idx,'pred,'act) formula" where
  "Disj xset = Not (Conj (map_bset Not xset))"

lemma finite_supp_map_bset_Not [simp]:
  assumes "finite (supp xset)"
  shows "finite (supp (map_bset Not xset))"
proof -
  have "eqvt map_bset" and "eqvt Not"
    by (simp add: eqvtI)+
  then have "supp (map_bset Not) = {}"
    using supp_fun_eqvt supp_fun_app_eqvt by blast
  then have "supp (map_bset Not xset) \<subseteq> supp xset"
    using supp_fun_app by blast
  with assms show "finite (supp (map_bset Not xset))"
    by (metis finite_subset)
qed

lemma Disj_eqvt [simp]:
  assumes "finite (supp xset)"
  shows "p \<bullet> Disj xset = Disj (p \<bullet> xset)"
using assms unfolding Disj_def by simp

lemma Disj_eq_iff [simp]:
  assumes "finite (supp xset1)" and "finite (supp xset2)"
  shows "Disj xset1 = Disj xset2 \<longleftrightarrow> xset1 = xset2"
using assms unfolding Disj_def by (metis Conj_eq_iff Not_eq_iff bset.inj_map_strong finite_supp_map_bset_Not)

context nominal_ts
begin

  lemma valid_Disj [simp]:
    assumes "finite (supp xset)"
    shows "P \<Turnstile> Disj xset \<longleftrightarrow> (\<exists>x\<in>set_bset xset. P \<Turnstile> x)"
  using assms by (simp add: Disj_def map_bset.rep_eq)

end

end


theory SimplyTypedLambdaCalculus

imports Main

begin

type_synonym var = string

no_notation Set.member ("(_/ \<in> _)" [51, 51] 50)

datatype type = TUnit
  | TApp type type ("_ \<rightarrow> _")

datatype expr =
    Unit
  | Var var
  | Abs var type expr
  | App expr expr

(* it is important to choose a list here, since this defines how the type lookup is made
   when augmenting the context *)
type_synonym ctx = "(var \<times> type) list"

fun has_type_in_ctx :: "var \<times> type \<Rightarrow> ctx \<Rightarrow> bool" ("(_ \<in> _)" [51, 51] 50) where
  "has_type_in_ctx    _          [] = False" |
  "has_type_in_ctx (x,\<tau>) ((y,\<tau>')#\<Gamma>) = (if x = y then \<tau> = \<tau>' else has_type_in_ctx (x,\<tau>) \<Gamma>)"

inductive "value" :: "expr \<Rightarrow> bool" where
  ValueUnit: "value Unit"
| ValueFn: "value (Abs x t e1)"

declare value.intros[simp,intro]

fun fvs :: "expr \<Rightarrow> var set" where
  "fvs Unit          = {}" |
  "fvs (Var v)       = {v}" |
  "fvs (Abs x ty e)  = fvs e - {x}" |
  "fvs (App e1 e2)   = fvs e1 \<union> fvs e2"

fun subst :: "var \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" where
  "subst x t Unit         = Unit" |
  "subst x t (Var v)      = (if x = v then t else Var v)" |
  "subst x t (Abs v ty e) = Abs v ty (if x = v then e else subst x t e)" |
  "subst x t (App e1 e2)  = App (subst x t e1) (subst x t e2)"

inductive reduce :: "expr \<Rightarrow> expr \<Rightarrow> bool" where
  CApp1: "reduce e1 e1' \<Longrightarrow> reduce (App e1 e2) (App e1' e2)"
| CApp2: "value e1      \<Longrightarrow> reduce e2 e2' \<Longrightarrow> reduce (App e1 e2) (App e1 e2')"
| RApp:  "value e2      \<Longrightarrow> reduce (App (Abs x ty e1) e2) (subst x e2 e1)"

declare reduce.intros[simp,intro]

inductive_cases ReduceAppE[elim]: "reduce (App e1 e2) e"
inductive_cases ReduceElimE[elim]: "reduce (Let x e1 e2) e"

inductive has_type :: "ctx \<Rightarrow> expr \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ : _" [40,40,40]) where
  TypeUnit: "\<Gamma> \<turnstile> Unit : TUnit" |
  TypeVar:  "(x, \<tau>) \<in> \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> (Var x) : \<tau>" |
  TypeFn:   "\<lbrakk> ((x, \<tau>)#\<Gamma>) \<turnstile> e : \<tau>' \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (Abs x \<tau> e) : (\<tau> \<rightarrow> \<tau>')" |
  TypeApp:  "\<lbrakk> \<Gamma> \<turnstile> e1 : (\<tau>' \<rightarrow> \<tau>); \<Gamma> \<turnstile> e2 : \<tau>' \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (App e1 e2) : \<tau>"

declare has_type.intros[simp,intro]

inductive_cases TypeUnitE[elim!]: "\<Gamma> \<turnstile> Unit : \<tau>"
inductive_cases TypeVarE[elim!]:  "\<Gamma> \<turnstile> (Var x) : \<tau>"
inductive_cases TypeFnE[elim]:    "\<Gamma> \<turnstile> (Abs x \<tau> e) : \<tau>"
inductive_cases TypeAppE[elim]:   "\<Gamma> \<turnstile> (App e1 e2) : \<tau>"

inductive step_or_value where
  IsValue: "value e \<Longrightarrow> step_or_value e" |
  IsStep: "\<exists>e'. reduce e e' \<Longrightarrow> step_or_value e"

declare step_or_value.intros[simp,intro]

inductive_cases StepOrValueE[elim!]: "step_or_value e"

lemma subst_identity[simp]:
  "subst x (Var x) e = e"
  by (induct e, auto)

lemma identity_exists:
  "value e \<Longrightarrow> reduce (App (Abs x \<tau> (Var x)) e) e"
  (* found by sledgehammer *)
  by (metis RApp subst.simps(2))

theorem progress:
  "[] \<turnstile> e : \<tau> \<Longrightarrow> step_or_value e"
proof (induction  "[] :: ctx" "e" "\<tau>" rule:has_type.induct)
  case (TypeApp e1 \<tau>' \<tau> e2)
  then show ?case
    (* found by sledgehammer *)
    using step_or_value.simps value.simps by auto
qed auto

lemma context_strengthening:
  "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> \<forall>x \<tau>'. Set.member x (fvs e) \<longrightarrow> (x, \<tau>') \<in> \<Gamma> \<longrightarrow> (x, \<tau>') \<in> \<Gamma>' \<Longrightarrow> \<Gamma>' \<turnstile> e : \<tau>"
proof (induction arbitrary: \<Gamma>' rule: has_type.induct)
  case (TypeApp \<Gamma> e1 \<tau>' \<tau> e2)
  then show ?case
    (* found by sledgehammer *)
    by (metis Un_iff fvs.simps(4) has_type.TypeApp)
qed auto

lemma well_typed_fvs:
  "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> \<forall>v \<in> fvs e. (\<exists>\<tau>. (v, \<tau>) \<in> \<Gamma>)"
  apply (induction rule:has_type.induct, auto)
  by metis+

corollary well_typed_no_fvs:
  "[] \<turnstile> e : \<tau> \<Longrightarrow> fvs e = {}"
  (* sledgehammer *)
  by (meson ex_in_conv has_type_in_ctx.simps(1) well_typed_fvs)

lemma subst_preservation:
  "\<lbrakk> ((x, \<tau>')#\<Gamma>) \<turnstile> e2 : \<tau>; [] \<turnstile> e1 : \<tau>' \<rbrakk>
   \<Longrightarrow> \<Gamma> \<turnstile> subst x e1 e2 : \<tau>"
proof (induct e2 arbitrary: \<Gamma> \<tau> \<tau>' x)
  case (Var v)
  then show ?case
    (* found by sledgehammer *)
    by (metis TypeVar TypeVarE context_strengthening has_type_in_ctx.simps(1) has_type_in_ctx.simps(2) subst.simps(2))
next
  case (Abs y \<sigma> e)
  then show ?case
  proof (cases "x = y")
    case False
    with Abs(2) obtain \<tau>\<^sub>2 where "\<tau> = (\<sigma> \<rightarrow> \<tau>\<^sub>2)" "((y, \<sigma>)#(x, \<tau>')#\<Gamma>) \<turnstile> e : \<tau>\<^sub>2"
      by (induct "(x, \<tau>') # \<Gamma>" "Abs y \<sigma> e" "\<tau>" rule:has_type.induct, blast)
    then have "((x, \<tau>')#(y, \<sigma>)#\<Gamma>) \<turnstile> e : \<tau>\<^sub>2"
      (* found by sledgehammer *)
      using False context_strengthening has_type_in_ctx.simps(2) by presburger
    then show ?thesis
      (* found by sledgehammer *)
      by (simp add: Abs.hyps Abs.prems(2) False \<open>\<tau> = \<sigma> \<rightarrow> \<tau>\<^sub>2\<close>)
  qed (auto simp: context_strengthening)
qed fastforce+

theorem preservation:
  "reduce e e' \<Longrightarrow> [] \<turnstile> e : \<tau> \<Longrightarrow> [] \<turnstile> e' : \<tau>"
proof (induct arbitrary: \<tau> rule:reduce.induct)
  case (RApp e2 x \<tau>' e)
  from RApp.prems show ?case
    by (induct "[] :: ctx" "App (Abs x \<tau>' e) e2" "\<tau>")
       (* found by sledgehammer *)
       (metis expr.inject(2) expr.simps(11) expr.simps(15) expr.simps(7) has_type.simps subst_preservation type.inject)
qed blast+

end


header{*De Bruijn Syntax, Quotations, Codes, V-Codes*}

theory Coding
imports SyntaxN
begin

declare fresh_Nil [iff]

section {* de Bruijn Indices (locally-nameless version) *}

nominal_datatype dbtm = DBZero | DBVar name | DBInd nat | DBEats dbtm dbtm

nominal_datatype dbfm =
    DBMem dbtm dbtm
  | DBEq dbtm dbtm
  | DBDisj dbfm dbfm
  | DBNeg dbfm
  | DBEx dbfm

declare dbtm.supp [simp]
declare dbfm.supp [simp]

fun lookup :: "name list \<Rightarrow> nat \<Rightarrow> name \<Rightarrow> dbtm"
  where
    "lookup [] n x = DBVar x"
  | "lookup (y # ys) n x = (if x = y then DBInd n else (lookup ys (Suc n) x))"

lemma fresh_imp_notin_env: "atom name \<sharp> e \<Longrightarrow> name \<notin> set e"
  by (metis List.finite_set fresh_finite_set_at_base fresh_set)

lemma lookup_notin: "x \<notin> set e \<Longrightarrow> lookup e n x = DBVar x"
  by (induct e arbitrary: n) auto

lemma lookup_in:
  "x \<in> set e \<Longrightarrow> \<exists>k. lookup e n x = DBInd k \<and> n \<le> k \<and> k < n + length e"
apply (induct e arbitrary: n)
apply (auto intro: Suc_leD)
apply (metis Suc_leD add_Suc_right add_Suc_shift)
done

lemma lookup_fresh: "x \<sharp> lookup e n y \<longleftrightarrow> y \<in> set e \<or> x \<noteq> atom y"
  by (induct arbitrary: n rule: lookup.induct) (auto simp: pure_fresh fresh_at_base)

lemma lookup_eqvt[eqvt]: "(p \<bullet> lookup xs n x) = lookup (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
  by (induct xs arbitrary: n) (simp_all add: permute_pure)

lemma lookup_inject [iff]: "(lookup e n x = lookup e n y) \<longleftrightarrow> x = y"
apply (induct e n x arbitrary: y rule: lookup.induct, force, simp)
by (metis Suc_n_not_le_n dbtm.distinct(7) dbtm.eq_iff(3) lookup_in lookup_notin)

nominal_function trans_tm :: "name list \<Rightarrow> tm \<Rightarrow> dbtm"
  where
   "trans_tm e Zero = DBZero"
 | "trans_tm e (Var k) = lookup e 0 k"
 | "trans_tm e (Eats t u) = DBEats (trans_tm e t) (trans_tm e u)"
by (auto simp: eqvt_def trans_tm_graph_aux_def) (metis tm.strong_exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_trans_tm_iff [simp]: "i \<sharp> trans_tm e t \<longleftrightarrow> i \<sharp> t \<or> i \<in> atom ` set e"
  by (induct t rule: tm.induct, auto simp: lookup_fresh fresh_at_base)

lemma trans_tm_forget: "atom i \<sharp> t \<Longrightarrow> trans_tm [i] t = trans_tm [] t"
  by (induct t rule: tm.induct, auto simp: fresh_Pair)

nominal_function (invariant "\<lambda>(xs, _) y. atom ` set xs \<sharp>* y")
  trans_fm :: "name list \<Rightarrow> fm \<Rightarrow> dbfm"
  where
   "trans_fm e (Mem t u) = DBMem (trans_tm e t) (trans_tm e u)"
 | "trans_fm e (Eq t u)  = DBEq (trans_tm e t) (trans_tm e u)"
 | "trans_fm e (Disj A B) = DBDisj (trans_fm e A) (trans_fm e B)"
 | "trans_fm e (Neg A)   = DBNeg (trans_fm e A)"
 | "atom k \<sharp> e \<Longrightarrow> trans_fm e (Ex k A) = DBEx (trans_fm (k#e) A)"
apply(simp add: eqvt_def trans_fm_graph_aux_def)
apply(erule trans_fm_graph.induct)
using [[simproc del: alpha_lst]]
apply(auto simp: fresh_star_def)
apply(rule_tac y=b and c=a in fm.strong_exhaust)
apply(auto simp: fresh_star_def)
apply(erule_tac c=ea in Abs_lst1_fcb2')
apply (simp_all add: eqvt_at_def)
apply (simp_all add: fresh_star_Pair perm_supp_eq)
apply (simp add: fresh_star_def)
done

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_trans_fm [simp]: "i \<sharp> trans_fm e A \<longleftrightarrow> i \<sharp> A \<or> i \<in> atom ` set e"
  by (nominal_induct A avoiding: e rule: fm.strong_induct, auto simp: fresh_at_base)

abbreviation DBConj :: "dbfm \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where "DBConj t u \<equiv> DBNeg (DBDisj (DBNeg t) (DBNeg u))"

lemma trans_fm_Conj [simp]: "trans_fm e (Conj A B) = DBConj (trans_fm e A) (trans_fm e B)"
  by (simp add: Conj_def)

lemma trans_tm_inject [iff]: "(trans_tm e t = trans_tm e u) \<longleftrightarrow> t = u"
proof (induct t arbitrary: e u rule: tm.induct)
  case Zero show ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(1) dbtm.distinct(3) lookup_in lookup_notin)
    done
next
  case (Var i) show ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(1) dbtm.distinct(3) lookup_in lookup_notin)
    apply (metis dbtm.distinct(10) dbtm.distinct(11) lookup_in lookup_notin)
    done
next
  case (Eats tm1 tm2) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(12) dbtm.distinct(9) lookup_in lookup_notin)
    done
qed

lemma trans_fm_inject [iff]: "(trans_fm e A = trans_fm e B) \<longleftrightarrow> A = B"
proof (nominal_induct A avoiding: e B rule: fm.strong_induct)
  case (Mem tm1 tm2) thus ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: fresh_star_def)
next
  case (Eq tm1 tm2) thus ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: fresh_star_def)
next
  case (Disj fm1 fm2) show ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: Disj fresh_star_def)
next
  case (Neg fm) show ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: Neg fresh_star_def)
next
  case (Ex name fm)
  thus ?case  using [[simproc del: alpha_lst]]
  proof (cases rule: fm.strong_exhaust [where y=B and c="(e, name)"], simp_all add: fresh_star_def)
    fix name'::name and fm'::fm
    assume name': "atom name' \<sharp> (e, name)"
    assume "atom name \<sharp> fm' \<or> name = name'"
    thus "(trans_fm (name # e) fm = trans_fm (name' # e) fm') = ([[atom name]]lst. fm = [[atom name']]lst. fm')"
         (is "?lhs = ?rhs")
    proof (rule disjE)
      assume "name = name'"
      thus "?lhs = ?rhs"
        by (metis fresh_Pair fresh_at_base(2) name')
    next
      assume name: "atom name \<sharp> fm'"
      have eq1: "(name \<leftrightarrow> name') \<bullet> trans_fm (name' # e) fm' = trans_fm (name' # e) fm'"
        by (simp add: flip_fresh_fresh name)
      have eq2: "(name \<leftrightarrow> name') \<bullet> ([[atom name']]lst. fm') = [[atom name']]lst. fm'"
        by (rule flip_fresh_fresh) (auto simp: Abs_fresh_iff name)
      show "?lhs = ?rhs" using name' eq1 eq2 Ex(1) Ex(3) [of "name#e" "(name \<leftrightarrow> name') \<bullet> fm'"]
        by (simp add: flip_fresh_fresh) (metis Abs1_eq(3))
    qed
  qed
qed

lemma trans_fm_perm:
  assumes c: "atom c \<sharp> (i,j,A,B)"
  and     t: "trans_fm [i] A = trans_fm [j] B"
  shows "(i \<leftrightarrow> c) \<bullet> A = (j \<leftrightarrow> c) \<bullet> B"
proof -
  have c_fresh1: "atom c \<sharp> trans_fm [i] A"
    using c by (auto simp: supp_Pair)
  moreover
  have i_fresh: "atom i \<sharp> trans_fm [i] A"
    by auto
  moreover
  have c_fresh2: "atom c \<sharp> trans_fm [j] B"
    using c by (auto simp: supp_Pair)
  moreover
  have j_fresh: "atom j \<sharp> trans_fm [j] B"
    by auto
  ultimately have "((i \<leftrightarrow> c) \<bullet> (trans_fm [i] A)) = ((j \<leftrightarrow> c) \<bullet> trans_fm [j] B)"
    by (simp only: flip_fresh_fresh t)
  then have "trans_fm [c] ((i \<leftrightarrow> c) \<bullet> A) = trans_fm [c] ((j \<leftrightarrow> c) \<bullet> B)"
    by simp
  then show "(i \<leftrightarrow> c) \<bullet> A = (j \<leftrightarrow> c) \<bullet> B" by simp
qed

section{*Characterising the Well-Formed de Bruijn Formulas*}

subsection{*Well-Formed Terms*}

inductive wf_dbtm :: "dbtm \<Rightarrow> bool"
  where
    Zero:  "wf_dbtm DBZero"
  | Var:   "wf_dbtm (DBVar name)"
  | Eats:  "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbtm (DBEats t1 t2)"

equivariance wf_dbtm

inductive_cases Zero_wf_dbtm [elim!]: "wf_dbtm DBZero"
inductive_cases Var_wf_dbtm [elim!]:  "wf_dbtm (DBVar name)"
inductive_cases Ind_wf_dbtm [elim!]:  "wf_dbtm (DBInd i)"
inductive_cases Eats_wf_dbtm [elim!]: "wf_dbtm (DBEats t1 t2)"

declare wf_dbtm.intros [intro]

lemma wf_dbtm_imp_is_tm:
  assumes "wf_dbtm x"
  shows "\<exists>t::tm. x = trans_tm [] t"
using assms
proof (induct rule: wf_dbtm.induct)
  case Zero thus ?case
    by (metis trans_tm.simps(1))
next
  case (Var i) thus ?case
    by (metis lookup.simps(1) trans_tm.simps(2))
next
  case (Eats dt1 dt2) thus ?case
    by (metis trans_tm.simps(3))
qed

lemma wf_dbtm_trans_tm: "wf_dbtm (trans_tm [] t)"
  by (induct t rule: tm.induct) auto

theorem wf_dbtm_iff_is_tm: "wf_dbtm x \<longleftrightarrow> (\<exists>t::tm. x = trans_tm [] t)"
  by (metis wf_dbtm_imp_is_tm wf_dbtm_trans_tm)

nominal_function abst_dbtm :: "name \<Rightarrow> nat \<Rightarrow> dbtm \<Rightarrow> dbtm"
  where
   "abst_dbtm name i DBZero = DBZero"
 | "abst_dbtm name i (DBVar name') = (if name = name' then DBInd i else DBVar name')"
 | "abst_dbtm name i (DBInd j) = DBInd j"
 | "abst_dbtm name i (DBEats t1 t2) = DBEats (abst_dbtm name i t1) (abst_dbtm name i t2)"
apply (simp add: eqvt_def abst_dbtm_graph_aux_def, auto)
apply (metis dbtm.exhaust)
done

nominal_termination (eqvt)
  by lexicographic_order

nominal_function subst_dbtm :: "dbtm \<Rightarrow> name \<Rightarrow> dbtm \<Rightarrow> dbtm"
  where
   "subst_dbtm u i DBZero = DBZero"
 | "subst_dbtm u i (DBVar name) = (if i = name then u else DBVar name)"
 | "subst_dbtm u i (DBInd j) = DBInd j"
 | "subst_dbtm u i (DBEats t1 t2) = DBEats (subst_dbtm u i t1) (subst_dbtm u i t2)"
by (auto simp: eqvt_def subst_dbtm_graph_aux_def) (metis dbtm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_iff_non_subst_dbtm: "subst_dbtm DBZero i t = t \<longleftrightarrow> atom i \<sharp> t"
  by (induct t rule: dbtm.induct) (auto simp: pure_fresh fresh_at_base(2))

lemma lookup_append: "lookup (e @ [i]) n j = abst_dbtm i (length e + n) (lookup e n j)"
  by (induct e arbitrary: n) (auto simp: fresh_Cons)

lemma trans_tm_abs: "trans_tm (e@[name]) t = abst_dbtm name (length e) (trans_tm e t)"
  by (induct t rule: tm.induct) (auto simp: lookup_notin lookup_append)

subsection{*Well-Formed Formulas*}

nominal_function abst_dbfm :: "name \<Rightarrow> nat \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where
   "abst_dbfm name i (DBMem t1 t2) = DBMem (abst_dbtm name i t1) (abst_dbtm name i t2)"
 | "abst_dbfm name i (DBEq t1 t2) =  DBEq (abst_dbtm name i t1) (abst_dbtm name i t2)"
 | "abst_dbfm name i (DBDisj A1 A2) = DBDisj (abst_dbfm name i A1) (abst_dbfm name i A2)"
 | "abst_dbfm name i (DBNeg A) = DBNeg (abst_dbfm name i A)"
 | "abst_dbfm name i (DBEx A) = DBEx (abst_dbfm name (i+1) A)"
apply (simp add: eqvt_def abst_dbfm_graph_aux_def, auto)
apply (metis dbfm.exhaust)
done

nominal_termination (eqvt)
  by lexicographic_order

nominal_function subst_dbfm :: "dbtm \<Rightarrow> name \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where
   "subst_dbfm u i (DBMem t1 t2) = DBMem (subst_dbtm u i t1) (subst_dbtm u i t2)"
 | "subst_dbfm u i (DBEq t1 t2) =  DBEq (subst_dbtm u i t1) (subst_dbtm u i t2)"
 | "subst_dbfm u i (DBDisj A1 A2) = DBDisj (subst_dbfm u i A1) (subst_dbfm u i A2)"
 | "subst_dbfm u i (DBNeg A) = DBNeg (subst_dbfm u i A)"
 | "subst_dbfm u i (DBEx A) = DBEx (subst_dbfm u i A)"
by (auto simp: eqvt_def subst_dbfm_graph_aux_def) (metis dbfm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_iff_non_subst_dbfm: "subst_dbfm DBZero i t = t \<longleftrightarrow> atom i \<sharp> t"
  by (induct t rule: dbfm.induct) (auto simp: fresh_iff_non_subst_dbtm)

section{*Well formed terms and formulas (de Bruijn representation)*}

inductive wf_dbfm :: "dbfm \<Rightarrow> bool"
  where
    Mem:   "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbfm (DBMem t1 t2)"
  | Eq:    "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbfm (DBEq t1 t2)"
  | Disj:  "wf_dbfm A1 \<Longrightarrow> wf_dbfm A2 \<Longrightarrow> wf_dbfm (DBDisj A1 A2)"
  | Neg:   "wf_dbfm A \<Longrightarrow> wf_dbfm (DBNeg A)"
  | Ex:    "wf_dbfm A \<Longrightarrow> wf_dbfm (DBEx (abst_dbfm name 0 A))"

equivariance wf_dbfm

lemma atom_fresh_abst_dbtm [simp]: "atom i \<sharp> abst_dbtm i n t"
  by (induct t rule: dbtm.induct) (auto simp: pure_fresh)

text{*Setting up strong induction: "avoiding" for name. Necessary to allow some proofs to go through*}
nominal_inductive wf_dbfm
  avoids Ex: name
  by (auto simp: fresh_star_def)

inductive_cases Mem_wf_dbfm [elim!]:  "wf_dbfm (DBMem t1 t2)"
inductive_cases Eq_wf_dbfm [elim!]:   "wf_dbfm (DBEq t1 t2)"
inductive_cases Disj_wf_dbfm [elim!]: "wf_dbfm (DBDisj A1 A2)"
inductive_cases Neg_wf_dbfm [elim!]:  "wf_dbfm (DBNeg A)"
inductive_cases Ex_wf_dbfm [elim!]:   "wf_dbfm (DBEx z)"

declare wf_dbfm.intros [intro]

lemma trans_fm_abs: "trans_fm (e@[name]) A = abst_dbfm name (length e) (trans_fm e A)"
  apply (nominal_induct A avoiding: name e rule: fm.strong_induct)
  apply (auto simp: trans_tm_abs fresh_Cons fresh_append)
  apply (metis One_nat_def Suc_eq_plus1 append_Cons list.size(4))
  done

lemma abst_trans_fm: "abst_dbfm name 0 (trans_fm [] A) = trans_fm [name] A"
  by (metis append_Nil list.size(3) trans_fm_abs)

lemma abst_trans_fm2: "i \<noteq> j \<Longrightarrow> abst_dbfm i (Suc 0) (trans_fm [j] A) = trans_fm [j,i] A"
  using trans_fm_abs [where e="[j]" and name=i]
  by auto

lemma wf_dbfm_imp_is_fm:
  assumes "wf_dbfm x" shows "\<exists>A::fm. x = trans_fm [] A"
using assms
proof (induct rule: wf_dbfm.induct)
  case (Mem t1 t2) thus ?case
    by (metis trans_fm.simps(1) wf_dbtm_imp_is_tm)
next
  case (Eq t1 t2) thus ?case
    by (metis trans_fm.simps(2) wf_dbtm_imp_is_tm)
next
  case (Disj fm1 fm2) thus ?case
    by (metis trans_fm.simps(3))
next
  case (Neg fm) thus ?case
    by (metis trans_fm.simps(4))
next
  case (Ex fm name) thus ?case
    apply auto
    apply (rule_tac x="Ex name A" in exI)
    apply (auto simp: abst_trans_fm)
    done
qed

lemma wf_dbfm_trans_fm: "wf_dbfm (trans_fm [] A)"
  apply (nominal_induct A rule: fm.strong_induct)
  apply (auto simp: wf_dbtm_trans_tm abst_trans_fm)
  apply (metis abst_trans_fm wf_dbfm.Ex)
  done

lemma wf_dbfm_iff_is_fm: "wf_dbfm x \<longleftrightarrow> (\<exists>A::fm. x = trans_fm [] A)"
  by (metis wf_dbfm_imp_is_fm wf_dbfm_trans_fm)

lemma dbtm_abst_ignore [simp]:
  "abst_dbtm name i (abst_dbtm name j t) = abst_dbtm name j t"
  by (induct t rule: dbtm.induct) auto

lemma abst_dbtm_fresh_ignore [simp]: "atom name \<sharp> u \<Longrightarrow> abst_dbtm name j u = u"
  by (induct u rule: dbtm.induct) auto

lemma dbtm_subst_ignore [simp]:
  "subst_dbtm u name (abst_dbtm name j t) = abst_dbtm name j t"
  by (induct t rule: dbtm.induct) auto

lemma dbtm_abst_swap_subst:
  "name \<noteq> name' \<Longrightarrow> atom name' \<sharp> u \<Longrightarrow>
   subst_dbtm u name (abst_dbtm name' j t) = abst_dbtm name' j (subst_dbtm u name t)"
  by (induct t rule: dbtm.induct) auto

lemma dbfm_abst_swap_subst:
  "name \<noteq> name' \<Longrightarrow> atom name' \<sharp> u \<Longrightarrow>
   subst_dbfm u name (abst_dbfm name' j A) = abst_dbfm name' j (subst_dbfm u name A)"
  by (induct A arbitrary: j rule: dbfm.induct) (auto simp: dbtm_abst_swap_subst)

lemma subst_trans_commute [simp]:
  "atom i \<sharp> e \<Longrightarrow> subst_dbtm (trans_tm e u) i (trans_tm e t) = trans_tm e (subst i u t)"
  apply (induct t rule: tm.induct)
  apply (auto simp: lookup_notin fresh_imp_notin_env)
  apply (metis abst_dbtm_fresh_ignore dbtm_subst_ignore lookup_fresh lookup_notin subst_dbtm.simps(2))
  done

lemma subst_fm_trans_commute [simp]:
  "subst_dbfm (trans_tm [] u) name (trans_fm [] A) = trans_fm [] (A (name::= u))"
  apply (nominal_induct A avoiding: name u rule: fm.strong_induct)
  apply (auto simp: lookup_notin abst_trans_fm [symmetric])
  apply (metis dbfm_abst_swap_subst fresh_at_base(2) fresh_trans_tm_iff)
  done

lemma subst_fm_trans_commute_eq:
  "du = trans_tm [] u \<Longrightarrow> subst_dbfm du i (trans_fm [] A) = trans_fm [] (A(i::=u))"
  by (metis subst_fm_trans_commute)

section{*Quotations*}

fun htuple :: "nat \<Rightarrow> hf"  where
   "htuple 0 = \<langle>0,0\<rangle>"
 | "htuple (Suc k) = \<langle>0, htuple k\<rangle>"

fun HTuple :: "nat \<Rightarrow> tm"  where
   "HTuple 0 = HPair Zero Zero"
 | "HTuple (Suc k) = HPair Zero (HTuple k)"

lemma eval_tm_HTuple [simp]:  "\<lbrakk>HTuple n\<rbrakk>e = htuple n"
  by (induct n) auto

lemma fresh_HTuple [simp]: "x \<sharp> HTuple n"
  by (induct n) auto

lemma HTuple_eqvt[eqvt]: "(p \<bullet> HTuple n) = HTuple (p \<bullet> n)"
  by (induct n, auto simp: HPair_eqvt permute_pure)

lemma htuple_nonzero [simp]: "htuple k \<noteq> 0"
  by (induct k) auto

lemma htuple_inject [iff]: "htuple i = htuple j \<longleftrightarrow> i=j"
proof (induct i arbitrary: j)
  case 0 show ?case
    by (cases j) auto
next
  case (Suc i) show ?case
    by (cases j) (auto simp: Suc)
qed

subsection {*Quotations of de Bruijn terms *}

definition nat_of_name :: "name \<Rightarrow> nat"
  where "nat_of_name x = nat_of (atom x)"

lemma nat_of_name_inject [simp]: "nat_of_name n1 = nat_of_name n2 \<longleftrightarrow> n1 = n2"
  by (metis nat_of_name_def atom_components_eq_iff atom_eq_iff sort_of_atom_eq)

definition name_of_nat :: "nat \<Rightarrow> name"
  where "name_of_nat n \<equiv> Abs_name (Atom (Sort ''SyntaxN.name'' []) n)"

lemma nat_of_name_Abs_eq [simp]: "nat_of_name (Abs_name (Atom (Sort ''SyntaxN.name'' []) n)) = n"
  by (auto simp: nat_of_name_def atom_name_def Abs_name_inverse)

lemma nat_of_name_name_eq [simp]: "nat_of_name (name_of_nat n) = n"
  by (simp add: name_of_nat_def)

lemma name_of_nat_nat_of_name [simp]: "name_of_nat (nat_of_name i) = i"
  by (metis nat_of_name_inject nat_of_name_name_eq)

lemma HPair_neq_ORD_OF [simp]: "HPair x y \<noteq> ORD_OF i"
  by (metis Not_Ord_hpair Ord_ord_of eval_tm_HPair eval_tm_ORD_OF)

text{*Infinite support, so we cannot use nominal primrec.*}
function quot_dbtm :: "dbtm \<Rightarrow> tm"
  where
   "quot_dbtm DBZero = Zero"
 | "quot_dbtm (DBVar name) = ORD_OF (Suc (nat_of_name name))"
 | "quot_dbtm (DBInd k) = HPair (HTuple 6) (ORD_OF k)"
 | "quot_dbtm (DBEats t u) = HPair (HTuple 1) (HPair (quot_dbtm t) (quot_dbtm u))"
by (rule dbtm.exhaust) auto

termination
  by lexicographic_order

lemma quot_dbtm_inject_

lemma quot_dbtm_inject [iff]: "quot_dbtm t = quot_dbtm u \<longleftrightarrow> t=u"
  by (metis quot_dbtm_inject_lemma)

subsection {*Quotations of de Bruijn formulas *}

text{*Infinite support, so we cannot use nominal primrec.*}
function quot_dbfm :: "dbfm \<Rightarrow> tm"
  where
   "quot_dbfm (DBMem t u) = HPair (HTuple 0) (HPair (quot_dbtm t) (quot_dbtm u))"
 | "quot_dbfm (DBEq t u) = HPair (HTuple 2) (HPair (quot_dbtm t) (quot_dbtm u))"
 | "quot_dbfm (DBDisj A B) = HPair (HTuple 3) (HPair (quot_dbfm A) (quot_dbfm B))"
 | "quot_dbfm (DBNeg A) = HPair (HTuple 4) (quot_dbfm A)"
 | "quot_dbfm (DBEx A) = HPair (HTuple 5) (quot_dbfm A)"
by (rule_tac y=x in dbfm.exhaust, auto)

termination
  by lexicographic_order

lemma htuple_minus_1: "n > 0 \<Longrightarrow> htuple n = \<langle>0, htuple (n - 1)\<rangle>"
  by (metis Suc_diff_1 htuple.simps(2))

lemma HTuple_minus_1: "n > 0 \<Longrightarrow> HTuple n = HPair Zero (HTuple (n - 1))"
  by (metis Suc_diff_1 HTuple.simps(2))

lemmas HTS = HTuple_minus_1 HTuple.simps --{*for freeness reasoning on codes*}

lemma quot_dbfm_inject_lemma [simp]: "\<lbrakk>quot_dbfm A\<rbrakk>e = \<lbrakk>quot_dbfm B\<rbrakk>e \<longleftrightarrow> A=B"
proof (induct A arbitrary: B rule: dbfm.induct)
  case (DBMem t u) show ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
next
  case (DBEq t u) show ?case
    by (induct B rule: dbfm.induct) (auto simp: htuple_minus_1)
next
  case (DBDisj A B') thus ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
next
  case (DBNeg A) thus ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
next
  case (DBEx A) thus ?case
    by (induct B rule: dbfm.induct) (simp_all add: htuple_minus_1)
qed

class quot =
  fixes quot :: "'a \<Rightarrow> tm"  ("\<lceil>_\<rceil>")

instantiation tm :: quot
begin
  definition quot_tm :: "tm \<Rightarrow> tm"
    where "quot_tm t = quot_dbtm (trans_tm [] t)"

  instance ..
end

lemma quot_dbtm_fresh [simp]: "s \<sharp> (quot_dbtm t)"
  by (induct t rule: dbtm.induct) auto

lemma quot_tm_fresh [simp]: fixes t::tm shows "s \<sharp> \<lceil>t\<rceil>"
  by (simp add: quot_tm_def)

lemma quot_Zero [simp]: "\<lceil>Zero\<rceil> = Zero"
  by (simp add: quot_tm_def)

lemma quot_Var: "\<lceil>Var x\<rceil> = SUCC (ORD_OF (nat_of_name x))"
  by (simp add: quot_tm_def)

lemma quot_Eats: "\<lceil>Eats x y\<rceil> = HPair (HTuple 1) (HPair \<lceil>x\<rceil> \<lceil>y\<rceil>)"
  by (simp add: quot_tm_def)

text{*irrelevance of the environment for quotations, because they are ground terms*}
lemma eval_quot_dbtm_ignore:
    "\<lbrakk>quot_dbtm t\<rbrakk>e = \<lbrakk>quot_dbtm t\<rbrakk>e'"
  by (induct t rule: dbtm.induct) auto

lemma eval_quot_dbfm_ignore:
    "\<lbrakk>quot_dbfm A\<rbrakk>e = \<lbrakk>quot_dbfm A\<rbrakk>e'"
  by (induct A rule: dbfm.induct) (auto intro: eval_quot_dbtm_ignore)

instantiation fm :: quot
begin
  definition quot_fm :: "fm \<Rightarrow> tm"
    where "quot_fm A = quot_dbfm (trans_fm [] A)"

  instance ..
end

lemma quot_dbfm_fresh [simp]: "s \<sharp> (quot_dbfm A)"
  by (induct A rule: dbfm.induct) auto

lemma quot_fm_fresh [simp]: fixes A::fm shows "s \<sharp> \<lceil>A\<rceil>"
  by (simp add: quot_fm_def)

lemma quot_fm_permute [simp]: fixes A:: fm shows "p \<bullet> \<lceil>A\<rceil> = \<lceil>A\<rceil>"
  by (metis fresh_star_def perm_supp_eq quot_fm_fresh)

lemma quot_Mem: "\<lceil>x IN y\<rceil> = HPair (HTuple 0) (HPair (\<lceil>x\<rceil>) (\<lceil>y\<rceil>))"
  by (simp add: quot_fm_def quot_tm_def)

lemma quot_Eq: "\<lceil>x EQ y\<rceil> = HPair (HTuple 2) (HPair (\<lceil>x\<rceil>) (\<lceil>y\<rceil>))"
  by (simp add: quot_fm_def quot_tm_def)

lemma quot_Disj: "\<lceil>A OR B\<rceil> = HPair (HTuple 3) (HPair (\<lceil>A\<rceil>) (\<lceil>B\<rceil>))"
  by (simp add: quot_fm_def)

lemma quot_Neg: "\<lceil>Neg A\<rceil> = HPair (HTuple 4) (\<lceil>A\<rceil>)"
  by (simp add: quot_fm_def)

lemma quot_Ex: "\<lceil>Ex i A\<rceil> = HPair (HTuple 5) (quot_dbfm (trans_fm [i] A))"
  by (simp add: quot_fm_def)

lemma eval_quot_fm_ignore: fixes A:: fm shows "\<lbrakk>\<lceil>A\<rceil>\<rbrakk>e = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e'"
  by (metis eval_quot_dbfm_ignore quot_fm_def)

lemmas quot_simps = quot_Var quot_Eats quot_Eq quot_Mem quot_Disj quot_Neg quot_Ex

section{*Definitions Involving Coding*}

definition q_Var :: "name \<Rightarrow> hf"
  where "q_Var i \<equiv> succ (ord_of (nat_of_name i))"

definition q_Ind :: "hf \<Rightarrow> hf"
  where "q_Ind k \<equiv>  \<langle>htuple 6, k\<rangle>"

abbreviation Q_Eats :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Eats t u \<equiv> HPair (HTuple (Suc 0)) (HPair t u)"

definition q_Eats :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Eats x y \<equiv> \<langle>htuple 1, x, y\<rangle>"

abbreviation Q_Succ :: "tm \<Rightarrow> tm"
  where "Q_Succ t \<equiv> Q_Eats t t"

definition q_Succ :: "hf \<Rightarrow> hf"
  where "q_Succ x \<equiv> q_Eats x x"

lemma quot_Succ: "\<lceil>SUCC x\<rceil> = Q_Succ \<lceil>x\<rceil>"
  by (auto simp: SUCC_def quot_Eats)

abbreviation Q_HPair :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_HPair t u \<equiv>
           Q_Eats (Q_Eats Zero (Q_Eats (Q_Eats Zero u) t))
                  (Q_Eats (Q_Eats Zero t) t)"

definition q_HPair :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_HPair x y \<equiv>
           q_Eats (q_Eats 0 (q_Eats (q_Eats 0 y) x))
                  (q_Eats (q_Eats 0 x) x)"

abbreviation Q_Mem :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Mem t u \<equiv> HPair (HTuple 0) (HPair t u)"

definition q_Mem :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Mem x y \<equiv> \<langle>htuple 0, x, y\<rangle>"

abbreviation Q_Eq :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Eq t u \<equiv> HPair (HTuple 2) (HPair t u)"

definition q_Eq :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Eq x y \<equiv> \<langle>htuple 2, x, y\<rangle>"

abbreviation Q_Disj :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Disj t u \<equiv> HPair (HTuple 3) (HPair t u)"

definition q_Disj :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Disj x y \<equiv> \<langle>htuple 3, x, y\<rangle>"

abbreviation Q_Neg :: "tm \<Rightarrow> tm"
  where "Q_Neg t \<equiv> HPair (HTuple 4) t"

definition q_Neg :: "hf \<Rightarrow> hf"
  where "q_Neg x \<equiv> \<langle>htuple 4, x\<rangle>"

abbreviation Q_Conj :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Conj t u \<equiv> Q_Neg (Q_Disj (Q_Neg t) (Q_Neg u))"

definition q_Conj :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Conj t u \<equiv> q_Neg (q_Disj (q_Neg t) (q_Neg u))"

abbreviation Q_Imp :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Imp t u \<equiv> Q_Disj (Q_Neg t) u"

definition q_Imp :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "q_Imp t u \<equiv> q_Disj (q_Neg t) u"

abbreviation Q_Ex :: "tm \<Rightarrow> tm"
  where "Q_Ex t \<equiv> HPair (HTuple 5) t"

definition q_Ex :: "hf \<Rightarrow> hf"
  where "q_Ex x \<equiv> \<langle>htuple 5, x\<rangle>"

abbreviation Q_All :: "tm \<Rightarrow> tm"
  where "Q_All t \<equiv> Q_Neg (Q_Ex (Q_Neg t))"

definition q_All :: "hf \<Rightarrow> hf"
  where "q_All x \<equiv> q_Neg (q_Ex (q_Neg x))"

lemmas q_defs = q_Var_def q_Ind_def q_Eats_def q_HPair_def q_Eq_def q_Mem_def
                q_Disj_def q_Neg_def q_Conj_def q_Imp_def q_Ex_def q_All_def

lemma q_Eats_iff [iff]: "q_Eats x y = q_Eats x' y' \<longleftrightarrow> x=x' \<and> y=y'"
  by (metis hpair_iff q_Eats_def)

lemma quot_subst_eq: "\<lceil>A(i::=t)\<rceil> = quot_dbfm (subst_dbfm (trans_tm [] t) i (trans_fm [] A))"
  by (metis quot_fm_def subst_fm_trans_commute)

lemma Q_Succ_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> Q_Succ x EQ Q_Succ x'"
  by (metis HPair_cong Refl)

section{*Quotations are Injective*}

subsection{*Terms*}

lemma eval_tm_inject [simp]: fixes t::tm shows "\<lbrakk>\<lceil>t\<rceil>\<rbrakk> e = \<lbrakk>\<lceil>u\<rceil>\<rbrakk> e \<longleftrightarrow> t=u"
proof (induct t arbitrary: u rule: tm.induct)
  case Zero thus ?case
    by (cases u rule: tm.exhaust) (auto simp: quot_Var quot_Eats)
next
  case (Var i) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (auto simp: quot_Var quot_Eats)
    done
next
  case (Eats t1 t2) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (auto simp: quot_Eats quot_Var)
    done
qed

subsection{*Formulas*}

lemma eval_fm_inject [simp]: fixes A::fm shows "\<lbrakk>\<lceil>A\<rceil>\<rbrakk> e = \<lbrakk>\<lceil>B\<rceil>\<rbrakk> e \<longleftrightarrow> A=B"
proof (nominal_induct B arbitrary: A rule: fm.strong_induct)
  case (Mem tm1 tm2) thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Eq tm1 tm2) thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Neg \<alpha>) thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Disj fm1 fm2)
  thus ?case
    by (cases A rule: fm.exhaust, auto simp: quot_simps htuple_minus_1)
next
  case (Ex i \<alpha>)
  thus ?case
    apply (induct A arbitrary: i rule: fm.induct)
    apply (auto simp: trans_fm_perm quot_simps htuple_minus_1 Abs1_eq_iff_all)
    by (metis (no_types) Abs1_eq_iff_all(3) dbfm.eq_iff(5) fm.eq_iff(5) fresh_Nil trans_fm.simps(5))
qed

subsection{*The set @{text \<Gamma>} of Definition 1.1, constant terms used for coding*}

inductive coding_tm :: "tm \<Rightarrow> bool"
  where
    Ord:    "\<exists>i. x = ORD_OF i \<Longrightarrow> coding_tm x"
  | HPair:  "coding_tm x \<Longrightarrow> coding_tm y \<Longrightarrow> coding_tm (HPair x y)"

declare coding_tm.intros [intro]

lemma coding_tm_Zero [intro]: "coding_tm Zero"
  by (metis ORD_OF.simps(1) Ord)

lemma coding_tm_HTuple [intro]: "coding_tm (HTuple k)"
  by (induct k, auto)

inductive_simps coding_tm_HPair [simp]: "coding_tm (HPair x y)"

lemma quot_dbtm_coding [simp]: "coding_tm (quot_dbtm t)"
  apply (induct t rule: dbtm.induct, auto)
  apply (metis ORD_OF.simps(2) Ord)
  done

lemma quot_dbfm_coding [simp]: "coding_tm (quot_dbfm fm)"
  by (induct fm rule: dbfm.induct, auto)

lemma quot_fm_coding: fixes A::fm shows "coding_tm \<lceil>A\<rceil>"
  by (metis quot_dbfm_coding quot_fm_def)

inductive coding_hf :: "hf \<Rightarrow> bool"
  where
    Ord:    "\<exists>i. x = ord_of i \<Longrightarrow> coding_hf x"
  | HPair:  "coding_hf x \<Longrightarrow> coding_hf y \<Longrightarrow> coding_hf (\<langle>x,y\<rangle>)"

declare coding_hf.intros [intro]

lemma coding_hf_0 [intro]: "coding_hf 0"
  by (metis coding_hf.Ord ord_of.simps(1))

inductive_simps coding_hf_hpair [simp]: "coding_hf (\<langle>x,y\<rangle>)"

lemma coding_tm_hf [simp]: "coding_tm t \<Longrightarrow> coding_hf \<lbrakk>t\<rbrakk>e"
  by (induct t rule: coding_tm.induct) auto

section {*V-Coding for terms and formulas, for the Second Theorem *}

text{*Infinite support, so we cannot use nominal primrec.*}
function vquot_dbtm :: "name set \<Rightarrow> dbtm \<Rightarrow> tm"
  where
   "vquot_dbtm V DBZero = Zero"
 | "vquot_dbtm V (DBVar name) = (if name \<in> V then Var name
                                 else ORD_OF (Suc (nat_of_name name)))"
 | "vquot_dbtm V (DBInd k) = HPair (HTuple 6) (ORD_OF k)"
 | "vquot_dbtm V (DBEats t u) = HPair (HTuple 1) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
by (auto, rule_tac y=b in dbtm.exhaust, auto)

termination
  by lexicographic_order

lemma fresh_vquot_dbtm [simp]: "i \<sharp> vquot_dbtm V tm \<longleftrightarrow> i \<sharp> tm \<or> i \<notin> atom ` V"
  by (induct tm rule: dbtm.induct) (auto simp: fresh_at_base pure_fresh)

text{*Infinite support, so we cannot use nominal primrec.*}
function vquot_dbfm :: "name set \<Rightarrow> dbfm \<Rightarrow> tm"
  where
   "vquot_dbfm V (DBMem t u) = HPair (HTuple 0) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
 | "vquot_dbfm V (DBEq t u) = HPair (HTuple 2) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
 | "vquot_dbfm V (DBDisj A B) = HPair (HTuple 3) (HPair (vquot_dbfm V A) (vquot_dbfm V B))"
 | "vquot_dbfm V (DBNeg A) = HPair (HTuple 4) (vquot_dbfm V A)"
 | "vquot_dbfm V (DBEx A) = HPair (HTuple 5) (vquot_dbfm V A)"
by (auto, rule_tac y=b in dbfm.exhaust, auto)

termination
  by lexicographic_order

lemma fresh_vquot_dbfm [simp]: "i \<sharp> vquot_dbfm V fm \<longleftrightarrow> i \<sharp> fm \<or> i \<notin> atom ` V"
  by (induct fm rule: dbfm.induct) (auto simp: HPair_def HTuple_minus_1)

class vquot =
  fixes vquot :: "'a \<Rightarrow> name set \<Rightarrow> tm"  ("\<lfloor>_\<rfloor>_"  [0,1000]1000)

instantiation tm :: vquot
begin
  definition vquot_tm :: "tm \<Rightarrow> name set \<Rightarrow> tm"
    where "vquot_tm t V = vquot_dbtm V (trans_tm [] t)"
  instance ..
end

lemma vquot_dbtm_empty [simp]: "vquot_dbtm {} t = quot_dbtm t"
  by (induct t rule: dbtm.induct) auto

lemma vquot_tm_empty [simp]: fixes t::tm shows "\<lfloor>t\<rfloor>{} = \<lceil>t\<rceil>"
  by (simp add: vquot_tm_def quot_tm_def)

lemma vquot_dbtm_eq: "atom ` V \<inter> supp t = atom ` W \<inter> supp t \<Longrightarrow> vquot_dbtm V t = vquot_dbtm W t"
  by (induct t rule: dbtm.induct) (auto simp: image_iff, blast+)

instantiation fm :: vquot
begin
  definition vquot_fm :: "fm \<Rightarrow> name set \<Rightarrow> tm"
    where "vquot_fm A V = vquot_dbfm V (trans_fm [] A)"
  instance ..
end

lemma vquot_fm_fresh [simp]: fixes A::fm shows "i \<sharp> \<lfloor>A\<rfloor>V \<longleftrightarrow> i \<sharp> A \<or> i \<notin> atom ` V"
  by (simp add: vquot_fm_def)

lemma vquot_dbfm_empty [simp]: "vquot_dbfm {} A = quot_dbfm A"
  by (induct A rule: dbfm.induct) auto

lemma vquot_fm_empty [simp]: fixes A::fm shows "\<lfloor>A\<rfloor>{} = \<lceil>A\<rceil>"
  by (simp add: vquot_fm_def quot_fm_def)

lemma vquot_dbfm_eq: "atom ` V \<inter> supp A = atom ` W \<inter> supp A \<Longrightarrow> vquot_dbfm V A = vquot_dbfm W A"
  by (induct A rule: dbfm.induct) (auto simp: intro!: vquot_dbtm_eq, blast+)

lemma vquot_fm_insert:
  fixes A::fm shows "atom i \<notin> supp A \<Longrightarrow> \<lfloor>A\<rfloor>(insert i V) = \<lfloor>A\<rfloor>V"
  by (auto simp: vquot_fm_def supp_conv_fresh intro: vquot_dbfm_eq)

declare HTuple.simps [simp del]

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_sort_NStoogeSort2Count
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

fun count :: "'a => 'a list => int" where
  "count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

theorem property0 :
  "((count y (nstoogesort2 xs)) = (count y xs))"
  oops


section \<open>Order Pairs\<close>

text \<open>
  An order pair consists of two relations @{term S} and @{term NS}, where @{term S}
  is a strict order and @{term NS} a compatible non-strict order,
  such that the combination of @{term S} and @{term NS} always results in strict decrease.
\<close>

theory Order_Pair
  imports "Abstract-Rewriting.Relative_Rewriting"
begin

named_theorems order_simps
declare O_assoc[order_simps]

locale pre_order_pair =
  fixes S :: "'a rel"
    and NS :: "'a rel"
  assumes refl_NS: "refl NS"
    and trans_S: "trans S"
    and trans_NS: "trans NS"
begin

lemma refl_NS_point: "(s, s) \<in> NS" using refl_NS unfolding refl_on_def by blast

lemma NS_O_NS[order_simps]: "NS O NS = NS" "NS O NS O T = NS O T"
proof -
  show "NS O NS = NS" by(fact trans_refl_imp_O_id[OF trans_NS refl_NS])
  then show "NS O NS O T = NS O T" by fast
qed

lemma trancl_NS[order_simps]: "NS\<^sup>+ = NS" using trans_NS by simp

lemma rtrancl_NS[order_simps]: "NS\<^sup>* = NS"
  by (rule trans_refl_imp_rtrancl_id[OF trans_NS refl_NS])

lemma trancl_S[order_simps]: "S\<^sup>+ = S" using trans_S by simp

lemma S_O_S: "S O S \<subseteq> S" "S O S O T \<subseteq> S O T"
proof -
  show "S O S \<subseteq> S" by (fact trans_O_subset[OF trans_S])
  then show "S O S O T \<subseteq> S O T" by blast
qed

lemma trans_S_point: "\<And> x y z. (x, y) \<in> S \<Longrightarrow> (y, z) \<in> S \<Longrightarrow> (x, z) \<in> S"
  using trans_S unfolding trans_def by blast

lemma trans_NS_point: "\<And> x y z. (x, y) \<in> NS \<Longrightarrow> (y, z) \<in> NS \<Longrightarrow> (x, z) \<in> NS"
  using trans_NS unfolding trans_def by blast
end

locale compat_pair =
  fixes S NS :: "'a rel"
  assumes compat_NS_S: "NS O S \<subseteq> S"
    and compat_S_NS: "S O NS \<subseteq> S"
begin
lemma compat_NS_S_point: "\<And> x y z. (x, y) \<in> NS \<Longrightarrow> (y, z) \<in> S \<Longrightarrow> (x, z) \<in> S"
  using compat_NS_S by blast

lemma compat_S_NS_point: "\<And> x y z. (x, y) \<in> S \<Longrightarrow> (y, z) \<in> NS \<Longrightarrow> (x, z) \<in> S"
  using compat_S_NS by blast

lemma S_O_rtrancl_NS[order_simps]: "S O NS\<^sup>* = S" "S O NS\<^sup>* O T = S O T"
proof -
  show "S O NS\<^sup>* = S"
  proof(intro equalityI subrelI)
    fix x y assume "(x, y) \<in> S O NS\<^sup>*"
    then obtain n where "(x, y) \<in> S O NS^^n" by blast
    then show "(x, y) \<in> S"
    proof(induct n arbitrary: y)
      case 0 then show ?case by auto
    next
      case IH: (Suc n)
      then obtain z where xz: "(x, z) \<in> S O NS^^n" and zy: "(z, y) \<in> NS" by auto
      from IH.hyps[OF xz] zy have "(x, y) \<in> S O NS" by auto
      with compat_S_NS show ?case by auto
    qed
  qed auto
  then show "S O NS\<^sup>* O T = S O T" by auto
qed

lemma rtrancl_NS_O_S[order_simps]: "NS\<^sup>* O S = S" "NS\<^sup>* O S O T = S O T"
proof -
  show "NS\<^sup>* O S = S"
  proof(intro equalityI subrelI)
    fix x y assume "(x, y) \<in> NS\<^sup>* O S"
    then obtain n where "(x, y) \<in> NS^^n O S" by blast
    then show "(x, y) \<in> S"
    proof(induct n arbitrary: x)
      case 0 then show ?case by auto
    next
      case IH: (Suc n)
      then obtain z where xz: "(x, z) \<in> NS" and zy: "(z, y) \<in> NS^^n O S" by (unfold relpow_Suc, auto)
      from xz IH.hyps[OF zy] have "(x, y) \<in> NS O S" by auto
      with compat_NS_S show ?case by auto
    qed
  qed auto
  then show "NS\<^sup>* O S O T = S O T" by auto
qed

end

locale order_pair = pre_order_pair S NS + compat_pair S NS
  for S NS :: "'a rel"
begin

lemma S_O_NS[order_simps]: "S O NS = S" "S O NS O T = S O T" by (fact S_O_rtrancl_NS[unfolded rtrancl_NS])+
lemma NS_O_S[order_simps]: "NS O S = S" "NS O S O T = S O T" by (fact rtrancl_NS_O_S[unfolded rtrancl_NS])+

lemma compat_rtrancl:
  assumes ab: "(a, b) \<in> S"
    and bc: "(b, c) \<in> (NS \<union> S)\<^sup>*"
  shows "(a, c) \<in> S"
  using bc
proof (induct)
  case base
  show ?case by (rule ab)
next
  case (step c d)
  from step(2-3) show ?case using compat_S_NS_point trans_S unfolding trans_def by blast
qed

end

locale SN_ars =
  fixes S :: "'a rel"
  assumes SN: "SN S"

locale SN_pair = compat_pair S NS + SN_ars S for S NS :: "'a rel"

locale SN_order_pair = order_pair S NS + SN_ars S for S NS :: "'a rel"

sublocale SN_order_pair \<subseteq> SN_pair ..

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Conversions to Rational Numbers\<close>

text \<open>We define a class which provides tests whether a number is rational, and
  a conversion from to rational numbers.
  These conversion functions are principle the inverse functions of \emph{of-rat}, but
  they can be implemented for individual types more efficiently.

  Similarly, we define tests and conversions between integer and rational numbers.\<close>

theory Is_Rat_To_Rat
imports
  Sqrt_Babylonian.Sqrt_Babylonian_Auxiliary
begin

class is_rat = field_char_0 +
  fixes is_rat :: "'a \<Rightarrow> bool"
  and to_rat :: "'a \<Rightarrow> rat"
  assumes is_rat[simp]: "is_rat x = (x \<in> \<rat>)"
  and to_rat: "to_rat x = (if x \<in> \<rat> then (THE y. x = of_rat y) else 0)"

lemma of_rat_to_rat[simp]: "x \<in> \<rat> \<Longrightarrow> of_rat (to_rat x) = x"
  unfolding to_rat Rats_def by auto

lemma to_rat_of_rat[simp]: "to_rat (of_rat x) = x" unfolding to_rat by simp

instantiation rat :: is_rat
begin
definition "is_rat_rat (x :: rat) = True"
definition "to_rat_rat (x :: rat) = x"
  instance
  by (intro_classes, auto simp: is_rat_rat_def to_rat_rat_def Rats_def)
end

text \<open>The definition for reals at the moment is not executable, but it will become
  executable after loading the real algebraic numbers theory.\<close>
instantiation real :: is_rat
begin
definition "is_rat_real (x :: real) = (x \<in> \<rat>)"
definition "to_rat_real (x :: real) = (if x \<in> \<rat> then (THE y. x = of_rat y) else 0)"
  instance by (intro_classes, auto simp: is_rat_real_def to_rat_real_def)
end

lemma of_nat_complex: "of_nat n = Complex (of_nat n) 0"
  by (simp add: complex_eqI)

lemma of_int_complex: "of_int z = Complex (of_int z) 0"
  by (simp add: complex_eq_iff)

lemma of_rat_complex: "of_rat q = Complex (of_rat q) 0"
proof -
  obtain d n where dn: "quotient_of q = (d,n)" by force
  from quotient_of_div[OF dn] have q: "q = of_int d / of_int n" by auto
  then have "of_rat q = complex_of_real (real_of_rat q) \<or> (0::complex) = of_int n \<or> 0 = real_of_int n"
    by (simp add: of_rat_divide q)
  then show ?thesis
    using Complex_eq_0 complex_of_real_def q by auto
qed

lemma complex_of_real_of_rat[simp]: "complex_of_real (real_of_rat q) = of_rat q"
  unfolding complex_of_real_def of_rat_complex by simp

lemma is_rat_complex_iff: "x \<in> \<rat> \<longleftrightarrow> Re x \<in> \<rat> \<and> Im x = 0"
proof
  assume "x \<in> \<rat>"
  then obtain q where x: "x = of_rat q" unfolding Rats_def by auto
  let ?y = "Complex (of_rat q) 0"
  have "x - ?y = 0" unfolding x by (simp add: Complex_eq)
  hence x: "x = ?y" by simp
  show "Re x \<in> \<rat> \<and> Im x = 0" unfolding x complex.sel by auto
next
  assume "Re x \<in> \<rat> \<and> Im x = 0"
  then obtain q where "Re x = of_rat q" "Im x = 0" unfolding Rats_def by auto
  hence "x = Complex (of_rat q) 0" by (metis complex_surj)
  thus "x \<in> \<rat>" by (simp add: Complex_eq)
qed

instantiation complex :: is_rat
begin
definition "is_rat_complex (x :: complex) = (is_rat (Re x) \<and> Im x = 0)"
definition "to_rat_complex (x :: complex) = (if is_rat (Re x) \<and> Im x = 0 then to_rat (Re x) else 0)"

instance proof (intro_classes, auto simp: is_rat_complex_def to_rat_complex_def is_rat_complex_iff)
  fix x
  assume r: "Re x \<in> \<rat>" and i: "Im x = 0"
  hence "x \<in> \<rat>" unfolding is_rat_complex_iff by auto
  then obtain y where x: "x = of_rat y" unfolding Rats_def by blast
  from this[unfolded of_rat_complex] have x: "x = Complex (real_of_rat y) 0" by auto
  show "to_rat (Re x) = (THE y. x = of_rat y)"
    by (subst of_rat_eq_iff[symmetric, where 'a = real], unfold of_rat_to_rat[OF r] of_rat_complex,
    unfold x complex.sel, auto)
qed
end

lemma [code_unfold]: "(x \<in> \<rat>) = (is_rat x)" by simp

definition is_int_rat :: "rat \<Rightarrow> bool" where
  "is_int_rat x \<equiv> snd (quotient_of x) = 1"

definition int_of_rat :: "rat \<Rightarrow> int" where
  "int_of_rat x \<equiv> fst (quotient_of x)"

lemma is_int_rat[simp]: "is_int_rat x = (x \<in> \<int>)"
  unfolding is_int_rat_def Ints_def
  by (metis Ints_def Ints_induct
    quotient_of_int is_int_rat_def old.prod.exhaust quotient_of_inject rangeI snd_conv)

lemma int_of_rat[simp]: "int_of_rat (rat_of_int x) = x" "z \<in> \<int> \<Longrightarrow> rat_of_int (int_of_rat z) = z"
proof (force simp: int_of_rat_def)
  assume "z \<in> \<int>"
  thus "rat_of_int (int_of_rat z) = z" unfolding int_of_rat_def
    by (metis Ints_cases Pair_inject quotient_of_int surjective_pairing)
qed

lemma int_of_rat_0[simp]: "(int_of_rat x = 0) = (x = 0)" unfolding int_of_rat_def
  using quotient_of_div[of x] by (cases "quotient_of x", auto)

end


(*
Author: Alexander Katovsky
*)

section "Category"

theory Category
imports "~~/src/HOL/Library/FuncSet"
begin

record ('o,'m) Category =
  Obj :: "'o set" ("obj\<index>" 70)
  Mor :: "'m set" ("mor\<index>" 70)
  Dom :: "'m \<Rightarrow> 'o" ("dom\<index> _" [80] 70)
  Cod :: "'m \<Rightarrow> 'o" ("cod\<index> _" [80] 70)
  Id  :: "'o \<Rightarrow> 'm" ("id\<index> _" [80] 75)
  Comp :: "'m \<Rightarrow> 'm \<Rightarrow> 'm" (infixl ";;\<index>" 70)

definition
  MapsTo :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> bool" ("_ maps\<index> _ to _" [60, 60, 60] 65) where
  "MapsTo CC f X Y \<equiv> f \<in> Mor CC \<and> Dom CC f = X \<and> Cod CC f = Y"

definition
  CompDefined :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'm \<Rightarrow> bool" (infixl "\<approx>>\<index>" 65) where
  "CompDefined CC f g \<equiv> f \<in> Mor CC \<and> g \<in> Mor CC \<and> Cod CC f = Dom CC g"

locale ExtCategory =
  fixes C :: "('o,'m,'a) Category_scheme" (structure)
  assumes CdomExt: "(Dom C) \<in> extensional (Mor C)"
  and     CcodExt: "(Cod C) \<in> extensional (Mor C)"
  and     CidExt:  "(Id C) \<in> extensional (Obj C)"
  and     CcompExt:  "(split (Comp C)) \<in> extensional ({(f,g) | f g . f \<approx>> g})"

locale Category = ExtCategory +
  assumes Cdom : "f \<in> mor \<Longrightarrow> dom f \<in> obj"
  and     Ccod : "f \<in> mor \<Longrightarrow> cod f \<in> obj"
  and     Cidm [dest]: "X \<in> obj \<Longrightarrow> (id X) maps X to X"
  and     Cidl : "f \<in> mor \<Longrightarrow> id (dom f) ;; f = f"
  and     Cidr : "f \<in> mor \<Longrightarrow> f ;; id (cod f) = f"
  and     Cassoc : "\<lbrakk>f \<approx>> g ; g \<approx>> h\<rbrakk> \<Longrightarrow> (f ;; g) ;; h = f ;; (g ;; h)"
  and     Ccompt : "\<lbrakk>f maps X to Y ; g maps Y to Z\<rbrakk> \<Longrightarrow> (f ;; g) maps X to Z"

definition
  MakeCat :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'m,'a) Category_scheme" where
  "MakeCat C \<equiv> \<lparr>
      Obj = Obj C ,
      Mor = Mor C ,
      Dom = restrict (Dom C) (Mor C) ,
      Cod = restrict (Cod C) (Mor C) ,
      Id  = restrict (Id C) (Obj C) ,
      Comp = \<lambda> f g . (restrict (split (Comp C)) ({(f,g) | f g . f \<approx>>\<^bsub>C\<^esub> g})) (f,g),
      \<dots> = Category.more C
  \<rparr>"

lemma MakeCatMapsTo: "f maps\<^bsub>C\<^esub> X to Y \<Longrightarrow> f maps\<^bsub>MakeCat C\<^esub> X to Y"
by (auto simp add: MapsTo_def MakeCat_def)

lemma MakeCatComp: "f \<approx>>\<^bsub>C\<^esub> g \<Longrightarrow> f ;;\<^bsub>MakeCat C\<^esub> g = f ;;\<^bsub>C\<^esub> g"
by (auto simp add: MapsTo_def MakeCat_def)

lemma MakeCatId: "X \<in> obj\<^bsub>C\<^esub> \<Longrightarrow> id\<^bsub>C\<^esub> X = id\<^bsub>MakeCat C\<^esub> X"
by (auto simp add: MapsTo_def MakeCat_def)

lemma MakeCatObj: "obj\<^bsub>MakeCat C\<^esub> = obj\<^bsub>C\<^esub>"
by (simp add: MakeCat_def)

lemma MakeCatMor: "mor\<^bsub>MakeCat C\<^esub> = mor\<^bsub>C\<^esub>"
by (simp add: MakeCat_def)

lemma MakeCatDom: "f \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> dom\<^bsub>C\<^esub> f = dom\<^bsub>MakeCat C\<^esub> f"
by (simp add: MakeCat_def)

lemma MakeCatCod: "f \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> cod\<^bsub>C\<^esub> f = cod\<^bsub>MakeCat C\<^esub> f"
by (simp add: MakeCat_def)

lemma MakeCatCompDef: "f \<approx>>\<^bsub>MakeCat C\<^esub> g = f \<approx>>\<^bsub>C\<^esub> g"
by (auto simp add: CompDefined_def MakeCat_def)

lemma MakeCatComp2: "f \<approx>>\<^bsub>MakeCat C\<^esub> g \<Longrightarrow> f ;;\<^bsub>MakeCat C\<^esub> g = f ;;\<^bsub>C\<^esub> g"
by (simp add: MakeCatCompDef MakeCatComp)

lemma ExtCategoryMakeCat: "ExtCategory (MakeCat C)"
by (unfold_locales, simp_all add: MakeCat_def extensional_def CompDefined_def)

lemma MakeCat: "Category_axioms C \<Longrightarrow> Category (MakeCat C)"
apply(intro_locales, simp add: ExtCategoryMakeCat)
apply (simp add: Category_axioms_def)
apply (auto simp add: MakeCat_def CompDefined_def MapsTo_def)
done

lemma MapsToE[elim]: "\<lbrakk>f maps\<^bsub>C\<^esub> X to Y ; \<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; dom\<^bsub>C\<^esub> f = X ; cod\<^bsub>C\<^esub> f = Y\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: MapsTo_def)

lemma MapsToI[intro]: "\<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; dom\<^bsub>C\<^esub> f = X ; cod\<^bsub>C\<^esub> f = Y\<rbrakk> \<Longrightarrow> f maps\<^bsub>C\<^esub> X to Y"
  by (auto simp add: MapsTo_def)

lemma CompDefinedE[elim]: "\<lbrakk>f \<approx>>\<^bsub>C\<^esub> g ; \<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; g \<in> mor\<^bsub>C\<^esub> ; cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: CompDefined_def)

lemma CompDefinedI[intro]: "\<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; g \<in> mor\<^bsub>C\<^esub> ; cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g\<rbrakk> \<Longrightarrow> f \<approx>>\<^bsub>C\<^esub> g"
  by (auto simp add: CompDefined_def)

lemma (in Category) MapsToCompI: assumes "f \<approx>> g" shows "(f ;; g) maps (dom f) to (cod g)"
proof-
  have "f maps (dom f) to (dom g)"
  and  "g maps (dom g) to (cod g)" using assms by auto
  thus ?thesis by (simp add: Ccompt[of f "dom f" "dom g" g "cod g"])
qed

lemma MapsToCompDef:
  assumes "f maps\<^bsub>C\<^esub> X to Y" and "g maps\<^bsub>C\<^esub> Y to Z"
  shows "f \<approx>>\<^bsub>C\<^esub> g"
proof(rule CompDefinedI)
  show "f \<in> mor\<^bsub>C\<^esub>" and "g \<in> mor\<^bsub>C\<^esub>" using assms by auto
  have "cod\<^bsub>C\<^esub> f = Y" and "dom\<^bsub>C\<^esub> g = Y" using assms by auto
  thus "cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g" by simp
qed

lemma (in Category) MapsToMorDomCod:
  assumes "f \<approx>> g"
  shows "f ;; g \<in> mor" and "dom (f ;; g) = dom f" and "cod (f ;; g) = cod g"
proof-
  have "(f ;; g) maps (dom f) to (cod g)" using assms by (simp add: MapsToCompI)
  thus "f ;; g \<in> mor" and "dom (f ;; g) = dom f" and "cod (f ;; g) = cod g" by auto
qed

lemma (in Category) MapsToObj:
  assumes "f maps X to Y"
  shows "X \<in> obj" and "Y \<in> obj"
proof-
  have "dom f = X" and "cod f = Y" and "f \<in> mor" using assms by auto
  thus "X \<in> obj" and "Y \<in> obj" by (auto simp add: Cdom Ccod)
qed

lemma (in Category) IdInj:
  assumes "X \<in> obj" and "Y \<in> obj" and "id X = id Y"
  shows   "X = Y"
proof-
  have "dom (id X) = dom (id Y)" using assms by simp
  moreover have "dom (id X) = X" and "dom (id Y) = Y" using assms by (auto simp add: MapsTo_def)
  ultimately show ?thesis by simp
qed

lemma (in Category) CompDefComp:
  assumes "f \<approx>> g" and "g \<approx>> h"
  shows "f \<approx>> (g ;; h)" and "(f ;; g) \<approx>> h"
proof(auto simp add: CompDefined_def)
  show "f \<in> mor" and "h \<in> mor" using assms by auto
  have  1: "g ;; h maps (dom g) to (cod h)"
    and 2: "f ;; g maps (dom f) to (cod g)" using assms by (simp add: MapsToCompI)+
  thus "g ;; h \<in> mor" and "f ;; g \<in> mor" by auto
  have "cod f = dom g" using assms by auto
  also have "... = dom (g ;; h)" using 1 by auto
  finally show "cod f = dom (g ;; h)" .
  have "dom h = cod g" using assms by auto
  also have "... = cod (f ;; g)" using 2 by auto
  finally show "cod (f ;; g) = dom h" by simp
qed

lemma (in Category) CatIdInMor: "X \<in> obj \<Longrightarrow> id X \<in> mor"
by (auto simp add: Cidm)

lemma (in Category) MapsToId: assumes "X \<in> obj" shows "id X \<approx>> id X"
proof(rule CompDefinedI)
  have "id X maps X to X" using assms by (simp add: Cidm)
  thus "id X \<in> mor" and "id X \<in> mor" and "cod (id X) = dom (id X)" by auto
qed

lemmas (in Category) Simps = Cdom Ccod Cidm Cidl Cidr MapsToCompI IdInj MapsToId

lemma (in Category) LeftRightInvUniq:
  assumes 0: "h \<approx>> f" and  z: "f \<approx>> g"
  assumes 1: "f ;; g = id (dom f)"
  and     2: "h ;; f = id (cod f)"
  shows   "h = g"
proof-
  have mor: "h \<in> mor \<and> g \<in> mor"
  and  dc : "dom f = cod h \<and> cod f = dom g" using 0 z by auto
  then have "h = h ;; id (dom f)" by (auto simp add: Simps)
  also have "... = h ;; (f ;; g)" using 1 by simp+
  also have "... = (h ;; f) ;; g" using 0 z by (simp add: Cassoc)
  also have "... = (id (cod f)) ;; g" using 2 by simp+
  also have "... = g" using mor dc by (auto simp add: Simps)
  finally show ?thesis .
qed

lemma (in Category) CatIdDomCod:
  assumes "X \<in> obj"
  shows "dom (id X) = X" and "cod (id X) = X"
proof-
  have "id X maps X to X" using assms
    by (simp add: Simps)
  thus "dom (id X) = X" and "cod (id X) = X" by auto
qed

lemma (in Category) CatIdCompId:
  assumes "X \<in> obj"
  shows   "id X ;; id X = id X"
proof-
  have 0: "id X \<in> mor" using assms by (auto simp add: Simps)
  moreover have "cod (id X) = X" using assms by auto
  moreover have "id X ;; id (cod (id X)) = id X" using 0 by (simp add: Simps)
  ultimately show ?thesis by simp
qed

(*lemmas (in Category) simps2 = simps CatIdCompId Cassoc CatIdDomCod*)

lemma (in Category) CatIdUniqR:
  assumes iota: "\<iota> maps X to X"
  and     rid:  "\<forall> f . f \<approx>> \<iota> \<longrightarrow> f ;; \<iota> = f"
  shows "id X = \<iota>"
proof(rule LeftRightInvUniq [of "id X" "id X" \<iota> ])
  have 0: "X \<in> obj" using iota by (auto simp add: Simps)
  hence "id X maps X to X" by (simp add: Cidm)
  thus 1: "id X \<approx>> \<iota>" using iota by (auto simp add: Simps)
  show    "id X \<approx>> id X" using 0 by (auto simp add: Simps)
  show    "(id X) ;; \<iota> = (id (dom (id X)))" using 0 1 rid by (auto simp add: Simps CompDefined_def MapsTo_def)
  show    "(id X) ;; (id X) = (id (cod (id X)))" using 0 by (auto simp add: CatIdCompId CompDefined_def MapsTo_def)
qed

definition
  inverse_rel :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'm \<Rightarrow> bool" ("cinv\<index> _ _" 60) where
  "inverse_rel C f g \<equiv> (f \<approx>>\<^bsub>C\<^esub> g) \<and> (f ;;\<^bsub>C\<^esub> g) = (id\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> f)) \<and> (g ;;\<^bsub>C\<^esub> f) = (id\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> f))"

definition
  isomorphism :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> bool" ("ciso\<index> _" [70]) where
  "isomorphism C f \<equiv> \<exists> g . inverse_rel C f g"

lemma (in Category) Inverse_relI: "\<lbrakk>f \<approx>> g ; f ;; g = id (dom f) ; g ;; f = id (cod f)\<rbrakk> \<Longrightarrow> (cinv f g)"
by (auto simp add: inverse_rel_def)

lemma (in Category) Inverse_relE[elim]: "\<lbrakk>cinv f g ; \<lbrakk>f \<approx>> g ; f ;; g = id (dom f) ; g ;; f = id (cod f)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (auto simp add: inverse_rel_def)

lemma (in Category) Inverse_relSym:
  assumes "cinv f g"
  shows   "cinv g f"
proof(rule Inverse_relI)
  have 1: "f \<approx>> g" using assms by auto
  show 2: "g \<approx>> f"
  proof(rule CompDefinedI)
    show "g \<in> mor" and 0: "f \<in> mor" using assms by auto
    have "f ;; g maps dom f to cod g" using 1 by (simp add: MapsToCompI)
    hence "cod g = cod (f ;; g)" by auto
    also have "... = cod (id (dom f))" using assms by (auto simp add: inverse_rel_def)
    also have "... = dom f"
    proof-
      have "dom f \<in> obj" using 0 by (simp add: Simps)
      hence "id (dom f) maps (dom f) to (dom f)" by (simp add: Simps)
      thus ?thesis by auto
    qed
    finally show 2: "cod g = dom f" by simp
  qed
  show "g ;; f = id (dom g)" using assms by (auto simp add: inverse_rel_def)
  show "f ;; g = id (cod g)"using assms 1 2 by (auto simp add: inverse_rel_def)
qed

lemma (in Category) InverseUnique:
  assumes 1: "cinv f g"
  and     2: "cinv f h"
  shows   "g = h"
proof(rule LeftRightInvUniq [of g f h])
  have "cinv g f" using 1 2 by (simp only: Inverse_relSym[of f g])
  thus "g \<approx>> f" and
    "g ;; f = id (cod f)" using 1 by auto
  show "f \<approx>> h" using 2 by auto
  show "f ;; h = id (dom f)" using 2 by auto
qed

lemma (in Category) InvId: assumes "X \<in> obj" shows "(cinv (id X) (id X))"
proof(rule Inverse_relI)
  show "id X \<approx>> id X" using assms by (simp add: Simps)
  have "dom (id X) = X" and "dom (id X) = X" using assms by (simp add: CatIdDomCod)+
  thus "id X ;; id X = id (dom (id X))" and "id X ;; id X = id (cod (id X))"
    using assms by (simp add: CatIdCompId CatIdDomCod)+
qed

definition
  inverse :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'm" ("Cinv\<index> _" [70]) where
  "inverse C f \<equiv> THE g . inverse_rel C f g"

lemma (in Category) inv2Inv:
  assumes "cinv f g"
  shows   "ciso f" and "Cinv f = g"
proof-
  show "ciso f" using assms by (auto simp add: isomorphism_def)
  hence "\<exists>! g . cinv f g" using assms by (auto simp add: InverseUnique)
  thus "Cinv f = g" using assms by (auto simp add: inverse_def)
qed

lemma (in Category) iso2Inv:
  assumes "ciso f"
  shows   "cinv f (Cinv f)"
proof-
  have "\<exists>! g . cinv f g" using assms by (auto simp add: InverseUnique isomorphism_def)
  thus ?thesis by (auto simp add:  inverse_def intro:theI')
qed

lemma (in Category) InvInv:
  assumes "ciso f"
  shows   "ciso (Cinv f)" and "(Cinv (Cinv f)) = f"
proof-
  have "cinv f (Cinv f)" using assms by (simp add: iso2Inv)
  hence "cinv (Cinv f) f" by (simp add: Inverse_relSym[of f])
  thus  "ciso (Cinv f)" and "Cinv (Cinv f) = f" by (auto simp add: inv2Inv)
qed

lemma (in Category) InvIsMor: "(cinv f g) \<Longrightarrow> (f \<in> mor \<and> g \<in> mor)"
  by (auto simp add: inverse_rel_def)

lemma (in Category) IsoIsMor: "ciso f \<Longrightarrow> f \<in> mor"
  by (auto simp add: InvIsMor dest: iso2Inv)

lemma (in Category) InvDomCod:
  assumes "ciso f"
  shows "dom (Cinv f) = cod f" and "cod (Cinv f) = dom f" and "Cinv f \<in> mor"
proof-
  have 1: "cinv f (Cinv f)" using assms by (auto simp add: iso2Inv)
  thus "dom (Cinv f) = cod f" by (auto simp add: inverse_rel_def)
  from 1 have "cinv (Cinv f) f" by (auto simp add: Inverse_relSym[of f])
  thus  "cod (Cinv f) = dom f" by (auto simp add: inverse_rel_def)
  show "Cinv f \<in> mor" using 1 by (auto simp add: inverse_rel_def)
qed

lemma (in Category) InvCompIso: "ciso f \<Longrightarrow> Cinv f \<approx>> f"
  by (auto simp add: IsoIsMor InvDomCod)

lemma (in Category) IsoInvId1 : "ciso f \<Longrightarrow> (Cinv f) ;; f = (id (cod f))"
by (auto dest: iso2Inv)

lemma (in Category) IsoInvId2 :  "ciso f \<Longrightarrow> f ;; (Cinv f) = (id (dom f))"
by (auto dest: iso2Inv)

lemma (in Category) IsoCompDef:
  assumes 1: "f \<approx>> g" and 2: "ciso f" and 3: "ciso g"
  shows "(Cinv g) \<approx>> (Cinv f)"
proof(rule CompDefinedI)
  show "Cinv g \<in> mor" and "Cinv f \<in> mor" using assms by (auto simp add: InvDomCod)
  have "cod (Cinv g) = dom g" using 3 by (simp add: InvDomCod)
  also have "... = cod f" using 1 by auto
  also have "... = dom (Cinv f)" using 2 by (simp add: InvDomCod)
  finally show "cod (Cinv g) = dom (Cinv f)" .
qed

lemma (in Category) IsoCompose:
  assumes 1: "f \<approx>> g" and 2: "ciso f" and 3: "ciso g"
  shows "ciso (f ;; g)" and "Cinv (f ;; g) = (Cinv g) ;; (Cinv f)"
proof-
  have  a: "(Cinv g) \<approx>> (Cinv f)" using assms by (simp add: IsoCompDef)
  hence b: "(Cinv g) ;; (Cinv f) maps (dom (Cinv g)) to (cod (Cinv f))" by (simp add: MapsToCompI)
  hence c: "(Cinv g) ;; (Cinv f) maps (cod g) to (dom f)" using 2 3 by (simp add: InvDomCod)
  have  d: "f ;; g maps (dom f) to (cod g)" using 1 by (simp add: Simps)
  have "cinv (f ;; g) ((Cinv g) ;; (Cinv f))"
  proof(auto simp add: inverse_rel_def)
    show "f ;; g \<approx>> (Cinv g) ;; (Cinv f)"
    proof(rule CompDefinedI)
      show "f ;; g \<in> mor" using d by auto
      show "(Cinv g) ;; (Cinv f) \<in> mor" using c by auto
      have "cod (f ;; g) = cod g" using d by auto
      also have "... = dom (Cinv g)" using assms by (simp add: InvDomCod)
      also have "... = dom ((Cinv g) ;; (Cinv f))" using b by auto
      finally show "cod (f ;; g) = dom ((Cinv g) ;; (Cinv f))" .
    qed
    show "f ;; g ;; ((Cinv g) ;; (Cinv f)) = id (dom (f ;; g))"
    proof-
      have e: "g \<approx>> (Cinv g)" using assms by (simp add: IsoCompInv)
      have f: "f \<in> mor" using 1 by auto
      have "(f ;; g) ;; ((Cinv g) ;; (Cinv f)) = (f ;; (g ;; (Cinv g))) ;; (Cinv f)"
        using 1 e a by (auto simp add: Cassoc CompDefComp)
      also have "... = f ;; (id (dom g)) ;; (Cinv f)" using 3 by (simp add: IsoInvId2)
      also have "... = f ;; id (cod f) ;; (Cinv f)" using 1 by (auto simp add: Simps)
      also have "... = f ;; (Cinv f)" using f by (auto simp add: Cidr)
      also have "... = id (dom f)" using 2 by (simp add: IsoInvId2)
      also have "... = id (dom (f ;; g))" using d by auto
      finally show ?thesis by simp
    qed
    show "((Cinv g) ;; (Cinv f)) ;; (f ;; g) = id (cod (f ;; g))"
    proof-
      have e: "(Cinv f) \<approx>> f" using assms by (simp add: InvCompIso)
      have f: "g \<in> mor" using 1 by auto
      have "((Cinv g) ;; (Cinv f)) ;; (f ;; g) = (Cinv g) ;; (((Cinv f) ;; f) ;; g)"
        using 1 e a by (auto simp add: Cassoc CompDefComp)
      also have "... = (Cinv g) ;; ((id (cod f)) ;; g)" using 2 by (simp add: IsoInvId1)
      also have "... = (Cinv g) ;; ((id (dom g)) ;; g)" using 1 by (auto simp add: Simps)
      also have "... = (Cinv g) ;; g" using f by (auto simp add: Cidl)
      also have "... = id (cod g)" using 3 by (simp add: IsoInvId1)
      also have "... = id (cod (f ;; g))" using d by auto
      finally show ?thesis by simp
    qed
  qed
  thus "ciso (f ;; g)" and "Cinv (f ;; g) = (Cinv g) ;; (Cinv f)" by (auto simp add: inv2Inv)
qed

definition "ObjIso C A B \<equiv> \<exists> k . (k maps\<^bsub>C\<^esub> A to B) \<and> ciso\<^bsub>C \<^esub>k"

definition
  UnitCategory :: "(unit, unit) Category" where
  "UnitCategory = MakeCat \<lparr>
      Obj = {()} ,
      Mor = {()} ,
      Dom = (\<lambda>f.()) ,
      Cod = (\<lambda>f.()) ,
      Id = (\<lambda>f.()) ,
      Comp = (\<lambda>f g. ())
  \<rparr>"

definition
  OppositeCategory :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'m,'a) Category_scheme" ("Op _" [65] 65) where
  "OppositeCategory C \<equiv> \<lparr>
      Obj = Obj C ,
      Mor = Mor C ,
      Dom = Cod C ,
      Cod = Dom C ,
      Id  = Id C ,
      Comp = (\<lambda>f g. g ;;\<^bsub>C\<^esub> f),
      \<dots> = Category.more C
  \<rparr>"

lemma OpCatOpCat: "Op (Op C) = C"
  by (simp add: OppositeCategory_def)

lemma OpCatCatAx: "Category_axioms C \<Longrightarrow> Category_axioms (Op C)"
  by (simp add: OppositeCategory_def Category_axioms_def MapsTo_def CompDefined_def)

lemma OpCatCatExt: "ExtCategory C \<Longrightarrow> ExtCategory (Op C)"
  by (auto simp add: OppositeCategory_def ExtCategory_def MapsTo_def CompDefined_def extensional_def)

lemma OpCatCat: "Category C \<Longrightarrow> Category (Op C)"
  by (intro_locales, simp_all add: Category_def OpCatCatAx OpCatCatExt)

lemma MapsToOp: "f maps\<^bsub>C \<^esub>X to Y \<Longrightarrow> f maps\<^bsub>Op C \<^esub>Y to X"
by (simp add: MapsTo_def OppositeCategory_def)

lemma MapsToOpOp: "f maps\<^bsub>Op C \<^esub>X to Y \<Longrightarrow> f maps\<^bsub>C \<^esub>Y to X"
by (simp add: MapsTo_def OppositeCategory_def)

lemma CompDefOp: "f \<approx>>\<^bsub>C\<^esub> g \<Longrightarrow> g \<approx>>\<^bsub>Op C\<^esub> f"
by (simp add: CompDefined_def OppositeCategory_def)

end