section \<open>Quadrangle Inequality\<close>

theory Quadrilateral_Inequality
imports Main
begin

(* did not use @{const is_arg_min} because no benefit *)
definition is_arg_min_on :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_arg_min_on f S x = (x \<in> S \<and> (\<forall>y \<in> S. f x \<le> f y))"

definition Args_min_on :: "(int \<Rightarrow> ('b::linorder)) \<Rightarrow> int set \<Rightarrow> int set" where
"Args_min_on f I = {k. is_arg_min_on f I k}"

lemmas Args_min_simps = Args_min_on_def is_arg_min_on_def

lemma is_arg_min_on_antimono: fixes f :: "_ \<Rightarrow> _::order"
shows "\<lbrakk> is_arg_min_on f S x; f y \<le> f x; y \<in> S \<rbrakk> \<Longrightarrow> is_arg_min_on f S y"
by (metis antisym is_arg_min_on_def)

lemma ex_is_arg_min_on_if_finite: fixes f :: "'a \<Rightarrow> 'b :: linorder"
shows "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>x. is_arg_min_on f S x"
unfolding is_arg_min_on_def using ex_min_if_finite[of "f ` S"] by fastforce

locale QI =
  fixes c_k :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> nat"
  fixes c :: "int \<Rightarrow> int \<Rightarrow> nat"
  and w :: "int \<Rightarrow> int \<Rightarrow> nat"
  assumes QI_w: "\<lbrakk>i \<le> i'; i' < j; j \<le> j'\<rbrakk> \<Longrightarrow>
    w i j + w i' j'\<le> w i' j + w i j'"
  assumes monotone_w: "\<lbrakk>i \<le> i'; i' < j; j \<le> j'\<rbrakk> \<Longrightarrow> w i' j \<le> w i j'"
  assumes c_def: "i < j \<Longrightarrow> c i j = Min ((c_k i j) ` {i+1..j})"
  assumes c_k_def: "\<lbrakk> i < j;  k \<in> {i+1..j} \<rbrakk> \<Longrightarrow>
    c_k i j k = w i j + c i (k-1) + c k j"
begin

abbreviation "mins i j \<equiv> Args_min_on (c_k i j) {i+1..j}"

definition "K i j \<equiv> (if i = j then i else Max (mins i j))"

lemma c_def_rec:
  "i < j \<Longrightarrow> c i j = Min ((\<lambda>k. c i (k-1) + c k j + w i j) ` {i+1..j})"
using c_def c_k_def by (auto simp: algebra_simps image_def)

lemma mins_subset: "mins i j \<subseteq> {i+1..j}"
by (auto simp: Args_min_simps)

lemma mins_nonempty: "i < j \<Longrightarrow> mins i j \<noteq> {}"
using ex_is_arg_min_on_if_finite[OF finite_atLeastAtMost_int, of "i+1" j "c_k i j"]
by(auto simp: Args_min_simps)

lemma finite_mins: "finite(mins i j)"
by(simp add: finite_subset[OF mins_subset])

lemma is_arg_min_on_Min:
assumes "finite A" "is_arg_min_on f A a" shows "Min (f ` A) = f a"
proof -
  from assms(2) have "f ` A \<noteq> {}"
    by (fastforce simp: is_arg_min_on_def)
  thus ?thesis using assms by (simp add: antisym is_arg_min_on_def)
qed

lemma c_k_with_K: "i < j \<Longrightarrow> c i j = c_k i j (K i j)"
using Max_in[of "mins i j"] finite_mins[of i j] mins_nonempty[of i j]
  is_arg_min_on_Min[of "{i+1..j}" "c_k i j"]
by (auto simp: Args_min_simps c_def K_def)

lemma K_subset: assumes "i \<le> j" shows "K i j \<in> {i..j}" using mins_subset K_def
proof cases
  assume "i = j"
  thus ?thesis
    using K_def by auto
next
  assume "\<not>i = j"
  hence "K i j \<in> {i+1..j}" using mins_subset K_def \<open>i \<le> j\<close>
    by (metis Max_in finite_mins less_le mins_nonempty subsetCE)

  thus ?thesis  by auto
qed

lemma lemma_2:
  "\<lbrakk> l = nat (j'- i);  i \<le> i';  i' \<le> j;  j \<le> j' \<rbrakk>
   \<Longrightarrow> c i j + c i' j' \<le> c i j' + c i' j"
proof(induction l arbitrary: i i' j j' rule:less_induct)
  case (less l)
  show ?case
  proof cases
    assume "l \<le> 1"
    hence "i = i' \<or> j = j'" using less.prems by linarith
    thus ?case by auto
  next
    assume "\<not> l \<le> 1"
    show ?case
    proof cases
      assume "i \<ge> i'" thus ?thesis using less.prems by auto
    next
      assume "\<not>i \<ge> i'"
      hence "i < i'" by simp
      show ?thesis
      proof cases
        assume "j \<ge> j'" thus ?thesis using less.prems by auto
      next
        assume "\<not> j \<ge> j'"
        show ?thesis
        (*-----------------------case 1: i' = j --------------------------------------------------*)
        proof cases
          assume "i' = j"
          let ?k = "K i j'"
          have "?k \<in> {i+1..j'}"
            unfolding K_def
            using mins_subset Max_in[OF finite_mins mins_nonempty] less.prems \<open>\<not> i' \<le> i\<close>
            by (smt subsetCE)
          show ?thesis
          (*---------------------case 1.1: i' = j \<and> k \<le> j ----------------------------------------*)
          proof cases
            assume "?k \<le> j"

            have a: "c i j \<le> w i j + c i (?k-1) + c ?k j"
            proof -
              have "c i j = Min ((\<lambda>k. c i (k-1) + c k j + w i j) ` {i+1..j})"
                using c_def_rec \<open>\<not> i' \<le> i\<close> \<open>i' = j\<close> by auto
              also have "... \<le> c i (?k-1) + c ?k j + w i j"
                using \<open>?k\<in>{i+1..j'}\<close> \<open>?k \<le> j\<close> by simp
              finally show ?thesis by simp
            qed

            have "nat (j' - ?k) < l" using \<open>?k\<in>{i+1..j'}\<close> less.prems by simp
            hence b: "c ?k j + c j j' \<le> c ?k j' + c j j"
              using \<open>?k \<le> j\<close> less.prems
                less.IH [where i = ?k and i' = j and j = j and j' = j', OF _ refl]
              by auto

            have "c i j + c i' j' = c i j + c j j'" by (simp add: \<open>i' = j\<close>)
            also have "...\<le> w i j + c i (?k-1) + c ?k j + c j j'"
              using a by auto
            also have "... \<le> w i j'+ c i (?k-1) + c ?k j + c j j'"
              using less.prems monotone_w \<open>i < i'\<close> by simp
            also have "... \<le> w i j'+ c i (?k-1) + c ?k j' + c j j"
              using b by auto
            also have "... = c i j' + c j j" using \<open>?k\<in>{i+1..j'}\<close>
              by(simp add: c_k_def c_k_with_K)
            finally show ?thesis by(simp add: \<open>i' = j\<close>)
          next
          (*---------------------case 1.2: i' = j \<and> k \<ge> j ----------------------------------------*)
            assume "\<not> ?k \<le> j"
            hence "?k \<in> {j+1..j'}" using \<open>?k \<in> {i+1..j'}\<close> by auto
            have a: "c j j' \<le> w j j' + c j (?k-1) + c ?k j'"
            proof -
             have "c j j' = Min ((\<lambda>k. c j (k-1) + c k j' + w j j') ` {j+1..j'})"
               using c_def_rec \<open>\<not> j' \<le> j\<close> by auto
             also have "... \<le> c j (?k-1) + c ?k j' + w j j'"
              using \<open>?k \<in> {j+1..j'}\<close> by simp
             finally show "c j j' \<le> w j j' + c j (?k-1) + c ?k j'" by simp
            qed

            have "nat ((?k-1) -i) < l" using \<open>?k \<in> {i+1..j'}\<close> less.prems by simp
            hence b: "c i j + c j (?k-1) \<le> c i (?k-1) + c j j"
              using less.prems \<open>\<not> ?k \<le> j\<close>
                less.IH[where i=i and i'=j and j=j and j'="(?k-1)", OF _ refl]
              by auto

            have "c i j + c i' j' = c i j + c j j'" by(simp add: \<open>i' = j\<close>)
            also have "... \<le> w j j' + c j (?k-1) + c ?k j' + c i j"
              using a by simp
            also have "... \<le> w i j'+ c j (?k-1) + c ?k j' + c i j"
              using less.prems monotone_w \<open>?k \<in> {j+1..j'}\<close> by simp
            also have "... \<le> w i j'+ c i (?k-1) + c ?k j' + c j j"
              using b by simp
            also have "... \<le> c i j' + c j j"
              using \<open>?k\<in>{i+1..j'}\<close> by (simp add: c_k_def c_k_with_K)
            finally show ?thesis by(simp add: \<open>i' = j\<close>)
          qed
        next
          (*---------------------case 2 i' \<noteq> j ---------------------------------------------------*)
          assume "i' \<noteq> j"
          let ?y = "K i' j"
          let ?z = "K i j'"
          have "?y \<in> {i'+1..j}"
            using mins_subset less.prems \<open>i' \<noteq> j\<close> Max_in[OF finite_mins mins_nonempty]
            unfolding K_def by (metis le_less subsetCE)
          have "?z \<in> {i+1..j'}"
            using mins_subset less.prems \<open>i' \<noteq> j\<close> Max_in[OF finite_mins mins_nonempty]
            unfolding K_def by (smt subsetCE)
          have w_mon: "w i' j' + w i j \<le> w i' j + w i j'"
            using less.prems QI_w \<open>i' \<noteq> j\<close> by force

          have "i' < j'" "i < j" using \<open>i' \<noteq> j\<close> less.prems by auto
          show ?thesis
          (*---------------------case 2.1 i' \<noteq> j \<and> z \<le> y ----------------------------------------*)
          proof cases
            assume "?z \<le> ?y"
            have "?y \<in> {i'+1..j'}" using less.prems \<open>?y \<in> {i'+1..j}\<close> by simp
            have "?z \<in> {i+1..j}" using \<open>?z \<in> {i+1..j'}\<close> \<open>?z \<le> ?y\<close> \<open>?y \<in> {i'+1..j}\<close> by simp

            have a: "c i' j' \<le> w i' j' + c i' (?y-1) + c ?y j'"
            proof -
              have "c i' j' = Min((\<lambda>k. c i' (k-1) + c k j' + w i' j') ` {i'+1..j'})"
                by (simp add: c_def_rec[OF  \<open>i' < j'\<close>])
              also have "... \<le> w i' j' + c i' (?y-1) + c ?y j'"
                using \<open>?y \<in> {i'+1..j'}\<close> by simp
              finally show ?thesis .
            qed

            have b: "c i j \<le> w i j + c i (?z-1) + c ?z j"
            proof -
              have "c i j = Min ((\<lambda>k. c i (k-1) + c k j + w i j)  ` {i+1..j})"
                using \<open>i < j\<close> by (simp add: c_def_rec)
              also have "... \<le> w i j + c i (?z-1) + c ?z j"
                using \<open>?z \<in> {i+1..j}\<close> by simp
              finally show ?thesis .
            qed

            have "nat (j' - ?z) < l" using \<open>?z \<in> {i+1..j}\<close> less.prems by simp
            hence IH_step: "c ?z j + c ?y j' \<le> c ?z j' + c ?y j"
              using \<open>?z \<le> ?y\<close> \<open>j \<le> j'\<close> \<open>?y \<in> {i'+1..j}\<close>
               less.IH[where i = ?z and i' = ?y and j = j and j' = j', OF _ refl]
              by simp

            have "c i' j' + c i j
              \<le> w i' j + w i j' + c i' (?y-1) + c i (?z-1) + c ?y j' + c ?z j"
              using a b w_mon by simp
            also have "\<dots> \<le> w i j' + w i' j +  c i' (?y-1) + c i (?z-1) + c ?y j + c ?z j'"
              using IH_step by auto
            also have "... = c i j' + c i' j" using \<open>?z \<in> {i+1..j'}\<close> \<open>?y \<in> {i'+1..j}\<close>
              by(simp add: c_k_def c_k_with_K)
            finally show ?thesis by linarith
          next
            (*---------------------case 2.1 i' \<noteq> j \<and> z > y ---------------------------------------*)
            assume "\<not>?z \<le> ?y"

            have "?y \<in> {i+1..j}" using less.prems \<open>?y \<in> {i'+1..j}\<close> by simp
            have "?z \<in> {i'+1..j'}" using \<open>?z \<in> {i+1..j'}\<close> \<open>\<not>?z \<le> ?y\<close> \<open>?y \<in> {i'+1..j}\<close>
              by simp

            have a: "c i' j' \<le> w i' j' + c i' (?z-1) + c ?z j'"
            proof -
              have  "c i' j' =  Min ((\<lambda>k. c i' (k-1) + c k j' + w i' j') ` {i'+1..j'})"
                using \<open>i' < j'\<close> by(simp add: c_def_rec)
              also have "... \<le> w i' j' + c i' (?z-1) + c ?z j'"
                using \<open>?z \<in> {i'+1..j'}\<close> by simp
              finally show ?thesis .
            qed

            have b: "c i j \<le> w i j + c i (?y-1) + c ?y j"
            proof -
              have "c i j = Min ((\<lambda>k. c i (k-1) + c k j + w i j)  ` {i+1..j})"
                using \<open>i < j\<close> by(simp add: c_def_rec)
              also have "... \<le> w i j + c i (?y-1) + c ?y j"
                using \<open>?y \<in> {i+1..j}\<close> by simp
              finally show ?thesis .
            qed

            have "nat (?z - 1 - i) < l" using \<open>?z \<in> {i'+1..j'}\<close> less.prems by simp
            hence IH_Step: " c i (?y-1) + c i' (?z-1) \<le> c i' (?y-1) + c i (?z-1)"
              using \<open>?y \<in> {i'+1..j}\<close> \<open>\<not>?z \<le> ?y\<close> \<open>i \<le> i'\<close>
                less.IH[where i=i and i'=i' and j="?y-1" and j'="?z-1", OF _ refl]
              by simp

            have "c i' j' + c i j
              \<le> w i' j +  w i j' + c i' (?z-1) + c i (?y-1) + c ?z j' + c ?y j"
              using a b w_mon by simp
            also have "\<dots> \<le> w i' j +  w i j' + c i (?z-1) + c i' (?y-1) + c ?z j' + c ?y j"
              using IH_Step by auto
            also have "... = c i j' + c i' j" using \<open>?z \<in> {i + 1..j'}\<close> \<open>?y \<in> {i' + 1..j}\<close>
              by(simp add: c_k_def c_k_with_K)
            finally show ?thesis by linarith
          qed
        qed
      qed
    qed
  qed
qed

corollary QI': assumes "i < k" " k \<le> k'"  "k' \<le> j "  "c_k i j k' \<le> c_k i j k"
shows "c_k i (j+1) k' \<le> c_k i (j+1) k"
proof -
  have "c k j + c k' (j+1) \<le> c k' j + c k (j+1)"
    using lemma_2[of _ "j+1" k k' j] assms(1-3) by fastforce

  hence "c_k i j k + c_k i (j+1) k' \<le> c_k i j k' + c_k i (j+1) k"
    using assms(1-3) c_k_def by simp

  thus "c_k i (j+1) k' \<le> c_k i (j+1) k"
    using assms(4) by simp
qed

corollary QI'': assumes "i+1 < k" "k \<le> k'" "k' \<le> j+1" "c_k i (j+1) k' \<le> c_k i (j+1) k"
shows "c_k (i+1) (j+1) k' \<le> c_k (i+1) (j+1) k"
proof -
  have "c i k + c (i + 1) k' \<le> c i k' + c (i + 1) k"
    using lemma_2[of _ k' i "i+1" k] assms(1,2) by fastforce

  hence "c_k i (j+1) k + c_k (i+1) (j+1) k' \<le> c_k i (j+1) k' + c_k (i+1) (j+1) k"
    using c_k_def assms(1-3) lemma_2 by simp

  thus "c_k (i+1) (j+1) k' \<le> c_k (i+1) (j+1) k"
    using assms(4) by simp
qed

lemma lemma_3_1: assumes "i \<le> j" shows "K i j \<le> K i (j+1)"
proof cases
  assume "i = j"
  thus ?thesis
    by (metis K_def K_subset atLeastAtMost_iff less_add_one less_le)
next
  assume "i\<noteq>j"
  hence "i < j" using \<open>i \<le> j\<close> by simp

  let ?k = "K i (j+1)"
  have "K i j \<in> {i+1..j}" using K_def
    by (metis Max_in \<open>i < j\<close> mins_nonempty[OF \<open>i < j\<close>] finite_mins less_le mins_subset subsetCE)

  have "i < j+1" using \<open>i < j\<close> by linarith
  hence "K i (j+1) \<in> {i+1..j+1}"
    by (metis Max_in K_def mins_nonempty[OF \<open>i < j+1\<close>] finite_mins less_le mins_subset subsetCE)

  have *: "is_arg_min_on (c_k i (j+1)) {i+1..j+1} ?k"
  proof -
    have "K i (j+1) \<in> mins i (j+1)" using finite_mins mins_nonempty \<open>i < j\<close> K_def by fastforce
    thus "is_arg_min_on (c_k i (j+1)) {i+1..j+1} (K i (j+1))"
      unfolding Args_min_simps by blast
  qed
  show ?thesis
  proof cases
    assume "?k = j+1" thus ?thesis using \<open>K i j \<in> {i+1..j}\<close> by simp
  next
    assume "?k \<noteq> j+1"
    hence "?k \<in> {i+1..j}" using \<open>K i (j+1) \<in> {i+1..j+1}\<close> by auto
    have "i\<noteq>j" "i\<noteq>j+1" using \<open>i < j\<close> by auto
    hence K_simps: "K i j = Max (mins i j)" "K i (j+1) = Max (mins i (j+1))"
      unfolding K_def by auto
    show ?thesis unfolding K_simps
    proof (rule Max.boundedI[OF finite_mins mins_nonempty[OF \<open>i < j\<close>]])
      fix k' assume k': "k' \<in> mins i j"
      show "k' \<le> Max (mins i (j+1))"
      proof (rule ccontr)
        assume "~ k' \<le> Max (mins i (j+1))"
        have "c_k i (j+1) k' \<le> c_k i (j+1) ?k" unfolding K_simps
        proof (rule QI')
          show "i < Max (mins i (j+1))"
            using \<open>K i (j + 1) \<in> {i+1..j + 1}\<close> K_simps by auto
          show "Max (mins i (j+1)) \<le> k'" using \<open>~ k' \<le> Max (mins i (j+1))\<close>
            by linarith
          show "k' \<le> j" using mins_subset atLeastAtMost_iff k' by blast
          show "c_k i j k' \<le> c_k i j (Max (mins i (j + 1))) "
            using k' \<open>?k \<in> {i+1..j}\<close> by(simp add: K_simps Args_min_simps)
        qed

        hence "is_arg_min_on (c_k i (j+1)) {i+1..j+1} k'"
          apply(rule is_arg_min_on_antimono[OF *])
          using mins_subset k' by fastforce
        hence "k' \<in> mins i (j+1)" using k' by (auto simp: Args_min_on_def)
        thus False using finite_mins \<open>\<not> k' \<le> Max (mins i (j + 1))\<close> by auto
      qed
    qed
  qed
qed

lemma lemma_3_2: assumes "i \<le> j" shows "K i (j+1) \<le> K (i+1) (j+1)"
proof cases
  assume "i = j"
  thus ?thesis
    by (metis K_def K_subset atLeastAtMost_iff less_add_one less_le)
next
  assume "i \<noteq> j"
  hence "i < j" using \<open>i \<le> j\<close> by simp
  let ?k = "K (i+1) (j+1)"
  have "K i (j+1) \<in> {i+1..j+1}" unfolding K_def
    by (metis Max_in \<open>i < j\<close> finite_mins less_irrefl mins_nonempty mins_subset subsetCE zless_add1_eq)

  have "i+1 < j+1" using \<open>i < j\<close> by linarith
  hence "K (i+1) (j+1) \<in> {i+1+1..j+1}"
    using mins_nonempty[OF \<open>i+1 < j+1\<close>] mins_subset Max_in K_def finite_mins
    by (metis atLeastatMost_empty atLeastatMost_empty_iff2 contra_subsetD empty_subsetI less_add_one psubsetI)

  have *: "is_arg_min_on (c_k (i+1)(j+1)) {i+1+1..j+1} ?k"
  proof -
    have "K (i+1) (j+1) \<in> mins (i+1) (j+1)"
      using finite_mins mins_nonempty \<open>i + 1 < j + 1\<close> unfolding K_def
      by (metis Max_in not_less_iff_gr_or_eq)
    thus "is_arg_min_on (c_k (i+1) (j+1)) {i+1+1..j+1} (K (i+1) (j+1))"
      unfolding Args_min_on_def by blast
  qed
  show ?thesis
  proof cases
    assume "?k = j+1" thus ?thesis using \<open>K i (j+1) \<in> {i+1..j+1}\<close> by simp
  next
    assume "?k \<noteq> j+1"
    hence "?k \<in> {i+1+1..j}" using \<open>K (i+1) (j+1) \<in> {i+1+1..j+1}\<close> by auto

    have  "i\<noteq>j+1" "i+1 \<noteq> j+1" using \<open>i < j\<close> by auto
    hence K_simps: "K i (j+1) = Max (mins i (j+1))"
                      "K (i+1) (j+1) = Max (mins (i+1) (j+1))"
      unfolding K_def by auto
    have "i < j+1" using \<open>i+1 < j+1\<close> by simp

    show ?thesis unfolding K_simps
    proof (rule Max.boundedI[OF finite_mins mins_nonempty[OF \<open>i < j+1\<close>]])
      fix k' assume k': "k' \<in> mins i (j+1)"
      show "k' \<le> Max (mins (i + 1) (j + 1))"
      proof (rule ccontr)
        assume "~ k' \<le> Max (mins (i+1)(j+1))"
        have "c_k (i+1) (j+1) k' \<le> c_k (i+1) (j+1) ?k" unfolding K_simps
          thm QI'[of "i+1" "Max(mins (i+1)(j+1))" k' "j"]
        proof (rule QI'')
          show "i+1  < Max (mins (i+1)(j+1))"
            using \<open>K (i+1) (j+1) \<in> {i+1+1..j+1}\<close> K_simps
            by auto
          show "Max (mins (i + 1) (j + 1)) \<le> k'"
            using \<open>~ k' \<le> Max (mins (i+1)(j+1))\<close> K_simps by linarith
          show "k' \<le> j+1"
            using mins_subset k' by fastforce
          show "c_k i (j+1) k' \<le> c_k i (j+1) (Max (mins (i + 1) (j + 1)))"
            using k' \<open>?k \<in> {(i+1)+1..j + 1}\<close> K_simps
            by(simp add: Args_min_simps)
        qed

        hence "is_arg_min_on (c_k (i+1) (j+1)) {i+1+1..j+1} k'"
          apply(rule is_arg_min_on_antimono[OF *])
          using mins_subset k' K_simps \<open>?k \<in> {i+1+1..j}\<close>
            \<open>\<not> k' \<le> Max (mins (i + 1) (j + 1))\<close> atLeastAtMost_iff
          by force
        hence "k' \<in> mins (i+1) (j+1)" by (simp add: k' Args_min_on_def)
        thus False using finite_mins \<open>\<not> k' \<le> Max (mins (i+1)(j+1))\<close> Max_ge
          by blast
      qed
    qed
  qed
qed

lemma lemma_3: assumes "i \<le> j"
  shows "K i j \<le> K i (j+1)" "K i (j+1) \<le> K (i+1) (j+1)"
using assms lemma_3_1 lemma_3_2 by blast+

end (* locale QI *)

end


theory Simply
imports CR
begin

section {* Simply typed *}

subsection {* Typing rules *}

nominal_datatype simply = TVar string | TArr simply simply (infixr "\<rightarrow>" 90)

inductive valid :: "(var \<times> simply) list \<Rightarrow> bool" where
  valid_nil: "valid []"
| valid_cons: "\<lbrakk> valid \<Gamma>; x \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

lemma elim_valid_cons: "valid ((x,T)#\<Gamma>) \<Longrightarrow> valid \<Gamma> \<and> x \<sharp> \<Gamma>"
by (cases rule: valid.cases, auto)

lemma fresh_notin:
  fixes x :: var and \<Gamma> :: "(var \<times> simply) list"
  assumes "x \<sharp> \<Gamma>"
  shows "(x,y) \<notin> set \<Gamma>"
using assms
apply (induction \<Gamma> arbitrary: x, simp, simp add: fresh_list_cons)
apply (rule, auto simp add: fresh_prod fresh_atm)
done

lemma valid_ctx_unique:
  assumes "valid \<Gamma>" "(x,\<sigma>) \<in> set \<Gamma>" "(x,\<tau>) \<in> set \<Gamma>"
  shows "\<sigma> = \<tau>"
using assms apply (induction \<Gamma> arbitrary: x, auto)
  using fresh_notin apply simp
  using fresh_notin apply simp
done

inductive typed ("_ \<turnstile> _ : _" 40) where
  st_var: "\<lbrakk> valid \<Gamma>; (x,\<sigma>) \<in> set \<Gamma> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : \<sigma>"
| st_app: "\<lbrakk> \<Gamma> \<turnstile> M : (\<sigma> \<rightarrow> \<tau>); \<Gamma> \<turnstile> N : \<sigma> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App M N : \<tau>"
| st_abs: "\<lbrakk> x \<sharp> \<Gamma>; (x,\<sigma>)#\<Gamma> \<turnstile> M : \<tau> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (lam [x]. M) : (\<sigma> \<rightarrow> \<tau>)"

equivariance typed

lemma fresh_type:
  fixes x :: var
  and T :: simply
  shows "x \<sharp> T"
by (nominal_induct T rule:simply.strong_induct, simp_all add: fresh_string)

nominal_inductive typed
  by (simp_all add: fresh_type abs_fresh)

fun dom where
  "dom \<Gamma> = (\<lambda>(x,y). x) ` \<Gamma>"

subsubsection {* lemma *}

lemma weak_ctx:
  assumes "set \<Gamma> \<subseteq> set \<Gamma>'" "valid \<Gamma>'" "\<Gamma> \<turnstile> M : \<sigma>"
  shows "\<Gamma>' \<turnstile> M : \<sigma>"
using assms(1) assms(2) apply (nominal_induct avoiding: \<Gamma>' rule: typed.strong_induct [OF assms(3)])
apply (rule, simp, fastforce)
using st_app apply blast
apply (rule, simp, simp)
by (simp add: subset_insertI2 valid.intros(2))

lemma typed_valid: "\<Gamma> \<turnstile> M : A \<Longrightarrow> valid \<Gamma>"
apply (nominal_induct rule: typed.strong_induct, auto)
using elim_valid_cons by blast

lemma ctx_swap_head_typed: "(x,t) # (y,s) # \<Gamma> \<turnstile> M : A \<Longrightarrow> (y,s) # (x,t) # \<Gamma> \<turnstile> M : A"
proof (rule weak_ctx [of "(x,t) # (y,s) # \<Gamma>"], auto)
  assume "(x, t) # (y, s) # \<Gamma> \<turnstile> M : A"
  hence "valid ((x,t) # (y, s) # \<Gamma>)" by (simp add: typed_valid)
  hence "valid ((y,s) # \<Gamma>) \<and> x \<sharp> (y,\<Gamma>)"
    using elim_valid_cons
    by (meson fresh_list_cons fresh_prod)
  hence fresh: "valid \<Gamma>" "y \<sharp> \<Gamma>" "x \<noteq> y" "x \<sharp> \<Gamma>"
    using elim_valid_cons apply blast
    using \<open>valid ((y, s) # \<Gamma>) \<and> x \<sharp> (y, \<Gamma>)\<close> elim_valid_cons apply blast
    apply (metis \<open>valid ((x, t) # (y, s) # \<Gamma>)\<close> elim_valid_cons fresh_notin list.set_intros(1))
    by (simp add: \<open>valid ((y, s) # \<Gamma>) \<and> x \<sharp> (y, \<Gamma>)\<close>)
  show "valid ((y, s) # (x, t) # \<Gamma>)"
    apply (rule, rule, rule fresh, rule fresh)
    by (metis fresh(2) fresh(3) fresh_atm fresh_list_cons fresh_prod fresh_type)
qed

subsubsection {* coherence *}

lemma gen_typed_valid: "\<Gamma> \<turnstile> M : \<sigma> \<Longrightarrow> valid \<Gamma>"
apply (nominal_induct rule: typed.strong_induct)
  apply (auto)
  by (metis list.distinct(1) list.inject valid.simps)

lemma gen_typed_var: "\<Gamma> \<turnstile> Var x : \<sigma> \<Longrightarrow> (x,\<sigma>) \<in> set \<Gamma>"
by (cases rule:typed.cases, auto simp add: lambda.inject)

lemma gen_typed_app:
  assumes "\<Gamma> \<turnstile> M $ N : \<tau>"
  obtains \<sigma> where "\<Gamma> \<turnstile> M : (\<sigma> \<rightarrow> \<tau>)" "\<Gamma> \<turnstile> N : \<sigma>"
by (cases rule:typed.cases [OF assms], auto simp add: lambda.inject)

lemma gen_typed_abs:
  assumes "\<Gamma> \<turnstile> lam [x]. M : \<rho>" "x \<sharp> \<Gamma>"
  obtains \<sigma> \<tau> where "(x,\<sigma>)#\<Gamma> \<turnstile> M : \<tau>" "\<rho> = \<sigma> \<rightarrow> \<tau>"
using assms
apply (cases rule: typed.strong_cases [of _ _ _ _ x], auto)
by (metis abs_fresh(1) abs_fun_eq1 fresh_type lambda.inject(3))

subsubsection {* Soundness *}

lemma typed_var_unique: "(x,\<sigma>)#\<Gamma> \<turnstile> Var x : \<tau> \<Longrightarrow> \<sigma> = \<tau>"
apply (cases rule: typed.strong_cases, auto simp add: lambda.inject)
using elim_valid_cons apply (rule, simp)
  using fresh_notin apply auto
apply (generate_fresh var)
by (meson gen_typed_valid gen_typed_var list.set_intros(1) valid_ctx_unique)

lemma subst_typed: "\<lbrakk> (x,\<sigma>)#\<Gamma> \<turnstile> M : \<tau>; \<Gamma> \<turnstile> N : \<sigma> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> M[x::=N] : \<tau>"
apply (nominal_induct M avoiding: x N \<sigma> \<Gamma> arbitrary: \<tau> rule: lambda.strong_induct)
  apply (auto elim!: gen_typed_var)
  using typed_var_unique apply fastforce
  using gen_typed_var [of "(x,\<sigma>)#\<Gamma>" _ \<sigma>] apply simp
  apply (meson Pair_inject gen_typed_valid gen_typed_var set_ConsD st_var)
    apply (rule gen_typed_app, simp)
    apply (rule, blast, blast)
proof-
  fix name lambda x N \<sigma> \<Gamma> \<tau>
  assume name_fresh: "name \<sharp> x" "name \<sharp> N" "name \<sharp> \<sigma>" "name \<sharp> \<Gamma>"
  and IH: "\<And>b ba bb bc \<tau>. (b, bb) # bc \<turnstile> lambda : \<tau> \<Longrightarrow> bc \<turnstile> ba : bb \<Longrightarrow> bc \<turnstile> lambda[b::=ba] : \<tau>"
  and hyp: "(x, \<sigma>) # \<Gamma> \<turnstile> lam [name].lambda : \<tau>" "\<Gamma> \<turnstile> N : \<sigma>"

  obtain \<tau>1 \<tau>2 where tau: "\<tau> = \<tau>1 \<rightarrow> \<tau>2" "(name, \<tau>1) # (x, \<sigma>) # \<Gamma> \<turnstile> lambda : \<tau>2"
    by (metis fresh_list_cons fresh_prod fresh_type gen_typed_abs hyp(1) name_fresh(1) name_fresh(4))
  have "(name,\<tau>1) # \<Gamma> \<turnstile> lambda[x::=N] : \<tau>2"
    apply (rule IH)
    apply (rule ctx_swap_head_typed)
    apply (rule tau)
    apply (rule weak_ctx [of \<Gamma>], auto)
    apply (rule, rule typed_valid, rule hyp, rule name_fresh, rule hyp)
    done
  thus "\<Gamma> \<turnstile> lam [name]. (lambda[x::=N]) : \<tau>"
    apply (simp add: tau(1))
    by (simp add: name_fresh(4) st_abs)
qed

lemma preservation_one:
  assumes "M \<rightarrow>\<beta> M'"
  shows "\<Gamma> \<turnstile> M : \<sigma> \<Longrightarrow> \<Gamma> \<turnstile> M' : \<sigma>"
apply (nominal_induct avoiding: \<Gamma> arbitrary: \<sigma> rule: beta.strong_induct [OF assms])
apply (erule gen_typed_app, rule)
prefer 2 apply (simp, simp)
apply (erule gen_typed_app, rule)
apply (simp, simp)
apply (erule gen_typed_abs, simp, simp, rule, simp, simp)
apply (erule gen_typed_app, erule gen_typed_abs, simp)
apply (rule subst_typed, simp add: simply.inject, simp add: simply.inject)
done

lemma preservation:
  assumes "M \<longrightarrow>\<beta>* M'"
  shows "\<Gamma> \<turnstile> M : \<sigma> \<Longrightarrow> \<Gamma> \<turnstile> M' : \<sigma>"
by (induct rule: long_beta.induct [OF assms], auto simp add: preservation_one)

nominal_primrec Value :: "lambda \<Rightarrow> bool" where
  "Value (lam [_]._) = True"
  | "Value (Var _) = False"
  | "Value (App _ _) = False"
by (finite_guess+, rule+, fresh_guess+)

lemma Value_eqvt[eqvt]:
  fixes \<pi> :: "var prm" and M :: lambda
  shows "\<pi> \<bullet> Value M = Value (\<pi> \<bullet> M)"
by (nominal_induct M rule: lambda.strong_induct, auto)

lemma Value_abs:
  assumes "Value M"
  obtains x M' where "M = lam [x]. M'"
using assms by (nominal_induct M rule: lambda.strong_induct, auto)

lemma progress: "[] \<turnstile> M : \<sigma> \<Longrightarrow> Value M \<or> (\<exists>M'. M \<rightarrow>\<beta> M')"
proof-
  have "\<And>\<Gamma>. \<lbrakk> \<Gamma> \<turnstile> M : \<sigma>; \<Gamma> = [] \<rbrakk> \<Longrightarrow> Value M \<or> (\<exists>M'. M \<rightarrow>\<beta> M')"
    proof-
      fix \<Gamma>
      show "\<lbrakk> \<Gamma> \<turnstile> M : \<sigma>; \<Gamma> = [] \<rbrakk> \<Longrightarrow> Value M \<or> (\<exists>M'. M \<rightarrow>\<beta> M')"
        apply (nominal_induct rule: typed.strong_induct, auto)
        apply (erule Value_abs, simp, rule, rule b_beta)
        done
    qed
  thus "[] \<turnstile> M : \<sigma> \<Longrightarrow> Value M \<or> (\<exists>M'. M \<rightarrow>\<beta> M')" by simp
qed

theorem soundness:
  assumes "[] \<turnstile> M : \<sigma>" "M \<longrightarrow>\<beta>* M'"
  shows "Value M' \<or> (\<exists> M''. M' \<rightarrow>\<beta> M'')"
by (rule progress, rule preservation, rule assms, rule assms)

inductive SN where
  SN: "(\<And>M'. M \<rightarrow>\<beta> M' \<Longrightarrow> SN M') \<Longrightarrow> SN M"

nominal_primrec RED where
  "RED (TVar x) = {t. SN t}"
| "RED (A \<rightarrow> B) = {t. \<forall>u. u \<in> RED A \<longrightarrow> t $ u \<in> RED B}"
by (rule+)

lemma RED_forward:
  assumes "M \<rightarrow>\<beta> M'"
  shows "M \<in> RED A \<Longrightarrow> M' \<in> RED A"
using assms apply (nominal_induct A arbitrary: M M' rule: simply.strong_induct, auto)
apply (cases rule: SN.cases, simp, simp)
apply blast
done

lemma SN_elim_app1_var: "SN (M $ Var x) \<Longrightarrow> SN M"
proof-
  { fix N
    have "\<lbrakk> SN N; N = (M $ Var x) \<rbrakk> \<Longrightarrow> SN M"
      apply (induct arbitrary: M rule: SN.induct, auto, rule)
      apply (cases rule: beta.cases, auto)
      done
  }
  thus "SN (M $ Var x) \<Longrightarrow> SN M" by simp
qed

lemma SN_var: "SN (Var x)"
by (rule, cases rule: beta.cases, auto)

lemma elim_app_beta:
  assumes "M $ N \<rightarrow>\<beta> L" and "nonabs M"
  shows "(\<And>M'. M \<rightarrow>\<beta> M' \<Longrightarrow> L = M' $ N \<Longrightarrow> thesis) \<Longrightarrow> (\<And>N'. N \<rightarrow>\<beta> N' \<Longrightarrow> L = M $ N' \<Longrightarrow> thesis) \<Longrightarrow> thesis"
apply (cases rule: beta.cases [OF assms(1)], auto simp add: lambda.inject)
using assms(2) apply simp
done

lemma RED_sn_and_neutral_backward:
  "M \<in> RED A \<Longrightarrow> SN M" and "\<lbrakk> nonabs M; (\<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> M' \<in> RED A) \<rbrakk> \<Longrightarrow> M \<in> RED A"
apply (nominal_induct A arbitrary: M rule: simply.strong_induct, auto)
  apply (rule, simp)
proof-
  fix t1 t2 M
  assume "(\<And>M. M \<in> RED t1 \<Longrightarrow> SN M)" and hyp: "(\<And>M. nonabs M \<Longrightarrow> \<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> M' \<in> RED t1 \<Longrightarrow> M \<in> RED t1)"
  and hyp3: "(\<And>M. M \<in> RED t2 \<Longrightarrow> SN M)" and "(\<And>M. nonabs M \<Longrightarrow> \<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> M' \<in> RED t2 \<Longrightarrow> M \<in> RED t2)"
  and hyp2: "\<forall>u. u \<in> RED t1 \<longrightarrow> M $ u \<in> RED t2"

  fix x
  have "Var x \<in> RED t1"
    apply (rule hyp, auto)
    apply (cases rule: beta.cases, auto)
    done
  hence "M $ Var x \<in> RED t2" by (simp add: hyp2)
  hence "SN (M $ Var x)" by (rule hyp3)
  thus "SN M" by (rule SN_elim_app1_var)
next
  fix t1 t2 M u
  assume "(\<And>M. M \<in> RED t1 \<Longrightarrow> SN M)" "(\<And>M. nonabs M \<Longrightarrow> \<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> M' \<in> RED t1 \<Longrightarrow> M \<in> RED t1)"
  and "(\<And>M. M \<in> RED t2 \<Longrightarrow> SN M)" "(\<And>M. nonabs M \<Longrightarrow> \<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> M' \<in> RED t2 \<Longrightarrow> M \<in> RED t2)"
  and "nonabs M"
  and hyp: "\<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> (\<forall>u. u \<in> RED t1 \<longrightarrow> M' $ u \<in> RED t2)" "u \<in> RED t1"

  { fix N
    have "\<lbrakk> SN N; N \<in> RED t1 \<rbrakk> \<Longrightarrow> M $ N \<in> RED t2"
      proof (induct rule: SN.induct)
        fix P
        assume "\<And>P'. P \<rightarrow>\<beta> P' \<Longrightarrow> SN P'"
        and "\<And>P'. P \<rightarrow>\<beta> P' \<Longrightarrow> P' \<in> RED t1 \<Longrightarrow> M $ P' \<in> RED t2"
        and "P \<in> RED t1"

        have P: "\<And>M'. M $ P \<rightarrow>\<beta> M' \<Longrightarrow> M' \<in> RED t2"
          apply (erule elim_app_beta, auto)
          apply fact
          using `P \<in> RED t1` hyp apply simp
          by (simp add: RED_forward \<open>P \<in> RED t1\<close> \<open>\<And>P'. \<lbrakk>P \<rightarrow>\<beta> P'; P' \<in> RED t1\<rbrakk> \<Longrightarrow> M $ P' \<in> RED t2\<close>)
        show "M $ P \<in> RED t2"
          apply (rule `\<And>M. nonabs M \<Longrightarrow> \<forall>M'. M \<rightarrow>\<beta> M' \<longrightarrow> M' \<in> RED t2 \<Longrightarrow> M \<in> RED t2`)
          using `nonabs M` apply simp
          apply (simp add: P)
          done
      qed
  }
  thus "M $ u \<in> RED t2"
    using `M \<in> RED t1 \<Longrightarrow> SN M` `u \<in> RED t1`
    using \<open>\<And>M. M \<in> RED t1 \<Longrightarrow> SN M\<close> by auto
qed

(*
lemma SN_abs:
  assumes "SN M"
  shows "SN (lam [x]. M)"
proof rule
  fix M'
  assume "lam [x]. M \<rightarrow>\<beta> M'"
  then obtain M'' where "M \<rightarrow>\<beta> M''" "M' = lam [x]. M''"
    apply (cases rule: beta.strong_cases [of _ _ _ x x], auto simp add: abs_fresh)
  show "SN M'"

lemma RED_subst:
  assumes "N \<in> RED t'" "M [x ::= N] \<in> RED t"
  shows "(lam [x]. M) $ N \<in> RED t"
*)

end


chapter \<open>Diagonalization\<close>

text \<open>This theory proves abstract versions of the diagonalization lemma,
with both hard and soft substitution.\<close>

section \<open>Alternative Diagonalization via Self-Substitution\<close>

(*<*)
theory Diagonalization imports Abstract_Representability
begin
(*>*)

text \<open>
Assuming representability of the diagonal instance of the substitution function,
we prove the standard diagonalization lemma. More precisely, we show that it applies
to any logic that
-- embeds intuitionistic first-order logic over numerals
-- has a countable number of formulas
-- has formula self-substitution representable
\<close>

context Repr_SelfSubst
begin

theorem diagonalization:
  assumes \<phi>[simp,intro!]: "\<phi> \<in> fmla" "Fvars \<phi> = {xx}"
  shows "\<exists> \<psi>. \<psi> \<in> fmla \<and> Fvars \<psi> = {} \<and> bprv (eqv \<psi> (subst \<phi> \<langle>\<psi>\<rangle> xx))"
proof-
  let ?phi = "\<lambda> t. subst \<phi> t xx"
  define \<chi> where "\<chi> \<equiv> exi yy (cnj (?phi (Var yy)) (SS (Var xx) (Var yy)))"
  have \<chi>[simp,intro!]: "\<chi> \<in> fmla" unfolding \<chi>_def by auto
  let ?chi = "\<lambda> t. subst \<chi> t xx"
  define \<psi> where "\<psi> \<equiv> ?chi \<langle>\<chi>\<rangle>"
  have \<psi>[simp,intro!]: "\<psi> \<in> fmla" unfolding \<psi>_def by auto
  have f\<chi>[simp]: "Fvars \<chi> = {xx}" unfolding \<chi>_def by auto
  hence Fvars_\<psi>: "Fvars \<psi> = {}" unfolding \<psi>_def by auto
  have 1: "bprv (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)"
    using subst_implies_prv_SS[OF \<chi>] unfolding \<psi>_def by simp
  have 2: "bprv (all yy' (
             imp (cnj (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)
                      (SS \<langle>\<chi>\<rangle> (Var yy')))
                 (eql \<langle>\<psi>\<rangle> (Var yy'))))"
    using Fvars_\<psi> B.prv_allE[OF _ _ _ SS_unique, of \<chi> "\<langle>\<psi>\<rangle>"]
    by fastforce
  have 31: "bprv (all yy'
                     (imp (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)
                          (imp (SS \<langle>\<chi>\<rangle> (Var yy'))
                               (eql \<langle>\<psi>\<rangle> (Var yy')))))"
    using B.prv_all_imp_cnj_rev[OF _ _ _ _ 2] by simp
  have 32: "bprv (imp (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)
                      (all yy' (imp (SS \<langle>\<chi>\<rangle> (Var yy'))
                                    (eql \<langle>\<psi>\<rangle> (Var yy')))))"
    by (intro B.prv_all_imp[OF _ _ _ _ 31]) (auto simp: SS_def2)
  have 33: "bprv (all yy' (imp (SS \<langle>\<chi>\<rangle> (Var yy'))
                               (eql \<langle>\<psi>\<rangle> (Var yy'))))"
    by (rule B.prv_imp_mp [OF _ _ 32 1]) auto
  have 3: "bprv (all yy (imp (SS \<langle>\<chi>\<rangle> (Var yy))
                             (eql \<langle>\<psi>\<rangle> (Var yy))))"
    using B.all_subst_rename_prv[OF _ _ _ _ 33, of yy]
    by fastforce
  have 41: "bprv (imp (?phi \<langle>\<psi>\<rangle>)
                      (cnj (?phi \<langle>\<psi>\<rangle>)
                           (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)))"
    by (auto intro: in_num B.prv_imp_cnj B.prv_imp_refl B.prv_imp_triv[OF _ _ 1])
  have [simp]: "subst (subst \<phi> \<langle>\<psi>\<rangle> xx) \<langle>\<psi>\<rangle> yy = subst \<phi> \<langle>\<psi>\<rangle> xx"
    by (intro subst_notIn) auto
  have [simp]: "subst (subst \<phi> (Var yy) xx) \<langle>\<psi>\<rangle> yy = subst \<phi> \<langle>\<psi>\<rangle> xx"
    by (intro subst_subst) auto
  have 42: "bprv (exi yy (imp (?phi \<langle>\<psi>\<rangle>)
                              (cnj (?phi (Var yy))
                                   (SS \<langle>\<chi>\<rangle> (Var yy)))))"
    using 41 by (intro B.prv_exiI[of _ _ "\<langle>\<psi>\<rangle>"]) auto
  have 4: "bprv (imp (?phi \<langle>\<psi>\<rangle>) (?chi \<langle>\<chi>\<rangle>))"
    using B.prv_imp_exi[OF _ _ _ _ 42,simplified]
    by (subst \<chi>_def) (auto simp add: subst_comp_num)
  have 50: "bprv (all yy (
          (imp (eql \<langle>\<psi>\<rangle> (Var yy))
               (imp (?phi (Var yy))
                    (?phi \<langle>\<psi>\<rangle>)))))"
    using B.prv_all_eql[of yy xx \<phi> "\<langle>\<psi>\<rangle>" "Var yy"] by simp
  have 51: "bprv (all yy (
          (imp (SS \<langle>\<chi>\<rangle> (Var yy))
               (imp (?phi (Var yy))
               (?phi \<langle>\<psi>\<rangle>)))))" using B.prv_all_imp_trans[OF _ _ _ _ 3 50] by simp
  have 52: "bprv (all yy (
          (imp (cnj (?phi (Var yy))
                    (SS \<langle>\<chi>\<rangle> (Var yy)))
               (?phi \<langle>\<psi>\<rangle>))))" using B.prv_all_imp_cnj[OF _ _ _ _ 51] by simp
  have 5: "bprv (imp (?chi \<langle>\<chi>\<rangle>) (?phi \<langle>\<psi>\<rangle>))"
    using B.prv_exi_imp[OF _ _ _ _ 52,simplified]
    by (subst \<chi>_def) (simp add: subst_comp_num)
  have 6: "bprv (eqv (?chi \<langle>\<chi>\<rangle>) (?phi \<langle>\<psi>\<rangle>))"
    using B.prv_cnjI[OF _ _ 5 4] unfolding eqv_def by simp
  have 7: "bprv (eqv \<psi> (?phi \<langle>\<psi>\<rangle>))" using 6 unfolding \<psi>_def .
  show ?thesis using \<psi> 7 Fvars_\<psi> by blast
qed

text \<open>Making this existential into a function.\<close>

definition diag :: "'fmla \<Rightarrow> 'fmla" where
  "diag \<phi> \<equiv> SOME \<psi>. \<psi> \<in> fmla \<and> Fvars \<psi> = {} \<and> bprv (eqv \<psi> (subst \<phi> \<langle>\<psi>\<rangle> xx))"

theorem diag_everything:
  assumes "\<phi> \<in> fmla" and "Fvars \<phi> = {xx}"
  shows "diag \<phi> \<in> fmla \<and> Fvars (diag \<phi>) = {} \<and> bprv (eqv (diag \<phi>) (subst \<phi> \<langle>diag \<phi>\<rangle> xx))"
  unfolding diag_def using someI_ex[OF diagonalization[OF assms]] .

lemmas diag[simp] = diag_everything[THEN conjunct1]
lemmas Fvars_diag[simp] = diag_everything[THEN conjunct2, THEN conjunct1]
lemmas bprv_diag_eqv = diag_everything[THEN conjunct2, THEN conjunct2]

end \<comment> \<open>context @{locale Repr_SelfSubst}\<close>

section \<open>Alternative Diagonalization via Soft Self-Substitution\<close>

context Repr_SelfSoftSubst
begin

theorem diagonalization:
  assumes \<phi>[simp,intro!]: "\<phi> \<in> fmla" "Fvars \<phi> = {xx}"
  shows "\<exists> \<psi>. \<psi> \<in> fmla \<and> Fvars \<psi> = {} \<and> bprv (eqv \<psi> (subst \<phi> \<langle>\<psi>\<rangle> xx))"
proof-
  let ?phi = "\<lambda> t. subst \<phi> t xx"
  define \<chi> where "\<chi> \<equiv> exi yy (cnj (?phi (Var yy)) (SS (Var xx) (Var yy)))"
  have \<chi>[simp,intro!]: "\<chi> \<in> fmla" unfolding \<chi>_def by auto
  let ?chi = "\<lambda> t. softSubst \<chi> t xx"
  define \<psi> where "\<psi> \<equiv> ?chi \<langle>\<chi>\<rangle>"
  have \<psi>[simp,intro!]: "\<psi> \<in> fmla" unfolding \<psi>_def by auto
  have f\<chi>[simp]: "Fvars \<chi> = {xx}" unfolding \<chi>_def by auto
  hence Fvars_\<psi>: "Fvars \<psi> = {}" unfolding \<psi>_def by auto
  have 1: "bprv (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)"
    using softSubst_implies_prv_SS[OF \<chi>] unfolding \<psi>_def by simp
  have 2: "bprv (all yy' (
             imp (cnj (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)
                      (SS \<langle>\<chi>\<rangle> (Var yy')))
                 (eql \<langle>\<psi>\<rangle> (Var yy'))))"
    using Fvars_\<psi> B.prv_allE[OF _ _ _ SS_unique, of \<chi> "\<langle>\<psi>\<rangle>"]
    by fastforce
  have 31: "bprv (all yy'
                     (imp (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)
                          (imp (SS \<langle>\<chi>\<rangle> (Var yy'))
                               (eql \<langle>\<psi>\<rangle> (Var yy')))))"
    using B.prv_all_imp_cnj_rev[OF _ _ _ _ 2] by simp
  have 32: "bprv (imp (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)
                     (all yy' (imp (SS \<langle>\<chi>\<rangle> (Var yy'))
                                   (eql \<langle>\<psi>\<rangle> (Var yy')))))"
    by (intro B.prv_all_imp[OF _ _ _ _ 31]) (auto simp: SS_def2)
  have 33: "bprv (all yy' (imp (SS \<langle>\<chi>\<rangle> (Var yy'))
                              (eql \<langle>\<psi>\<rangle> (Var yy'))))"
    by (rule B.prv_imp_mp [OF _ _ 32 1]) auto
  have 3: "bprv (all yy (imp (SS \<langle>\<chi>\<rangle> (Var yy))
                            (eql \<langle>\<psi>\<rangle> (Var yy))))"
    using B.all_subst_rename_prv[OF _ _ _ _ 33, of yy]
    by fastforce
  have 41: "bprv (imp (?phi \<langle>\<psi>\<rangle>)
                     (cnj (?phi \<langle>\<psi>\<rangle>)
                          (SS \<langle>\<chi>\<rangle> \<langle>\<psi>\<rangle>)))"
    by (auto intro: in_num B.prv_imp_cnj B.prv_imp_refl B.prv_imp_triv[OF _ _ 1])
  have [simp]: "subst (subst \<phi> \<langle>\<psi>\<rangle> xx) \<langle>\<psi>\<rangle> yy = subst \<phi> \<langle>\<psi>\<rangle> xx"
    by (intro subst_notIn) auto
  have [simp]: "subst (subst \<phi> (Var yy) xx) \<langle>\<psi>\<rangle> yy = subst \<phi> \<langle>\<psi>\<rangle> xx"
    by (intro subst_subst) auto
  have 42: "bprv (exi yy (imp (?phi \<langle>\<psi>\<rangle>)
                             (cnj (?phi (Var yy))
                                  (SS \<langle>\<chi>\<rangle> (Var yy)))))"
    using 41 by (intro B.prv_exiI[of _ _ "\<langle>\<psi>\<rangle>"]) auto
  have 4: "bprv (imp (?phi \<langle>\<psi>\<rangle>) (subst \<chi> \<langle>\<chi>\<rangle> xx))"
    using B.prv_imp_exi[OF _ _ _ _ 42,simplified]
    by (subst \<chi>_def) (auto simp add: subst_comp_num)
  moreover have "bprv (imp (subst \<chi> \<langle>\<chi>\<rangle> xx) (?chi \<langle>\<chi>\<rangle>))" by (rule B.prv_subst_imp_softSubst) auto
  ultimately have 4: "bprv (imp (?phi \<langle>\<psi>\<rangle>) (?chi \<langle>\<chi>\<rangle>))"
    by (rule B.prv_prv_imp_trans[rotated -2]) auto
  have 50: "bprv (all yy (
          (imp (eql \<langle>\<psi>\<rangle> (Var yy))
               (imp (?phi (Var yy))
                    (?phi \<langle>\<psi>\<rangle>)))))"
    using B.prv_all_eql[of yy xx \<phi> "\<langle>\<psi>\<rangle>" "Var yy"] by simp
  have 51: "bprv (all yy (
          (imp (SS \<langle>\<chi>\<rangle> (Var yy))
               (imp (?phi (Var yy))
               (?phi \<langle>\<psi>\<rangle>)))))" using B.prv_all_imp_trans[OF _ _ _ _ 3 50] by simp
  have 52: "bprv (all yy (
          (imp (cnj (?phi (Var yy))
                    (SS \<langle>\<chi>\<rangle> (Var yy)))
               (?phi \<langle>\<psi>\<rangle>))))" using B.prv_all_imp_cnj[OF _ _ _ _ 51] by simp
  have "bprv (imp (?chi \<langle>\<chi>\<rangle>) (subst \<chi> \<langle>\<chi>\<rangle> xx))" by (rule B.prv_softSubst_imp_subst) auto
  moreover have "bprv (imp (subst \<chi> \<langle>\<chi>\<rangle> xx) (?phi \<langle>\<psi>\<rangle>))"
    using B.prv_exi_imp[OF _ _ _ _ 52,simplified]
    by (subst \<chi>_def) (simp add: subst_comp_num)
  ultimately have 5: "bprv (imp (?chi \<langle>\<chi>\<rangle>) (?phi \<langle>\<psi>\<rangle>))"
    by (rule B.prv_prv_imp_trans[rotated -2]) auto
  have 6: "bprv (eqv (?chi \<langle>\<chi>\<rangle>) (?phi \<langle>\<psi>\<rangle>))"
    using B.prv_cnjI[OF _ _ 5 4] unfolding eqv_def by simp
  have 7: "bprv (eqv \<psi> (?phi \<langle>\<psi>\<rangle>))" using 6 unfolding \<psi>_def .
  show ?thesis using \<psi> 7 Fvars_\<psi> by blast
qed

text \<open>Making this existential into a function.\<close>

definition diag :: "'fmla \<Rightarrow> 'fmla" where
  "diag \<phi> \<equiv> SOME \<psi>. \<psi> \<in> fmla \<and> Fvars \<psi> = {} \<and> bprv (eqv \<psi> (subst \<phi> \<langle>\<psi>\<rangle> xx))"

theorem diag_everything:
  assumes "\<phi> \<in> fmla" and "Fvars \<phi> = {xx}"
  shows "diag \<phi> \<in> fmla \<and> Fvars (diag \<phi>) = {} \<and> bprv (eqv (diag \<phi>) (subst \<phi> \<langle>diag \<phi>\<rangle> xx))"
  unfolding diag_def using someI_ex[OF diagonalization[OF assms]] .

lemmas diag[simp] = diag_everything[THEN conjunct1]
lemmas Fvars_diag[simp] = diag_everything[THEN conjunct2, THEN conjunct1]
lemmas prv_diag_eqv = diag_everything[THEN conjunct2, THEN conjunct2]

end \<comment> \<open>context @{locale Repr_SelfSoftSubst}\<close>

(*<*)
end
(*>*)


theory prop_48
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun length :: "Nat list => Nat" where
  "length (Nil2) = Z"
  | "length (Cons2 y xs) = S (length xs)"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun insert2 :: "Nat => Nat list => Nat list" where
  "insert2 x (Nil2) = Cons2 x (Nil2)"
  | "insert2 x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"
  fun isort :: "Nat list => Nat list" where
  "isort (Nil2) = Nil2"
  | "isort (Cons2 y xs) = insert2 y (isort xs)"
  (*hipster length le insert2 isort *)

(*
lemma lemma_a [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_aa [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ab [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

(*hipster_cond le*)
lemma lemma_ac [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ad [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ae [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma le_trans [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)*)

(*hipster length le insert2 isort*)
lemma lemma_af [thy_expl]: "S (length x5) = length (insert2 y5 x5)"
by (hipster_induct_schemes length.simps  insert2.simps isort.simps)

lemma lemma_ag [thy_expl]: "length (isort x17) = length x17"
by (hipster_induct_schemes )
(*
lemma lemma_ah [thy_expl]: "insert2 Z (insert2 x18 y18) = insert2 x18 (insert2 Z y18)"
by (hipster_induct_schemes length.simps le.simps insert2.simps isort.simps)

lemma lemma_ai [thy_expl]: "insert2 Z (isort x3) = isort (insert2 Z x3)"
by (hipster_induct_schemes length.simps le.simps insert2.simps isort.simps)*)

  theorem x0 :
    "(length (isort x)) = (length x)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*
   Author: Mike Stannett
   Date: 22 October 2012
   m.stannett@sheffield.ac.uk
   Updated 28 April 2016 to run under Isabelle2016.
*)
theory SpaceTime
imports Main
begin

(* A linordered_field is a field with a linear (total) order
  INHERITED SYNTAX:
    linorder: <, \<le>, \<ge>, >
    field: a * b, a / b, inverse a
           a + b, a - b, -a
           0, 1
*)

(*
  A vector has four components
*)
record 'a Vector =
  tdir :: "'a"
  xdir :: "'a"
  ydir :: "'a"
  zdir :: "'a"

(*
  A point has four coordinates.
*)
record 'a Point =
  tval :: "'a"
  xval :: "'a"
  yval :: "'a"
  zval :: "'a"

(*
  To specify a line, give its local origin ("basepoint") together with its direction.
*)
record 'a Line  =
  basepoint :: "'a Point"
  direction :: "'a Vector"

(*
  To specify a plane, give its local origin ("pbasepoint") together with two basis vectors
*)
record 'a Plane =
  pbasepoint :: "'a Point"
  direction1 :: "'a Vector"
  direction2 :: "'a Vector"

(*
  To specify an upright cone, give its vertex and slope.
*)
record 'a Cone =
  vertex :: "'a Point"
  slope  :: "'a"

(*
  The set of quantities is assumed to be an ordered field. We shall
  sometimes need to assume that the field is also Euclidean, ie
  square roots exists, but this is not a general requirement so it
  will be added as a separate axiom class later.
*)
class Quantities = linordered_field

(*
  Vectors are defined over the field of quantities
*)
class Vectors = Quantities
begin

  abbreviation  vecZero :: "'a Vector" ("0") where
    "vecZero \<equiv> \<lparr> tdir = (0::'a), xdir = 0, ydir = 0, zdir = 0 \<rparr>"

  fun vecPlus :: "'a Vector \<Rightarrow> 'a Vector \<Rightarrow> 'a Vector" (infixr "\<oplus>" 100) where
    "vecPlus u v = \<lparr> tdir = tdir u + tdir v, xdir = xdir u + xdir v,
                     ydir = ydir u + ydir v, zdir = zdir u + zdir v \<rparr>"

  fun vecMinus :: "'a Vector \<Rightarrow> 'a Vector \<Rightarrow> 'a Vector" (infixr "\<ominus>" 100) where
    "vecMinus u v = \<lparr> tdir = tdir u - tdir v, xdir = xdir u - xdir v,
                      ydir = ydir u - ydir v, zdir = zdir u - zdir v \<rparr>"

  fun vecNegate :: "'a Vector \<Rightarrow> 'a Vector" ("~ _") where
    "vecNegate u = \<lparr> tdir = uminus (tdir u), xdir = uminus (xdir u),
                     ydir = uminus (ydir u), zdir = uminus (zdir u) \<rparr>"

  fun innerProd :: "'a Vector \<Rightarrow> 'a Vector \<Rightarrow> 'a" (infix "dot" 50) where
    "innerProd u v = (tdir u * tdir v) + (xdir u * xdir v) +
                     (ydir u * ydir v) + (zdir u * zdir v)"

  fun sqrlen :: "'a Vector \<Rightarrow> 'a"  where "sqrlen u = (u dot u)"

  fun minkowskiProd :: "'a Vector \<Rightarrow> 'a Vector \<Rightarrow> 'a" (infix "mdot" 50) where
    "minkowskiProd u v = (tdir u * tdir v)
                       -  ((xdir u * xdir v) + (ydir u * ydir v) + (zdir u * zdir v))"

  fun mSqrLen :: "'a Vector \<Rightarrow>  'a"  where "mSqrLen u = (u mdot u)"

  fun vecScale  :: "'a \<Rightarrow> 'a Vector \<Rightarrow> 'a Vector" (infix "**" 200)  where
    "vecScale k u = \<lparr> tdir = k * tdir u, xdir = k * xdir u, ydir = k * ydir u, zdir = k * zdir u \<rparr>"

  fun orthogonal :: "'a Vector \<Rightarrow> 'a Vector \<Rightarrow> bool" (infix "\<bottom>" 150) where
    "orthogonal u v = (u dot v = 0)"

(*
  vector addition and subtraction do what's expected
*)

lemma lemVecZeroMinus:
  shows "0 \<ominus> u = ~ u"
  by simp

lemma lemVecSelfMinus:
  shows "u \<ominus> u = 0"
  by simp

lemma lemVecPlusCommute:
  shows "u \<oplus> v = v \<oplus> u"
  by (simp add: add.commute)

lemma lemVecPlusAssoc:
  shows "u \<oplus> (v \<oplus> w) = (u \<oplus> v) \<oplus> w"
  by (simp add: add.assoc)

lemma lemVecPlusMinus:
  shows "u \<oplus> (~ v)  = u \<ominus> v"
  by (simp add: local.add_uminus_conv_diff)

(*
  Dot product commutes.
*)
lemma lemDotCommute:
  shows "(u dot v) = (v dot u)"
  by (simp add: mult.commute)

(*
  Minkowski product commutes.
*)
lemma lemMDotCommute:
  shows "(u mdot v) = (v mdot u)"
  by (simp add:mult.commute)

(* Scaling can be done in stages *)
lemma lemScaleScale:
  shows "a**(b**u) = (a*b)**u"
  by (simp add: mult.assoc)

(* Scaling by 1 has no effect *)
lemma lemScale1:
  shows "1 ** u = u"
  by simp

(* Scaling by 0 gives the null vector *)
lemma lemScale0:
  shows "0 ** u = 0"
  by simp

(* Scaling by a negative value reverses *)
lemma lemScaleNeg:
  shows "(-k)**u = ~ (k**u)"
  by simp

(* The null vector is invariant under scaling *)
lemma lemScaleOrigin:
  shows "k**0 = 0"
  by auto

(* Scaling distributes over addition *)
lemma lemScaleOverAdd:
  shows "k**(u \<oplus> v) = k**u \<oplus> k**v"
  by (simp add: semiring_normalization_rules(34))

lemma lemAddOverScale:
  shows "a**u \<oplus> b**u = (a+b)**u"
  by (simp add: semiring_normalization_rules(1))

(* Scaling can be reversed *)
lemma lemScaleInverse:
  assumes "k \<noteq> (0::'a)"
    and   "v = k**u"
  shows   "u = (inverse k)**v"
proof -
  have "(inverse k)**v = (inverse k * k)**u"
    by (simp add: lemScaleScale assms(2) mult.assoc)
  thus ?thesis by (metis (lifting) field_inverse assms(1) lemScale1)
qed

(* Being orthogonal is mutual *)
lemma lemOrthoSym:
  assumes "u \<bottom> v"
  shows "v \<bottom> u"
  by (metis assms(1) lemDotCommute orthogonal.simps)

end

(*
  Points have coordinates in the field of quantities.
*)
class Points = Quantities + Vectors
begin

  abbreviation origin :: "'a Point" where
    "origin \<equiv> \<lparr> tval = 0, xval = 0, yval = 0, zval = 0 \<rparr>"

  fun vectorJoining :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> 'a Vector" ("from _ to _") where
    "vectorJoining p q
      = \<lparr> tdir = tval q - tval p, xdir = xval q - xval p,
          ydir = yval q - yval p, zdir = zval q - zval p \<rparr>"

  fun moveBy :: "'a Point \<Rightarrow> 'a Vector \<Rightarrow> 'a Point" (infixl "\<leadsto>" 100) where
    "moveBy p u
      = \<lparr> tval = tval p + tdir u, xval = xval p + xdir u,
          yval = yval p + ydir u, zval = zval p + zdir u \<rparr>"

  fun positionVector :: "'a Point \<Rightarrow> 'a Vector" where
    "positionVector p = \<lparr> tdir = tval p, xdir = xval p, ydir = yval p, zdir = zval p \<rparr>"

  fun before :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> bool" (infixr "\<lesssim>" 100) where
    "before p q = (tval p < tval q)"

  fun after :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> bool" (infixr "\<greatersim>" 100) where
    "after p q = (tval p > tval q)"

  fun sametime :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> bool" (infixr "\<approx>" 100) where
    "sametime p q = (tval p = tval q)"

  lemma lemFromToTo:
    shows "(from p to q) \<oplus> (from q to r) = (from p to r)"
  proof -
    have shared: "\<forall>valp valq valr.( valq - valp + (valr - valq) = valr - valp)"
      by (metis add_uminus_conv_diff add_diff_cancel
                semiring_normalization_rules(24) semiring_normalization_rules(25))
    thus ?thesis by auto
  qed

  lemma lemMoveByMove:
    shows "p \<leadsto> u \<leadsto> v = p \<leadsto> (u \<oplus> v)"
    by (simp add: add.assoc)

  lemma lemScaleLinear:
    shows "p \<leadsto> a**u \<leadsto> b**v = p \<leadsto> (a**u \<oplus> b**v)"
  by (simp add: add.assoc)

end

(*
  Lines are defined using a basepoint and a direction.
*)
class Lines = Quantities + Vectors + Points
begin

  fun onAxisT :: "'a Point \<Rightarrow> bool" where
     "onAxisT u = ((xval u = 0) \<and> (yval u = 0) \<and> (zval u = 0))"

  fun space2 :: "('a Point) \<Rightarrow> ('a Point) \<Rightarrow> 'a" where
    "space2 u v
      = (xval u - xval v)*(xval u - xval v)
      + (yval u - yval v)*(yval u - yval v)
      + (zval u - zval v)*(zval u - zval v)"

  fun time2 :: "('a Point) \<Rightarrow> ('a Point) \<Rightarrow> 'a" where
    "time2 u v = (tval u - tval v)*(tval u - tval v)"

  fun speed :: "('a Point) \<Rightarrow> ('a Point) \<Rightarrow> 'a" where
    "speed u v = (space2 u v /  time2 u v)"

  fun mkLine :: "'a Point => 'a Vector \<Rightarrow> 'a Line" where
    "mkLine b d = \<lparr> basepoint = b, direction = d \<rparr>"

  fun lineJoining :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> 'a Line" ("line joining _ to _") where
    "lineJoining p q = \<lparr> basepoint = p, direction = from p to q \<rparr>"

  fun parallel :: "'a Line \<Rightarrow> 'a Line \<Rightarrow> bool" ("_ \<parallel> ") where
    "parallel lineA lineB = ((direction lineA = vecZero) \<or> (direction lineB = vecZero)
                                   \<or> (\<exists>k.(k \<noteq> (0::'a) \<and> direction lineB = k**direction lineA)))"

  fun collinear :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> 'a Point \<Rightarrow> bool" where
    "collinear p q r = (\<exists>\<alpha> \<beta>. ( (\<alpha> + \<beta> = 1)  \<and>
            positionVector p = \<alpha>**(positionVector q) \<oplus> \<beta>**(positionVector r) ))"

  fun inLine :: "'a Point \<Rightarrow> 'a Line \<Rightarrow> bool" where
    "inLine p l = collinear p (basepoint l) (basepoint l \<leadsto> direction l)"

  fun meets :: "'a Line \<Rightarrow> 'a Line \<Rightarrow> bool" where
    "meets line1 line2 = (\<exists>p.(inLine p line1 \<and> inLine p line2))"

  lemma lemParallelReflexive:
    shows "lineA \<parallel> lineA"
  proof -
    define dir where "dir = direction lineA"
    have "(1 \<noteq> 0) \<and> (dir = 1**dir)" by simp
    thus ?thesis by (metis dir_def parallel.simps)
  qed

  lemma lemParallelSym:
    assumes "lineA \<parallel> lineB"
    shows   "lineB \<parallel> lineA"
  proof -
    have case1: "direction lineA = vecZero \<longrightarrow> ?thesis" by auto
    have case2: "direction lineB = vecZero \<longrightarrow> ?thesis" by auto
    {
      assume case3: "direction lineA \<noteq> vecZero \<and> direction lineB \<noteq> vecZero"
      have exists_kab: "\<exists>kab.(kab \<noteq> (0::'a) \<and> direction lineB = kab**direction lineA)"
        by (metis parallel.simps assms(1) case3)
      define kab where "kab \<equiv> (SOME kab.(kab \<noteq> (0::'a) \<and> direction lineB = kab**direction lineA))"
      have kab_props: "kab \<noteq> 0 \<and> direction lineB = kab**direction lineA"
        using exists_kab kab_def
        by (rule Hilbert_Choice.exE_some)

      define kba where "kba = inverse kab"
      have kba_nonzero: "kba \<noteq> 0" by (metis inverse_zero_imp_zero kab_props kba_def)
      have "direction lineA = kba**direction lineB" by (metis kba_def lemScaleInverse kab_props)
      hence ?thesis by (metis kba_nonzero parallel.simps)
    }
    from this have "(direction lineA \<noteq> vecZero \<and> direction lineB \<noteq> vecZero) \<longrightarrow> ?thesis" by blast

    thus ?thesis by (metis case1 case2)
  qed

  lemma lemParallelTrans:
    assumes "lineA \<parallel> lineB"
      and   "lineB \<parallel> lineC"
      and   "direction lineB \<noteq> vecZero"
    shows   "lineA \<parallel> lineC"
  proof -
    have case1: "direction lineA = vecZero \<longrightarrow> ?thesis" by auto
    have case2: "direction lineC = vecZero \<longrightarrow> ?thesis" by auto

    {
      assume case3: "direction lineA \<noteq> vecZero \<and> direction lineC \<noteq> vecZero"

      have exists_kab: "\<exists>kab.(kab \<noteq> (0::'a) \<and> direction lineB = kab**direction lineA)"
        by (metis parallel.simps assms(1) case3 assms(3))
      then obtain kab where kab_props: "kab \<noteq> 0 \<and> direction lineB = kab**direction lineA" by auto

      have exists_kbc: "\<exists>kbc.(kbc \<noteq> (0::'a) \<and> direction lineC = kbc**direction lineB)"
        by (metis parallel.simps assms(2) case3 assms(3))
      then obtain kbc where kbc_props: "kbc \<noteq> 0 \<and> direction lineC = kbc**direction lineB" by auto

      define kac where "kac = kbc * kab"
      have kac_nonzero: "kac \<noteq> 0" by (metis kab_props kac_def kbc_props no_zero_divisors)
      have "direction lineC = kac**direction lineA"
        by (metis kab_props kbc_props kac_def lemScaleScale)
      hence ?thesis by (metis kac_nonzero parallel.simps)
    }
    from this have "(direction lineA \<noteq> vecZero \<and> direction lineC \<noteq> vecZero) \<longrightarrow> ?thesis" by blast

    thus ?thesis by (metis case1 case2)
  qed

  lemma (in -) lemLineIdentity:
    assumes "lineA = \<lparr> basepoint = basepoint lineB, direction = direction lineB \<rparr>"
    shows "lineA = lineB"
  proof -
  have "basepoint lineA = basepoint lineB \<and> direction lineA = direction lineB"
    by (simp add: assms(1))
  thus ?thesis by simp
  qed

  lemma lemDirectionJoining:
    shows "vectorJoining p (p \<leadsto> v) = v"
  proof -
    have "\<forall>a b.(a + b - a = b)"
      by (metis add_uminus_conv_diff diff_add_cancel semiring_normalization_rules(24))
    thus ?thesis by auto
  qed

  lemma lemDirectionFromTo:
    shows "direction (line joining p to (p \<leadsto> dir)) = dir"
  proof -
    have "direction (line joining p to (p \<leadsto> dir)) = from p to (p \<leadsto> dir)" by simp
    thus ?thesis by (metis lemDirectionJoining)
  qed

  lemma lemLineEndpoint:
    shows "q = p \<leadsto> (from p to q)"
  proof -
    have "\<forall>a b. (b = a + (b - a))"
      by (metis diff_add_cancel semiring_normalization_rules(24))
    thus ?thesis by auto
  qed

  lemma lemNullLine:
    assumes "direction lineA = vecZero"
      and   "inLine x lineA"
    shows   "x = basepoint lineA"
  proof -
    define bp where "bp = basepoint lineA"
    have "collinear x (basepoint lineA) (basepoint lineA \<leadsto> direction lineA)"
      by (metis inLine.simps assms(2))
    hence "collinear x bp (bp \<leadsto> vecZero)" by (metis bp_def  assms(1))
    hence "collinear x bp bp" by simp
    hence "\<exists>a b.( (a + b = 1) \<and>
                  (positionVector x = a**(positionVector bp) \<oplus> b**(positionVector bp)) )"
      by (metis collinear.simps)
    hence "positionVector x = positionVector bp" by (metis lemScale1 lemAddOverScale)
    thus ?thesis by (simp add: bp_def)
  qed

  lemma lemLineContainsBasepoint:
    shows "inLine p (line joining p to q)"
  proof -
    define linePQ where "linePQ = line joining p to q"
    have bp: "basepoint linePQ = p" by (simp add: linePQ_def)
    have dir: "direction linePQ = from p to q" by (simp add: linePQ_def)
    have endq: "basepoint linePQ \<leadsto> direction linePQ = q" by (metis bp dir lemLineEndpoint)

    have "(1 + 0 = 1)  \<and> (positionVector p = 1**(positionVector p) \<oplus> 0**(positionVector q))"
      by auto
    hence "collinear p p q" by (metis collinear.simps)
    hence "collinear p (basepoint linePQ) (basepoint linePQ \<leadsto> direction linePQ)"
      by (metis bp endq)
    thus ?thesis by (simp add: linePQ_def)
  qed

  lemma lemLineContainsEndpoint:
    shows "inLine q (line joining p to q)"
  proof -
    define linePQ where "linePQ = line joining p to q"
    have bp: "basepoint linePQ = p" by (simp add: linePQ_def)
    have dir: "direction linePQ = from p to q" by (simp add: linePQ_def)
    have endq: "basepoint linePQ \<leadsto> direction linePQ = q" by (metis bp dir lemLineEndpoint)

    have "(0 + 1 = 1)  \<and> (positionVector q = 0**(positionVector p) \<oplus> 1**(positionVector q))"
      by auto
    hence "collinear q p q" by (metis collinear.simps)
    hence "collinear q (basepoint linePQ) (basepoint linePQ \<leadsto> direction linePQ)"
      by (metis bp endq)
    thus ?thesis by (simp add: linePQ_def)
  qed

  lemma lemDirectionReverse:
    shows "from q to p = vecNegate (from p to q)"
    by simp

  lemma lemParallelJoin:
    assumes "line joining p to q \<parallel> line joining q to r"
    shows  "line joining p to q \<parallel> line joining p to r"
  proof -
    define linePQ where "linePQ = line joining p to q"
    define lineQR where "lineQR = line joining q to r"
    define linePR where "linePR = line joining p to r"

    have case1: "(direction linePQ = vecZero) \<longrightarrow> ?thesis" by (simp add: linePQ_def)
    have case2: "(direction linePR = vecZero) \<longrightarrow> ?thesis" by (simp add: linePR_def)

    {
      assume case3: "direction linePQ \<noteq> vecZero \<and> direction linePR \<noteq> vecZero"
      {
        assume case3a: "direction lineQR = vecZero"
        have "inLine r lineQR" by (metis lemLineContainsEndpoint lineQR_def)
        hence "r = basepoint lineQR" by (metis lemNullLine case3a)
        hence "r = q" by (simp add: lineQR_def)
        hence "linePQ = linePR" by (simp add: linePQ_def linePR_def)
        hence ?thesis by (metis lemParallelReflexive linePQ_def linePR_def)
      }
      from this have rtp3a: "direction lineQR = vecZero \<longrightarrow> ?thesis" by blast

      {
        assume case3b: "direction lineQR \<noteq> vecZero"

        define dirPQ where "dirPQ = from p to q"
        have dir_pq: "direction linePQ = dirPQ" by (simp add: linePQ_def dirPQ_def)

        define dirQR where "dirQR = from q to r"
        have dir_qr: "direction lineQR = dirQR" by (simp add: lineQR_def dirQR_def)

        have exists_k: "\<exists>k.(k \<noteq> 0 \<and> direction lineQR = k**direction linePQ)"
          by (metis linePQ_def lineQR_def assms(1) parallel.simps case3b case3)
        then obtain k where k_props: "k \<noteq> 0 \<and> dirQR= k**dirPQ" by (metis dir_pq dir_qr)

        define scalar where "scalar = 1+k"

        have "q = p \<leadsto> dirPQ \<and> r = q \<leadsto> dirQR" by (metis lemLineEndpoint dirPQ_def dirQR_def)
        hence "r = p \<leadsto> dirPQ \<leadsto> (k**dirPQ)" by (metis k_props)
        hence scalarPR: "r = p \<leadsto> scalar**dirPQ"
          by (metis lemScaleLinear lemScale1 lemAddOverScale scalar_def)

        {
          assume scalar0: "scalar = 0"
          have "r = p" by (simp add: lemScale0 scalarPR scalar0)
          hence "direction linePR = vecZero" by (simp add: linePR_def)
          hence "False" by (metis case3)
        }
        from this have scalar_nonzero: "scalar \<noteq> 0" by blast

        have "linePR = line joining p to (p \<leadsto> scalar**dirPQ)"
          by (simp add: linePR_def scalarPR)
        hence "direction linePR = scalar**dirPQ" by (metis lemDirectionFromTo)

        hence scalar_props: "scalar \<noteq> 0 \<and> direction linePR = scalar**direction linePQ"
         by (metis scalar_nonzero dir_pq)
        hence ?thesis by (metis parallel.simps linePR_def linePQ_def)
      }
      from this have "direction lineQR \<noteq> vecZero \<longrightarrow> ?thesis" by blast

      hence ?thesis by (metis rtp3a)
    }
    from this have "(direction linePQ \<noteq> vecZero \<and> direction linePR \<noteq> vecZero) \<longrightarrow> ?thesis" by blast

    thus ?thesis by (metis case1 case2)
  qed

  lemma lemDirectionCollinear:
    shows "collinear u v (v \<leadsto> d) \<longleftrightarrow> (\<exists>\<beta>.(from u to v = (-\<beta>)**d))"
  proof -
    have basic1: "\<forall>u v.(positionVector (u \<leadsto> v)) = (positionVector u) \<oplus> v" by simp
    have basic2: "\<forall>u v w.(u = v \<oplus> w \<longrightarrow> v \<ominus> u = vecNegate w )"
      apply auto
      by    (metis add_uminus_conv_diff diff_add_cancel minus_add
              semiring_normalization_rules(24)) +
    have basic3: "\<forall>u v.(from u to v = positionVector v \<ominus> positionVector u)" by simp
    have basic4: "\<forall>u v w.(v \<ominus> u = vecNegate w \<longrightarrow> u = v \<oplus> w)"
      apply auto
      by (metis add_uminus_conv_diff diff_add_cancel lemScale1 mult.left_neutral
          semiring_normalization_rules(24) vecScale.simps)

    {
      assume assm: "collinear u v (v \<leadsto> d)"
      have "\<exists>\<alpha> \<beta>. ( (\<alpha> + \<beta> = 1)  \<and>
         positionVector u = \<alpha>**(positionVector v) \<oplus> \<beta>**(positionVector (v \<leadsto> d)) )"
        by (metis assm collinear.simps)
      then obtain \<alpha> \<beta> where props: "(\<alpha> + \<beta> = 1)  \<and>
              positionVector u = \<alpha>**(positionVector v) \<oplus> \<beta>**(positionVector (v \<leadsto> d))" by auto
      hence "positionVector u = 1**(positionVector v) \<oplus> \<beta>**d"
        by (metis basic1 lemScaleOverAdd lemVecPlusAssoc lemAddOverScale props)
      hence "positionVector u = positionVector v \<oplus> \<beta>**d" by (metis lemScale1)
      hence "positionVector v \<ominus> positionVector u = (-\<beta>)**d" by (metis basic2 lemScaleNeg)
      hence "\<exists>\<beta>.(from u to v = (-\<beta>)**d)" by (metis basic3)
    }
    from this have fwd: "collinear u v (v \<leadsto> d) \<longrightarrow> (\<exists>\<beta>.(from u to v = (-\<beta>)**d))" by blast

    {
      assume "\<exists>\<beta>.(from u to v = (-\<beta>)**d)"
      then obtain \<beta> where assm: "from u to v = (-\<beta>)**d" by auto
      define \<alpha> where "\<alpha> = 1 - \<beta>"
      have \<alpha>\<beta>_sum: "\<alpha> + \<beta> = 1" by (simp add: \<alpha>_def)
      have "from u to v = vecNegate (\<beta>**d)" by (metis assm lemScaleNeg)
      hence "positionVector v \<ominus> positionVector u = vecNegate (\<beta>**d)" by auto
      hence "positionVector u = positionVector v \<oplus> \<beta>**d" by (metis basic4)
      hence "positionVector u = 1**(positionVector v) \<oplus> \<beta>**d"
        by (metis lemScale1)
      hence "(\<alpha> + \<beta> = 1)  \<and>
            positionVector u = \<alpha>**(positionVector v) \<oplus> \<beta>**(positionVector (v \<leadsto> d))"
        by (metis \<alpha>\<beta>_sum basic1 lemScaleOverAdd lemVecPlusAssoc lemAddOverScale)
      hence "collinear u v (v \<leadsto> d)" by auto
    }
    from this have "(\<exists>\<beta>.(from u to v = (-\<beta>)**d)) \<longrightarrow> collinear u v (v \<leadsto> d)" by blast

    thus ?thesis by (metis fwd)
  qed

  lemma lemParallelNotMeet:
    assumes "lineA \<parallel> lineB"
      and   "direction lineA \<noteq> vecZero"
      and   "direction lineB \<noteq> vecZero"
      and   "inLine x lineA"
      and   "\<not>(inLine x lineB)"
    shows   "\<not>(meets lineA lineB)"
  proof -

    have basic: "\<forall>p q v a.(from p to q = a**v \<longrightarrow> from q to p = (-a)**v)"
      apply (simp add: lemScaleNeg) by (metis minus_diff_eq)

    define bpA where "bpA = basepoint lineA"
    define dirA where "dirA = direction lineA"
    define bpB where "bpB = basepoint lineB"
    define dirB where "dirB = direction lineB"

    (* lineA is parallel to lineB *)
    have "lineB \<parallel> lineA" by (metis lemParallelSym assms(1))
    hence exists_kab: "\<exists>kab.(kab \<noteq> (0::'a) \<and> direction lineA = kab**direction lineB)"
      by (metis parallel.simps assms(2) assms(3))
    then obtain kab where kab_props: "kab \<noteq> 0 \<and> dirA = kab**dirB" by (metis dirA_def dirB_def)

    (* x is in lineA *)
    have "collinear x bpA (bpA \<leadsto> dirA)" by (metis assms(4) inLine.simps bpA_def dirA_def)
    then obtain \<beta> where "from x to bpA = (-\<beta>)**dirA" by (metis lemDirectionCollinear)
    hence x_to_bpA: "from x to bpA = ((-\<beta>)*kab)**dirB" by (metis lemScaleScale kab_props)

    (* Assume the claim is false, and show that x is in lineB, contrary to assumption *)
    {
      assume converse: "meets lineA lineB"
      have "\<exists>p.(inLine p lineA \<and> inLine p lineB)" by (metis converse meets.simps)
      then obtain p where  p_in_AB: "inLine p lineA \<and> inLine p lineB" by auto

      have "collinear p bpA (bpA \<leadsto> dirA)" by (metis p_in_AB inLine.simps bpA_def dirA_def)
      then obtain \<beta>A where "from p to bpA = (-\<beta>A)**dirA" by (metis lemDirectionCollinear)
      hence "from bpA to p = (\<beta>A)**dirA" by (metis basic minus_minus)
      hence bpA_to_p: "from bpA to p = (\<beta>A*kab)**dirB" by (metis lemScaleScale kab_props)

      have "collinear p bpB (bpB \<leadsto> dirB)" by (metis p_in_AB inLine.simps bpB_def dirB_def)
      then obtain \<beta>B where p_to_bpB: "from p to bpB = (-\<beta>B)**dirB" by (metis lemDirectionCollinear)

      (* Express from x to bpB directly in terms of dirB *)

      define \<gamma> where "\<gamma> = -((-\<beta>)*kab + (\<beta>A*kab) + (-\<beta>B))"
      have x_to_bpB: "(from x to bpA) \<oplus> (from bpA to p) \<oplus> (from p to bpB) = (from x to bpB)"
        by (metis lemFromToTo)
      hence "from x to bpB = ((-\<beta>)*kab)**dirB \<oplus> (\<beta>A*kab)**dirB \<oplus> (-\<beta>B)**dirB"
        by (metis x_to_bpA bpA_to_p p_to_bpB)
      hence "from x to bpB = (-\<gamma>)**dirB"
        by (metis lemAddOverScale add.assoc \<gamma>_def minus_minus)
      hence "collinear x bpB (bpB \<leadsto> dirB)" by (metis lemDirectionCollinear)
      hence "inLine x lineB" by (metis inLine.simps bpB_def dirB_def)
    }
    from this have "meets lineA lineB \<longrightarrow> inLine x lineB" by blast
    thus ?thesis by (metis assms(5))
  qed

  lemma lemAxisIsLine:
    assumes "onAxisT x"
      and   "onAxisT y"
      and   "onAxisT z"
      and   "x \<noteq> y"
      and   "y \<noteq> z"
      and   "z \<noteq> x"
    shows   "collinear x y z"
  proof -
    define ratio where "ratio = -(tval y - tval x) / (tval z - tval y)"

    have x_onAxis: "xval x = 0 \<and> yval x = 0 \<and> zval x = 0" by (metis assms(1) onAxisT.simps)
    have y_onAxis: "xval y = 0 \<and> yval y = 0 \<and> zval y = 0" by (metis assms(2) onAxisT.simps)
    have z_onAxis: "xval z = 0 \<and> yval z = 0 \<and> zval z = 0" by (metis assms(3) onAxisT.simps)

    have  "tval z - tval y = 0 \<longrightarrow> z = y" by (simp add: z_onAxis y_onAxis)
    hence "tval z \<noteq> tval y" by (metis assms(5) eq_iff_diff_eq_0)
    hence tvalyz_nonzero: "tval z - tval y \<noteq> 0" by (metis eq_iff_diff_eq_0)

    have x_to_y: "from x to y = \<lparr> tdir = tval y - tval x, xdir = 0, ydir = 0, zdir = 0 \<rparr>"
      by (simp add: x_onAxis y_onAxis)
    have y_to_z: "from y to z = \<lparr> tdir = tval z - tval y, xdir = 0, ydir = 0, zdir = 0 \<rparr>"
      by (simp add:y_onAxis z_onAxis)

    have "from x to y = (-ratio)**(from y to z)"
      apply (simp add: x_to_y y_to_z ratio_def)
      by (metis diff_self eq_divide_imp minus_diff_eq mult_eq_0_iff
                tvalyz_nonzero x_onAxis y_onAxis z_onAxis)
     hence "collinear x y (y \<leadsto> (from y to z))" by (metis lemDirectionCollinear)
    thus ?thesis by (metis lemLineEndpoint)
  qed

  lemma lemSpace2Sym:
    shows "space2 x y = space2 y x"
  proof -
    define xsep where "xsep = xval x - xval y"
    define ysep where "ysep = yval x - yval y"
    define zsep where "zsep = zval x - zval y"

    have spacexy: "space2 x y = (xsep*xsep) + (ysep*ysep) + (zsep*zsep)"
      by (simp add: xsep_def ysep_def zsep_def)
    have spaceyx: "space2 y x = (-xsep)*(-xsep) + (-ysep)*(-ysep) + (-zsep)*(-zsep)"
      by (simp add: xsep_def ysep_def zsep_def)
    thus ?thesis by (metis spacexy diff_0_right minus_diff_eq minus_mult_left minus_mult_right)
  qed

    have timexy: "time2 x y = tsep*tsep"
      by (simp add: tsep_def)
    have timeyx: "time2 y x = (-tsep)*(-tsep)"
      by (simp add: tsep_def)
    thus ?thesis by (metis timexy diff_0_right minus_diff_eq minus_mult_left minus_mult_right)
  qed

end

(*
  A plane is determined by a basepoint with two directions.
*)
class Planes = Quantities + Lines
begin
  fun mkPlane :: "'a Point \<Rightarrow> 'a Vector \<Rightarrow> 'a Vector \<Rightarrow> 'a Plane" where
    "mkPlane b d1 d2 = \<lparr> pbasepoint = b, direction1 = d1, direction2 = d2 \<rparr>"

  fun coplanar :: "'a Point \<Rightarrow> 'a Point \<Rightarrow> 'a Point \<Rightarrow> 'a Point \<Rightarrow> bool" where
    "coplanar e x y z
      = (\<exists>\<alpha> \<beta> \<gamma>. ( (\<alpha> +  \<beta> +  \<gamma> = 1)  \<and>
            positionVector e
              = (\<alpha>**(positionVector x) \<oplus> \<beta>**(positionVector y) \<oplus> \<gamma>**(positionVector z) )))"

  fun inPlane :: "'a Point \<Rightarrow> 'a Plane \<Rightarrow> bool" where
    "inPlane e pl = coplanar e (pbasepoint pl) (pbasepoint pl \<leadsto> direction1 pl)
                                               (pbasepoint pl \<leadsto> direction2 pl)"

  fun samePlane :: "'a Plane \<Rightarrow> 'a Plane \<Rightarrow> bool" where
    "samePlane pl pl' = (inPlane (pbasepoint pl) pl' \<and>
                         inPlane (pbasepoint pl \<leadsto> direction1 pl) pl' \<and>
                         inPlane (pbasepoint pl \<leadsto> direction2 pl) pl')"

lemma lemPlaneContainsBasePoint:
  shows "inPlane (pbasepoint pl) pl"
  proof -
    define \<alpha> where "\<alpha> = (1::'a)"
    define \<beta> where "\<beta> = (0::'a)"
    define \<gamma> where "\<gamma> = (0::'a)"
    have rtp1: "\<alpha> + \<beta> + \<gamma> = 1" by (simp add: \<alpha>_def \<beta>_def \<gamma>_def)

    define e where "e = pbasepoint pl"
    define x where "x = pbasepoint pl"
    define y where "y = pbasepoint pl \<leadsto> direction1 pl"
    define z where "z = pbasepoint pl \<leadsto> direction2 pl"
    have rtp2: "positionVector e = \<alpha>**(positionVector x)
                                 \<oplus> \<beta>**(positionVector y) \<oplus> \<gamma>**(positionVector z)"
      by (simp add: e_def x_def \<alpha>_def \<beta>_def \<gamma>_def)

    have sameplane: "coplanar e x y z" by (metis coplanar.simps rtp1 rtp2)
    hence "coplanar e (pbasepoint pl) (pbasepoint pl \<leadsto> direction1 pl)
                                      (pbasepoint pl \<leadsto> direction2 pl)"
      by (simp add: x_def y_def z_def)
    hence "inPlane e pl" by simp
    thus ?thesis by (simp add: e_def)
qed

end

(*
  An upright cone is determined by its vertex + slope (ie, speed).
*)

class Cones = Quantities + Lines + Planes +
fixes
  (* the tangent plane at a point on a cone *)
  tangentPlane :: "'a Point \<Rightarrow> 'a Cone \<Rightarrow> 'a Plane"
assumes
  (* The pbasepoint of the plane-at-e is e *)
  AxTangentBase: "pbasepoint (tangentPlane e cone) = e"
and
  (* The tangent plane contains the vertex *)
  AxTangentVertex: "inPlane (vertex cone) (tangentPlane e cone)"
and
  (* The tangent plane meets the cone in a line *)
  AxConeTangent: "(onCone e cone) \<longrightarrow>
                  ((inPlane pt (tangentPlane e cone) \<and> onCone pt cone)
                                                           \<longleftrightarrow> collinear (vertex cone) e pt)"
and
  (* The tangent plane is tangential to all cones with vertex in that plane, and
     the intersection lines are parallel. *)
  AxParallelCones: "(onCone e econe \<and> e \<noteq> vertex econe \<and> onCone f fcone \<and> f \<noteq> vertex fcone
                      \<and> inPlane f (tangentPlane e econe))
                    \<longrightarrow>  (samePlane (tangentPlane e econe) (tangentPlane f fcone)
                          \<and> ((lineJoining (vertex econe) e) \<parallel> (lineJoining (vertex fcone) f)))"
and
  (*
     if f is outside a cone, there is a tangent plane to that cone which contains f. The
     tangent plane is determined by some e lying on the intersection line with the cone.
  *)
  AxParallelConesE: "outsideCone f cone
    \<longrightarrow> (\<exists>e.(onCone e cone \<and> e \<noteq> vertex cone \<and> inPlane f (tangentPlane e cone)))"
and
(*
  Given distinct e f on the t-axis, and g off the axis, we can
  find a point p on the line e-g such that the line f-p has
  slope s. This can be proven using AxEuclidean, by taking the
  intersection of a line with a cone.
*)
  AxSlopedLineInVerticalPlane: "\<lbrakk>onAxisT e; onAxisT f; e \<noteq> f; \<not>(onAxisT g)\<rbrakk>
     \<Longrightarrow> (\<forall>s.( \<exists>p . (collinear e g p \<and> (space2 p f = (s*s)*time2 p f))))"

begin

  fun onCone :: "'a Point \<Rightarrow> 'a Cone \<Rightarrow> bool" where
    "onCone p cone
      = (space2 (vertex cone) p  = (slope cone * slope cone) * time2 (vertex cone) p )"

  fun insideCone :: "'a Point \<Rightarrow> 'a Cone \<Rightarrow> bool" where
    "insideCone p cone
      = (space2 (vertex cone) p < (slope cone * slope cone) * time2 (vertex cone) p)"

  fun outsideCone :: "'a Point \<Rightarrow> 'a Cone \<Rightarrow> bool" where
    "outsideCone p cone
      = (space2 (vertex cone) p > (slope cone * slope cone) * time2 (vertex cone) p)"

  fun mkCone :: "'a Point \<Rightarrow> 'a \<Rightarrow> 'a Cone" where
    "mkCone v s = \<lparr> vertex = v, slope = s \<rparr>"

  lemma lemVertexOnCone:
    shows "onCone (vertex cone) cone"
  by simp

  lemma lemOutsideNotOnCone:
    assumes "outsideCone f cone"
    shows   "\<not> (onCone f cone)"
  by (metis assms less_irrefl onCone.simps outsideCone.simps)

end

class SpaceTime = Quantities + Vectors + Points + Lines + Planes + Cones

end


theory Poset_Types
imports Main "HOL-Eisbach.Eisbach"

begin

locale carrier =
  fixes carrier :: "'a set"
begin

definition "member_of x \<equiv> x \<in> carrier"

end

locale poset = carrier +
  fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes p_refl: "x \<in> carrier \<Longrightarrow> le x x" and
          p_trans: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> z \<in> carrier \<Longrightarrow> le x y \<Longrightarrow> le y z \<Longrightarrow> le x z" and
          p_antisym: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> le x y \<Longrightarrow> le y x \<Longrightarrow> x = y"

typedef (overloaded) ('a) poset = " {(x, y). poset x y} :: ('a set \<times> ('a \<Rightarrow> 'a \<Rightarrow> bool)) set  "
  apply (rule_tac x="({}, undefined)" in exI)
  apply (clarsimp)
  by (standard; clarsimp)

setup_lifting type_definition_poset

lift_definition leq :: "'a poset \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" is
    "\<lambda>P :: ('a set \<times> ('a \<Rightarrow> 'a \<Rightarrow> bool)) . snd P" done

notation leq ("_ \<Ztypecolon> _ \<sqsubseteq> _" 50)

lift_definition el :: "'a poset \<Rightarrow> ('a set)" is
    "\<lambda>P :: ('a set \<times> ('a \<Rightarrow> 'a \<Rightarrow> bool)) . fst P" done

interpretation poset "(el x)" "(leq x)"
  apply (standard; transfer, clarsimp elim:  poset.p_refl  poset.p_trans  poset.p_antisym)
    apply (transfer)
    apply (simp add: poset.p_refl)
   apply (metis  poset.p_trans)
  by (metis  poset.p_antisym)

definition to_poset :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a poset"
  where "to_poset A f = Abs_poset (A, f)"

definition (in poset) witness :: "'a poset" where
  "witness \<equiv> (to_poset carrier le)"

interpretation empty: poset "{}" "f"
  apply (standard; clarsimp)
  done

interpretation nat_pos: poset "UNIV :: nat set" "(\<le>)"
  apply (standard; clarsimp)
  done

interpretation discrete: poset "UNIV :: 'a set" "(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
  apply (standard)
    apply (clarsimp)
   apply (clarsimp)
  apply (erule sym)
  done

context poset begin

lemma leq_valid[simp]: "leq witness = le "
  unfolding witness_def
  using poset_axioms
  by (simp add: Abs_poset_inverse leq.rep_eq to_poset_def)

lemma el_valid[simp]: "el witness = carrier "
  unfolding witness_def
  using poset_axioms
  by (simp add: Abs_poset_inverse el.rep_eq to_poset_def)

sublocale op_poset: poset carrier "\<lambda>y x. le x y"
  apply (standard)
    apply (simp add: local.p_refl)
   apply (erule (4) local.p_trans)
  apply (erule (3) local.p_antisym)
  done
end

lemma discrete_leq_iff: "(discrete.witness \<Ztypecolon> x \<sqsubseteq> x) \<longleftrightarrow> x = x"
  apply (safe, rule p_refl, clarsimp)
  done

lemma "nat_pos.witness \<Ztypecolon> x \<sqsubseteq> x"
  by (clarsimp)

locale morphism = fr: carrier S + to: carrier S'  for S :: "'a set" and S' :: "'b set" +
  fixes f :: "'a \<Rightarrow> 'b"
  assumes well_formed: "f ` S \<subseteq> S'"

begin

lemma maps_betw: "x \<in> S \<Longrightarrow> f x \<in> S'"
  using well_formed  by blast

definition "morphism_witness g P P' \<equiv> g = f \<and> P = S \<and> P' = S'"

end

locale poset_morphism = morphism "el P" "el P'" f for P P' f +
  assumes mono_ord: "x \<in> el P \<Longrightarrow> y \<in> el P \<Longrightarrow> leq P x y \<Longrightarrow> leq P' (f x) (f y)"

begin

sublocale is_morphism: morphism "(el P)" \<open>el P'\<close> f
  using morphism_axioms by blast

end

typedef (overloaded) ('a, 'b) poset_morphism = " {(p, f, p'). poset_morphism p p' f} :: ('a poset \<times> ('a \<Rightarrow> 'b) \<times> 'b poset) set"
  apply (clarsimp)
  apply (rule_tac x="discrete.witness" in exI)
  apply (rule_tac x="\<lambda>_. undefined" in exI)
  apply (rule_tac x="discrete.witness" in exI)
  apply (standard)
   apply (clarsimp)
  apply (clarsimp)
  done

setup_lifting type_definition_poset_morphism

lift_definition left :: "('a, 'b) poset_morphism \<Rightarrow> 'a poset" is
    "\<lambda>f :: ('a poset \<times> ('a \<Rightarrow> 'b) \<times> 'b poset) . fst f" done

lift_definition right :: "('a, 'b) poset_morphism \<Rightarrow> 'b poset" is
    "\<lambda>f :: ('a poset \<times> ('a \<Rightarrow> 'b) \<times> 'b poset) . snd (snd f)" done

lift_definition func :: "('a, 'b) poset_morphism \<Rightarrow> 'a \<Rightarrow> 'b" is
    "\<lambda>f :: ('a poset \<times> ('a \<Rightarrow> 'b) \<times> 'b poset) . fst (snd f)" done

interpretation poset_morphism "(left x)" "(right x)" "func x"
  apply (standard; transfer; clarsimp)
   apply (meson morphism.maps_betw poset_morphism.axioms(1))
  by (simp add:  poset_morphism.mono_ord)

interpretation id_morphism: poset_morphism P P id
  by (standard; clarsimp)

lift_definition lift_poset_morphism :: "'a poset \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b poset \<Rightarrow> ('a, 'b) poset_morphism"
           is "\<lambda>a f b. if poset_morphism a b f then (a, f, b) else Rep_poset_morphism (undefined)"
  apply (clarsimp)
  by (metis fst_conv func.rep_eq left.rep_eq poset_morphism_axioms right.rep_eq snd_conv)

definition "compose_poset f g = lift_poset_morphism (left f) (func g o func f) (right g)"

notation compose_poset (infixl "\<cdot>"  55)

definition "compatible f g \<equiv> right f = left g"

definition "mono_betw m P f P' \<equiv> left m = P \<and> right m = P' \<and> func m = f"

notation mono_betw ("_ \<Ztypecolon> _ \<longrightarrow>\<^sub>_ _")

lemma mono_betw_left[dest]: "mono_betw m P f P'  \<Longrightarrow> left m = P"
                                        unfolding mono_betw_def by simp

lemma mono_betw_right[dest]: "mono_betw m P f P' \<Longrightarrow> right m = P'"
                                        unfolding mono_betw_def by simp

lemma mono_betw_func[dest]: "mono_betw m P f P'  \<Longrightarrow> func m = f"
                                        unfolding mono_betw_def by simp

lemma poset_morphism_compose: "poset_morphism a b f \<Longrightarrow> poset_morphism b c g
                                                    \<Longrightarrow> poset_morphism a c (g \<circ> f)"
  apply (standard; clarsimp)
   apply (meson morphism.maps_betw poset_morphism.axioms(1))
  by (meson morphism.maps_betw poset_morphism.axioms(1)
             poset_morphism.axioms(2) poset_morphism_axioms_def)

lemma left_comp_iff[dest]: "compatible m m' \<Longrightarrow> mono_betw (m \<cdot> m') P f P' \<Longrightarrow> left m = P"
  apply (clarsimp simp:  mono_betw_def)
  apply (clarsimp simp: compatible_def compose_poset_def, transfer)
  by (clarsimp simp:poset_morphism_compose )

lemma right_comp_iff[dest]: "compatible m m' \<Longrightarrow> mono_betw (m \<cdot> m') P f P' \<Longrightarrow> right m' = P'"
  apply (clarsimp simp:  mono_betw_def)
  by (clarsimp simp: compatible_def compose_poset_def, transfer,
      clarsimp simp: poset_morphism_compose)

lemma func_comp_iff[dest]: "compatible m m' \<Longrightarrow> mono_betw (m \<cdot> m') P f P' \<Longrightarrow> f = func m' o func m"
  apply (clarsimp simp:  mono_betw_def)
  by (clarsimp simp: compatible_def compose_poset_def, transfer,
      clarsimp simp: poset_morphism_compose)

lemma "morphism_witness m f P P' \<Longrightarrow> x \<in> P \<Longrightarrow> f x \<in>  P'"
  apply (clarsimp simp: morphism_witness_def)
  by (simp add: maps_betw morphism_witness_def)

locale two_posets = A: poset S le + B: poset S' le' for S S' le le'
begin

sublocale product_poset: poset "S \<times> S'" "(\<lambda>x y. le (fst x) (fst y) \<and> le' (snd x) (snd y))"
  apply (standard)
    apply (simp add: A.p_refl B.p_refl mem_Times_iff)
   apply (metis A.p_trans B.p_trans mem_Times_iff)
  using A.op_poset.p_antisym B.op_poset.p_antisym by force

end

interpretation two_posets "el P" "el P'" "leq P" "leq P'"
  by (standard)

notation product_poset.witness (infixl \<open>\<times>\<^sub>P\<close> 50)

term "nat_pos.witness \<times>\<^sub>P discrete.witness"

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section "Nondeterministic automata"

theory NA
imports AutoProj
begin

type_synonym ('a,'s) na = "'s * ('a \<Rightarrow> 's \<Rightarrow> 's set) * ('s \<Rightarrow> bool)"

primrec delta :: "('a,'s)na \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 's set" where
"delta A []    p = {p}" |
"delta A (a#w) p = Union(delta A w ` next A a p)"

definition
 accepts :: "('a,'s)na \<Rightarrow> 'a list \<Rightarrow> bool" where
"accepts A w = (\<exists>q \<in> delta A w (start A). fin A q)"

definition
 step :: "('a,'s)na \<Rightarrow> 'a \<Rightarrow> ('s * 's)set" where
"step A a = {(p,q) . q : next A a p}"

primrec steps :: "('a,'s)na \<Rightarrow> 'a list \<Rightarrow> ('s * 's)set" where
"steps A [] = Id" |
"steps A (a#w) = step A a  O  steps A w"

lemma steps_append[simp]:
 "steps A (v@w) = steps A v  O  steps A w"
by(induct v, simp_all add:O_assoc)

lemma in_steps_append[iff]:
  "(p,r) : steps A (v@w) = ((p,r) : (steps A v O steps A w))"
apply(rule steps_append[THEN equalityE])
apply blast
done

lemma delta_conv_steps: "\<And>p. delta A w p = {q. (p,q) : steps A w}"
by(induct w)(auto simp:step_def)

lemma accepts_conv_steps:
 "accepts A w = (\<exists>q. (start A,q) \<in> steps A w \<and> fin A q)"
by(simp add: delta_conv_steps accepts_def)

abbreviation
  Cons_syn :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "##" 65) where
  "x ## S \<equiv> Cons x ` S"

end


subsection\<open>Substitutions\<close>
theory Substitution
imports Formulas
begin

primrec subst where
"subst A F (Atom B) = (if A = B then F else Atom B)" |
"subst _ _ \<bottom> = \<bottom>" |
"subst A F (G \<^bold>\<or> H) = (subst A F G \<^bold>\<or> subst A F H)" |
"subst A F (G \<^bold>\<and> H) = (subst A F G \<^bold>\<and> subst A F H)" |
"subst A F (G \<^bold>\<rightarrow> H) = (subst A F G \<^bold>\<rightarrow> subst A F H)" |
"subst A F (\<^bold>\<not> H) = (\<^bold>\<not> (subst A F H))"
term subst
abbreviation subst_syntax ("(_[/(_/'//_)])" [70,70] 69) where
"A[B / C] \<equiv> subst C B A"

lemma no_subst[simp]: "k \<notin> atoms F \<Longrightarrow> F[G / k] = F" by(induction F; simp)
lemma subst_atoms: "k \<in> atoms F \<Longrightarrow> atoms (F[G / k]) = atoms F - {k} \<union> atoms G"
proof(induction F)
  case (And F G) thus ?case by(cases "k \<in> atoms F"; force) next
  case (Or F G) thus ?case by(cases "k \<in> atoms F"; force) next
  case (Imp F G) thus ?case by(cases "k \<in> atoms F"; force) next
qed simp_all

lemma subst_atoms_simp: "atoms (F[G / k]) = atoms F - {k} \<union> (if k \<in> atoms F then atoms G else {})"
  by(simp add: subst_atoms)

end