(*  Title:      HOL/Cardinals/Order_Relation_More.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Basics on order-like relations.
*)

section \<open>Basics on Order-Like Relations\<close>

theory Order_Relation_More
  imports Main
begin

subsection \<open>The upper and lower bounds operators\<close>

lemma aboveS_subset_above: "aboveS r a \<le> above r a"
  by(auto simp add: aboveS_def above_def)

lemma AboveS_subset_Above: "AboveS r A \<le> Above r A"
  by(auto simp add: AboveS_def Above_def)

lemma UnderS_disjoint: "A Int (UnderS r A) = {}"
  by(auto simp add: UnderS_def)

lemma aboveS_notIn: "a \<notin> aboveS r a"
  by(auto simp add: aboveS_def)

lemma Refl_above_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> above r a"
  by(auto simp add: refl_on_def above_def)

lemma in_Above_under: "a \<in> Field r \<Longrightarrow> a \<in> Above r (under r a)"
  by(auto simp add: Above_def under_def)

lemma in_Under_above: "a \<in> Field r \<Longrightarrow> a \<in> Under r (above r a)"
  by(auto simp add: Under_def above_def)

lemma in_UnderS_aboveS: "a \<in> Field r \<Longrightarrow> a \<in> UnderS r (aboveS r a)"
  by(auto simp add: UnderS_def aboveS_def)

lemma UnderS_subset_Under: "UnderS r A \<le> Under r A"
  by(auto simp add: UnderS_def Under_def)

lemma subset_Above_Under: "B \<le> Field r \<Longrightarrow> B \<le> Above r (Under r B)"
  by(auto simp add: Above_def Under_def)

lemma subset_Under_Above: "B \<le> Field r \<Longrightarrow> B \<le> Under r (Above r B)"
  by(auto simp add: Under_def Above_def)

lemma subset_AboveS_UnderS: "B \<le> Field r \<Longrightarrow> B \<le> AboveS r (UnderS r B)"
  by(auto simp add: AboveS_def UnderS_def)

lemma subset_UnderS_AboveS: "B \<le> Field r \<Longrightarrow> B \<le> UnderS r (AboveS r B)"
  by(auto simp add: UnderS_def AboveS_def)

lemma Under_Above_Galois:
  "\<lbrakk>B \<le> Field r; C \<le> Field r\<rbrakk> \<Longrightarrow> (B \<le> Above r C) = (C \<le> Under r B)"
  by(unfold Above_def Under_def, blast)

lemma UnderS_AboveS_Galois:
  "\<lbrakk>B \<le> Field r; C \<le> Field r\<rbrakk> \<Longrightarrow> (B \<le> AboveS r C) = (C \<le> UnderS r B)"
  by(unfold AboveS_def UnderS_def, blast)

lemma Refl_above_aboveS:
  assumes REFL: "Refl r" and IN: "a \<in> Field r"
  shows "above r a = aboveS r a \<union> {a}"
proof(unfold above_def aboveS_def, auto)
  show "(a,a) \<in> r" using REFL IN refl_on_def[of _ r] by blast
qed

lemma Linear_order_under_aboveS_Field:
  assumes LIN: "Linear_order r" and IN: "a \<in> Field r"
  shows "Field r = under r a \<union> aboveS r a"
proof(unfold under_def aboveS_def, auto)
  assume "a \<in> Field r" "(a, a) \<notin> r"
  with LIN IN order_on_defs[of _ r] refl_on_def[of _ r]
  show False by auto
next
  fix b assume "b \<in> Field r" "(b, a) \<notin> r"
  with LIN IN order_on_defs[of "Field r" r] total_on_def[of "Field r" r]
  have "(a,b) \<in> r \<or> a = b" by blast
  thus "(a,b) \<in> r"
    using LIN IN order_on_defs[of _ r] refl_on_def[of _ r] by auto
next
  fix b assume "(b, a) \<in> r"
  thus "b \<in> Field r"
    using LIN order_on_defs[of _ r] refl_on_def[of _ r] by blast
next
  fix b assume "b \<noteq> a" "(a, b) \<in> r"
  thus "b \<in> Field r"
    using LIN order_on_defs[of "Field r" r] refl_on_def[of "Field r" r] by blast
qed

lemma Linear_order_underS_above_Field:
  assumes LIN: "Linear_order r" and IN: "a \<in> Field r"
  shows "Field r = underS r a \<union> above r a"
proof(unfold underS_def above_def, auto)
  assume "a \<in> Field r" "(a, a) \<notin> r"
  with LIN IN order_on_defs[of _ r] refl_on_def[of _ r]
  show False by metis
next
  fix b assume "b \<in> Field r" "(a, b) \<notin> r"
  with LIN IN order_on_defs[of "Field r" r] total_on_def[of "Field r" r]
  have "(b,a) \<in> r \<or> b = a" by blast
  thus "(b,a) \<in> r"
    using LIN IN order_on_defs[of _ r] refl_on_def[of _ r] by auto
next
  fix b assume "b \<noteq> a" "(b, a) \<in> r"
  thus "b \<in> Field r"
    using LIN order_on_defs[of _ r] refl_on_def[of _ r] by blast
next
  fix b assume "(a, b) \<in> r"
  thus "b \<in> Field r"
    using LIN order_on_defs[of "Field r" r] refl_on_def[of "Field r" r] by blast
qed

lemma under_empty: "a \<notin> Field r \<Longrightarrow> under r a = {}"
  unfolding Field_def under_def by auto

lemma Under_Field: "Under r A \<le> Field r"
  by(unfold Under_def Field_def, auto)

lemma UnderS_Field: "UnderS r A \<le> Field r"
  by(unfold UnderS_def Field_def, auto)

lemma above_Field: "above r a \<le> Field r"
  by(unfold above_def Field_def, auto)

lemma aboveS_Field: "aboveS r a \<le> Field r"
  by(unfold aboveS_def Field_def, auto)

lemma Above_Field: "Above r A \<le> Field r"
  by(unfold Above_def Field_def, auto)

lemma Refl_under_Under:
  assumes REFL: "Refl r" and NE: "A \<noteq> {}"
  shows "Under r A = (\<Inter>a \<in> A. under r a)"
proof
  show "Under r A \<subseteq> (\<Inter>a \<in> A. under r a)"
    by(unfold Under_def under_def, auto)
next
  show "(\<Inter>a \<in> A. under r a) \<subseteq> Under r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> under r xa"
    hence "\<forall>xa \<in> A. (x,xa) \<in> r"
      by (simp add: under_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
      with * have "x \<in> under r a" by simp
      hence "x \<in> Field r"
        using under_Field[of r a] by auto
    }
    ultimately show "x \<in> Under r A"
      unfolding Under_def by auto
  qed
qed

lemma Refl_underS_UnderS:
  assumes REFL: "Refl r" and NE: "A \<noteq> {}"
  shows "UnderS r A = (\<Inter>a \<in> A. underS r a)"
proof
  show "UnderS r A \<subseteq> (\<Inter>a \<in> A. underS r a)"
    by(unfold UnderS_def underS_def, auto)
next
  show "(\<Inter>a \<in> A. underS r a) \<subseteq> UnderS r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> underS r xa"
    hence "\<forall>xa \<in> A. x \<noteq> xa \<and> (x,xa) \<in> r"
      by (auto simp add: underS_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
      with * have "x \<in> underS r a" by simp
      hence "x \<in> Field r"
        using underS_Field[of _ r a] by auto
    }
    ultimately show "x \<in> UnderS r A"
      unfolding UnderS_def by auto
  qed
qed

lemma Refl_above_Above:
  assumes REFL: "Refl r" and NE: "A \<noteq> {}"
  shows "Above r A = (\<Inter>a \<in> A. above r a)"
proof
  show "Above r A \<subseteq> (\<Inter>a \<in> A. above r a)"
    by(unfold Above_def above_def, auto)
next
  show "(\<Inter>a \<in> A. above r a) \<subseteq> Above r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> above r xa"
    hence "\<forall>xa \<in> A. (xa,x) \<in> r"
      by (simp add: above_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
      with * have "x \<in> above r a" by simp
      hence "x \<in> Field r"
        using above_Field[of r a] by auto
    }
    ultimately show "x \<in> Above r A"
      unfolding Above_def by auto
  qed
qed

lemma Refl_aboveS_AboveS:
  assumes REFL: "Refl r" and NE: "A \<noteq> {}"
  shows "AboveS r A = (\<Inter>a \<in> A. aboveS r a)"
proof
  show "AboveS r A \<subseteq> (\<Inter>a \<in> A. aboveS r a)"
    by(unfold AboveS_def aboveS_def, auto)
next
  show "(\<Inter>a \<in> A. aboveS r a) \<subseteq> AboveS r A"
  proof(auto)
    fix x
    assume *: "\<forall>xa \<in> A. x \<in> aboveS r xa"
    hence "\<forall>xa \<in> A. xa \<noteq> x \<and> (xa,x) \<in> r"
      by (auto simp add: aboveS_def)
    moreover
    {from NE obtain a where "a \<in> A" by blast
      with * have "x \<in> aboveS r a" by simp
      hence "x \<in> Field r"
        using aboveS_Field[of r a] by auto
    }
    ultimately show "x \<in> AboveS r A"
      unfolding AboveS_def by auto
  qed
qed

lemma under_Under_singl: "under r a = Under r {a}"
  by(unfold Under_def under_def, auto simp add: Field_def)

lemma underS_UnderS_singl: "underS r a = UnderS r {a}"
  by(unfold UnderS_def underS_def, auto simp add: Field_def)

lemma above_Above_singl: "above r a = Above r {a}"
  by(unfold Above_def above_def, auto simp add: Field_def)

lemma aboveS_AboveS_singl: "aboveS r a = AboveS r {a}"
  by(unfold AboveS_def aboveS_def, auto simp add: Field_def)

lemma Under_decr: "A \<le> B \<Longrightarrow> Under r B \<le> Under r A"
  by(unfold Under_def, auto)

lemma UnderS_decr: "A \<le> B \<Longrightarrow> UnderS r B \<le> UnderS r A"
  by(unfold UnderS_def, auto)

lemma Above_decr: "A \<le> B \<Longrightarrow> Above r B \<le> Above r A"
  by(unfold Above_def, auto)

lemma AboveS_decr: "A \<le> B \<Longrightarrow> AboveS r B \<le> AboveS r A"
  by(unfold AboveS_def, auto)

lemma under_incl_iff:
  assumes TRANS: "trans r" and REFL: "Refl r" and IN: "a \<in> Field r"
  shows "(under r a \<le> under r b) = ((a,b) \<in> r)"
proof
  assume "(a,b) \<in> r"
  thus "under r a \<le> under r b" using TRANS
    by (auto simp add: under_incr)
next
  assume "under r a \<le> under r b"
  moreover
  have "a \<in> under r a" using REFL IN
    by (auto simp add: Refl_under_in)
  ultimately show "(a,b) \<in> r"
    by (auto simp add: under_def)
qed

lemma above_decr:
  assumes TRANS: "trans r" and REL: "(a,b) \<in> r"
  shows "above r b \<le> above r a"
proof(unfold above_def, auto)
  fix x assume "(b,x) \<in> r"
  with REL TRANS trans_def[of r]
  show "(a,x) \<in> r" by blast
qed

lemma aboveS_decr:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    REL: "(a,b) \<in> r"
  shows "aboveS r b \<le> aboveS r a"
proof(unfold aboveS_def, auto)
  assume *: "a \<noteq> b" and **: "(b,a) \<in> r"
  with ANTISYM antisym_def[of r] REL
  show False by auto
next
  fix x assume "x \<noteq> b" "(b,x) \<in> r"
  with REL TRANS trans_def[of r]
  show "(a,x) \<in> r" by blast
qed

lemma under_trans:
  assumes TRANS: "trans r" and
    IN1: "a \<in> under r b" and IN2: "b \<in> under r c"
  shows "a \<in> under r c"
proof-
  have "(a,b) \<in> r \<and> (b,c) \<in> r"
    using IN1 IN2 under_def by fastforce
  hence "(a,c) \<in> r"
    using TRANS trans_def[of r] by blast
  thus ?thesis unfolding under_def by simp
qed

lemma under_underS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> under r b" and IN2: "b \<in> underS r c"
  shows "a \<in> underS r c"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
    using IN1 IN2 under_def underS_def by fastforce
  hence 1: "(a,c) \<in> r"
    using TRANS trans_def[of r] by blast
  have 2: "b \<noteq> c" using IN2 underS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding underS_def by simp
qed

lemma underS_under_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> underS r b" and IN2: "b \<in> under r c"
  shows "a \<in> underS r c"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
    using IN1 IN2 under_def underS_def by fast
  hence 1: "(a,c) \<in> r"
    using TRANS trans_def[of r] by fast
  have 2: "a \<noteq> b" using IN1 underS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding underS_def by simp
qed

lemma underS_underS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> underS r b" and IN2: "b \<in> underS r c"
  shows "a \<in> underS r c"
proof-
  have "a \<in> under r b"
    using IN1 underS_subset_under by fast
  with assms under_underS_trans show ?thesis by fast
qed

lemma above_trans:
  assumes TRANS: "trans r" and
    IN1: "b \<in> above r a" and IN2: "c \<in> above r b"
  shows "c \<in> above r a"
proof-
  have "(a,b) \<in> r \<and> (b,c) \<in> r"
    using IN1 IN2 above_def by fast
  hence "(a,c) \<in> r"
    using TRANS trans_def[of r] by blast
  thus ?thesis unfolding above_def by simp
qed

lemma above_aboveS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "b \<in> above r a" and IN2: "c \<in> aboveS r b"
  shows "c \<in> aboveS r a"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
    using IN1 IN2 above_def aboveS_def by fast
  hence 1: "(a,c) \<in> r"
    using TRANS trans_def[of r] by blast
  have 2: "b \<noteq> c" using IN2 aboveS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding aboveS_def by simp
qed

lemma aboveS_above_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "b \<in> aboveS r a" and IN2: "c \<in> above r b"
  shows "c \<in> aboveS r a"
proof-
  have 0: "(a,b) \<in> r \<and> (b,c) \<in> r"
    using IN1 IN2 above_def aboveS_def by fast
  hence 1: "(a,c) \<in> r"
    using TRANS trans_def[of r] by blast
  have 2: "a \<noteq> b" using IN1 aboveS_def by force
  have 3: "a \<noteq> c"
  proof
    assume "a = c" with 0 2 ANTISYM antisym_def[of r]
    show False by auto
  qed
  from 1 3 show ?thesis unfolding aboveS_def by simp
qed

lemma aboveS_aboveS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "b \<in> aboveS r a" and IN2: "c \<in> aboveS r b"
  shows "c \<in> aboveS r a"
proof-
  have "b \<in> above r a"
    using IN1 aboveS_subset_above by fast
  with assms above_aboveS_trans show ?thesis by fast
qed

lemma under_Under_trans:
  assumes TRANS: "trans r" and
    IN1: "a \<in> under r b" and IN2: "b \<in> Under r C"
  shows "a \<in> Under r C"
proof-
  have "b \<in> {u \<in> Field r. \<forall>x. x \<in> C \<longrightarrow> (u, x) \<in> r}"
    using IN2 Under_def by force
  hence "(a,b) \<in> r \<and> (\<forall>c \<in> C. (b,c) \<in> r)"
    using IN1 under_def by fast
  hence "\<forall>c \<in> C. (a,c) \<in> r"
    using TRANS trans_def[of r] by blast
  moreover
  have "a \<in> Field r" using IN1 unfolding Field_def under_def by blast
  ultimately
  show ?thesis unfolding Under_def by blast
qed

lemma underS_Under_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> underS r b" and IN2: "b \<in> Under r C"
  shows "a \<in> UnderS r C"
proof-
  from IN1 have "a \<in> under r b"
    using underS_subset_under[of r b] by fast
  with assms under_Under_trans
  have "a \<in> Under r C" by fast
      (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "b \<noteq> a \<and> (a,b) \<in> r"
      using IN1 underS_def[of r b] by auto
    have "\<forall>c \<in> C. (b,c) \<in> r"
      using IN2 Under_def[of r C] by auto
    with * have "(b,a) \<in> r" by simp
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
    (*  *)
  ultimately
  show ?thesis unfolding UnderS_def
    using Under_def by force
qed

lemma underS_UnderS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> underS r b" and IN2: "b \<in> UnderS r C"
  shows "a \<in> UnderS r C"
proof-
  from IN2 have "b \<in> Under r C"
    using UnderS_subset_Under[of r C] by blast
  with underS_Under_trans assms
  show ?thesis by force
qed

lemma above_Above_trans:
  assumes TRANS: "trans r" and
    IN1: "a \<in> above r b" and IN2: "b \<in> Above r C"
  shows "a \<in> Above r C"
proof-
  have "(b,a) \<in> r \<and> (\<forall>c \<in> C. (c,b) \<in> r)"
    using IN1[unfolded above_def] IN2[unfolded Above_def] by simp
  hence "\<forall>c \<in> C. (c,a) \<in> r"
    using TRANS trans_def[of r] by blast
  moreover
  have "a \<in> Field r" using IN1[unfolded above_def] Field_def by fast
  ultimately
  show ?thesis unfolding Above_def by auto
qed

lemma aboveS_Above_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> aboveS r b" and IN2: "b \<in> Above r C"
  shows "a \<in> AboveS r C"
proof-
  from IN1 have "a \<in> above r b"
    using aboveS_subset_above[of r b] by blast
  with assms above_Above_trans
  have "a \<in> Above r C" by fast
      (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "b \<noteq> a \<and> (b,a) \<in> r"
      using IN1 aboveS_def[of r b] by auto
    have "\<forall>c \<in> C. (c,b) \<in> r"
      using IN2 Above_def[of r C] by auto
    with * have "(a,b) \<in> r" by simp
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
    (*  *)
  ultimately
  show ?thesis unfolding AboveS_def
    using Above_def by force
qed

lemma above_AboveS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> above r b" and IN2: "b \<in> AboveS r C"
  shows "a \<in> AboveS r C"
proof-
  from IN2 have "b \<in> Above r C"
    using AboveS_subset_Above[of r C] by blast
  with assms above_Above_trans
  have "a \<in> Above r C" by force
      (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "(b,a) \<in> r"
      using IN1 above_def[of r b] by auto
    have "\<forall>c \<in> C. b \<noteq> c \<and> (c,b) \<in> r"
      using IN2 AboveS_def[of r C] by auto
    with * have "b \<noteq> a \<and> (a,b) \<in> r" by simp
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
    (*  *)
  ultimately
  show ?thesis unfolding AboveS_def
    using Above_def by force
qed

lemma aboveS_AboveS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> aboveS r b" and IN2: "b \<in> AboveS r C"
  shows "a \<in> AboveS r C"
proof-
  from IN2 have "b \<in> Above r C"
    using AboveS_subset_Above[of r C] by blast
  with aboveS_Above_trans assms
  show ?thesis by force
qed

lemma under_UnderS_trans:
  assumes TRANS: "trans r" and ANTISYM: "antisym r" and
    IN1: "a \<in> under r b" and IN2: "b \<in> UnderS r C"
  shows "a \<in> UnderS r C"
proof-
  from IN2 have "b \<in> Under r C"
    using UnderS_subset_Under[of r C] by blast
  with assms under_Under_trans
  have "a \<in> Under r C" by force
      (*  *)
  moreover
  have "a \<notin> C"
  proof
    assume *: "a \<in> C"
    have 1: "(a,b) \<in> r"
      using IN1 under_def[of r b] by auto
    have "\<forall>c \<in> C. b \<noteq> c \<and> (b,c) \<in> r"
      using IN2 UnderS_def[of r C] by blast
    with * have "b \<noteq> a \<and> (b,a) \<in> r" by blast
    with 1 ANTISYM antisym_def[of r]
    show False by blast
  qed
    (*  *)
  ultimately
  show ?thesis unfolding UnderS_def Under_def by fast
qed

subsection \<open>Properties depending on more than one relation\<close>

lemma under_incr2:
  "r \<le> r' \<Longrightarrow> under r a \<le> under r' a"
  unfolding under_def by blast

lemma underS_incr2:
  "r \<le> r' \<Longrightarrow> underS r a \<le> underS r' a"
  unfolding underS_def by blast

(* FIXME: r \<leadsto> r'
lemma Under_incr:
"r \<le> r' \<Longrightarrow> Under r A \<le> Under r A"
unfolding Under_def by blast

lemma UnderS_incr:
"r \<le> r' \<Longrightarrow> UnderS r A \<le> UnderS r A"
unfolding UnderS_def by blast

lemma Under_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk>  \<Longrightarrow> Under r A \<le> Under r A'"
unfolding Under_def by blast

lemma UnderS_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk>  \<Longrightarrow> UnderS r A \<le> UnderS r A'"
unfolding UnderS_def by blast
*)

lemma above_incr2:
  "r \<le> r' \<Longrightarrow> above r a \<le> above r' a"
  unfolding above_def by blast

lemma aboveS_incr2:
  "r \<le> r' \<Longrightarrow> aboveS r a \<le> aboveS r' a"
  unfolding aboveS_def by blast

(* FIXME
lemma Above_incr:
"r \<le> r' \<Longrightarrow> Above r A \<le> Above r A"
unfolding Above_def by blast

lemma AboveS_incr:
"r \<le> r' \<Longrightarrow> AboveS r A \<le> AboveS r A"
unfolding AboveS_def by blast

lemma Above_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk> \<Longrightarrow> Above r A \<le> Above r A'"
unfolding Above_def by blast

lemma AboveS_incr_decr:
"\<lbrakk>r \<le> r'; A' \<le> A\<rbrakk> \<Longrightarrow> AboveS r A \<le> AboveS r A'"
unfolding AboveS_def by blast
*)

end


section \<open>Simply-typed lambda-calculus with let and tuple patterns\<close>

theory Pattern
imports "HOL-Nominal.Nominal"
begin

no_syntax
  "_Map" :: "maplets => 'a \<rightharpoonup> 'b"  ("(1[_])")

atom_decl name

nominal_datatype ty =
    Atom nat
  | Arrow ty ty  (infixr "\<rightarrow>" 200)
  | TupleT ty ty  (infixr "\<otimes>" 210)

lemma fresh_type [simp]: "(a::name) \<sharp> (T::ty)"
  by (induct T rule: ty.induct) (simp_all add: fresh_nat)

lemma supp_type [simp]: "supp (T::ty) = ({} :: name set)"
  by (induct T rule: ty.induct) (simp_all add: ty.supp supp_nat)

lemma perm_type: "(pi::name prm) \<bullet> (T::ty) = T"
  by (induct T rule: ty.induct) (simp_all add: perm_nat_def)

nominal_datatype trm =
    Var name
  | Tuple trm trm  ("(1'\<langle>_,/ _'\<rangle>)")
  | Abs ty "\<guillemotleft>name\<guillemotright>trm"
  | App trm trm  (infixl "\<cdot>" 200)
  | Let ty trm btrm
and btrm =
    Base trm
  | Bind ty "\<guillemotleft>name\<guillemotright>btrm"

abbreviation
  Abs_syn :: "name \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm"  ("(3\<lambda>_:_./ _)" [0, 0, 10] 10)
where
  "\<lambda>x:T. t \<equiv> Abs T x t"

datatype pat =
    PVar name ty
  | PTuple pat pat  ("(1'\<langle>\<langle>_,/ _'\<rangle>\<rangle>)")

(* FIXME: The following should be done automatically by the nominal package *)
overloading pat_perm \<equiv> "perm :: name prm \<Rightarrow> pat \<Rightarrow> pat" (unchecked)
begin

primrec pat_perm
where
  "pat_perm pi (PVar x ty) = PVar (pi \<bullet> x) (pi \<bullet> ty)"
| "pat_perm pi \<langle>\<langle>p, q\<rangle>\<rangle> = \<langle>\<langle>pat_perm pi p, pat_perm pi q\<rangle>\<rangle>"

end

declare pat_perm.simps [eqvt]

lemma supp_PVar [simp]: "((supp (PVar x T))::name set) = supp x"
  by (simp add: supp_def perm_fresh_fresh)

lemma supp_PTuple [simp]: "((supp \<langle>\<langle>p, q\<rangle>\<rangle>)::name set) = supp p \<union> supp q"
  by (simp add: supp_def Collect_disj_eq del: disj_not1)

instance pat :: pt_name
proof (standard, goal_cases)
  case (1 x)
  show ?case by (induct x) simp_all
next
  case (2 _ _ x)
  show ?case by (induct x) (simp_all add: pt_name2)
next
  case (3 _ _ x)
  then show ?case by (induct x) (simp_all add: pt_name3)
qed

instance pat :: fs_name
proof (standard, goal_cases)
  case (1 x)
  show ?case by (induct x) (simp_all add: fin_supp)
qed

(* the following function cannot be defined using nominal_primrec, *)
(* since variable parameters are currently not allowed.            *)
primrec abs_pat :: "pat \<Rightarrow> btrm \<Rightarrow> btrm" ("(3\<lambda>[_]./ _)" [0, 10] 10)
where
  "(\<lambda>[PVar x T]. t) = Bind T x t"
| "(\<lambda>[\<langle>\<langle>p, q\<rangle>\<rangle>]. t) = (\<lambda>[p]. \<lambda>[q]. t)"

lemma abs_pat_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. (pi \<bullet> t))"
  by (induct p arbitrary: t) simp_all

lemma abs_pat_fresh [simp]:
  "(x::name) \<sharp> (\<lambda>[p]. t) = (x \<in> supp p \<or> x \<sharp> t)"
  by (induct p arbitrary: t) (simp_all add: abs_fresh supp_atm)

lemma abs_pat_alpha:
  assumes fresh: "((pi::name prm) \<bullet> supp p::name set) \<sharp>* t"
  and pi: "set pi \<subseteq> supp p \<times> pi \<bullet> supp p"
  shows "(\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. pi \<bullet> t)"
proof -
  note pt_name_inst at_name_inst pi
  moreover have "(supp p::name set) \<sharp>* (\<lambda>[p]. t)"
    by (simp add: fresh_star_def)
  moreover from fresh
  have "(pi \<bullet> supp p::name set) \<sharp>* (\<lambda>[p]. t)"
    by (simp add: fresh_star_def)
  ultimately have "pi \<bullet> (\<lambda>[p]. t) = (\<lambda>[p]. t)"
    by (rule pt_freshs_freshs)
  then show ?thesis by (simp add: eqvts)
qed

primrec pat_vars :: "pat \<Rightarrow> name list"
where
  "pat_vars (PVar x T) = [x]"
| "pat_vars \<langle>\<langle>p, q\<rangle>\<rangle> = pat_vars q @ pat_vars p"

lemma pat_vars_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (pat_vars p) = pat_vars (pi \<bullet> p)"
  by (induct p rule: pat.induct) (simp_all add: eqvts)

lemma set_pat_vars_supp: "set (pat_vars p) = supp p"
  by (induct p) (auto simp add: supp_atm)

lemma distinct_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (distinct (xs::name list)) = distinct (pi \<bullet> xs)"
  by (induct xs) (simp_all add: eqvts)

primrec pat_type :: "pat \<Rightarrow> ty"
where
  "pat_type (PVar x T) = T"
| "pat_type \<langle>\<langle>p, q\<rangle>\<rangle> = pat_type p \<otimes> pat_type q"

lemma pat_type_eqvt [eqvt]:
  "(pi :: name prm) \<bullet> (pat_type p) = pat_type (pi \<bullet> p)"
  by (induct p) simp_all

lemma pat_type_perm_eq: "pat_type ((pi :: name prm) \<bullet> p) = pat_type p"
  by (induct p) (simp_all add: perm_type)

type_synonym ctx = "(name \<times> ty) list"

inductive
  ptyping :: "pat \<Rightarrow> ty \<Rightarrow> ctx \<Rightarrow> bool"  ("\<turnstile> _ : _ \<Rightarrow> _" [60, 60, 60] 60)
where
  PVar: "\<turnstile> PVar x T : T \<Rightarrow> [(x, T)]"
| PTuple: "\<turnstile> p : T \<Rightarrow> \<Delta>\<^sub>1 \<Longrightarrow> \<turnstile> q : U \<Rightarrow> \<Delta>\<^sub>2 \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> : T \<otimes> U \<Rightarrow> \<Delta>\<^sub>2 @ \<Delta>\<^sub>1"

lemma pat_vars_ptyping:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "pat_vars p = map fst \<Delta>" using assms
  by induct simp_all

inductive
  valid :: "ctx \<Rightarrow> bool"
where
  Nil [intro!]: "valid []"
| Cons [intro!]: "valid \<Gamma> \<Longrightarrow> x \<sharp> \<Gamma> \<Longrightarrow> valid ((x, T) # \<Gamma>)"

inductive_cases validE[elim!]: "valid ((x, T) # \<Gamma>)"

lemma fresh_ctxt_set_eq: "((x::name) \<sharp> (\<Gamma>::ctx)) = (x \<notin> fst ` set \<Gamma>)"
  by (induct \<Gamma>) (auto simp add: fresh_list_nil fresh_list_cons fresh_prod fresh_atm)

lemma valid_distinct: "valid \<Gamma> = distinct (map fst \<Gamma>)"
  by (induct \<Gamma>) (auto simp add: fresh_ctxt_set_eq [symmetric])

abbreviation
  "sub_ctx" :: "ctx \<Rightarrow> ctx \<Rightarrow> bool" ("_ \<sqsubseteq> _")
where
  "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^sub>1 \<longrightarrow> x \<in> set \<Gamma>\<^sub>2"

abbreviation
  Let_syn :: "pat \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm"  ("(LET (_ =/ _)/ IN (_))" 10)
where
  "LET p = t IN u \<equiv> Let (pat_type p) t (\<lambda>[p]. Base u)"

inductive typing :: "ctx \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60, 60, 60] 60)
where
  Var [intro]: "valid \<Gamma> \<Longrightarrow> (x, T) \<in> set \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| Tuple [intro]: "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> u : U \<Longrightarrow> \<Gamma> \<turnstile> \<langle>t, u\<rangle> : T \<otimes> U"
| Abs [intro]: "(x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>x:T. t) : T \<rightarrow> U"
| App [intro]: "\<Gamma> \<turnstile> t : T \<rightarrow> U \<Longrightarrow> \<Gamma> \<turnstile> u : T \<Longrightarrow> \<Gamma> \<turnstile> t \<cdot> u : U"
| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow>
    \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow>
    \<Gamma> \<turnstile> (LET p = t IN u) : U"

equivariance ptyping

equivariance valid

equivariance typing

lemma valid_typing:
  assumes "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>" using assms
  by induct auto

lemma pat_var:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "(supp p::name set) = supp \<Delta>" using assms
  by induct (auto simp add: supp_list_nil supp_list_cons supp_prod supp_list_append)

lemma valid_app_fresh:
  assumes "valid (\<Delta> @ \<Gamma>)" and "(x::name) \<in> supp \<Delta>"
  shows "x \<sharp> \<Gamma>" using assms
  by (induct \<Delta>)
    (auto simp add: supp_list_nil supp_list_cons supp_prod supp_atm fresh_list_append)

lemma pat_freshs:
  assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
  shows "(supp p::name set) \<sharp>* c = (supp \<Delta>::name set) \<sharp>* c" using assms
  by (auto simp add: fresh_star_def pat_var)

lemma valid_app_mono:
  assumes "valid (\<Delta> @ \<Gamma>\<^sub>1)" and "(supp \<Delta>::name set) \<sharp>* \<Gamma>\<^sub>2" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2"
  shows "valid (\<Delta> @ \<Gamma>\<^sub>2)" using assms
  by (induct \<Delta>)
    (auto simp add: supp_list_cons fresh_star_Un_elim supp_prod
       fresh_list_append supp_atm fresh_star_insert_elim fresh_star_empty_elim)

nominal_inductive2 typing
avoids
  Abs: "{x}"
| Let: "(supp p)::name set"
  by (auto simp add: fresh_star_def abs_fresh fin_supp pat_var
    dest!: valid_typing valid_app_fresh)

lemma better_T_Let [intro]:
  assumes t: "\<Gamma> \<turnstile> t : T" and p: "\<turnstile> p : T \<Rightarrow> \<Delta>" and u: "\<Delta> @ \<Gamma> \<turnstile> u : U"
  shows "\<Gamma> \<turnstile> (LET p = t IN u) : U"
proof -
  obtain pi::"name prm" where pi: "(pi \<bullet> (supp p::name set)) \<sharp>* (t, Base u, \<Gamma>)"
    and pi': "set pi \<subseteq> supp p \<times> (pi \<bullet> supp p)"
    by (rule at_set_avoiding [OF at_name_inst fin_supp fin_supp])
  from p u have p_fresh: "(supp p::name set) \<sharp>* \<Gamma>"
    by (auto simp add: fresh_star_def pat_var dest!: valid_typing valid_app_fresh)
  from pi have p_fresh': "(pi \<bullet> (supp p::name set)) \<sharp>* \<Gamma>"
    by (simp add: fresh_star_prod_elim)
  from pi have p_fresh'': "(pi \<bullet> (supp p::name set)) \<sharp>* Base u"
    by (simp add: fresh_star_prod_elim)
  from pi have "(supp (pi \<bullet> p)::name set) \<sharp>* t"
    by (simp add: fresh_star_prod_elim eqvts)
  moreover note t
  moreover from p have "pi \<bullet> (\<turnstile> p : T \<Rightarrow> \<Delta>)" by (rule perm_boolI)
  then have "\<turnstile> (pi \<bullet> p) : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: eqvts perm_type)
  moreover from u have "pi \<bullet> (\<Delta> @ \<Gamma> \<turnstile> u : U)" by (rule perm_boolI)
  with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' p_fresh p_fresh']
  have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> (pi \<bullet> u) : U" by (simp add: eqvts perm_type)
  ultimately have "\<Gamma> \<turnstile> (LET (pi \<bullet> p) = t IN (pi \<bullet> u)) : U"
    by (rule Let)
  then show ?thesis by (simp add: abs_pat_alpha [OF p_fresh'' pi'] pat_type_perm_eq)
qed

lemma weakening:
  assumes "\<Gamma>\<^sub>1 \<turnstile> t : T" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<sqsubseteq> \<Gamma>\<^sub>2"
  shows "\<Gamma>\<^sub>2 \<turnstile> t : T" using assms
  apply (nominal_induct \<Gamma>\<^sub>1 t T avoiding: \<Gamma>\<^sub>2 rule: typing.strong_induct)
  apply auto
  apply (drule_tac x="(x, T) # \<Gamma>\<^sub>2" in meta_spec)
  apply (auto intro: valid_typing)
  apply (drule_tac x="\<Gamma>\<^sub>2" in meta_spec)
  apply (drule_tac x="\<Delta> @ \<Gamma>\<^sub>2" in meta_spec)
  apply (auto intro: valid_typing)
  apply (rule typing.Let)
  apply assumption+
  apply (drule meta_mp)
  apply (rule valid_app_mono)
  apply (rule valid_typing)
  apply assumption
  apply (auto simp add: pat_freshs)
  done

inductive
  match :: "pat \<Rightarrow> trm \<Rightarrow> (name \<times> trm) list \<Rightarrow> bool"  ("\<turnstile> _ \<rhd> _ \<Rightarrow> _" [50, 50, 50] 50)
where
  PVar: "\<turnstile> PVar x T \<rhd> t \<Rightarrow> [(x, t)]"
| PProd: "\<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> \<turnstile> q \<rhd> u \<Rightarrow> \<theta>' \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> \<langle>t, u\<rangle> \<Rightarrow> \<theta> @ \<theta>'"

fun
  lookup :: "(name \<times> trm) list \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x = Var x"
| "lookup ((y, e) # \<theta>) x = (if x = y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi :: "name prm"
  and   \<theta> :: "(name \<times> trm) list"
  and   X :: "name"
  shows "pi \<bullet> (lookup \<theta> X) = lookup (pi \<bullet> \<theta>) (pi \<bullet> X)"
  by (induct \<theta>) (auto simp add: eqvts)

nominal_primrec
  psubst :: "(name \<times> trm) list \<Rightarrow> trm \<Rightarrow> trm"  ("_\<lparr>_\<rparr>" [95,0] 210)
  and psubstb :: "(name \<times> trm) list \<Rightarrow> btrm \<Rightarrow> btrm"  ("_\<lparr>_\<rparr>\<^sub>b" [95,0] 210)
where
  "\<theta>\<lparr>Var x\<rparr> = (lookup \<theta> x)"
| "\<theta>\<lparr>t \<cdot> u\<rparr> = \<theta>\<lparr>t\<rparr> \<cdot> \<theta>\<lparr>u\<rparr>"
| "\<theta>\<lparr>\<langle>t, u\<rangle>\<rparr> = \<langle>\<theta>\<lparr>t\<rparr>, \<theta>\<lparr>u\<rparr>\<rangle>"
| "\<theta>\<lparr>Let T t u\<rparr> = Let T (\<theta>\<lparr>t\<rparr>) (\<theta>\<lparr>u\<rparr>\<^sub>b)"
| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>x:T. t\<rparr> = (\<lambda>x:T. \<theta>\<lparr>t\<rparr>)"
| "\<theta>\<lparr>Base t\<rparr>\<^sub>b = Base (\<theta>\<lparr>t\<rparr>)"
| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>Bind T x t\<rparr>\<^sub>b = Bind T x (\<theta>\<lparr>t\<rparr>\<^sub>b)"
  apply finite_guess+
  apply (simp add: abs_fresh | fresh_guess)+
  done

lemma lookup_fresh:
  "x = y \<longrightarrow> x \<in> set (map fst \<theta>) \<Longrightarrow> \<forall>(y, t)\<in>set \<theta>. x \<sharp> t \<Longrightarrow> x \<sharp> lookup \<theta> y"
  apply (induct \<theta>)
  apply (simp_all add: split_paired_all fresh_atm)
  apply (case_tac "x = y")
  apply (auto simp add: fresh_atm)
  done

lemma psubst_fresh:
  assumes "x \<in> set (map fst \<theta>)" and "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t"
  shows "x \<sharp> \<theta>\<lparr>t\<rparr>" and "x \<sharp> \<theta>\<lparr>t'\<rparr>\<^sub>b" using assms
  apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
  apply simp
  apply (rule lookup_fresh)
  apply (rule impI)
  apply (simp_all add: abs_fresh)
  done

lemma psubst_eqvt[eqvt]:
  fixes pi :: "name prm"
  shows "pi \<bullet> (\<theta>\<lparr>t\<rparr>) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t\<rparr>"
  and "pi \<bullet> (\<theta>\<lparr>t'\<rparr>\<^sub>b) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t'\<rparr>\<^sub>b"
  by (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
    (simp_all add: eqvts fresh_bij)

abbreviation
  subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_\<mapsto>_]" [100,0,0] 100)
where
  "t[x\<mapsto>t'] \<equiv> [(x,t')]\<lparr>t\<rparr>"

abbreviation
  substb :: "btrm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> btrm" ("_[_\<mapsto>_]\<^sub>b" [100,0,0] 100)
where
  "t[x\<mapsto>t']\<^sub>b \<equiv> [(x,t')]\<lparr>t\<rparr>\<^sub>b"

lemma lookup_forget:
  "(supp (map fst \<theta>)::name set) \<sharp>* x \<Longrightarrow> lookup \<theta> x = Var x"
  by (induct \<theta>) (auto simp add: split_paired_all fresh_star_def fresh_atm supp_list_cons supp_atm)

lemma supp_fst: "(x::name) \<in> supp (map fst (\<theta>::(name \<times> trm) list)) \<Longrightarrow> x \<in> supp \<theta>"
  by (induct \<theta>) (auto simp add: supp_list_nil supp_list_cons supp_prod)

lemma psubst_forget:
  "(supp (map fst \<theta>)::name set) \<sharp>* t \<Longrightarrow> \<theta>\<lparr>t\<rparr> = t"
  "(supp (map fst \<theta>)::name set) \<sharp>* t' \<Longrightarrow> \<theta>\<lparr>t'\<rparr>\<^sub>b = t'"
  apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
  apply (auto simp add: fresh_star_def lookup_forget abs_fresh)
  apply (drule_tac x=\<theta> in meta_spec)
  apply (drule meta_mp)
  apply (rule ballI)
  apply (drule_tac x=x in bspec)
  apply assumption
  apply (drule supp_fst)
  apply (auto simp add: fresh_def)
  apply (drule_tac x=\<theta> in meta_spec)
  apply (drule meta_mp)
  apply (rule ballI)
  apply (drule_tac x=x in bspec)
  apply assumption
  apply (drule supp_fst)
  apply (auto simp add: fresh_def)
  done

lemma psubst_nil: "[]\<lparr>t\<rparr> = t" "[]\<lparr>t'\<rparr>\<^sub>b = t'"
  by (induct t and t' rule: trm_btrm.inducts) (simp_all add: fresh_list_nil)

lemma psubst_cons:
  assumes "(supp (map fst \<theta>)::name set) \<sharp>* u"
  shows "((x, u) # \<theta>)\<lparr>t\<rparr> = \<theta>\<lparr>t[x\<mapsto>u]\<rparr>" and "((x, u) # \<theta>)\<lparr>t'\<rparr>\<^sub>b = \<theta>\<lparr>t'[x\<mapsto>u]\<^sub>b\<rparr>\<^sub>b"
  using assms
  by (nominal_induct t and t' avoiding: x u \<theta> rule: trm_btrm.strong_inducts)
    (simp_all add: fresh_list_nil fresh_list_cons psubst_forget)

lemma psubst_append:
  "(supp (map fst (\<theta>\<^sub>1 @ \<theta>\<^sub>2))::name set) \<sharp>* map snd (\<theta>\<^sub>1 @ \<theta>\<^sub>2) \<Longrightarrow> (\<theta>\<^sub>1 @ \<theta>\<^sub>2)\<lparr>t\<rparr> = \<theta>\<^sub>2\<lparr>\<theta>\<^sub>1\<lparr>t\<rparr>\<rparr>"
  by (induct \<theta>\<^sub>1 arbitrary: t)
    (simp_all add: psubst_nil split_paired_all supp_list_cons psubst_cons fresh_star_def
      fresh_list_cons fresh_list_append supp_list_append)

lemma abs_pat_psubst [simp]:
  "(supp p::name set) \<sharp>* \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>[p]. t\<rparr>\<^sub>b = (\<lambda>[p]. \<theta>\<lparr>t\<rparr>\<^sub>b)"
  by (induct p arbitrary: t) (auto simp add: fresh_star_def supp_atm)

lemma valid_insert:
  assumes "valid (\<Delta> @ [(x, T)] @ \<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)" using assms
  by (induct \<Delta>)
    (auto simp add: fresh_list_append fresh_list_cons)

lemma fresh_set:
  shows "y \<sharp> xs = (\<forall>x\<in>set xs. y \<sharp> x)"
  by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes "valid \<Gamma>"
  and "(x, T) \<in> set \<Gamma>"
  and "(x, U) \<in> set \<Gamma>"
  shows "T = U" using assms
  by induct (auto simp add: fresh_set fresh_prod fresh_atm)

lemma subst_type_aux:
  assumes a: "\<Delta> @ [(x, U)] @ \<Gamma> \<turnstile> t : T"
  and b: "\<Gamma> \<turnstile> u : U"
  shows "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" using a b
proof (nominal_induct \<Gamma>'\<equiv>"\<Delta> @ [(x, U)] @ \<Gamma>" t T avoiding: x u \<Delta> rule: typing.strong_induct)
  case (Var y T x u \<Delta>)
  from \<open>valid (\<Delta> @ [(x, U)] @ \<Gamma>)\<close>
  have valid: "valid (\<Delta> @ \<Gamma>)" by (rule valid_insert)
  show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T"
  proof cases
    assume eq: "x = y"
    from Var eq have "T = U" by (auto intro: context_unique)
    with Var eq valid show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" by (auto intro: weakening)
  next
    assume ineq: "x \<noteq> y"
    from Var ineq have "(y, T) \<in> set (\<Delta> @ \<Gamma>)" by simp
    then show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" using ineq valid by auto
  qed
next
  case (Tuple t\<^sub>1 T\<^sub>1 t\<^sub>2 T\<^sub>2)
  from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>1[x\<mapsto>u] : T\<^sub>1" by (rule Tuple)
  moreover from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2[x\<mapsto>u] : T\<^sub>2" by (rule Tuple)
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> \<langle>t\<^sub>1[x\<mapsto>u], t\<^sub>2[x\<mapsto>u]\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2" ..
  then show ?case by simp
next
  case (Let p t T \<Delta>' s S)
  from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" by (rule Let)
  moreover note \<open>\<turnstile> p : T \<Rightarrow> \<Delta>'\<close>
  moreover have "\<Delta>' @ (\<Delta> @ [(x, U)] @ \<Gamma>) = (\<Delta>' @ \<Delta>) @ [(x, U)] @ \<Gamma>" by simp
  then have "(\<Delta>' @ \<Delta>) @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" using \<open>\<Gamma> \<turnstile> u : U\<close> by (rule Let)
  then have "\<Delta>' @ \<Delta> @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" by simp
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> (LET p = t[x\<mapsto>u] IN s[x\<mapsto>u]) : S"
    by (rule better_T_Let)
  moreover from Let have "(supp p::name set) \<sharp>* [(x, u)]"
    by (simp add: fresh_star_def fresh_list_nil fresh_list_cons)
  ultimately show ?case by simp
next
  case (Abs y T t S)
  have "(y, T) # \<Delta> @ [(x, U)] @ \<Gamma> = ((y, T) # \<Delta>) @ [(x, U)] @ \<Gamma>"
    by simp
  then have "((y, T) # \<Delta>) @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" using \<open>\<Gamma> \<turnstile> u : U\<close> by (rule Abs)
  then have "(y, T) # \<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" by simp
  then have "\<Delta> @ \<Gamma> \<turnstile> (\<lambda>y:T. t[x\<mapsto>u]) : T \<rightarrow> S"
    by (rule typing.Abs)
  moreover from Abs have "y \<sharp> [(x, u)]"
    by (simp add: fresh_list_nil fresh_list_cons)
  ultimately show ?case by simp
next
  case (App t\<^sub>1 T S t\<^sub>2)
  from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>1[x\<mapsto>u] : T \<rightarrow> S" by (rule App)
  moreover from refl \<open>\<Gamma> \<turnstile> u : U\<close>
  have "\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2[x\<mapsto>u] : T" by (rule App)
  ultimately have "\<Delta> @ \<Gamma> \<turnstile> (t\<^sub>1[x\<mapsto>u]) \<cdot> (t\<^sub>2[x\<mapsto>u]) : S"
    by (rule typing.App)
  then show ?case by simp
qed

lemmas subst_type = subst_type_aux [of "[]", simplified]

lemma match_supp_fst:
  assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map fst \<theta>)::name set) = supp p" using assms
  by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append)

lemma match_supp_snd:
  assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map snd \<theta>)::name set) = supp u" using assms
  by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append trm.supp)

lemma match_fresh: "\<turnstile> p \<rhd> u \<Rightarrow> \<theta> \<Longrightarrow> (supp p::name set) \<sharp>* u \<Longrightarrow>
  (supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
  by (simp add: fresh_star_def fresh_def match_supp_fst match_supp_snd)

lemma match_type_aux:
  assumes "\<turnstile> p : U \<Rightarrow> \<Delta>"
  and "\<Gamma>\<^sub>2 \<turnstile> u : U"
  and "\<Gamma>\<^sub>1 @ \<Delta> @ \<Gamma>\<^sub>2 \<turnstile> t : T"
  and "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>"
  and "(supp p::name set) \<sharp>* u"
  shows "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<lparr>t\<rparr> : T" using assms
proof (induct arbitrary: \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 t u T \<theta>)
  case (PVar x U)
  from \<open>\<Gamma>\<^sub>1 @ [(x, U)] @ \<Gamma>\<^sub>2 \<turnstile> t : T\<close> \<open>\<Gamma>\<^sub>2 \<turnstile> u : U\<close>
  have "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> t[x\<mapsto>u] : T" by (rule subst_type_aux)
  moreover from \<open>\<turnstile> PVar x U \<rhd> u \<Rightarrow> \<theta>\<close> have "\<theta> = [(x, u)]"
    by cases simp_all
  ultimately show ?case by simp
next
  case (PTuple p S \<Delta>\<^sub>1 q U \<Delta>\<^sub>2)
  from \<open>\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>\<close> obtain u\<^sub>1 u\<^sub>2 \<theta>\<^sub>1 \<theta>\<^sub>2
    where u: "u = \<langle>u\<^sub>1, u\<^sub>2\<rangle>" and \<theta>: "\<theta> = \<theta>\<^sub>1 @ \<theta>\<^sub>2"
    and p: "\<turnstile> p \<rhd> u\<^sub>1 \<Rightarrow> \<theta>\<^sub>1" and q: "\<turnstile> q \<rhd> u\<^sub>2 \<Rightarrow> \<theta>\<^sub>2"
    by cases simp_all
  with PTuple have "\<Gamma>\<^sub>2 \<turnstile> \<langle>u\<^sub>1, u\<^sub>2\<rangle> : S \<otimes> U" by simp
  then obtain u\<^sub>1: "\<Gamma>\<^sub>2 \<turnstile> u\<^sub>1 : S" and u\<^sub>2: "\<Gamma>\<^sub>2 \<turnstile> u\<^sub>2 : U"
    by cases (simp_all add: ty.inject trm.inject)
  note u\<^sub>1
  moreover from \<open>\<Gamma>\<^sub>1 @ (\<Delta>\<^sub>2 @ \<Delta>\<^sub>1) @ \<Gamma>\<^sub>2 \<turnstile> t : T\<close>
  have "(\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2) @ \<Delta>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> t : T" by simp
  moreover note p
  moreover from \<open>supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u\<close> and u
  have "(supp p::name set) \<sharp>* u\<^sub>1" by (simp add: fresh_star_def)
  ultimately have \<theta>\<^sub>1: "(\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2) @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>1\<lparr>t\<rparr> : T"
    by (rule PTuple)
  note u\<^sub>2
  moreover from \<theta>\<^sub>1
  have "\<Gamma>\<^sub>1 @ \<Delta>\<^sub>2 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>1\<lparr>t\<rparr> : T" by simp
  moreover note q
  moreover from \<open>supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u\<close> and u
  have "(supp q::name set) \<sharp>* u\<^sub>2" by (simp add: fresh_star_def)
  ultimately have "\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<theta>\<^sub>2\<lparr>\<theta>\<^sub>1\<lparr>t\<rparr>\<rparr> : T"
    by (rule PTuple)
  moreover from \<open>\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>\<close> \<open>supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u\<close>
  have "(supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
    by (rule match_fresh)
  ultimately show ?case using \<theta> by (simp add: psubst_append)
qed

lemmas match_type = match_type_aux [where \<Gamma>\<^sub>1="[]", simplified]

inductive eval :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<longmapsto> _" [60,60] 60)
where
  TupleL: "t \<longmapsto> t' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t', u\<rangle>"
| TupleR: "u \<longmapsto> u' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t, u'\<rangle>"
| Abs: "t \<longmapsto> t' \<Longrightarrow> (\<lambda>x:T. t) \<longmapsto> (\<lambda>x:T. t')"
| AppL: "t \<longmapsto> t' \<Longrightarrow> t \<cdot> u \<longmapsto> t' \<cdot> u"
| AppR: "u \<longmapsto> u' \<Longrightarrow> t \<cdot> u \<longmapsto> t \<cdot> u'"
| Beta: "x \<sharp> u \<Longrightarrow> (\<lambda>x:T. t) \<cdot> u \<longmapsto> t[x\<mapsto>u]"
| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow> distinct (pat_vars p) \<Longrightarrow>
    \<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> (LET p = t IN u) \<longmapsto> \<theta>\<lparr>u\<rparr>"

equivariance match

equivariance eval

lemma match_vars:
  assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "x \<in> supp p"
  shows "x \<in> set (map fst \<theta>)" using assms
  by induct (auto simp add: supp_atm)

lemma match_fresh_mono:
  assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "(x::name) \<sharp> t"
  shows "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t" using assms
  by induct auto

nominal_inductive2 eval
avoids
  Abs: "{x}"
| Beta: "{x}"
| Let: "(supp p)::name set"
  apply (simp_all add: fresh_star_def abs_fresh fin_supp)
  apply (rule psubst_fresh)
  apply simp
  apply simp
  apply (rule ballI)
  apply (rule psubst_fresh)
  apply (rule match_vars)
  apply assumption+
  apply (rule match_fresh_mono)
  apply auto
  done

lemma typing_case_Abs:
  assumes ty: "\<Gamma> \<turnstile> (\<lambda>x:T. t) : S"
  and fresh: "x \<sharp> \<Gamma>"
  and R: "\<And>U. S = T \<rightarrow> U \<Longrightarrow> (x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> P"
  shows P using ty
proof cases
  case (Abs x' T' t' U)
  obtain y::name where y: "y \<sharp> (x, \<Gamma>, \<lambda>x':T'. t')"
    by (rule exists_fresh) (auto intro: fin_supp)
  from \<open>(\<lambda>x:T. t) = (\<lambda>x':T'. t')\<close> [symmetric]
  have x: "x \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
  have x': "x' \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
  from \<open>(x', T') # \<Gamma> \<turnstile> t' : U\<close> have x'': "x' \<sharp> \<Gamma>"
    by (auto dest: valid_typing)
  have "(\<lambda>x:T. t) = (\<lambda>x':T'. t')" by fact
  also from x x' y have "\<dots> = [(x, y)] \<bullet> [(x', y)] \<bullet> (\<lambda>x':T'. t')"
    by (simp only: perm_fresh_fresh fresh_prod)
  also have "\<dots> = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')"
    by (simp add: swap_simps perm_fresh_fresh)
  finally have "(\<lambda>x:T. t) = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')" .
  then have T: "T = T'" and t: "[(x, y)] \<bullet> [(x', y)] \<bullet> t' = t"
    by (simp_all add: trm.inject alpha)
  from Abs T have "S = T \<rightarrow> U" by simp
  moreover from \<open>(x', T') # \<Gamma> \<turnstile> t' : U\<close>
  have "[(x, y)] \<bullet> [(x', y)] \<bullet> ((x', T') # \<Gamma> \<turnstile> t' : U)"
    by (simp add: perm_bool)
  with T t y x'' fresh have "(x, T) # \<Gamma> \<turnstile> t : U"
    by (simp add: eqvts swap_simps perm_fresh_fresh fresh_prod)
  ultimately show ?thesis by (rule R)
qed simp_all

nominal_primrec ty_size :: "ty \<Rightarrow> nat"
where
  "ty_size (Atom n) = 0"
| "ty_size (T \<rightarrow> U) = ty_size T + ty_size U + 1"
| "ty_size (T \<otimes> U) = ty_size T + ty_size U + 1"
  by (rule TrueI)+

lemma bind_tuple_ineq:
  "ty_size (pat_type p) < ty_size U \<Longrightarrow> Bind U x t \<noteq> (\<lambda>[p]. u)"
  by (induct p arbitrary: U x t u) (auto simp add: btrm.inject)

lemma valid_appD: assumes "valid (\<Gamma> @ \<Delta>)"
  shows "valid \<Gamma>" "valid \<Delta>" using assms
  by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
    (auto simp add: Cons_eq_append_conv fresh_list_append)

lemma valid_app_freshs: assumes "valid (\<Gamma> @ \<Delta>)"
  shows "(supp \<Gamma>::name set) \<sharp>* \<Delta>" "(supp \<Delta>::name set) \<sharp>* \<Gamma>" using assms
  by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
    (auto simp add: Cons_eq_append_conv fresh_star_def
     fresh_list_nil fresh_list_cons supp_list_nil supp_list_cons fresh_list_append
     supp_prod fresh_prod supp_atm fresh_atm
     dest: notE [OF iffD1 [OF fresh_def]])

lemma perm_mem_left: "(x::name) \<in> ((pi::name prm) \<bullet> A) \<Longrightarrow> (rev pi \<bullet> x) \<in> A"
  by (drule perm_boolI [of _ "rev pi"]) (simp add: eqvts perm_pi_simp)

lemma perm_mem_right: "(rev (pi::name prm) \<bullet> (x::name)) \<in> A \<Longrightarrow> x \<in> (pi \<bullet> A)"
  by (drule perm_boolI [of _ pi]) (simp add: eqvts perm_pi_simp)

lemma perm_cases:
  assumes pi: "set pi \<subseteq> A \<times> A"
  shows "((pi::name prm) \<bullet> B) \<subseteq> A \<union> B"
proof
  fix x assume "x \<in> pi \<bullet> B"
  then show "x \<in> A \<union> B" using pi
    apply (induct pi arbitrary: x B rule: rev_induct)
    apply simp
    apply (simp add: split_paired_all supp_eqvt)
    apply (drule perm_mem_left)
    apply (simp add: calc_atm split: if_split_asm)
    apply (auto dest: perm_mem_right)
    done
qed

lemma abs_pat_alpha':
  assumes eq: "(\<lambda>[p]. t) = (\<lambda>[q]. u)"
  and ty: "pat_type p = pat_type q"
  and pv: "distinct (pat_vars p)"
  and qv: "distinct (pat_vars q)"
  shows "\<exists>pi::name prm. p = pi \<bullet> q \<and> t = pi \<bullet> u \<and>
    set pi \<subseteq> (supp p \<union> supp q) \<times> (supp p \<union> supp q)"
  using assms
proof (induct p arbitrary: q t u)
  case (PVar x T)
  note PVar' = this
  show ?case
  proof (cases q)
    case (PVar x' T')
    with \<open>(\<lambda>[PVar x T]. t) = (\<lambda>[q]. u)\<close>
    have "x = x' \<and> t = u \<or> x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
      by (simp add: btrm.inject alpha)
    then show ?thesis
    proof
      assume "x = x' \<and> t = u"
      with PVar PVar' have "PVar x T = ([]::name prm) \<bullet> q \<and>
        t = ([]::name prm) \<bullet> u \<and>
        set ([]::name prm) \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
          (supp (PVar x T) \<union> supp q)" by simp
      then show ?thesis ..
    next
      assume "x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
      with PVar PVar' have "PVar x T = [(x, x')] \<bullet> q \<and>
        t = [(x, x')] \<bullet> u \<and>
        set [(x, x')] \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
          (supp (PVar x T) \<union> supp q)"
        by (simp add: perm_swap swap_simps supp_atm perm_type)
      then show ?thesis ..
    qed
  next
    case (PTuple p\<^sub>1 p\<^sub>2)
    with PVar have "ty_size (pat_type p\<^sub>1) < ty_size T" by simp
    then have "Bind T x t \<noteq> (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. u)"
      by (rule bind_tuple_ineq)
    moreover from PTuple PVar
    have "Bind T x t = (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. u)" by simp
    ultimately show ?thesis ..
  qed
next
  case (PTuple p\<^sub>1 p\<^sub>2)
  note PTuple' = this
  show ?case
  proof (cases q)
    case (PVar x T)
    with PTuple have "ty_size (pat_type p\<^sub>1) < ty_size T" by auto
    then have "Bind T x u \<noteq> (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t)"
      by (rule bind_tuple_ineq)
    moreover from PTuple PVar
    have "Bind T x u = (\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t)" by simp
    ultimately show ?thesis ..
  next
    case (PTuple p\<^sub>1' p\<^sub>2')
    with PTuple' have "(\<lambda>[p\<^sub>1]. \<lambda>[p\<^sub>2]. t) = (\<lambda>[p\<^sub>1']. \<lambda>[p\<^sub>2']. u)" by simp
    moreover from PTuple PTuple' have "pat_type p\<^sub>1 = pat_type p\<^sub>1'"
      by (simp add: ty.inject)
    moreover from PTuple' have "distinct (pat_vars p\<^sub>1)" by simp
    moreover from PTuple PTuple' have "distinct (pat_vars p\<^sub>1')" by simp
    ultimately have "\<exists>pi::name prm. p\<^sub>1 = pi \<bullet> p\<^sub>1' \<and>
      (\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u) \<and>
      set pi \<subseteq> (supp p\<^sub>1 \<union> supp p\<^sub>1') \<times> (supp p\<^sub>1 \<union> supp p\<^sub>1')"
      by (rule PTuple')
    then obtain pi::"name prm" where
      "p\<^sub>1 = pi \<bullet> p\<^sub>1'" "(\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u)" and
      pi: "set pi \<subseteq> (supp p\<^sub>1 \<union> supp p\<^sub>1') \<times> (supp p\<^sub>1 \<union> supp p\<^sub>1')" by auto
    from \<open>(\<lambda>[p\<^sub>2]. t) = pi \<bullet> (\<lambda>[p\<^sub>2']. u)\<close>
    have "(\<lambda>[p\<^sub>2]. t) = (\<lambda>[pi \<bullet> p\<^sub>2']. pi \<bullet> u)"
      by (simp add: eqvts)
    moreover from PTuple PTuple' have "pat_type p\<^sub>2 = pat_type (pi \<bullet> p\<^sub>2')"
      by (simp add: ty.inject pat_type_perm_eq)
    moreover from PTuple' have "distinct (pat_vars p\<^sub>2)" by simp
    moreover from PTuple PTuple' have "distinct (pat_vars (pi \<bullet> p\<^sub>2'))"
      by (simp add: pat_vars_eqvt [symmetric] distinct_eqvt [symmetric])
    ultimately have "\<exists>pi'::name prm. p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2' \<and>
      t = pi' \<bullet> pi \<bullet> u \<and>
      set pi' \<subseteq> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2'))"
      by (rule PTuple')
    then obtain pi'::"name prm" where
      "p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2'" "t = pi' \<bullet> pi \<bullet> u" and
      pi': "set pi' \<subseteq> (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2')) \<times>
        (supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2'))" by auto
    from PTuple PTuple' have "pi \<bullet> distinct (pat_vars \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>)" by simp
    then have "distinct (pat_vars \<langle>\<langle>pi \<bullet> p\<^sub>1', pi \<bullet> p\<^sub>2'\<rangle>\<rangle>)" by (simp only: eqvts)
    with \<open>p\<^sub>1 = pi \<bullet> p\<^sub>1'\<close> PTuple'
    have fresh: "(supp p\<^sub>2 \<union> supp (pi \<bullet> p\<^sub>2') :: name set) \<sharp>* p\<^sub>1"
      by (auto simp add: set_pat_vars_supp fresh_star_def fresh_def eqvts)
    from \<open>p\<^sub>1 = pi \<bullet> p\<^sub>1'\<close> have "pi' \<bullet> (p\<^sub>1 = pi \<bullet> p\<^sub>1')" by (rule perm_boolI)
    with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' fresh fresh]
    have "p\<^sub>1 = pi' \<bullet> pi \<bullet> p\<^sub>1'" by (simp add: eqvts)
    with \<open>p\<^sub>2 = pi' \<bullet> pi \<bullet> p\<^sub>2'\<close> have "\<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>"
      by (simp add: pt_name2)
    moreover
    have "((supp p\<^sub>2 \<union> (pi \<bullet> supp p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> (pi \<bullet> supp p\<^sub>2'))::(name \<times> name) set) \<subseteq>
      (supp p\<^sub>2 \<union> (supp p\<^sub>1 \<union> supp p\<^sub>1' \<union> supp p\<^sub>2')) \<times> (supp p\<^sub>2 \<union> (supp p\<^sub>1 \<union> supp p\<^sub>1' \<union> supp p\<^sub>2'))"
      by (rule subset_refl Sigma_mono Un_mono perm_cases [OF pi])+
    with pi' have "set pi' \<subseteq> \<dots>" by (simp add: supp_eqvt [symmetric])
    with pi have "set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>) \<times>
      (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^sub>1', p\<^sub>2'\<rangle>\<rangle>)"
      by (simp add: Sigma_Un_distrib1 Sigma_Un_distrib2 Un_ac) blast
    moreover note \<open>t = pi' \<bullet> pi \<bullet> u\<close>
    ultimately have "\<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> q \<and> t = (pi' @ pi) \<bullet> u \<and>
      set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp q) \<times>
        (supp \<langle>\<langle>p\<^sub>1, p\<^sub>2\<rangle>\<rangle> \<union> supp q)" using PTuple
      by (simp add: pt_name2)
    then show ?thesis ..
  qed
qed

lemma typing_case_Let:
  assumes ty: "\<Gamma> \<turnstile> (LET p = t IN u) : U"
  and fresh: "(supp p::name set) \<sharp>* \<Gamma>"
  and distinct: "distinct (pat_vars p)"
  and R: "\<And>T \<Delta>. \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow> P"
  shows P using ty
proof cases
  case (Let p' t' T \<Delta> u')
  then have "(supp \<Delta>::name set) \<sharp>* \<Gamma>"
    by (auto intro: valid_typing valid_app_freshs)
  with Let have "(supp p'::name set) \<sharp>* \<Gamma>"
    by (simp add: pat_var)
  with fresh have fresh': "(supp p \<union> supp p' :: name set) \<sharp>* \<Gamma>"
    by (auto simp add: fresh_star_def)
  from Let have "(\<lambda>[p]. Base u) = (\<lambda>[p']. Base u')"
    by (simp add: trm.inject)
  moreover from Let have "pat_type p = pat_type p'"
    by (simp add: trm.inject)
  moreover note distinct
  moreover from \<open>\<Delta> @ \<Gamma> \<turnstile> u' : U\<close> have "valid (\<Delta> @ \<Gamma>)"
    by (rule valid_typing)
  then have "valid \<Delta>" by (rule valid_appD)
  with \<open>\<turnstile> p' : T \<Rightarrow> \<Delta>\<close> have "distinct (pat_vars p')"
    by (simp add: valid_distinct pat_vars_ptyping)
  ultimately have "\<exists>pi::name prm. p = pi \<bullet> p' \<and> Base u = pi \<bullet> Base u' \<and>
    set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
    by (rule abs_pat_alpha')
  then obtain pi::"name prm" where pi: "p = pi \<bullet> p'" "u = pi \<bullet> u'"
    and pi': "set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
    by (auto simp add: btrm.inject)
  from Let have "\<Gamma> \<turnstile> t : T" by (simp add: trm.inject)
  moreover from \<open>\<turnstile> p' : T \<Rightarrow> \<Delta>\<close> have "\<turnstile> (pi \<bullet> p') : (pi \<bullet> T) \<Rightarrow> (pi \<bullet> \<Delta>)"
    by (simp add: ptyping.eqvt)
  with pi have "\<turnstile> p : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: perm_type)
  moreover from Let
  have "(pi \<bullet> \<Delta>) @ (pi \<bullet> \<Gamma>) \<turnstile> (pi \<bullet> u') : (pi \<bullet> U)"
    by (simp add: append_eqvt [symmetric] typing.eqvt)
  with pi have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> u : U"
    by (simp add: perm_type pt_freshs_freshs
      [OF pt_name_inst at_name_inst pi' fresh' fresh'])
  ultimately show ?thesis by (rule R)
qed simp_all

lemma preservation:
  assumes "t \<longmapsto> t'" and "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T" using assms
proof (nominal_induct avoiding: \<Gamma> T rule: eval.strong_induct)
  case (TupleL t t' u)
  from \<open>\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T\<close> obtain T\<^sub>1 T\<^sub>2
    where "T = T\<^sub>1 \<otimes> T\<^sub>2" "\<Gamma> \<turnstile> t : T\<^sub>1" "\<Gamma> \<turnstile> u : T\<^sub>2"
    by cases (simp_all add: trm.inject)
  from \<open>\<Gamma> \<turnstile> t : T\<^sub>1\<close> have "\<Gamma> \<turnstile> t' : T\<^sub>1" by (rule TupleL)
  then have "\<Gamma> \<turnstile> \<langle>t', u\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2" using \<open>\<Gamma> \<turnstile> u : T\<^sub>2\<close>
    by (rule Tuple)
  with \<open>T = T\<^sub>1 \<otimes> T\<^sub>2\<close> show ?case by simp
next
  case (TupleR u u' t)
  from \<open>\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T\<close> obtain T\<^sub>1 T\<^sub>2
    where "T = T\<^sub>1 \<otimes> T\<^sub>2" "\<Gamma> \<turnstile> t : T\<^sub>1" "\<Gamma> \<turnstile> u : T\<^sub>2"
    by cases (simp_all add: trm.inject)
  from \<open>\<Gamma> \<turnstile> u : T\<^sub>2\<close> have "\<Gamma> \<turnstile> u' : T\<^sub>2" by (rule TupleR)
  with \<open>\<Gamma> \<turnstile> t : T\<^sub>1\<close> have "\<Gamma> \<turnstile> \<langle>t, u'\<rangle> : T\<^sub>1 \<otimes> T\<^sub>2"
    by (rule Tuple)
  with \<open>T = T\<^sub>1 \<otimes> T\<^sub>2\<close> show ?case by simp
next
  case (Abs t t' x S)
  from \<open>\<Gamma> \<turnstile> (\<lambda>x:S. t) : T\<close> \<open>x \<sharp> \<Gamma>\<close> obtain U where
    T: "T = S \<rightarrow> U" and U: "(x, S) # \<Gamma> \<turnstile> t : U"
    by (rule typing_case_Abs)
  from U have "(x, S) # \<Gamma> \<turnstile> t' : U" by (rule Abs)
  then have "\<Gamma> \<turnstile> (\<lambda>x:S. t') : S \<rightarrow> U"
    by (rule typing.Abs)
  with T show ?case by simp
next
  case (Beta x u S t)
  from \<open>\<Gamma> \<turnstile> (\<lambda>x:S. t) \<cdot> u : T\<close> \<open>x \<sharp> \<Gamma>\<close>
  obtain "(x, S) # \<Gamma> \<turnstile> t : T" and "\<Gamma> \<turnstile> u : S"
    by cases (auto simp add: trm.inject ty.inject elim: typing_case_Abs)
  then show ?case by (rule subst_type)
next
  case (Let p t \<theta> u)
  from \<open>\<Gamma> \<turnstile> (LET p = t IN u) : T\<close> \<open>supp p \<sharp>* \<Gamma>\<close> \<open>distinct (pat_vars p)\<close>
  obtain U \<Delta> where "\<turnstile> p : U \<Rightarrow> \<Delta>" "\<Gamma> \<turnstile> t : U" "\<Delta> @ \<Gamma> \<turnstile> u : T"
    by (rule typing_case_Let)
  then show ?case using \<open>\<turnstile> p \<rhd> t \<Rightarrow> \<theta>\<close> \<open>supp p \<sharp>* t\<close>
    by (rule match_type)
next
  case (AppL t t' u)
  from \<open>\<Gamma> \<turnstile> t \<cdot> u : T\<close> obtain U where
    t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
    by cases (auto simp add: trm.inject)
  from t have "\<Gamma> \<turnstile> t' : U \<rightarrow> T" by (rule AppL)
  then show ?case using u by (rule typing.App)
next
  case (AppR u u' t)
  from \<open>\<Gamma> \<turnstile> t \<cdot> u : T\<close> obtain U where
    t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
    by cases (auto simp add: trm.inject)
  from u have "\<Gamma> \<turnstile> u' : U" by (rule AppR)
  with t show ?case by (rule typing.App)
qed

end


theory trapezoidalMap
imports tDag polygon (*"~~/src/HOL/Library/Multiset"*)
begin

(*#######Suche nach Punkten in der Trapezoidal-Map#########*)

(*order for tDag*)
(*Algorithm QueryTrapezoidMap(tDag,point2d)
Input: T is the trapezoid map search structure, n is a node in the search structure and p is a query point.
Output:  A pointer to the node in D for the trapezoid containing the point p.*)
fun queryTrapezoidMap :: "tDag \<Rightarrow> point2d \<Rightarrow> trapez" where
  "queryTrapezoidMap (Tip T) _ =  T"
  |"queryTrapezoidMap (Node lf (xNode n) rt) p =
   (if (xCoord p < xCoord n) then (queryTrapezoidMap lf p) else (queryTrapezoidMap rt p))"
  |"queryTrapezoidMap (Node lf (yNode x) rt) p =
  (*lf ist über dem segment x, rt ist unter dem segment*)
   (if (leftTurn (fst x) (snd x) p) then (queryTrapezoidMap lf p) else (queryTrapezoidMap rt p))"

(*jedes Trapez was mit queryTrapezoidMap gefunden wird, muss auch mit tipInDag gefunden werden können*)
lemma queryTrapezoidMapInDag[simp]: "tipInDag (queryTrapezoidMap D P) D"
  apply (subgoal_tac "(queryTrapezoidMap D P) \<in> set (tDagList D)", simp add: tDagListComplete)
by (induct D P rule: queryTrapezoidMap.induct, auto)
(*query gibt nur elemente von tDag zurück*)
lemma queryTrapezoidMapInDagList[simp]: "(queryTrapezoidMap D P) \<in> set (tDagList D)"
  using queryTrapezoidMapInDag tDagListComplete by blast
(*wenn tDagList nur echte Trapeze enthält ist queryTrapezoidMap auch ein echtes Trapez*)
lemma queryTrapezoidMapIsTrapez[simp]:"trapezList (tDagList D) \<Longrightarrow> isTrapez (queryTrapezoidMap D P)"
  using queryTrapezoidMapInDag tDagListComplete trapezList_def by blast

(*alle Punkte die in rBox liegen findet quiryTrapezoidMap*)
lemma pointInRBox1: "pointInDag (Tip R) a \<Longrightarrow> pointInTrapez (queryTrapezoidMap (Tip R) a) a"
  apply (auto, simp add: pointInDag_def)
done
lemma pointInRBox:"rBoxTrapezS PL R \<Longrightarrow> a \<in> set PL \<Longrightarrow>pointInTrapez (queryTrapezoidMap (Tip R) a) a"
  apply (auto)
  apply (auto simp add: rBoxTrapezS_def pointInTrapez_def)
  using leftFrom_def pointInRBox_def apply auto[1]
  using leftFrom_def pointInRBox_def apply auto[1]
  using pointInRBox_def rightTurn_def apply fastforce
  using pointInRBox_def rightTurn_def apply fastforce
done

(*alle Punkte in der trapezoidalMap müssen im richtigen Trapez gefunden werden*)
definition pointsInTramMap :: "tDag \<Rightarrow> bool" where
   "pointsInTramMap D \<equiv> \<forall> a. pointInDag D a \<longrightarrow> pointInTrapez (queryTrapezoidMap D a) a"
(*rechte Ecke rechts von queryTrapezoidMap*)
lemma pointInQueryTrapezoid: "trapezList (tDagList D) \<Longrightarrow> pointsInTramMap D \<Longrightarrow> pointInDag D P \<Longrightarrow>
  xCoord P \<le> xCoord (rightP (queryTrapezoidMap D P))"
  using pointInTrapezSimp pointsInTramMap_def queryTrapezoidMapInDag tDagListComplete
  trapezList_def by blast

(*pointsInTramMap gilt für rBox*)
lemma rBoxPointsInTramMap: "isTrapez R \<Longrightarrow> pointsInTramMap (Tip R)"
  by (auto simp add: pointsInTramMap_def)

(*#######Konstruieren neuer Bäume beim hinzufügen neuer Strecken#########*)

(*****create new Dag to replace intersected Trapez*)
(*Einfacher Fall: allgemeinFall*)
definition newDagSimpA :: "trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "newDagSimpA T P Q \<equiv>
   Node (Tip (Abs_trapez (topT T,(P,Q),P,Q)))
    (yNode (P,Q))
   (Tip (Abs_trapez ((P,Q),bottomT T,P,Q)))"
lemma newDagSimpANotSame[simp]: "newDagSimpA T P Q \<noteq> Tip T"
  by (simp add: newDagSimpA_def)
lemma neDagSimpAIsTrapez [simp]:"leftFrom P Q \<Longrightarrow> isTrapez T \<Longrightarrow>
  trapezList (tDagList (newDagSimpA T P Q))"
  apply (auto simp add: newDagSimpA_def trapezList_def)
oops

(*Einfacher Fall: füge Q hinzu, P bereits betrachtet*)
definition newDagSimpQ :: "trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "newDagSimpQ T P Q \<equiv>
    Node (newDagSimpA T P Q)
      (xNode Q)
    (Tip (Abs_trapez(topT T,bottomT T,Q,rightP T)))"
lemma newDagSimpQNotSame[simp]: "newDagSimpQ T P Q \<noteq> Tip T"
  by (simp add: newDagSimpQ_def)

(*Einfacher Fall: wenn P und Q in T liegen*)
definition newDagSimp :: "trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "newDagSimp  T P Q \<equiv> (
    if((leftP T \<noteq> P \<and> rightP T \<noteq> Q)) (*P und Q sind keine Endpunkte von Trapezen*)
    then (
      Node (Tip(Abs_trapez(topT T,bottomT T,leftP T,P)))
        (xNode P)
        (newDagSimpQ T P Q)
    ) else( if (leftP T = P \<and> rightP T \<noteq> Q) (*P ist ein Endpunkt, Q nicht*)
        then (newDagSimpQ T P Q)
        else (if(leftP T \<noteq> P \<and> rightP T = Q) (*Q ist ein Endpunkt, P nicht*)
          then (Node (Tip (Abs_trapez(topT T, bottomT T, leftP T, P)))
            (xNode P)
           (newDagSimpA T P Q)
           (*P und Q sind Endpunkte*)
           )else (newDagSimpA T P Q)
      )))"
lemma newDagSimpNotSame[simp]: "newDagSimp T P Q \<noteq> Tip T"
  by (simp add: newDagSimp_def)

(*newDagSimp konstruiert echtes Trapez*)
lemma newDagSimpTrapez:"\<forall> a \<in> set (tDagList (newDagSimp R p q)). isTrapez (a)"
  apply (auto simp add: newDagSimp_def newDagSimpQ_def newDagSimpA_def)
oops

(*gehe solange bis zum nächsten Nachbarn bis gesuchte Ecke gefunden ist
Input: funktion die linke/rechte Ecke vom Trapez gibt, Liste mit Trapezen durch die PQ geht,
  Entscheidung Trapez-Ecke über/unter segment PQ liegt, Strecke PQ
Output: nächste linke/rechte Ecke die über/unter dem Segment P/Q liegt*)
fun nextCorner :: "(trapez \<Rightarrow> point2d) \<Rightarrow> trapez list \<Rightarrow> (point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool)
  \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
    "nextCorner f [TM] _  _ _ = f TM"
    |" nextCorner f (TM#TS) g P Q = (if (g (f TM) P Q) then (f TM) else (nextCorner f TS g P Q))"

(*gehe solange von T zum nächsten linken Nachbarn, bis leftP des Trapez über PQ liegt*)
definition topLeftCorner:: "trapez list \<Rightarrow> trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
  "topLeftCorner TM T P Q \<equiv> nextCorner leftP (dropWhile (trapezNotEq T) (rev TM)) leftTurn P Q"
(*gehe solange von T zum nächsten rechten Nachbarn, bis rightP des Trapez über PQ liegt*)
definition topRightCorner :: "trapez list \<Rightarrow> trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
  "topRightCorner TM T P Q \<equiv> nextCorner rightP (dropWhile (trapezNotEq T) TM) leftTurn P Q"
(*gehe solange von T zum nächsten linken Nachbarn, bis leftP des Trapez unter PQ liegt*)
definition bottomLeftCorner :: "trapez list \<Rightarrow> trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
  "bottomLeftCorner TM T P Q \<equiv> nextCorner leftP (dropWhile (trapezNotEq T) (rev TM)) rightTurn P Q"
(*gehe solange von T zum nächsten rechten Nachbarn, bis rightP des Trapez unter PQ liegt*)
definition bottomRightCorner :: "trapez list \<Rightarrow> trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
  "bottomRightCorner TM T P Q \<equiv> nextCorner rightP (dropWhile (trapezNotEq T) TM) rightTurn P Q"

(*ersetze mittlere Trapeze, d.h. P liegt in T0, Q liegt in Tn und Trapez Ti(0<i<n) soll ersetzt werden*)
definition newDagM :: "trapez \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
   "newDagM  T TM P Q \<equiv>
   Node (Tip (Abs_trapez(topT T,(P,Q),(topLeftCorner TM T P Q), (topRightCorner TM T P Q))))
      (yNode (P,Q))
    (Tip (Abs_trapez((P,Q), bottomT T, (bottomLeftCorner TM T P Q), (bottomRightCorner TM T P Q))))"
lemma newDagMNotSame[simp]: "newDagM T TM P Q \<noteq> Tip T"
  by (simp add: newDagM_def)

(*gegebenes Trapez wird durch 2 neue Trapeze ersetzt; geteilt durch die Strecke PQ*)
definition newDagFirstY :: "trapez \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "newDagFirstY T TM P Q \<equiv>
  Node (Tip (Abs_trapez(topT T, (P,Q), P, (topRightCorner TM T P Q))))
    (yNode (P,Q))
   (Tip (Abs_trapez((P,Q), bottomT T, P, (bottomRightCorner TM T P Q))))"

(*Das erste Trapez soll ersetzt werden, zu überprüfen ist ob Ecke im Trapez ist oder auf der Kante*)
definition newDagFirst :: "trapez \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "newDagFirst T TM P Q \<equiv> (
  if (leftP T = P) then(newDagFirstY T TM P Q)
  else (Node (Tip (Abs_trapez(topT T, bottomT T, leftP T, P)))
    (xNode P)
  (newDagFirstY T TM P Q) ))"
lemma newDagFirstNotSame[simp]: "newDagFirst T TM P Q \<noteq> Tip T"
  by (simp add: newDagFirst_def newDagFirstY_def)

(*gegebenes Trapez wird durch 2 neue Trapeze ersetzt; geteilt durch die Strecke PQ*)
definition newDagLastY :: "trapez \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
   "newDagLastY T TM P Q \<equiv> Node (Tip (Abs_trapez(topT T, (P,Q), topLeftCorner TM T P Q, Q)))
    (yNode (P,Q))
   (Tip (Abs_trapez((P,Q),bottomT T, bottomLeftCorner TM T P Q, Q)))"

(*Das letzte Trapez soll ersetzt werden, zu überprüfen ist ob Ecke im Trapez ist oder auf der Kante*)
definition newDagLast :: "trapez \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "newDagLast T TM P Q \<equiv> (
  if (rightP T = Q) then(newDagLastY T TM P Q)
  else (Node (newDagLastY T TM P Q)
   (xNode Q)
  (Tip (Abs_trapez(topT T,bottomT T, Q, rightP T)))
  ))"
lemma newDagLastNotSame[simp]: "newDagLast T TM P Q \<noteq> Tip T"
  by (simp add: newDagLast_def newDagLastY_def)

(*Algorithm newDag(tDag,trapez, trapez list, segment)*)
(*Input: SuchBaum D, Trapez T das ersetz werden soll, Trapezliste TM mit Trapezen die Strecke PQ kreuzt, Strecke PQ(linksgeordnet)
Output: tDag welches Trapez T ersetzen soll*)
definition newDag :: "tDag \<Rightarrow> trapez \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
"newDag D T TM P Q \<equiv> (if (length TM = 1) then (newDagSimp T P Q)
    else (if (queryTrapezoidMap D P = T) then (newDagFirst T TM P Q)
      else (if (queryTrapezoidMap D Q = T \<or> rightP T = Q) then (newDagLast T TM P Q)
        else (newDagM T TM P Q)
      )
    ))"
lemma newDagNotSame[simp]: "newDag D T TM P Q \<noteq> Tip T"
  by (simp add: newDag_def)

(*newDag konstruiert ein Baum, für dessen x-Knoten uniqueXCoord gilt, wenn Strecke nicht vertikal*)
lemma unicXSimpA[simp]: "leftFrom P Q \<Longrightarrow> uniqueXCoord (xDagList (newDagSimpA D P Q))"
  by (simp add: newDagSimpA_def)
lemma unicXSimp[simp]: "leftFrom P Q \<Longrightarrow> uniqueXCoord (xDagList (newDagSimp D P Q))"
  by (auto simp add: newDagSimp_def newDagSimpA_def newDagSimpQ_def pointsUniqueXCoord)
lemma unicXFirst[simp]: "leftFrom P Q \<Longrightarrow> uniqueXCoord (xDagList (newDagFirst a TM P Q))"
  by (auto simp add: newDagFirst_def newDagFirstY_def)
lemma unicXLast[simp]: "leftFrom P Q \<Longrightarrow> uniqueXCoord (xDagList (newDagLast a TM P Q))"
  by (auto simp add: newDagLast_def newDagLastY_def)
lemma unicXnewDag[simp]: "leftFrom P Q \<Longrightarrow> uniqueXCoord (xDagList (newDag D a TM P Q))"
  by (auto simp add: newDag_def newDagM_def)

(*welche x-Knoten kann newDag enthalten*)
lemma xDagListNewDagSimpA [simp]:"xDagList (newDagSimpA T P Q) = []" by (simp add: newDagSimpA_def)
lemma xDagListNewDagSimp1[intro]:"xDagList (newDagSimp T P Q) = [P,Q]
  \<or> xDagList (newDagSimp T P Q) = [P] \<or> xDagList (newDagSimp T P Q) = []
  \<or> xDagList (newDagSimp T P Q) = [Q]"
  by (auto simp add: newDagSimp_def newDagSimpQ_def)
lemma xDagListNewDagM[simp]:"xDagList (newDagM T TM P Q) = []" by (auto simp add: newDagM_def)
lemma xDagListNewDagFirst[intro]:"xDagList (newDagFirst T TM P Q) = []
  \<or> xDagList (newDagFirst T TM P Q) = [P]"
  by (auto simp add: newDagFirst_def newDagFirstY_def)
lemma xDagListNewDagLast[intro]:"xDagList (newDagLast T TM P Q) = []
  \<or> xDagList (newDagLast T TM P Q) = [Q]"
  by (auto simp add: newDagLast_def newDagLastY_def)
lemma xDagListNewDag[intro]:"xDagList (newDag D T TM P Q) = [P,Q]
  \<or> xDagList (newDag D T TM P Q) = [P] \<or> xDagList (newDag D T TM P Q) = [Q]
  \<or> xDagList (newDag D T TM P Q) = []"
  apply (auto simp add: newDag_def newDagFirst_def newDagFirstY_def newDagLast_def newDagLastY_def)
  using xDagListNewDagSimp1 apply blast
  using xDagListNewDagSimp1 apply blast
using xDagListNewDagSimp1 by blast

(*welche y-Knoten kann newDag enthalten*)
lemma yDagListNewDagSimp[simp]: "yDagList (newDagSimp T P Q) = [(P,Q)]"
  by (auto simp add: newDagSimp_def newDagSimpQ_def newDagSimpA_def)
lemma yDagListNewDag[simp]: "yDagList (newDag D TM T P Q) = [(P,Q)]"
  by (auto simp add: newDag_def newDagM_def newDagFirst_def newDagFirstY_def
    newDagLast_def newDagLastY_def)

(*#######Suche nach Trapezen die von einer Strecke geschnitten werden#########*)

(*Such nach rechten oberen Trapeznachbar*)
fun rUpNeighb :: "trapez list \<Rightarrow> trapez \<Rightarrow> trapez" where
  "rUpNeighb [] T = T"
  | "rUpNeighb (Tr#TN) T = (if(neighbor T Tr \<and> topT T = topT Tr)
    then (Tr) else (rUpNeighb TN T))"
lemma rUpNeighbElem[intro]:"(rUpNeighb TM T) \<in> set TM \<or> rUpNeighb TM T = T"
  by (induct TM T rule: rUpNeighb.induct, auto)
lemma rUpNeigbIsTrapez:"trapezList TM \<Longrightarrow> isTrapez T \<Longrightarrow> isTrapez (rUpNeighb TM T)"
  by (induct TM T rule: rUpNeighb.induct, simp, simp add: trapezList_def)
lemma rUpNeighbSimp: "rUpNeighb TM T = T \<or> (neighbor T (rUpNeighb TM T)
    \<and> topT (rUpNeighb TM T) = topT T)"
  by (induct TM, auto)
lemma rUpNeighbSimp1:"isTrapez T \<Longrightarrow> isTrapez (rUpNeighb (tDagList D) T) \<Longrightarrow>
  leftFrom (rightP T) (rightP (rUpNeighb (tDagList D) T)) \<or> rUpNeighb (tDagList D) T = T"
  by (meson neighbor_def rUpNeighbSimp trapezNeighbour1)

lemma rUpNeighbInDag[simp]:"tipInDag T D \<Longrightarrow>(rUpNeighb (tDagList D) T) \<in> set (tDagList D)"
  apply (induct "(tDagList D)" T rule: rUpNeighb.induct, auto)
  apply (metis tDagListNotEmpty)
using rUpNeighbElem tDagListComplete by fastforce

lemma rUpNeighbInDag1[simp]: "tipInDag (rUpNeighb (tDagList D) (queryTrapezoidMap D P)) D"
  apply (induct "tDagList D" "queryTrapezoidMap D P" rule: rUpNeighb.induct)
  apply (subgoal_tac "tipInDag (queryTrapezoidMap D P) D", simp)
  apply (auto)
by (auto simp add: tDagListComplete)

(*Such nach rechten unteren Trapeznachbar*)
fun rBtNeighb :: "trapez list \<Rightarrow> trapez \<Rightarrow> trapez" where
  "rBtNeighb [] T = T"
  | "rBtNeighb (Tr#TN) T = (if(neighbor T Tr \<and> bottomT T = bottomT Tr)
    then (Tr) else (rBtNeighb TN T))"
lemma rBtNeighbElem[intro]:"(rBtNeighb TM T) \<in> set TM \<or> rBtNeighb TM T = T"
  by (induct TM T rule: rBtNeighb.induct, auto)
lemma rBtNeigbIsTrapez:"trapezList TM \<Longrightarrow> isTrapez T \<Longrightarrow> isTrapez (rBtNeighb TM T)"
  by (induct TM T rule: rBtNeighb.induct, simp, simp add: trapezList_def)
lemma rBtNeighbSimp: "rBtNeighb TM T = T
  \<or> (neighbor T (rBtNeighb TM T) \<and> bottomT (rBtNeighb TM T) = bottomT T)"
  by (induct TM, auto)
lemma rBtNeighbSimp1:"isTrapez T \<Longrightarrow> isTrapez (rBtNeighb (tDagList D) T) \<Longrightarrow>
  leftFrom (rightP T) (rightP (rBtNeighb (tDagList D) T)) \<or> rBtNeighb (tDagList D) T = T"
  by (meson neighbor_def rBtNeighbSimp trapezNeighbour1)

lemma rBtNeighbInDag[simp]:"tipInDag T D \<Longrightarrow>(rBtNeighb (tDagList D) T) \<in> set (tDagList D)"
  apply (induct "(tDagList D)" T rule: rBtNeighb.induct, auto)
  apply (metis tDagListNotEmpty)
using rBtNeighbElem tDagListComplete by fastforce

lemma rBtNeighbInDag1[simp]: "tipInDag (rBtNeighb (tDagList D) (queryTrapezoidMap D P)) D"
  apply (induct "tDagList D" "queryTrapezoidMap D P" rule: rBtNeighb.induct)
  apply (subgoal_tac "tipInDag (queryTrapezoidMap D P) D", simp)
  apply (auto)
by (auto simp add: tDagListComplete)

(*Definition für Bedingung der Nacharn. jedesmal wenn ein Punkt sich rechts von einem Trapez T
  befindet, muss es für T einen rechten Nachbar geben*)
definition trapezMapNeighbor :: "tDag \<Rightarrow> bool" where
  "trapezMapNeighbor D \<equiv> \<forall> Q T. (pointInDag D Q \<and> tipInDag T D \<and> xCoord(rightP T) < xCoord Q)
  \<longrightarrow> (rBtNeighb (tDagList D) T \<noteq> T \<or> rUpNeighb (tDagList D) T \<noteq> T)"
(*rBox entspricht der Definition von trapezMapNeigbor*)
lemma isRBoxMapNeighbor[simp]:"isTrapez X \<Longrightarrow> trapezMapNeighbor (Tip X)"
  apply (auto simp add: trapezMapNeighbor_def)
by (meson not_le pointInTrapezSimp)

(*position der Ecken des rechten Nachbar von T zu T*)
lemma isTramMapNextTrapez[simp]: "trapezMapNeighbor D \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  pointInDag D Q \<Longrightarrow> tipInDag T D \<Longrightarrow> xCoord(rightP T) < xCoord Q \<Longrightarrow> rBtNeighb (tDagList D) T = T
  \<Longrightarrow> leftFrom (rightP T) (rightP (rUpNeighb (tDagList D) T))"
  by (meson rUpNeighbInDag rUpNeighbSimp1 tDagListComplete trapezListTDag trapezMapNeighbor_def)
lemma isTramMapNextTrapez1[simp]: "trapezMapNeighbor D \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  pointInDag D Q \<Longrightarrow> tipInDag T D \<Longrightarrow> xCoord(rightP T) < xCoord Q \<Longrightarrow> rUpNeighb (tDagList D) T = T
  \<Longrightarrow> leftFrom (rightP T) (rightP (rBtNeighb (tDagList D) T))"
  by (meson rBtNeighbInDag rBtNeighbSimp1 tDagListComplete trapezListTDag trapezMapNeighbor_def)

(*Beweis für die Termination von followSeg*)
lemma nextNeighbour: "trapezMapNeighbor D \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow> tipInDag T D \<Longrightarrow>
  length (filter ((\<lambda>x. xCoord (rightP (rBtNeighb (tDagList D) T)) < x) \<circ> (xCoord \<circ> rightP))
          (tDagList D))
  < length (filter ((\<lambda>x. xCoord (rightP T) < x) \<circ> (xCoord \<circ> rightP)) (tDagList D))"
  apply (subgoal_tac "leftFrom (rightP T) (rightP (rBtNeighb (tDagList D) T))")
sorry
lemma nextNeighbour1: "trapezMapNeighbor D \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow> tipInDag T D \<Longrightarrow>
  length (filter ((\<lambda>x. xCoord (rightP (rUpNeighb (tDagList D) T)) < x) \<circ> (xCoord \<circ> rightP))
          (tDagList D))
  < length (filter ((\<lambda>x. xCoord (rightP T) < x) \<circ> (xCoord \<circ> rightP)) (tDagList D))"
  apply (subgoal_tac "leftFrom (rightP T) (rightP (rBtNeighb (tDagList D) T))")
sorry

(*lemma tramMap_measure_size [measure_function]:"isTramMap D \<and> pointInDag D Q \<Longrightarrow>
  leftFrom (rightP T) ()"*)

(*gib eine trapezliste, die von PQ geschnitten werden zurück.*)
function followSeg :: "tDag \<Rightarrow> trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> trapez list" where
  (*signedArea P Q (rightP T) \<noteq> 0 \<Longrightarrow> kann man beweisen, da PQ nicht durch rightP T durchgeht,
    und P Q nicht vollständig in T ist*)
  "followSeg D T P Q =
  (if (trapezMapNeighbor D \<and> trapezList (tDagList D) \<and> tipInDag T D \<and> pointInDag D Q \<and>
  leftFrom P Q) then (
    (if (xCoord (rightP T) < xCoord Q) then
      (if (leftTurn P Q (rightP T))
        then (T # followSeg D (rBtNeighb (tDagList D) T) P Q)
        else (T # followSeg D (rUpNeighb (tDagList D) T) P Q))
    else([T])))
   else ([]))"
by pat_completeness auto
termination followSeg
 apply (relation "measure (\<lambda> (D,T,P,Q). length (filter (\<lambda>x. xCoord(rightP T) < x)
   (map (xCoord o rightP)(tDagList D))))")
 (*beweise das das nächste Trapez rechts von dem linkem Trapez
  bzw. dass der Abstand zwischen rightP T und Q immer kleiner wird.
  Beweis mit Abstand für reale Zahlen garnicht möglich!
  Abstand kan beliebig klein werden und Q nicht erreichen
  Beweis sollte über die Anzahl der Elemente in der Liste sein, die noch als Nachbar in Frage kommen*)
by (auto simp add: nextNeighbour nextNeighbour1)

(*alle Trapeze aus followSeg sind aus D*)
lemma followSegmetInDag[simp]:"tipInDag T D \<Longrightarrow> A \<in> set (followSeg D T P Q) \<Longrightarrow>
  A \<in> set (tDagList D)"
  apply (induct D T P Q rule: followSeg.induct, simp)
  apply (simp add: conflictingLeftTurns3 set_ConsD tDagListComplete)
  apply (simp add: pointInDag_def set_ConsD tDagListComplete)
by (smt empty_iff followSeg.simps insert_iff list.set(1) list.set(2) notLeftTurn notRightTurn1)
lemma followSegmetInDag1: "A \<in> set (followSeg D (queryTrapezoidMap D P) P Q) \<Longrightarrow> tipInDag A D"
  using followSegmetInDag queryTrapezoidMapInDag tDagListComplete by blast

(*gib eine trapezliste, die von PQ geschnitten werden. Start-Trapez enthält P*)
definition intersectedTrapez :: "tDag \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> trapez list" where
  "leftFrom P Q \<Longrightarrow> intersectedTrapez D P Q \<equiv> followSeg D (queryTrapezoidMap D P) P Q"
lemma intersectedTrapezNotEmpty[simp]: "leftFrom p q \<Longrightarrow> rBoxTrapezS [p,q] R \<Longrightarrow>
  intersectedTrapez (Tip R) p q = [] \<Longrightarrow> False"
  apply (subgoal_tac "isTrapez R") defer apply (simp add: rBoxTrapezS_def)
  apply (subgoal_tac "trapezList [R]") defer apply (simp add: trapezList_def)
  apply (simp add: intersectedTrapez_def)
  apply (subgoal_tac "trapezMapNeighbor (Tip R) \<and> pointInDag (Tip R) q", simp)
  apply (subgoal_tac "xCoord (rightP R) \<ge> xCoord q", simp)
  apply (metis list.distinct(1))
  apply (auto) defer
using pointInDag_def pointInRBox by auto[1]

(*jedes Trapez von intersectedTrapez ist aus D*)
lemma intersectedTrapezInDag[simp]: "leftFrom P Q \<Longrightarrow> T \<in> set (intersectedTrapez D P Q) \<Longrightarrow>
  tipInDag T D"
  apply(simp add: intersectedTrapez_def)
by (smt empty_iff followSegmetInDag list.set(1) queryTrapezoidMapInDag rBtNeighbInDag1
  rUpNeighbInDag1 set_ConsD tDagListComplete)
(*enthält D nur eine rBox liefert intersectedTrapez die rBox zurück*)
lemma intersectedTrapezSimp[simp]: "leftFrom p q \<Longrightarrow> rBoxTrapezS [p,q] R \<Longrightarrow>
  intersectedTrapez (Tip R) p q = [R]"
  apply (subgoal_tac "isTrapez R") defer apply (simp add: rBoxTrapezS_def)
  apply (subgoal_tac "trapezList [R]") defer apply (simp add: trapezList_def)
  apply (simp only: intersectedTrapez_def)
  apply (subgoal_tac "queryTrapezoidMap (Tip R) p = R")
  apply (erule ssubst)
  apply (subgoal_tac "xCoord (rightP R) \<ge> xCoord q", auto)
  using pointInDag_def pointInRBox  apply auto[1]
using pointInRBox pointInTrapez_def by auto[1]
lemma intersectedTrapezSimp1[simp]: "isTrapez R \<Longrightarrow> leftFrom p q \<Longrightarrow> pointInDag (Tip R) q \<Longrightarrow>
  intersectedTrapez (Tip R) p q = [R]"
  apply (subgoal_tac "trapezList [R]") defer apply (simp add: trapezList_def)
  apply (simp only: intersectedTrapez_def)
  apply (subgoal_tac "queryTrapezoidMap (Tip R) p = R")
  apply (erule ssubst)
  apply (subgoal_tac "xCoord (rightP R) \<ge> xCoord q")
  apply (metis followSeg.simps isRBoxMapNeighbor rBtNeighbInDag
    rUpNeighbInDag tDagList.simps(1) tDagListComplete tipInDag.simps(1) trapezMapNeighbor_def)
  apply simp
using queryTrapezoidMap.simps(1) by blast

(*das erste Trapez enthält die linke Ecke*)
lemma intersectedHD[simp]: "trapezMapNeighbor D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow>
  trapezList (tDagList D) \<Longrightarrow> pointInDag D Q \<Longrightarrow> TM = intersectedTrapez D P Q \<Longrightarrow>
  hd(TM) = queryTrapezoidMap D P"
  by (simp add: intersectedTrapez_def)
(*das letzte Trapez enthält die letzte Ecke*)
lemma intersectedLast[intro]: "trapezMapNeighbor D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow>
  pointInDag D Q \<Longrightarrow> TM = intersectedTrapez D P Q \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  last(TM) = queryTrapezoidMap D Q \<or> leftP (queryTrapezoidMap D Q) = rightP (last TM)"
  apply (auto, simp only: intersectedTrapez_def)
oops

(*segment ist im Trapez dann liefert intersectedTrapez nur ein Trapez*)
lemma intersectOne: "trapezMapNeighbor D \<Longrightarrow> pointsInTramMap D \<Longrightarrow>
  trapezList (tDagList D)\<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  TM = intersectedTrapez D P Q \<Longrightarrow> queryTrapezoidMap D Q = queryTrapezoidMap D P \<Longrightarrow> length TM = 1"
  apply (auto, simp only: intersectedTrapez_def)
  apply (simp)
  apply (subgoal_tac "xCoord (rightP (queryTrapezoidMap D P)) \<ge> xCoord Q", simp)
using  pointsInTramMap_def by auto
lemma intersectOne1:"trapezMapNeighbor D \<Longrightarrow> pointsInTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow>
  pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow> TM = intersectedTrapez D P Q \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  queryTrapezoidMap D P = T \<Longrightarrow> queryTrapezoidMap D Q = T\<Longrightarrow> TM = [T]"
  apply (auto, simp only: intersectedTrapez_def)
  apply (subgoal_tac "xCoord (rightP (queryTrapezoidMap D P)) \<ge> xCoord Q", simp)
using pointsInTramMap_def by auto

(*segment schneidet mehrere Trapeze, intersectedTrapez berechnet Folge von benachbarten Trapezen*)
lemma intersectedTrapezComp: "trapezMapNeighbor D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow>
  pointInDag D Q \<Longrightarrow> TM = intersectedTrapez D P Q \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  (\<forall> i < length TM - 1. neighborAlongSeg (TM!i) (TM!Suc i) P Q)"
  apply (induct TM, auto)
oops
(*Q kann nur sich nur im letzten Trapez befinden *)
lemma intersectedTrapezPos: "trapezMapNeighbor D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow>
  pointInDag D Q \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  \<not> (\<exists>i<length (intersectedTrapez D P Q) - 1. i \<noteq> 0 \<and> rightP (intersectedTrapez D P Q ! i) = Q)"
oops
(*P kann nur sich nur im ersten Trapez befinden *)
lemma intersectedTrapezPos1: "trapezMapNeighbor D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow>
  pointInDag D Q \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow>
  \<not>(\<exists> i. i < length (intersectedTrapez D P Q) \<and> i \<noteq> 0 \<and> leftP ((intersectedTrapez D P Q)!i) = P)"
oops

(*#######Füge neue Segmente in die Trapezoidal-Map ein#########*)

(*ersetzt alle übergebenen Trapeze im tDag durch neue Trapeze, die mit PQ erstellt wurden
Input : suchBaum D, 2 mal Liste mit Trapezen die ersetzt werden sollen,Segment PQ
Output: neues Dag, nachdem alle Trapeze ersetzt wurden*)
fun replaceDag :: "tDag \<Rightarrow> trapez list \<Rightarrow> trapez list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "replaceDag D [] TM P Q = D"
  | "replaceDag D (T#Ts) TM P Q = replaceDag (replaceTip T (newDag D T TM P Q ) D) Ts TM P Q"
(*Inhalt von tDag nach replaceDag*)
lemma replaceDagXDagList[intro]: "a \<in> set (xDagList D) \<longrightarrow>
  a \<in> set (xDagList (replaceDag D TM TN P Q))"
  by (induct D TM TN P Q rule: replaceDag.induct, auto)
lemma replaceXDagListElem[intro]: "a \<in> set (xDagList (replaceDag D TM TN P Q)) \<longrightarrow>
  a \<in> set (xDagList D) \<or> a = P \<or> a = Q"
  apply (induct D TM TN P Q rule: replaceDag.induct, auto)
by (metis empty_iff insert_iff list.set(1) list.set(2) replaceTipXDagList1 xDagListNewDag)
lemma replaceYDagListElem[intro]:"a \<in> set (yDagList (replaceDag D TM TN P Q)) \<longrightarrow>
  a \<in> set (yDagList D) \<or> a = (P,Q)"
  apply (induct rule: replaceDag.induct)
  apply (auto)
  apply (cut_tac a=a and oT=T and nT="newDag D T TM P Q" and D=D in replaceTipYDagList1, assumption)
by(auto)

lemma replaceRBoxNotSame[simp]:"leftFrom p q \<Longrightarrow> rBoxTrapezS [p,q] R \<Longrightarrow>
  replaceDag (Tip R) (intersectedTrapez (Tip R) p q) (intersectedTrapez (Tip R) p q) p q \<noteq> Tip R"
by (simp)

(******add Segment to trapezoidal-map*)
(*erneure tDag nach dem hinzufügen eines segments*)
definition addSegmentToTrapMap :: "tDag \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> tDag" where
  "leftFrom P Q \<Longrightarrow> addSegmentToTrapMap D P Q \<equiv>
    replaceDag D(intersectedTrapez D P Q)(intersectedTrapez D P Q) P Q"
lemma addSegmentToRBoxNotSame [simp]:"leftFrom p q \<Longrightarrow> rBoxTrapezS [p,q] R \<Longrightarrow>
  addSegmentToTrapMap (Tip R) p q \<noteq> Tip R"
  apply (simp add: addSegmentToTrapMap_def)
done

(*****Add Polygon to trapezoidal-map*)
(*Input: List of line segments(one Polygon) forming a planar subdivision.
Output:  A trapezoid map M in associated search structure tDag.*)
fun addSegmentsToTrapMap :: "tDag \<Rightarrow> point2d list \<Rightarrow> tDag" where
  "addSegmentsToTrapMap D [] = D"
  | "addSegmentsToTrapMap D [p] = D"
  | "addSegmentsToTrapMap D (p#q#xs) = addSegmentsToTrapMap
    (addSegmentToTrapMap D (leftPSegment p q) (rightPSegment p q)) (q#xs)"

fun addPolygonsToTrapMap :: "tDag \<Rightarrow> (point2d list) list \<Rightarrow> tDag" where
   "addPolygonsToTrapMap D [] = D"
  | "addPolygonsToTrapMap D (x#xs) = addPolygonsToTrapMap (addSegmentsToTrapMap D x) xs"

(*alte Definition*)

end


section "Discussion"
subsection \<open>Relation between the explicit Hoare logics\<close>
theory Discussion
imports Quant_Hoare SepLog_Hoare
begin

subsubsection \<open>Relation SepLogic to quantHoare\<close>

definition em where "em P' = (%(ps,n). P' (emb ps (%_. 0)) \<le> enat n )"  (* with equality next lemma also works *)

lemma assumes s: "\<Turnstile>\<^sub>3 { em P'} c { em Q' }"
shows  "\<Turnstile>\<^sub>2 { P' } c { Q' }"
proof -
  from s have s': "\<And>ps n. em P' (ps, n) \<Longrightarrow> (\<exists>ps' m. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> m \<le> n \<and> em Q' (ps', n - m))" unfolding hoare3_valid_def  by auto
  {
    fix s
    assume P': "P' s < \<infinity>"
    then obtain n where n: "P' s = enat n"
      by fastforce
    with P' have "em P' (part s, n)" unfolding em_def by auto
    with s' obtain ps' m where c: "(c, part s) \<Rightarrow>\<^sub>A m \<Down> ps'" and m: "m \<le> n" and Q': "em Q' (ps', n - m)" by blast

    from Q' have q: "Q' (emb ps' (\<lambda>_. 0)) \<le> enat ( n - m)" unfolding em_def by auto

    thm full_to_part  part_to_full
    have i: "(c, s) \<Rightarrow> m \<Down> emb ps' (\<lambda>_. 0)" using  part_to_full'[OF c] apply simp done

    have ii: "enat m + Q' (emb ps' (\<lambda>_. 0)) \<le> P' s" unfolding  n using q m
      using enat_ile by fastforce

    from i ii have "(\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + Q' t \<le> P' s)" by auto
  } then
  show ?thesis unfolding hoare2_valid_def by blast
qed

end