(*  Title:      Schutz_Spacetime/TernaryOrdering.thy
    Authors:    Richard Schmoetten, Jake Palmer and Jacques D. Fleuriot
                University of Edinburgh, 2021
*)
theory TernaryOrdering
imports Util

begin

text \<open>
  Definition of chains using an ordering on sets of events
  based on natural numbers, plus some proofs.
\<close>

section \<open>Totally ordered chains\<close>

text \<open>
  Based on page 110 of Phil Scott's thesis and the following HOL Light definition:
  \begin{verbatim}
  let ORDERING = new_definition
    `ORDERING f X <=> (!n. (FINITE X ==> n < CARD X) ==> f n IN X)
                    /\ (!x. x IN X ==> ?n. (FINITE X ==> n < CARD X)
                        /\ f n = x)
                    /\ !n n' n''. (FINITE X ==> n'' < CARD X)
                          /\ n < n' /\ n' < n''
                          ==> between (f n) (f n') (f n'')`;;
  \end{verbatim}
  I've made it strict for simplicity, and because that's how Schutz's ordering is. It could be
  made more generic by taking in the function corresponding to $<$ as a paramater.
  Main difference to Schutz: he has local order, not total (cf Theorem 2 and \<open>local_ordering\<close>).
\<close>

definition ordering :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "ordering f ord X \<equiv> (\<forall>n. (finite X \<longrightarrow> n < card X) \<longrightarrow> f n \<in> X)
                     \<and> (\<forall>x\<in>X. (\<exists>n. (finite X \<longrightarrow> n < card X) \<and> f n = x))
                     \<and> (\<forall>n n' n''. (finite X \<longrightarrow> n'' < card X) \<and> n < n' \<and> n' < n''
                                   \<longrightarrow> ord (f n) (f n') (f n''))"

lemma finite_ordering_intro:
  assumes "finite X"
    and "\<forall>n < card X. f n \<in> X"
    and "\<forall>x \<in> X. \<exists>n < card X. f n = x"
    and "\<forall>n n' n''. n < n' \<and> n' < n'' \<and> n'' < card X \<longrightarrow> ord (f n) (f n') (f n'')"
  shows "ordering f ord X"
  unfolding ordering_def by (simp add: assms)

lemma infinite_ordering_intro:
  assumes "infinite X"
    and "\<forall>n::nat. f n \<in> X"
    and "\<forall>x \<in> X. \<exists>n::nat. f n = x"
    and "\<forall>n n' n''. n < n' \<and> n' < n'' \<longrightarrow> ord (f n) (f n') (f n'')"
  shows "ordering f ord X"
  unfolding ordering_def by (simp add: assms)

lemma ordering_ord_ijk:
  assumes "ordering f ord X"
      and "i < j \<and> j < k \<and> (finite X \<longrightarrow> k < card X)"
  shows "ord (f i) (f j) (f k)"
  by (metis ordering_def assms)

lemma empty_ordering [simp]: "\<exists>f. ordering f ord {}"
  by (simp add: ordering_def)

lemma singleton_ordering [simp]: "\<exists>f. ordering f ord {a}"
  apply (rule_tac x = "\<lambda>n. a" in exI)
  by (simp add: ordering_def)

lemma two_ordering [simp]: "\<exists>f. ordering f ord {a, b}"
proof cases
  assume "a = b"
  thus ?thesis using singleton_ordering by simp
next
  assume a_neq_b: "a \<noteq> b"
  let ?f = "\<lambda>n. if n = 0 then a else b"
  have ordering1: "(\<forall>n. (finite {a,b} \<longrightarrow> n < card {a,b}) \<longrightarrow> ?f n \<in> {a,b})" by simp
  have local_ordering: "(\<forall>x\<in>{a,b}. \<exists>n. (finite {a,b} \<longrightarrow> n < card {a,b}) \<and> ?f n = x)"
    using a_neq_b all_not_in_conv card_Suc_eq card_0_eq card_gt_0_iff insert_iff lessI by auto
  have ordering3: "(\<forall>n n' n''. (finite {a,b} \<longrightarrow> n'' < card {a,b}) \<and> n < n' \<and> n' < n''
                                \<longrightarrow> ord (?f n) (?f n') (?f n''))" using a_neq_b by auto
  have "ordering ?f ord {a, b}" using ordering_def ordering1 local_ordering ordering3 by blast
  thus ?thesis by auto
qed

lemma card_le2_ordering:
  assumes finiteX: "finite X"
      and card_le2: "card X \<le> 2"
  shows "\<exists>f. ordering f ord X"
proof -
  have card012: "card X = 0 \<or> card X = 1 \<or> card X = 2" using card_le2 by auto
  have card0: "card X = 0 \<longrightarrow> ?thesis" using finiteX by simp
  have card1: "card X = 1 \<longrightarrow> ?thesis" using card_eq_SucD by fastforce
  have card2: "card X = 2 \<longrightarrow> ?thesis" by (metis two_ordering card_eq_SucD numeral_2_eq_2)
  thus ?thesis using card012 card0 card1 card2 by auto
qed

lemma ord_ordered:
  assumes abc: "ord a b c"
      and abc_neq: "a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c"
  shows "\<exists>f. ordering f ord {a,b,c}"
  apply (rule_tac x = "\<lambda>n. if n = 0 then a else if n = 1 then b else c" in exI)
  apply (unfold ordering_def)
  using abc abc_neq by auto

lemma overlap_ordering:
  assumes abc: "ord a b c"
      and bcd: "ord b c d"
      and abd: "ord a b d"
      and acd: "ord a c d"
      and abc_neq: "a \<noteq> b \<and> a \<noteq> c \<and> a \<noteq> d \<and> b \<noteq> c \<and> b \<noteq> d \<and> c \<noteq> d"
  shows "\<exists>f. ordering f ord {a,b,c,d}"
proof -
  let ?X = "{a,b,c,d}"
  let ?f = "\<lambda>n. if n = 0 then a else if n = 1 then b else if n = 2 then c else d"
  have card4: "card ?X = 4" using abc bcd abd abc_neq by simp
  have ordering1: "\<forall>n. (finite ?X \<longrightarrow> n < card ?X) \<longrightarrow> ?f n \<in> ?X" by simp
  have local_ordering: "\<forall>x\<in>?X. \<exists>n. (finite ?X \<longrightarrow> n < card ?X) \<and> ?f n = x"
    by (metis card4 One_nat_def Suc_1 Suc_lessI empty_iff insertE numeral_3_eq_3 numeral_eq_iff
              numeral_eq_one_iff rel_simps(51) semiring_norm(85) semiring_norm(86) semiring_norm(87)
              semiring_norm(89) zero_neq_numeral)
  have ordering3: "(\<forall>n n' n''. (finite ?X \<longrightarrow> n'' < card ?X) \<and> n < n' \<and> n' < n''
                                 \<longrightarrow> ord (?f n) (?f n') (?f n''))"
    using card4 abc bcd abd acd card_0_eq card_insert_if finite.emptyI finite_insert less_antisym
          less_one less_trans_Suc not_less_eq not_one_less_zero numeral_2_eq_2 by auto
  have "ordering ?f ord ?X" using ordering1 local_ordering ordering3 ordering_def by blast
  thus ?thesis by auto
qed

lemma overlap_ordering_alt1:
  assumes abc: "ord a b c"
      and bcd: "ord b c d"
      and abc_bcd_abd: "\<forall> a b c d. ord a b c \<and> ord b c d \<longrightarrow> ord a b d"
      and abc_bcd_acd: "\<forall> a b c d. ord a b c \<and> ord b c d \<longrightarrow> ord a c d"
      and ord_distinct: "\<forall>a b c. (ord a b c \<longrightarrow> a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c)"
  shows "\<exists>f. ordering f ord {a,b,c,d}"
  by (metis (full_types) assms overlap_ordering)

lemma overlap_ordering_alt2:
  assumes abc: "ord a b c"
      and bcd: "ord b c d"
      and abd: "ord a b d"
      and acd: "ord a c d"
      and ord_distinct: "\<forall>a b c. (ord a b c \<longrightarrow> a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c)"
  shows "\<exists>f. ordering f ord {a,b,c,d}"
  by (metis assms overlap_ordering)

lemma overlap_ordering_alt:
  assumes abc: "ord a b c"
      and bcd: "ord b c d"
      and abc_bcd_abd: "\<forall> a b c d. ord a b c \<and> ord b c d \<longrightarrow> ord a b d"
      and abc_bcd_acd: "\<forall> a b c d. ord a b c \<and> ord b c d \<longrightarrow> ord a c d"
      and abc_neq: "a \<noteq> b \<and> a \<noteq> c \<and> a \<noteq> d \<and> b \<noteq> c \<and> b \<noteq> d \<and> c \<noteq> d"
  shows "\<exists>f. ordering f ord {a,b,c,d}"
  by (meson assms overlap_ordering)

text \<open>
  The lemmas below are easy to prove for \<open>X = {}\<close>, and if I included that case then I would have
  to write a conditional definition in place of \<open>{0..|X| - 1}\<close>.
\<close>

lemma finite_ordering_img: "\<lbrakk>X \<noteq> {}; finite X; ordering f ord X\<rbrakk> \<Longrightarrow> f ` {0..card X - 1} = X"
  by (force simp add: ordering_def image_def)

lemma inf_ordering_img: "\<lbrakk>infinite X; ordering f ord X\<rbrakk> \<Longrightarrow> f ` {0..} = X"
  by (auto simp add: ordering_def image_def)

lemma inf_ordering_inv_img: "\<lbrakk>infinite X; ordering f ord X\<rbrakk> \<Longrightarrow> f -` X = {0..}"
  by (auto simp add: ordering_def image_def)

lemma inf_ordering_img_inv_img: "\<lbrakk>infinite X; ordering f ord X\<rbrakk> \<Longrightarrow> f ` f -` X = X"
  using inf_ordering_img by auto

lemma finite_ordering_inj_on: "\<lbrakk>finite X; ordering f ord X\<rbrakk> \<Longrightarrow> inj_on f {0..card X - 1}"
  by (metis finite_ordering_img Suc_diff_1 atLeastAtMost_iff card_atLeastAtMost card_eq_0_iff
        diff_0_eq_0 diff_zero eq_card_imp_inj_on gr0I inj_onI le_0_eq)

lemma finite_ordering_bij:
  assumes orderingX: "ordering f ord X"
      and finiteX: "finite X"
      and non_empty: "X \<noteq> {}"
  shows "bij_betw f {0..card X - 1} X"
proof -
  have f_image: "f ` {0..card X - 1} = X" by (metis orderingX finiteX finite_ordering_img non_empty)
  thus ?thesis by (metis inj_on_imp_bij_betw orderingX finiteX finite_ordering_inj_on)
qed

lemma inf_ordering_inj':
  assumes infX: "infinite X"
      and f_ord: "ordering f ord X"
      and ord_distinct: "\<forall>a b c. (ord a b c \<longrightarrow> a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c)"
      and f_eq: "f m = f n"
  shows "m = n"
proof (rule ccontr)
  assume m_not_n: "m \<noteq> n"
  have betw_3n: "\<forall>n n' n''. n < n' \<and> n' < n'' \<longrightarrow> ord (f n) (f n') (f n'')"
       using f_ord by (simp add: ordering_def infX)
  thus False
  proof cases
    assume m_less_n: "m < n"
    then obtain k where "n < k" by auto
    then have "ord (f m) (f n) (f k)" using m_less_n betw_3n by simp
    then have "f m \<noteq> f n" using ord_distinct by simp
    thus ?thesis using f_eq by simp
  next
    assume "\<not> m < n"
    then have n_less_m: "n < m" using m_not_n by simp
    then obtain k where "m < k" by auto
    then have "ord (f n) (f m) (f k)" using n_less_m betw_3n by simp
    then have "f n \<noteq> f m" using ord_distinct by simp
    thus ?thesis using f_eq by simp
  qed
qed

lemma inf_ordering_inj:
  assumes "infinite X"
      and "ordering f ord X"
      and "\<forall>a b c. (ord a b c \<longrightarrow> a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c)"
  shows "inj f"
  using inf_ordering_inj' assms by (metis injI)

text \<open>
  The finite case is a little more difficult as I can't just choose some other natural number
  to form the third part of the betweenness relation and the initial simplification isn't as nice.
  Note that I cannot prove \<open>inj f\<close> (over the whole type that \<open>f\<close> is defined on, i.e. natural numbers),
  because I need to capture the \<open>m\<close> and \<open>n\<close> that obey specific requirements for the finite case.
  In order to prove \<open>inj f\<close>, I would have to extend the definition for ordering to include \<open>m\<close> and \<open>n\<close>
  beyond \<open>card X\<close>, such that it is still injective. That would probably not be very useful.
\<close>

lemma finite_ordering_inj:
  assumes finiteX: "finite X"
      and f_ord: "ordering f ord X"
      and ord_distinct: "\<forall>a b c. (ord a b c \<longrightarrow> a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c)"
      and m_less_card: "m < card X"
      and n_less_card: "n < card X"
      and f_eq: "f m = f n"
  shows "m = n"
proof (rule ccontr)
  assume m_not_n: "m \<noteq> n"
  have surj_f: "\<forall>x\<in>X. \<exists>n<card X. f n = x"
               using f_ord by (simp add: ordering_def finiteX)
  have betw_3n: "\<forall>n n' n''. n'' < card X \<and> n < n' \<and> n' < n'' \<longrightarrow> ord (f n) (f n') (f n'')"
                using f_ord by (simp add: ordering_def)
  show False
  proof cases
    assume card_le2: "card X \<le> 2"
    have card0: "card X = 0 \<longrightarrow> False" using m_less_card by simp
    have card1: "card X = 1 \<longrightarrow> False" using m_less_card n_less_card m_not_n by simp
    have card2: "card X = 2 \<longrightarrow> False"
    proof (rule impI)
      assume card_is_2: "card X = 2"
      then have mn01: "m = 0 \<and> n = 1 \<or> n = 0 \<and> m = 1" using m_less_card n_less_card m_not_n by auto
      then have "f m \<noteq> f n" using card_is_2 surj_f One_nat_def card_eq_SucD insertCI
                                  less_2_cases numeral_2_eq_2 by (metis (no_types, lifting))
      thus False using f_eq by simp
    qed
    show False using card0 card1 card2 card_le2 by simp
  next
    assume "\<not> card X \<le> 2"
    then have card_ge3: "card X \<ge> 3" by simp
    thus False
    proof cases
      assume m_less_n: "m < n"
      then obtain k where k_pos: "k < m \<or> (m < k \<and> k < n) \<or> (n < k \<and> k < card X)"
          using is_free_nat m_less_n n_less_card card_ge3 by blast
      have k1: "k < m \<longrightarrow>ord (f k) (f m) (f n)" using m_less_n n_less_card betw_3n by simp
      have k2: "m < k \<and> k < n \<longrightarrow> ord (f m) (f k) (f n)" using m_less_n n_less_card betw_3n by simp
      have k3: "n < k \<and> k < card X \<longrightarrow> ord (f m) (f n) (f k)" using m_less_n betw_3n by simp
      have "f m \<noteq> f n" using k1 k2 k3 k_pos ord_distinct by auto
      thus False using f_eq by simp
    next
      assume "\<not> m < n"
      then have n_less_m: "n < m" using m_not_n by simp
      then obtain k where k_pos: "k < n \<or> (n < k \<and> k < m) \<or> (m < k \<and> k < card X)"
          using is_free_nat n_less_m m_less_card card_ge3 by blast
      have k1: "k < n \<longrightarrow>ord (f k) (f n) (f m)" using n_less_m m_less_card betw_3n by simp
      have k2: "n < k \<and> k < m \<longrightarrow> ord (f n) (f k) (f m)" using n_less_m m_less_card betw_3n by simp
      have k3: "m < k \<and> k < card X \<longrightarrow> ord (f n) (f m) (f k)" using n_less_m betw_3n by simp
      have "f n \<noteq> f m" using k1 k2 k3 k_pos ord_distinct by auto
      thus False using f_eq by simp
    qed
  qed
qed

lemma ordering_inj:
  assumes "ordering f ord X"
      and "\<forall>a b c. (ord a b c \<longrightarrow> a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c)"
      and "finite X \<longrightarrow> m < card X"
      and "finite X \<longrightarrow> n < card X"
      and "f m = f n"
  shows "m = n"
  using inf_ordering_inj' finite_ordering_inj assms by blast

lemma ordering_sym:
  assumes ord_sym: "\<And>a b c. ord a b c \<Longrightarrow> ord c b a"
      and "finite X"
      and "ordering f ord X"
  shows "ordering (\<lambda>n. f (card X - 1 - n)) ord X"
unfolding ordering_def using assms(2)
  apply auto
  apply (metis ordering_def assms(3) card_0_eq card_gt_0_iff diff_Suc_less gr_implies_not0)
proof -
  fix x
  assume "finite X"
  assume "x \<in> X"
  obtain n where "finite X \<longrightarrow> n < card X" and "f n = x"
    by (metis ordering_def \<open>x \<in> X\<close> assms(3))
  have "f (card X - ((card X - 1 - n) + 1)) = x"
    by (simp add: Suc_leI \<open>f n = x\<close> \<open>finite X \<longrightarrow> n < card X\<close> assms(2))
  thus "\<exists>n<card X. f (card X - Suc n) = x"
    by (metis \<open>x \<in> X\<close> add.commute assms(2) card_Diff_singleton card_Suc_Diff1 diff_less_Suc plus_1_eq_Suc)
next
  fix n n' n''
  assume "finite X"
  assume "n'' < card X" "n < n'" "n' < n''"
  have "ord (f (card X - Suc n'')) (f (card X - Suc n')) (f (card X - Suc n))"
    using assms(3) unfolding ordering_def
    using \<open>n < n'\<close> \<open>n' < n''\<close> \<open>n'' < card X\<close> diff_less_mono2 by auto
  thus " ord (f (card X - Suc n)) (f (card X - Suc n')) (f (card X - Suc n''))"
    using ord_sym by blast
qed

lemma  zero_into_ordering:
  assumes "ordering f betw X"
  and "X \<noteq> {}"
  shows "(f 0) \<in> X"
  using ordering_def
  by (metis assms card_eq_0_iff gr_implies_not0 linorder_neqE_nat)

section "Locally ordered chains"
text \<open>Definitions for Schutz-like chains, with local order only.\<close>

definition local_ordering :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
  where "local_ordering f ord X
    \<equiv> (\<forall>n. (finite X \<longrightarrow> n < card X) \<longrightarrow> f n \<in> X) \<and>
      (\<forall>x\<in>X. \<exists>n. (finite X \<longrightarrow> n < card X) \<and> f n = x) \<and>
      (\<forall>n. (finite X \<longrightarrow> Suc (Suc n) < card X) \<longrightarrow> ord (f n) (f (Suc n)) (f (Suc (Suc n))))"

lemma finite_local_ordering_intro:
  assumes "finite X"
    and "\<forall>n < card X. f n \<in> X"
    and "\<forall>x \<in> X. \<exists>n < card X. f n = x"
    and "\<forall>n n' n''. Suc n = n' \<and> Suc n' = n'' \<and> n'' < card X \<longrightarrow> ord (f n) (f n') (f n'')"
  shows "local_ordering f ord X"
  unfolding local_ordering_def by (simp add: assms)

lemma infinite_local_ordering_intro:
  assumes "infinite X"
    and "\<forall>n::nat. f n \<in> X"
    and "\<forall>x \<in> X. \<exists>n::nat. f n = x"
    and "\<forall>n n' n''. Suc n = n' \<and> Suc n' = n'' \<longrightarrow> ord (f n) (f n') (f n'')"
  shows "local_ordering f ord X"
  using assms unfolding local_ordering_def by metis

lemma total_implies_local:
  "ordering f ord X \<Longrightarrow> local_ordering f ord X"
  unfolding ordering_def local_ordering_def
  using lessI by presburger

lemma ordering_ord_ijk_loc:
  assumes "local_ordering f ord X"
      and "finite X \<longrightarrow> Suc (Suc i) < card X"
  shows "ord (f i) (f (Suc i)) (f (Suc (Suc i)))"
  by (metis local_ordering_def assms)

lemma empty_ordering_loc [simp]:
  "\<exists>f. local_ordering f ord {}"
  by (simp add: local_ordering_def)

lemma singleton_ordered_loc [simp]:
  "local_ordering f ord {f 0}"
  unfolding local_ordering_def by simp

lemma singleton_ordering_loc [simp]:
  "\<exists>f. local_ordering f ord {a}"
  using singleton_ordered_loc by fast

lemma two_ordered_loc:
  assumes "a = f 0" and "b = f 1"
  shows "local_ordering f ord {a, b}"
proof cases
  assume "a = b"
  thus ?thesis using assms singleton_ordered_loc by (metis insert_absorb2)
next
  assume a_neq_b: "a \<noteq> b"
  hence "(\<forall>n. (finite {a,b} \<longrightarrow> n < card {a,b}) \<longrightarrow> f n \<in> {a,b})"
    using assms by (metis One_nat_def card.infinite card_2_iff fact_0 fact_2 insert_iff less_2_cases_iff)
  moreover have "(\<forall>x\<in>{a,b}. \<exists>n. (finite {a,b} \<longrightarrow> n < card {a,b}) \<and> f n = x)"
    using assms a_neq_b all_not_in_conv card_Suc_eq card_0_eq card_gt_0_iff insert_iff lessI by auto
  moreover have "(\<forall>n. (finite {a,b} \<longrightarrow> Suc (Suc n) < card {a,b})
                      \<longrightarrow> ord (f n) (f (Suc n)) (f (Suc (Suc n))))"
    using a_neq_b by auto
  ultimately have "local_ordering f ord {a, b}"
     using local_ordering_def by blast
  thus ?thesis by auto
qed

lemma two_ordering_loc [simp]:
  "\<exists>f. local_ordering f ord {a, b}"
  using total_implies_local two_ordering by fastforce

lemma card_le2_ordering_loc:
  assumes finiteX: "finite X"
      and card_le2: "card X \<le> 2"
  shows "\<exists>f. local_ordering f ord X"
  using assms total_implies_local card_le2_ordering by metis

lemma ord_ordered_loc:
  assumes abc: "ord a b c"
      and abc_neq: "a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c"
  shows "\<exists>f. local_ordering f ord {a,b,c}"
  using assms total_implies_local ord_ordered by metis

lemma overlap_ordering_loc:
  assumes abc: "ord a b c"
      and bcd: "ord b c d"
      and abd: "ord a b d"
      and acd: "ord a c d"
      and abc_neq: "a \<noteq> b \<and> a \<noteq> c \<and> a \<noteq> d \<and> b \<noteq> c \<and> b \<noteq> d \<and> c \<noteq> d"
  shows "\<exists>f. local_ordering f ord {a,b,c,d}"
  using overlap_ordering[OF assms] total_implies_local by blast

lemma ordering_sym_loc:
  assumes ord_sym: "\<And>a b c. ord a b c \<Longrightarrow> ord c b a"
      and "finite X"
      and "local_ordering f ord X"
  shows "local_ordering (\<lambda>n. f (card X - 1 - n)) ord X"
  unfolding local_ordering_def using assms(2) apply auto
  apply (metis local_ordering_def assms(3) card_0_eq card_gt_0_iff diff_Suc_less gr_implies_not0)
proof -
  fix x
  assume "finite X"
  assume "x \<in> X"
  obtain n where "finite X \<longrightarrow> n < card X" and "f n = x"
    by (metis local_ordering_def \<open>x \<in> X\<close> assms(3))
  have "f (card X - ((card X - 1 - n) + 1)) = x"
    by (simp add: Suc_leI \<open>f n = x\<close> \<open>finite X \<longrightarrow> n < card X\<close> assms(2))
  thus "\<exists>n<card X. f (card X - Suc n) = x"
    by (metis \<open>x \<in> X\<close> add.commute assms(2) card_Diff_singleton card_Suc_Diff1 diff_less_Suc plus_1_eq_Suc)
next
  fix n
  let ?n1 = "Suc n"
  let ?n2 = "Suc ?n1"
  assume "finite X"
  assume "Suc (Suc n) < card X"
  have "ord (f (card X - Suc ?n2)) (f (card X - Suc ?n1)) (f (card X - Suc n))"
    using assms(3) unfolding local_ordering_def
    using \<open>Suc (Suc n) < card X\<close> by (metis
      Suc_diff_Suc Suc_lessD card_eq_0_iff card_gt_0_iff diff_less gr_implies_not0 zero_less_Suc)
  thus " ord (f (card X - Suc n)) (f (card X - Suc ?n1)) (f (card X - Suc ?n2))"
    using ord_sym by blast
qed

lemma  zero_into_ordering_loc:
  assumes "local_ordering f betw X"
  and "X \<noteq> {}"
  shows "(f 0) \<in> X"
    using local_ordering_def by (metis assms card_eq_0_iff gr_implies_not0 linorder_neqE_nat)

end


(*  Title:      HOL/Isar_Examples/Group.thy
    Author:     Makarius
*)

section \<open>Basic group theory\<close>

theory Group
  imports MainRLT
begin

subsection \<open>Groups and calculational reasoning\<close>

text \<open>
  Groups over signature \<open>(* :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>, 1 :: \<alpha>, inverse :: \<alpha> \<Rightarrow> \<alpha>)\<close> are
  defined as an axiomatic type class as follows. Note that the parent classes
  \<^class>\<open>times\<close>, \<^class>\<open>one\<close>, \<^class>\<open>inverse\<close> is provided by the basic HOL theory.
\<close>

class group = times + one + inverse +
  assumes group_assoc: "(x * y) * z = x * (y * z)"
    and group_left_one: "1 * x = x"
    and group_left_inverse: "inverse x * x = 1"

text \<open>
  The group axioms only state the properties of left one and inverse, the
  right versions may be derived as follows.
\<close>

theorem (in group) group_right_inverse: "x * inverse x = 1"
proof -
  have "x * inverse x = 1 * (x * inverse x)"
    by (simp only: group_left_one)
  also have "\<dots> = 1 * x * inverse x"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * inverse x * x * inverse x"
    by (simp only: group_left_inverse)
  also have "\<dots> = inverse (inverse x) * (inverse x * x) * inverse x"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * 1 * inverse x"
    by (simp only: group_left_inverse)
  also have "\<dots> = inverse (inverse x) * (1 * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * inverse x"
    by (simp only: group_left_one)
  also have "\<dots> = 1"
    by (simp only: group_left_inverse)
  finally show ?thesis .
qed

text \<open>
  With \<open>group_right_inverse\<close> already available, \<open>group_right_one\<close>
  is now established much easier.
\<close>

theorem (in group) group_right_one: "x * 1 = x"
proof -
  have "x * 1 = x * (inverse x * x)"
    by (simp only: group_left_inverse)
  also have "\<dots> = x * inverse x * x"
    by (simp only: group_assoc)
  also have "\<dots> = 1 * x"
    by (simp only: group_right_inverse)
  also have "\<dots> = x"
    by (simp only: group_left_one)
  finally show ?thesis .
qed

text \<open>
  \<^medskip>
  The calculational proof style above follows typical presentations given in
  any introductory course on algebra. The basic technique is to form a
  transitive chain of equations, which in turn are established by simplifying
  with appropriate rules. The low-level logical details of equational
  reasoning are left implicit.

  Note that ``\<open>\<dots>\<close>'' is just a special term variable that is bound
  automatically to the argument\<^footnote>\<open>The argument of a curried infix expression
  happens to be its right-hand side.\<close> of the last fact achieved by any local
  assumption or proven statement. In contrast to \<open>?thesis\<close>, the ``\<open>\<dots>\<close>''
  variable is bound \<^emph>\<open>after\<close> the proof is finished.

  There are only two separate Isar language elements for calculational proofs:
  ``\<^theory_text>\<open>also\<close>'' for initial or intermediate calculational steps, and
  ``\<^theory_text>\<open>finally\<close>'' for exhibiting the result of a calculation. These constructs
  are not hardwired into Isabelle/Isar, but defined on top of the basic
  Isar/VM interpreter. Expanding the \<^theory_text>\<open>also\<close> and \<^theory_text>\<open>finally\<close> derived language
  elements, calculations may be simulated by hand as demonstrated below.
\<close>

theorem (in group) "x * 1 = x"
proof -
  have "x * 1 = x * (inverse x * x)"
    by (simp only: group_left_inverse)

  note calculation = this
    \<comment> \<open>first calculational step: init calculation register\<close>

  have "\<dots> = x * inverse x * x"
    by (simp only: group_assoc)

  note calculation = trans [OF calculation this]
    \<comment> \<open>general calculational step: compose with transitivity rule\<close>

  have "\<dots> = 1 * x"
    by (simp only: group_right_inverse)

  note calculation = trans [OF calculation this]
    \<comment> \<open>general calculational step: compose with transitivity rule\<close>

  have "\<dots> = x"
    by (simp only: group_left_one)

  note calculation = trans [OF calculation this]
    \<comment> \<open>final calculational step: compose with transitivity rule \dots\<close>
  from calculation
    \<comment> \<open>\dots\ and pick up the final result\<close>

  show ?thesis .
qed

text \<open>
  Note that this scheme of calculations is not restricted to plain
  transitivity. Rules like anti-symmetry, or even forward and backward
  substitution work as well. For the actual implementation of \<^theory_text>\<open>also\<close> and
  \<^theory_text>\<open>finally\<close>, Isabelle/Isar maintains separate context information of
  ``transitivity'' rules. Rule selection takes place automatically by
  higher-order unification.
\<close>

subsection \<open>Groups as monoids\<close>

text \<open>
  Monoids over signature \<open>(* :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>, 1 :: \<alpha>)\<close> are defined like this.
\<close>

class monoid = times + one +
  assumes monoid_assoc: "(x * y) * z = x * (y * z)"
    and monoid_left_one: "1 * x = x"
    and monoid_right_one: "x * 1 = x"

text \<open>
  Groups are \<^emph>\<open>not\<close> yet monoids directly from the definition. For monoids,
  \<open>right_one\<close> had to be included as an axiom, but for groups both \<open>right_one\<close>
  and \<open>right_inverse\<close> are derivable from the other axioms. With
  \<open>group_right_one\<close> derived as a theorem of group theory (see @{thm
  group_right_one}), we may still instantiate \<open>group \<subseteq> monoid\<close> properly as
  follows.
\<close>

instance group \<subseteq> monoid
  by intro_classes
    (rule group_assoc,
      rule group_left_one,
      rule group_right_one)

text \<open>
  The \<^theory_text>\<open>instance\<close> command actually is a version of \<^theory_text>\<open>theorem\<close>, setting up a
  goal that reflects the intended class relation (or type constructor arity).
  Thus any Isar proof language element may be involved to establish this
  statement. When concluding the proof, the result is transformed into the
  intended type signature extension behind the scenes.
\<close>

subsection \<open>More theorems of group theory\<close>

text \<open>
  The one element is already uniquely determined by preserving an \<^emph>\<open>arbitrary\<close>
  group element.
\<close>

theorem (in group) group_one_equality:
  assumes eq: "e * x = x"
  shows "1 = e"
proof -
  have "1 = x * inverse x"
    by (simp only: group_right_inverse)
  also have "\<dots> = (e * x) * inverse x"
    by (simp only: eq)
  also have "\<dots> = e * (x * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = e * 1"
    by (simp only: group_right_inverse)
  also have "\<dots> = e"
    by (simp only: group_right_one)
  finally show ?thesis .
qed

text \<open>
  Likewise, the inverse is already determined by the cancel property.
\<close>

theorem (in group) group_inverse_equality:
  assumes eq: "x' * x = 1"
  shows "inverse x = x'"
proof -
  have "inverse x = 1 * inverse x"
    by (simp only: group_left_one)
  also have "\<dots> = (x' * x) * inverse x"
    by (simp only: eq)
  also have "\<dots> = x' * (x * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = x' * 1"
    by (simp only: group_right_inverse)
  also have "\<dots> = x'"
    by (simp only: group_right_one)
  finally show ?thesis .
qed

text \<open>
  The inverse operation has some further characteristic properties.
\<close>

theorem (in group) group_inverse_times: "inverse (x * y) = inverse y * inverse x"
proof (rule group_inverse_equality)
  show "(inverse y * inverse x) * (x * y) = 1"
  proof -
    have "(inverse y * inverse x) * (x * y) =
        (inverse y * (inverse x * x)) * y"
      by (simp only: group_assoc)
    also have "\<dots> = (inverse y * 1) * y"
      by (simp only: group_left_inverse)
    also have "\<dots> = inverse y * y"
      by (simp only: group_right_one)
    also have "\<dots> = 1"
      by (simp only: group_left_inverse)
    finally show ?thesis .
  qed
qed

theorem (in group) inverse_inverse: "inverse (inverse x) = x"
proof (rule group_inverse_equality)
  show "x * inverse x = one"
    by (simp only: group_right_inverse)
qed

theorem (in group) inverse_inject:
  assumes eq: "inverse x = inverse y"
  shows "x = y"
proof -
  have "x = x * 1"
    by (simp only: group_right_one)
  also have "\<dots> = x * (inverse y * y)"
    by (simp only: group_left_inverse)
  also have "\<dots> = x * (inverse x * y)"
    by (simp only: eq)
  also have "\<dots> = (x * inverse x) * y"
    by (simp only: group_assoc)
  also have "\<dots> = 1 * y"
    by (simp only: group_right_inverse)
  also have "\<dots> = y"
    by (simp only: group_left_one)
  finally show ?thesis .
qed

end


(*  Title:      HOL/Library/ContNonDenum.thy
    Author:     Benjamin Porter, Monash University, NICTA, 2005
    Author:     Johannes Hölzl, TU München
*)

section {* Non-denumerability of the Continuum. *}

theory ContNotDenum
imports Complex_Main Countable_Set
begin

subsection {* Abstract *}

text {* The following document presents a proof that the Continuum is
uncountable. It is formalised in the Isabelle/Isar theorem proving
system.

{\em Theorem:} The Continuum @{text "\<real>"} is not denumerable. In other
words, there does not exist a function @{text "f: \<nat> \<Rightarrow> \<real>"} such that f is
surjective.

{\em Outline:} An elegant informal proof of this result uses Cantor's
Diagonalisation argument. The proof presented here is not this
one. First we formalise some properties of closed intervals, then we
prove the Nested Interval Property. This property relies on the
completeness of the Real numbers and is the foundation for our
argument. Informally it states that an intersection of countable
closed intervals (where each successive interval is a subset of the
last) is non-empty. We then assume a surjective function @{text
"f: \<nat> \<Rightarrow> \<real>"} exists and find a real x such that x is not in the range of f
by generating a sequence of closed intervals then using the NIP. *}

theorem real_non_denum: "\<not> (\<exists>f :: nat \<Rightarrow> real. surj f)"
proof
  assume "\<exists>f::nat \<Rightarrow> real. surj f"
  then obtain f :: "nat \<Rightarrow> real" where "surj f" ..

  txt {* First we construct a sequence of nested intervals, ignoring @{term "range f"}. *}

  have "\<forall>a b c::real. a < b \<longrightarrow> (\<exists>ka kb. ka < kb \<and> {ka..kb} \<subseteq> {a..b} \<and> c \<notin> {ka..kb})"
    using assms
    by (auto simp add: not_le cong: conj_cong)
       (metis dense le_less_linear less_linear less_trans order_refl)
  then obtain i j where ij:
    "\<And>a b c::real. a < b \<Longrightarrow> i a b c < j a b c"
    "\<And>a b c. a < b \<Longrightarrow> {i a b c .. j a b c} \<subseteq> {a .. b}"
    "\<And>a b c. a < b \<Longrightarrow> c \<notin> {i a b c .. j a b c}"
    by metis

  def ivl \<equiv> "rec_nat (f 0 + 1, f 0 + 2) (\<lambda>n x. (i (fst x) (snd x) (f n), j (fst x) (snd x) (f n)))"
  def I \<equiv> "\<lambda>n. {fst (ivl n) .. snd (ivl n)}"

  have ivl[simp]:
    "ivl 0 = (f 0 + 1, f 0 + 2)"
    "\<And>n. ivl (Suc n) = (i (fst (ivl n)) (snd (ivl n)) (f n), j (fst (ivl n)) (snd (ivl n)) (f n))"
    unfolding ivl_def by simp_all

  txt {* This is a decreasing sequence of non-empty intervals. *}

  { fix n have "fst (ivl n) < snd (ivl n)"
      by (induct n) (auto intro!: ij) }
  note less = this

  have "decseq I"
    unfolding I_def decseq_Suc_iff ivl fst_conv snd_conv by (intro ij allI less)

  txt {* Now we apply the finite intersection property of compact sets. *}

  have "I 0 \<inter> (\<Inter>i. I i) \<noteq> {}"
  proof (rule compact_imp_fip_image)
    fix S :: "nat set" assume fin: "finite S"
    have "{} \<subset> I (Max (insert 0 S))"
      unfolding I_def using less[of "Max (insert 0 S)"] by auto
    also have "I (Max (insert 0 S)) \<subseteq> (\<Inter>i\<in>insert 0 S. I i)"
      using fin decseqD[OF `decseq I`, of _ "Max (insert 0 S)"] by (auto simp: Max_ge_iff)
    also have "(\<Inter>i\<in>insert 0 S. I i) = I 0 \<inter> (\<Inter>i\<in>S. I i)"
      by auto
    finally show "I 0 \<inter> (\<Inter>i\<in>S. I i) \<noteq> {}"
      by auto
  qed (auto simp: I_def)
  then obtain x where "\<And>n. x \<in> I n"
    by blast
  moreover from `surj f` obtain j where "x = f j"
    by blast
  ultimately have "f j \<in> I (Suc j)"
    by blast
  with ij(3)[OF less] show False
    unfolding I_def ivl fst_conv snd_conv by auto
qed

lemma uncountable_UNIV_real: "uncountable (UNIV::real set)"
  using real_non_denum unfolding uncountable_def by auto

lemma bij_betw_open_intervals:
  fixes a b c d :: real
  assumes "a < b" "c < d"
  shows "\<exists>f. bij_betw f {a<..<b} {c<..<d}"
proof -
  def f \<equiv> "\<lambda>a b c d x::real. (d - c)/(b - a) * (x - a) + c"
  { fix a b c d x :: real assume *: "a < b" "c < d" "a < x" "x < b"
    moreover from * have "(d - c) * (x - a) < (d - c) * (b - a)"
      by (intro mult_strict_left_mono) simp_all
    moreover from * have "0 < (d - c) * (x - a) / (b - a)"
      by simp
    ultimately have "f a b c d x < d" "c < f a b c d x"
      by (simp_all add: f_def field_simps) }
  with assms have "bij_betw (f a b c d) {a<..<b} {c<..<d}"
    by (intro bij_betw_byWitness[where f'="f c d a b"]) (auto simp: f_def)
  thus ?thesis by auto
qed

lemma bij_betw_tan: "bij_betw tan {-pi/2<..<pi/2} UNIV"
  using arctan_ubound by (intro bij_betw_byWitness[where f'=arctan]) (auto simp: arctan_tan)

lemma uncountable_open_interval:
  fixes a b :: real assumes ab: "a < b"
  shows "uncountable {a<..<b}"
proof -
  obtain f where "bij_betw f {a <..< b} {-pi/2<..<pi/2}"
    using bij_betw_open_intervals[OF `a < b`, of "-pi/2" "pi/2"] by auto
  then show ?thesis
    by (metis bij_betw_tan uncountable_bij_betw uncountable_UNIV_real)
qed

end


theory Samplers
  imports Main "HOL-Library.Omega_Words_Fun"
begin

section \<open>Utility Lemmas\<close>

text \<open>
  The following lemmas about strictly monotonic functions could go
  to the standard library of Isabelle/HOL.
\<close>

text \<open>
  Strongly monotonic functions over the integers grow without bound.
\<close>
lemma strict_mono_exceeds:
  assumes f: "strict_mono (f::nat \<Rightarrow> nat)"
  shows "\<exists>k. n < f k"
proof (induct n)
  from f have "f 0 < f 1" by (rule strict_monoD) simp
  hence "0 < f 1" by simp
  thus "\<exists>k. 0 < f k" ..
next
  fix n
  assume "\<exists>k. n < f k"
  then obtain k where "n < f k" ..
  hence "Suc n \<le> f k" by simp
  also from f have "f k < f (Suc k)" by (rule strict_monoD) simp
  finally show "\<exists>k. Suc n < f k" ..
qed

text \<open>
  More precisely, any natural number \<open>n \<ge> f 0\<close> lies in the interval
  between \<open>f k\<close> and \<open>f (Suc k)\<close>, for some \<open>k\<close>.
\<close>
lemma strict_mono_interval:
  assumes f: "strict_mono (f::nat \<Rightarrow> nat)" and n: "f 0 \<le> n"
  obtains k where "f k \<le> n" and "n < f (Suc k)"
proof -
  from f[THEN strict_mono_exceeds] obtain m where m: "n < f m" ..
  have "m \<noteq> 0"
  proof
    assume "m = 0"
    with m n show "False" by simp
  qed
  with m obtain m' where m': "n < f (Suc m')" by (auto simp: gr0_conv_Suc)
  let ?k = "LEAST k. n < f (Suc k)"
  from m' have 1: "n < f (Suc ?k)" by (rule LeastI)
  have "f ?k \<le> n"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence k: "n < f ?k" by simp
    show "False"
    proof (cases "?k")
      case 0 with k n show "False" by simp
    next
      case Suc with k show "False" by (auto dest: Least_le)
    qed
  qed
  with 1 that show ?thesis by simp
qed

lemma strict_mono_comp:
  assumes g: "strict_mono (g::'a::order \<Rightarrow> 'b::order)"
      and f: "strict_mono (f::'b::order \<Rightarrow> 'c::order)"
  shows "strict_mono (f \<circ> g)"
  using assms by (auto simp: strict_mono_def)

section \<open>Stuttering Sampling Functions\<close>

text \<open>
  Given an \<open>\<omega>\<close>-sequence \<open>\<sigma>\<close>, a stuttering sampling function
  is a strictly monotonic function \<open>f::nat \<Rightarrow> nat\<close> such that
  \<open>f 0 = 0\<close> and for all \<open>i\<close> and all \<open>f i \<le> k < f (i+1)\<close>,
  the elements \<open>\<sigma> k\<close> are the same. In other words, \<open>f\<close> skips some
  (but not necessarily all) stuttering steps, but never skips a non-stuttering step.
  Given such \<open>\<sigma>\<close> and \<open>f\<close>, the (stuttering-)sampled
  reduction of \<open>\<sigma>\<close> is the sequence of elements of \<open>\<sigma>\<close> at the
  indices \<open>f i\<close>, which can simply be written as \<open>\<sigma> \<circ> f\<close>.
\<close>

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

definition stutter_sampler where
  \<comment> \<open>f is a stuttering sampling function for @{text "\<sigma>"}\<close>
  "stutter_sampler (f::nat \<Rightarrow> nat) \<sigma> \<equiv>
     f 0 = 0
   \<and> strict_mono f
   \<and> (\<forall>k n. f k < n \<and> n < f (Suc k) \<longrightarrow> \<sigma> n = \<sigma> (f k))"

lemma stutter_sampler_0: "stutter_sampler f \<sigma> \<Longrightarrow> f 0 = 0"
  by (simp add: stutter_sampler_def)

lemma stutter_sampler_mono: "stutter_sampler f \<sigma> \<Longrightarrow> strict_mono f"
  by (simp add: stutter_sampler_def)

lemma stutter_sampler_between:
  assumes f: "stutter_sampler f \<sigma>"
      and lo: "f k \<le> n" and hi: "n < f (Suc k)"
    shows "\<sigma> n = \<sigma> (f k)"
  using assms by (auto simp: stutter_sampler_def less_le)

lemma stutter_sampler_interval:
  assumes f: "stutter_sampler f \<sigma>"
  obtains k where "f k \<le> n" and "n < f (Suc k)"
using f[THEN stutter_sampler_mono] proof (rule strict_mono_interval)
  from f show "f 0 \<le> n" by (simp add: stutter_sampler_0)
qed

text \<open>
  The identity function is a stuttering sampling function for any \<open>\<sigma>\<close>.
\<close>
lemma id_stutter_sampler [iff]: "stutter_sampler id \<sigma>"
  by (auto simp: stutter_sampler_def strict_mono_def)

text \<open>
  Stuttering sampling functions compose, sort of.
\<close>
lemma stutter_sampler_comp:
  assumes f: "stutter_sampler f \<sigma>"
      and g: "stutter_sampler g (\<sigma> \<circ> f)"
  shows "stutter_sampler (f \<circ> g) \<sigma>"
proof (auto simp: stutter_sampler_def)
  from f g show "f (g 0) = 0" by (simp add: stutter_sampler_0)
next
  from g[THEN stutter_sampler_mono] f[THEN stutter_sampler_mono]
  show "strict_mono (f \<circ> g)" by (rule strict_mono_comp)
next
  fix i k
  assume lo: "f (g i) < k" and hi: "k < f (g (Suc i))"
  from f obtain m where 1: "f m \<le> k" and 2: "k < f (Suc m)"
    by (rule stutter_sampler_interval)
  with f have 3: "\<sigma> k = \<sigma> (f m)" by (rule stutter_sampler_between)
  from lo 2 have "f (g i) < f (Suc m)" by simp
  with f[THEN stutter_sampler_mono] have 4: "g i \<le> m" by (simp add: strict_mono_less)
  from 1 hi have "f m < f (g (Suc i))" by simp
  with f[THEN stutter_sampler_mono] have 5: "m < g (Suc i)"by (simp add: strict_mono_less)
  from g 4 5 have "(\<sigma> \<circ> f) m = (\<sigma> \<circ> f) (g i)" by (rule stutter_sampler_between)
  with 3 show "\<sigma> k = \<sigma> (f (g i))" by simp
qed

text \<open>
  Stuttering sampling functions can be extended to suffixes.
\<close>
lemma stutter_sampler_suffix:
  assumes f: "stutter_sampler f \<sigma>"
  shows "stutter_sampler (\<lambda>k. f (n+k) - f n) (suffix (f n) \<sigma>)"
proof (auto simp: stutter_sampler_def strict_mono_def)
  fix i j
  assume ij: "(i::nat) < j"
  from f have mono: "strict_mono f" by (rule stutter_sampler_mono)

  from mono[THEN strict_mono_mono] have "f n \<le> f (n+i)"
    by (rule monoD) simp
  moreover
  from mono[THEN strict_mono_mono] have "f n \<le> f (n+j)"
    by (rule monoD) simp
  moreover
  from mono ij have "f (n+i) < f (n+j)" by (auto intro: strict_monoD)
  ultimately
  show "f (n+i) - f n < f (n+j) - f n" by simp
next
  fix i k
  assume lo: "f (n+i) - f n < k" and hi: "k < f (Suc (n+i)) - f n"
  from lo have "f (n+i) \<le> f n + k" by simp
  moreover
  from hi have "f n + k < f (Suc (n + i))" by simp
  moreover
  from f[THEN stutter_sampler_mono, THEN strict_mono_mono]
  have "f n \<le> f (n+i)" by (rule monoD) simp
  ultimately show "\<sigma> (f n + k) = \<sigma> (f n + (f (n+i) - f n))"
    by (auto dest: stutter_sampler_between[OF f])
qed

subsection \<open>Preservation of properties through stuttering sampling\<close>

text \<open>
  Stuttering sampling preserves the initial element of the sequence, as well as
  the presence and relative ordering of different elements.
\<close>

lemma stutter_sampled_0:
  assumes "stutter_sampler f \<sigma>"
  shows "\<sigma> (f 0) = \<sigma> 0"
  using assms[THEN stutter_sampler_0] by simp

lemma stutter_sampled_in_range:
  assumes f: "stutter_sampler f \<sigma>" and s: "s \<in> range \<sigma>"
  shows "s \<in> range (\<sigma> \<circ> f)"
proof -
  from s obtain n where n: "\<sigma> n = s" by auto
  from f obtain k where "f k \<le> n" "n < f (Suc k)" by (rule stutter_sampler_interval)
  with f have "\<sigma> n = \<sigma> (f k)" by (rule stutter_sampler_between)
  with n show ?thesis by auto
qed

lemma stutter_sampled_range:
  "range (\<sigma> \<circ> f) = range \<sigma>" if "stutter_sampler f \<sigma>"
  using that stutter_sampled_in_range [of f \<sigma>] by auto

lemma stutter_sampled_precedence:
  assumes f: "stutter_sampler f \<sigma>" and ij: "i \<le> j"
  obtains k l where "k \<le> l" "\<sigma> (f k) = \<sigma> i" "\<sigma> (f l) = \<sigma> j"
proof -
  from f obtain k where k: "f k \<le> i" "i < f (Suc k)" by (rule stutter_sampler_interval)
  with f have 1: "\<sigma> i = \<sigma> (f k)" by (rule stutter_sampler_between)
  from f obtain l where l: "f l \<le> j" "j < f (Suc l)" by (rule stutter_sampler_interval)
  with f have 2: "\<sigma> j = \<sigma> (f l)" by (rule stutter_sampler_between)
  from k l ij have "f k < f (Suc l)" by simp
  with f[THEN stutter_sampler_mono] have "k \<le> l" by (simp add: strict_mono_less)
  with 1 2 that show ?thesis by simp
qed

subsection \<open>Maximal stuttering sampling\<close>

text \<open>
  We define a particular sampling function that is maximal in the sense that it
  eliminates all finite stuttering. If a sequence ends with infinite stuttering
  then it behaves as the identity over the (maximal such) suffix.
\<close>

fun max_stutter_sampler where
  "max_stutter_sampler \<sigma> 0 = 0"
| "max_stutter_sampler \<sigma> (Suc n) =
    (let prev = max_stutter_sampler \<sigma> n
     in  if (\<forall>k > prev. \<sigma> k = \<sigma> prev)
         then Suc prev
         else (LEAST k. prev < k \<and> \<sigma> k \<noteq> \<sigma> prev))"

text \<open>
  \<open>max_stutter_sampler\<close> is indeed a stuttering sampling function.
\<close>
lemma max_stutter_sampler:
  "stutter_sampler (max_stutter_sampler \<sigma>) \<sigma>" (is "stutter_sampler ?ms _")
proof -
  have "?ms 0 = 0" by simp
  moreover
  have "\<forall>n. ?ms n < ?ms (Suc n)"
  proof
    fix n
    show "?ms n < ?ms (Suc n)" (is "?prev < ?next")
    proof (cases "\<forall>k > ?prev. \<sigma> k = \<sigma> ?prev")
      case True thus ?thesis by (simp add: Let_def)
    next
      case False
      hence "\<exists>k. ?prev < k \<and> \<sigma> k \<noteq> \<sigma> ?prev" by simp
      from this[THEN LeastI_ex]
      have "?prev < (LEAST k. ?prev < k \<and> \<sigma> k \<noteq> \<sigma> ?prev)" ..
      with False show ?thesis by (simp add: Let_def)
    qed
  qed
  hence "strict_mono ?ms"
    unfolding strict_mono_def by (blast intro: lift_Suc_mono_less)
  moreover
  have "\<forall>n k. ?ms n < k \<and> k < ?ms (Suc n) \<longrightarrow> \<sigma> k = \<sigma> (?ms n)"
  proof (clarify)
    fix n k
    assume lo: "?ms n < k" (is "?prev < k")
       and hi: "k < ?ms (Suc n)" (is "k < ?next")
    show "\<sigma> k = \<sigma> ?prev"
    proof (cases "\<forall>k > ?prev. \<sigma> k = \<sigma> ?prev")
      case True
      hence "?next = Suc ?prev" by (simp add: Let_def)
      with lo hi show ?thesis by simp  \<comment> \<open>no room for intermediate index\<close>
    next
      case False
      hence "?next = (LEAST k. ?prev < k \<and> \<sigma> k \<noteq> \<sigma> ?prev)"
        by (auto simp add: Let_def)
      with lo hi show ?thesis by (auto dest: not_less_Least)
    qed
  qed
  ultimately show ?thesis unfolding stutter_sampler_def by blast
qed

text \<open>
  We write \<open>\<natural>\<sigma>\<close> for the sequence \<open>\<sigma>\<close> sampled by the
  maximal stuttering sampler. Also, a sequence is \emph{stutter free}
  if it contains no finite stuttering: whenever two subsequent
  elements are equal then all subsequent elements are the same.
\<close>
definition stutter_reduced ("\<natural>_" [100] 100) where
  "\<natural>\<sigma> = \<sigma> \<circ> (max_stutter_sampler \<sigma>)"

definition stutter_free where
  "stutter_free \<sigma> \<equiv> \<forall>k. \<sigma> (Suc k) = \<sigma> k \<longrightarrow> (\<forall>n>k. \<sigma> n = \<sigma> k)"

lemma stutter_freeI:
  assumes "\<And>k n. \<lbrakk>\<sigma> (Suc k) = \<sigma> k; n>k\<rbrakk> \<Longrightarrow> \<sigma> n = \<sigma> k"
  shows "stutter_free \<sigma>"
  using assms unfolding stutter_free_def by blast

lemma stutter_freeD:
  assumes "stutter_free \<sigma>" and "\<sigma> (Suc k) = \<sigma> k" and "n>k"
  shows "\<sigma> n = \<sigma> k"
  using assms unfolding stutter_free_def by blast

text \<open>
  Any suffix of a stutter free sequence is itself stutter free.
\<close>
lemma stutter_free_suffix:
  assumes sigma: "stutter_free \<sigma>"
  shows "stutter_free (suffix k \<sigma>)"
proof (rule stutter_freeI)
  fix j n
  assume j: "(suffix k \<sigma>) (Suc j) = (suffix k \<sigma>) j" and n: "j < n"
  from j have "\<sigma> (Suc (k+j)) = \<sigma> (k+j)" by simp
  moreover from n have "k+n > k+j" by simp
  ultimately have "\<sigma> (k+n) = \<sigma> (k+j)" by (rule stutter_freeD[OF sigma])
  thus "(suffix k \<sigma>) n = (suffix k \<sigma>) j" by simp
qed

lemma stutter_reduced_0: "(\<natural>\<sigma>) 0 = \<sigma> 0"
  by (simp add: stutter_reduced_def stutter_sampled_0 max_stutter_sampler)

lemma stutter_free_reduced:
  assumes sigma: "stutter_free \<sigma>"
  shows "\<natural>\<sigma> = \<sigma>"
proof -
  {
    fix n
    have "max_stutter_sampler \<sigma> n = n" (is "?ms n = n")
    proof (induct n)
      show "?ms 0 = 0" by simp
    next
      fix n
      assume ih: "?ms n = n"
      show "?ms (Suc n) = Suc n"
      proof (cases "\<sigma> (Suc n) = \<sigma> (?ms n)")
        case True
        with ih have "\<sigma> (Suc n) = \<sigma> n" by simp
        with sigma have "\<forall>k > n. \<sigma> k = \<sigma> n"
          unfolding stutter_free_def by blast
        with ih show ?thesis by (simp add: Let_def)
      next
        case False
        with ih have "(LEAST k. k>n \<and> \<sigma> k \<noteq> \<sigma> (?ms n)) = Suc n"
          by (auto intro: Least_equality)
        with ih False show ?thesis by (simp add: Let_def)
      qed
    qed
  }
  thus ?thesis by (auto simp: stutter_reduced_def)
qed

text \<open>
  Whenever two sequence elements at two consecutive sampling points of the
  maximal stuttering sampler are equal then the sequence stutters infinitely
  from the first sampling point onwards. In particular, \<open>\<natural>\<sigma>\<close> is
  stutter free.
\<close>
lemma max_stutter_sampler_nostuttering:
  assumes stut: "\<sigma> (max_stutter_sampler \<sigma> (Suc k)) = \<sigma> (max_stutter_sampler \<sigma> k)"
      and n: "n > max_stutter_sampler \<sigma> k" (is "_ > ?ms k")
  shows "\<sigma> n = \<sigma> (?ms k)"
proof (rule ccontr)
  assume contr: "\<not> ?thesis"
  with n have "?ms k < n \<and> \<sigma> n \<noteq> \<sigma> (?ms k)" (is "?diff n") ..
  hence "?diff (LEAST n. ?diff n)" by (rule LeastI)
  with contr have "\<sigma> (?ms (Suc k)) \<noteq> \<sigma> (?ms k)" by (auto simp add: Let_def)
  from this stut show "False" ..
qed

lemma stutter_reduced_stutter_free: "stutter_free (\<natural>\<sigma>)"
proof (rule stutter_freeI)
  fix k n
  assume k: "(\<natural>\<sigma>) (Suc k) = (\<natural>\<sigma>) k" and n: "k < n"
  from n have "max_stutter_sampler \<sigma> k < max_stutter_sampler \<sigma> n"
    using max_stutter_sampler[THEN stutter_sampler_mono, THEN strict_monoD]
    by blast
  with k show "(\<natural>\<sigma>) n = (\<natural>\<sigma>) k"
    unfolding stutter_reduced_def
    by (auto elim: max_stutter_sampler_nostuttering
             simp del: max_stutter_sampler.simps)
qed

lemma stutter_reduced_suffix: "\<natural> (suffix k (\<natural>\<sigma>)) = suffix k (\<natural>\<sigma>)"
proof (rule stutter_free_reduced)
  have "stutter_free (\<natural>\<sigma>)" by (rule stutter_reduced_stutter_free)
  thus "stutter_free (suffix k (\<natural>\<sigma>))" by (rule stutter_free_suffix)
qed

lemma stutter_reduced_reduced: "\<natural>\<natural>\<sigma> = \<natural>\<sigma>"
  by (insert stutter_reduced_suffix[of 0 "\<sigma>", simplified])

text \<open>
  One can define a partial order on sampling functions for a given sequence
  \<open>\<sigma>\<close> by saying that function \<open>g\<close> is better than function \<open>f\<close>
  if the reduced sequence induced by \<open>f\<close> can be further reduced to obtain
  the reduced sequence corresponding to \<open>g\<close>, i.e. if there exists a
  stuttering sampling function \<open>h\<close> for the reduced sequence \<open>\<sigma> \<circ> f\<close>
  such that \<open>\<sigma> \<circ> f \<circ> h = \<sigma> \<circ> g\<close>. (Note that \<open>f \<circ> h\<close> is indeed a stuttering
  sampling function for \<open>\<sigma>\<close>, by theorem \<open>stutter_sampler_comp\<close>.)

  We do not formalize this notion but prove that \<open>max_stutter_sampler \<sigma>\<close>
  is the best sampling function according to this order.
\<close>

theorem sample_max_sample:
  assumes f: "stutter_sampler f \<sigma>"
  shows "\<natural>(\<sigma> \<circ> f) = \<natural>\<sigma>"
proof -
  let ?mss = "max_stutter_sampler \<sigma>"
  let ?mssf = "max_stutter_sampler (\<sigma> \<circ> f)"
  from f have mssf: "stutter_sampler (f \<circ> ?mssf) \<sigma>"
    by (blast intro: stutter_sampler_comp max_stutter_sampler)
  txt \<open>
    The following is the core invariant of the proof: the sampling functions
    \<open>max_stutter_sampler \<sigma>\<close> and \<open>f \<circ> (max_stutter_sampler (\<sigma> \<circ> f))\<close>
    work in lock-step (i.e., sample the same points), except if \<open>\<sigma>\<close> ends
    in infinite stuttering, at which point function \<open>f\<close> may make larger
    steps than the maximal sampling functions.
\<close>
  {
    fix k
    have "  ?mss k = f (?mssf k)
          \<or> ?mss k \<le> f (?mssf k) \<and> (\<forall>n \<ge> ?mss k. \<sigma> (?mss k) = \<sigma> n)"
          (is "?P k" is "?A k \<or> ?B k")
    proof (induct k)
      from f mssf have "?mss 0 = f (?mssf 0)"
        by (simp add: max_stutter_sampler stutter_sampler_0)
      thus "?P 0" ..
    next
      fix k
      assume ih: "?P k"
      have b: "?B k \<longrightarrow> ?B (Suc k)"
      proof
        assume 0: "?B k" hence 1: "?mss k \<le> f (?mssf k)" ..
        (* NB: For some reason "... hence 1: ... and 2: ..." cannot be proved *)
        from 0 have 2: "\<forall>n \<ge> ?mss k. \<sigma> (?mss k) = \<sigma> n" ..
        hence "\<forall>n > ?mss k. \<sigma> (?mss k) = \<sigma> n" by auto
        hence "\<forall>n > ?mss k. \<sigma> n = \<sigma> (?mss k)" by auto
        hence 3: "?mss (Suc k) = Suc (?mss k)" by (simp add: Let_def)
        with 2 have "\<sigma> (?mss k) = \<sigma> (?mss (Suc k))"
          by (auto simp del: max_stutter_sampler.simps)
        from sym[OF this] 2 3 have "\<forall>n \<ge> ?mss (Suc k). \<sigma> (?mss (Suc k)) = \<sigma> n"
          by (auto simp del: max_stutter_sampler.simps)
        moreover
        from mssf[THEN stutter_sampler_mono, THEN strict_monoD]
        have "f (?mssf k) < f (?mssf (Suc k))"
          by (simp del: max_stutter_sampler.simps)
        with 1 3 have "?mss (Suc k) \<le> f (?mssf (Suc k))"
          by (simp del: max_stutter_sampler.simps)
        ultimately show "?B (Suc k)" by blast
      qed
      from ih show "?P (Suc k)"
      proof
        assume a: "?A k"
        show ?thesis
        proof (cases "\<forall>n > ?mss k. \<sigma> n = \<sigma> (?mss k)")
          case True
          hence "\<forall>n \<ge> ?mss k. \<sigma> (?mss k) = \<sigma> n" by (auto simp: le_less)
          with a have "?B k" by simp
          with b show ?thesis by (simp del: max_stutter_sampler.simps)
        next
          case False
          hence diff: "\<sigma> (?mss (Suc k)) \<noteq> \<sigma> (?mss k)"
            by (blast dest: max_stutter_sampler_nostuttering)
          have "?A (Suc k)"
          proof (rule antisym)
            show "f (?mssf (Suc k)) \<le> ?mss (Suc k)"
            proof (rule ccontr)
              assume "\<not> ?thesis"
              hence contr: "?mss (Suc k) < f (?mssf (Suc k))" by simp
              from mssf have "\<sigma> (?mss (Suc k)) = \<sigma> ((f \<circ> ?mssf) k)"
              proof (rule stutter_sampler_between)
                from max_stutter_sampler[of "\<sigma>", THEN stutter_sampler_mono]
                have "?mss k < ?mss (Suc k)" by (rule strict_monoD) simp
                with a show "(f \<circ> ?mssf) k \<le> ?mss (Suc k)"
                  by (simp add: o_def del: max_stutter_sampler.simps)
              next
                from contr show "?mss (Suc k) < (f \<circ> ?mssf) (Suc k)" by simp
              qed
              with a have "\<sigma> (?mss (Suc k)) = \<sigma> (?mss k)"
                by (simp add: o_def del: max_stutter_sampler.simps)
              with diff show "False" ..
            qed
          next
            have "\<exists>m > ?mssf k. f m = ?mss (Suc k)"
            proof (rule ccontr)
              assume "\<not> ?thesis"
              hence contr: "\<forall>i. f ((?mssf k) + Suc i) \<noteq> ?mss (Suc k)" by simp
              {
                fix i
                have "f (?mssf k + i) < ?mss (Suc k)" (is "?F i")
                proof (induct i)
                  from a have "f (?mssf k + 0) = ?mss k" by (simp add: o_def)
                  also from max_stutter_sampler[of "\<sigma>", THEN stutter_sampler_mono]
                       have "... < ?mss (Suc k)"
                         by (rule strict_monoD) simp
                  finally show "?F 0" .
                next
                  fix i
                  assume ih: "?F i"
                  show "?F (Suc i)"
                  proof (rule ccontr)
                    assume "\<not> ?thesis"
                    then have "?mss (Suc k) \<le> f (?mssf k + Suc i)"
                      by (simp add: o_def)
                    moreover from contr have "f (?mssf k + Suc i) \<noteq> ?mss (Suc k)"
                      by blast
                    ultimately have i: "?mss (Suc k) < f (?mssf k + Suc i)"
                      by (simp add: less_le)
                    from f have "\<sigma> (?mss (Suc k)) = \<sigma> (f (?mssf k + i))"
                    proof (rule stutter_sampler_between)
                      from ih show "f (?mssf k + i) \<le> ?mss (Suc k)"
                        by (simp add: o_def)
                    next
                      from i show "?mss (Suc k) < f (Suc (?mssf k + i))"
                        by simp
                    qed
                    also from max_stutter_sampler have "... = \<sigma> (?mss k)"
                    proof (rule stutter_sampler_between)
                      from f[THEN stutter_sampler_mono, THEN strict_mono_mono]
                      have "f (?mssf k) \<le> f (?mssf k + i)" by (rule monoD) simp
                      with a show "?mss k \<le> f (?mssf k + i)" by (simp add: o_def)
                    qed (rule ih)
                    also note diff
                    finally show "False" by simp
                  qed
                qed
              } note bounded = this
              from f[THEN stutter_sampler_mono]
              have "strict_mono (\<lambda>i. f (?mssf k + i))"
                by (auto simp: strict_mono_def)
              then obtain i where i: "?mss (Suc k) < f (?mssf k + i)"
                by (blast dest: strict_mono_exceeds)
              from bounded have "f (?mssf k + i) < ?mss (Suc k)" .
              with i show "False" by (simp del: max_stutter_sampler.simps)
            qed
            then obtain m where m: "m > ?mssf k" and m': "f m = ?mss (Suc k)"
              by blast
            show "?mss (Suc k) \<le> f (?mssf (Suc k))"
            proof (rule ccontr)
              assume "\<not> ?thesis"
              hence contr: "f (?mssf (Suc k)) < ?mss (Suc k)" by simp
              from mssf[THEN stutter_sampler_mono]
              have "(f \<circ> ?mssf) k < (f \<circ> ?mssf) (Suc k)"
                by (rule strict_monoD) simp
              with a have "?mss k \<le> f (?mssf (Suc k))"
                by (simp add: o_def)
              from this contr have "\<sigma> (f (?mssf (Suc k))) = \<sigma> (?mss k)"
                by (rule stutter_sampler_between[OF max_stutter_sampler])
              with a have stut: "(\<sigma> \<circ> f) (?mssf (Suc k)) = (\<sigma> \<circ> f) (?mssf k)"
                by (simp add: o_def)
              from this m have "(\<sigma> \<circ> f) m = (\<sigma> \<circ> f) (?mssf k)"
                by (blast intro: max_stutter_sampler_nostuttering)
              with diff m' a show "False"
                by (simp add: o_def)
            qed
          qed
          thus ?thesis ..
        qed
      next
        assume "?B k" with b show ?thesis by (simp del: max_stutter_sampler.simps)
      qed
    qed
  }
  hence "\<natural>\<sigma> = \<natural>(\<sigma> \<circ> f)" unfolding stutter_reduced_def by force
  thus ?thesis by (rule sym)
qed

end  (* theory Samplers *)


theory Induccion
imports Main
begin

(* HINT FOR ONLINE DEMO
   Start your first proof attempt with
   inversaIaux xs [] = rev xs
   then generalize by introducing ys, and finally quantify over ys.
   Each generalization should be motivated by the previous failed
   proof attempt.
*)

section {* Definiciones de la función inversa *}

text {* (inversa xs) es la inversa de xs. Por ejemplo,
     inversa [a,b,c] = [c,b,a]
*}
fun inversa :: "'a list \<Rightarrow> 'a list"
where
  "inversa []     = []"
| "inversa (x#xs) = inversa xs @ [x]"

value "inversa [a,b,c]"
lemma "inversa [a,b,c] = [c,b,a]" by simp

text {* (inversaIaux xs) es la inversa de xs calculada de manera
  iterativa. Por ejemplo,
     inversaIaux [a,b,c] = [c,b,a]
*}
fun inversaIaux :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "inversaIaux [] ys     = ys"
| "inversaIaux (x#xs) ys = inversaIaux xs (x#ys)"

definition inversaI :: "'a list \<Rightarrow> 'a list"
where
  "inversaI xs = inversaIaux xs []"

value "inversaI [a,b,c]"
lemma "inversaI [a,b,c] = [c,b,a]" by (simp add: inversaI_def)

section {* Equivalencia de las definiciones de inversa *}

text {* El objetivo de esta sección es demostrar la equivalencia de las
  dos definiciones; es decir,
     equiv_inversa: "inversaI xs = inversa xs"

  A la vista de la definición de inversaI, se observa que la propiedad
  anterior es un corolario de
     equiv_inversa_aux: "inversaIaux xs [] = inversa xs"

  Vamos a demostrar equiv_inversa_aux usando heurísticas de inducción.
*}

text {* 1\<ordmasculine> intento de prueba de equiv_inversa_aux *}
lemma equiv_inversa_aux_1:
  "inversaIaux xs [] = inversa xs"
apply (induction xs)
apply auto
oops

text {* Se observa que se queda sin demostrar el objetivo
     inversaIaux xs [] = inversa xs \<Longrightarrow>
     inversaIaux xs [a] = inversa xs @ [a]

  La causa es que el enunciado era demasiado específico al tener como
  segundo argumento la lista vacía. Lo generalizamos a
     equiv_inversa_aux_2: inversaIaux xs ys = inversa xs @ ys
*}

text {* 2\<ordmasculine> intento de prueba de equiv_inversa_aux *}
lemma equiv_inversa_aux_2:
  "inversaIaux xs ys = inversa xs @ ys"
apply (induction xs)
apply auto
oops

text {* Se observa que se queda sin demostrar el objetivo
     inversaIaux xs ys = inversa xs @ ys \<Longrightarrow>
     inversaIaux xs (a # ys) = inversa xs @ a # ys

  La causa es que aunque el segundo argumento es la variable ys, no se
  ha tenido en cuenta que su valor varía. Por tanto, hay que declararla
  como arbitraria.
*}

text {* Prueba de equiv_inversa_aux *}
lemma equiv_inversa_aux:
  "inversaIaux xs ys = inversa xs @ ys"
apply (induction xs arbitrary: ys)
apply auto
done

text {* Prueba de equiv_inversa *}
corollary equiv_inversa:
  "inversaI xs = inversa xs"
apply (simp add: inversaI_def equiv_inversa_aux)
done

end


section "N-Subsets"

theory n_Subsets
  imports
    Common_Lemmas
    "HOL-Combinatorics.Multiset_Permutations"
    Filter_Bool_List
begin

subsection"Definition"

definition n_subsets :: "'a set \<Rightarrow> nat \<Rightarrow> 'a set set" where
  "n_subsets A n = {B. B \<subseteq> A \<and> card B = n}"

text "Cardinality: \<open>binomial (card A) n\<close>"
text "Example: \<open>n_subsets {0,1,2} 2 = {{0,1}, {0,2}, {1,2}}\<close>"

subsection"Algorithm"

fun n_bool_lists :: "nat \<Rightarrow> nat \<Rightarrow> bool list list" where
  "n_bool_lists n 0 = (if n > 0 then [] else [[]])"
| "n_bool_lists n (Suc x) = (if n = 0 then [replicate (Suc x) False]
    else if n = Suc x then [replicate (Suc x) True]
    else if n > x then []
    else [False#xs . xs \<leftarrow> n_bool_lists n x] @ [True#xs . xs \<leftarrow> n_bool_lists (n-1) x])"

fun n_subset_enum :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list list" where
  "n_subset_enum xs n = [(filter_bool_list bs xs) . bs \<leftarrow> (n_bool_lists n (length xs))]"

subsection"Verification"

subsubsection"n-bool-lists"

lemma n_bool_lists_True_count: "xs \<in> set (n_bool_lists n x) \<Longrightarrow> count_list xs True = n"
 by (induct x arbitrary: xs n) (auto split: if_splits simp: count_list_replicate)

lemma n_bool_lists_length: "xs \<in> set (n_bool_lists n x) \<Longrightarrow> length xs = x"
  by (induct x arbitrary: xs n) (auto split: if_splits)

lemma n_bool_lists_distinct: "distinct (n_bool_lists n x)"
proof(induct x arbitrary: n)
  case 0
  then show ?case by simp
next
  case (Suc x)
  then show ?case
    using distinct_map by fastforce
qed

lemma replicate_True_not_False: "count_list ys True = 0 \<longleftrightarrow> ys = replicate (length ys) False"
  using count_list_zero_not_elem count_list_full_elem count_list_length_replicate by fastforce

lemma n_bool_lists_correct_aux:
  "length xs = x \<Longrightarrow> count_list xs True = n \<Longrightarrow> xs \<in> set (n_bool_lists n x)"
proof(induct x arbitrary: n xs)
  case 0
  then show ?case by auto
next
  case (Suc x)
   show ?case proof(cases "n = 0")
    case True
    then show ?thesis
      using Suc True replicate_True_not_False by auto
  next
    case c1: False
    then show ?thesis proof(cases "n = Suc x")
      case True
      then have "xs = True # replicate x True "
        using Suc.prems count_list_length_replicate replicate_Suc by metis
      then show ?thesis
        using True by simp
    next
      case c2: False
      then show ?thesis proof(cases "n > x")
        case True
        then have "xs = []"
          using Suc.prems c2 count_le_length by (metis Suc_lessI linorder_not_less)
        then show ?thesis
          using Suc by auto
      next
        case c3: False
        then show ?thesis proof (cases xs)
          case Nil
          then show ?thesis
            using Suc.prems(1) by auto
        next
          case (Cons y ys)
          then show ?thesis proof (cases y)
            case True
            then show ?thesis using Suc c1 c2 c3 Cons
              by simp
          next
            case False
            then show ?thesis using Suc c1 c2 c3 Cons
              by simp
          qed
        qed
      qed
    qed
  qed
qed

lemma n_bool_lists_correct: "set (n_bool_lists n x) = {xs. length xs = x \<and> count_list xs True = n}"
proof(standard)
  show "set (n_bool_lists n x) \<subseteq> {xs. length xs = x \<and> count_list xs True = n}"
  proof(cases x)
    case 0
    then show ?thesis by simp
  next
    case (Suc x)
    then show ?thesis using n_bool_lists_True_count n_bool_lists_length
      by blast
  qed
next
  show "{xs. length xs = x \<and> count_list xs True = n} \<subseteq> set (n_bool_lists n x)"
    using n_bool_lists_correct_aux by auto
qed

subsubsection"Correctness"

lemma n_subset_enum_correct_aux1:
  "\<lbrakk>distinct xs; length ys = length xs\<rbrakk>
    \<Longrightarrow> set (filter_bool_list ys xs) \<in> n_subsets (set xs) (count_list ys True)"
  unfolding n_subsets_def
  by (auto simp: filter_bool_list_card filter_bool_list_elem)

lemma n_subset_enum_correct_aux2:
  "distinct xs \<Longrightarrow> n_subsets (set xs) n \<subseteq> set (map set (n_subset_enum xs n))"
  unfolding n_subsets_def
  by (auto simp: n_bool_lists_correct image_def filter_bool_list_exist_length_card_True)

theorem n_subset_enum_correct:
  "distinct xs \<Longrightarrow> set (map set (n_subset_enum xs n)) = n_subsets (set xs) n"
proof(standard)
  show "distinct xs \<Longrightarrow> set (map set (n_subset_enum xs n)) \<subseteq> n_subsets (set xs) n"
    using n_subset_enum_correct_aux1 n_bool_lists_correct by auto
next
  show "distinct xs \<Longrightarrow> n_subsets (set xs) n \<subseteq> set (map set (n_subset_enum xs n))"
    using n_subset_enum_correct_aux2 by auto
qed

subsubsection"Distinctness"

theorem n_subset_enum_distinct_elem:
  "distinct xs \<Longrightarrow> ys \<in> set (n_subset_enum xs n) \<Longrightarrow> distinct ys"
  by(cases "length xs < n") (auto simp: filter_bool_list_distinct)

theorem n_subset_enum_distinct: "distinct xs \<Longrightarrow> distinct (n_subset_enum xs n)"
  by(auto simp: distinct_map n_bool_lists_distinct inj_on_def filter_bool_list_inj_aux n_bool_lists_length)

subsubsection"Cardinality"

text \<open>Cardinality of @{term "n_subsets"} is already shown in @{thm [source] "Binomial.n_subsets"}.\<close>

subsection "Alternative using Multiset permutations"

text "It would be possible to define \<open>n_bool_lists\<close> using \<open>permutations_of_multiset\<close> with the
following definition:"

fun n_bool_lists2 :: "nat \<Rightarrow> nat \<Rightarrow> bool list set" where
  "n_bool_lists2 n x = (if n > x then {}
    else permutations_of_multiset (mset (replicate n True @ replicate (x-n) False)))"

subsection"\<open>mset_count\<close>"

text"Correspondence between \<open>count_list\<close> and \<open>count (mset xs)\<close> and transfer of a few results
for multisets to lists."

lemma count_list_count_mset: "count_list ys T = n \<Longrightarrow> count (mset ys) T = n"
  by(induct ys arbitrary: n) auto

lemma count_mset_count_list: "count (mset ys) T = n \<Longrightarrow> count_list ys T = n"
  by(induct ys arbitrary: n) auto

lemma count_mset_replicate_aux1:
  "\<lbrakk>\<not> x < n; mset ys = mset (replicate n True) + mset (replicate (x - n) False)\<rbrakk>
    \<Longrightarrow> count (mset ys) True = n"
  by (auto simp: count_list_count_mset count_mset)

lemma  count_mset_replicate_aux2:
  assumes "\<not> length xs < count_list xs True"
  shows "mset xs = mset (replicate (count_list xs True) True) + mset (replicate (length xs - count_list xs True) False)"
proof -
  have "count_list xs B =
         count_list (replicate (count_list xs True) True) B + count_list (replicate (length xs - count_list xs True) False) B"
    for B
  proof(cases B)
    case True
    then show ?thesis
      by (simp add: count_list_replicate)
  next
    case False

    have "count_list xs False = count_list (replicate (length xs - count_list xs True) False) False"
      by (metis count_list_True_False count_list_replicate diff_add_inverse)

    from this False show ?thesis
      using assms by auto
  qed

  then have "count (mset xs) B =
         count (mset (replicate (count_list xs True) True) + mset (replicate (length xs - count_list xs True) False)) B"
    for B
    by (metis count_mset_count_list count_union)

  then show "mset xs = mset (replicate (count_list xs True) True) + mset (replicate (length xs - count_list xs True) False)"
    using multiset_eqI by blast
qed

lemma n_bool_lists2_correct: "set (n_bool_lists n x) = n_bool_lists2 n x"
proof(standard)
  have "\<lbrakk>\<not> length ys < count_list ys True; x = length ys; n = count_list ys True\<rbrakk>
          \<Longrightarrow> ys \<in> permutations_of_multiset
                     (mset (replicate (count_list ys True) True) + mset (replicate (length ys - count_list ys True) False))"
          for ys
    using count_mset_replicate_aux2 permutations_of_multisetI by blast

  then show "set (n_bool_lists n x) \<subseteq> n_bool_lists2 n x"
    unfolding n_bool_lists_correct
    by (auto simp: count_le_length leD)
next
  have "\<lbrakk>\<not> x < n; ys \<in> permutations_of_multiset (mset (replicate n True) + mset (replicate (x - n) False))\<rbrakk>
          \<Longrightarrow> count (mset ys) True = n " for ys
    using count_mset_replicate_aux1 permutations_of_multisetD by blast
  then have "\<lbrakk>\<not> x < n; ys \<in> permutations_of_multiset (mset (replicate n True) + mset (replicate (x - n) False))\<rbrakk>
          \<Longrightarrow>  count_list ys True = n " for ys
    by (simp add: count_list_count_mset)
  then show "n_bool_lists2 n x \<subseteq> set (n_bool_lists n x)" unfolding n_bool_lists_correct
    by (auto simp: length_finite_permutations_of_multiset)
qed

end


(*<*)
theory IHOML_Examples
imports IHOML
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3, atoms e = a b c d]
sledgehammer_params[verbose=true]
(*>*)

section \<open>Textbook Examples\<close>

text\<open>  In this section we provide further evidence that our embedded logic works as intended by proving the examples discussed in the book.
 In many cases, we consider further theorems which we derived from the original ones. We were able to confirm that all results
 (proofs or counterexamples) agree with Fitting's claims. \<close>

subsection \<open>Modal Logic - Syntax and Semantics (Chapter 7)\<close>

text\<open> Reminder: We call a term \emph{relativized} if it is of the form \<open>\<down>\<alpha>\<close>
(i.e. an intensional term preceded by the \emph{extension-of} operator), otherwise it is \emph{non-relativized}.
Relativized terms are non-rigid and non-relativized terms are rigid. \<close>

subsubsection \<open>Considerations Regarding \<open>\<beta>\<eta>\<close>-redex  (p. 94)\<close>

text\<open>  \<open>\<beta>\<eta>\<close>-redex is valid for non-relativized (intensional or extensional) terms:  \<close>
lemma "\<lfloor>((\<lambda>\<alpha>. \<phi> \<alpha>)  (\<tau>::\<up>\<zero>)) \<^bold>\<leftrightarrow> (\<phi>  \<tau>)\<rfloor>" by simp
lemma "\<lfloor>((\<lambda>\<alpha>. \<phi> \<alpha>)  (\<tau>::\<zero>)) \<^bold>\<leftrightarrow> (\<phi>  \<tau>)\<rfloor>" by simp
lemma "\<lfloor>((\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) (\<tau>::\<up>\<zero>)) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<tau>)\<rfloor>" by simp
lemma "\<lfloor>((\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) (\<tau>::\<zero>)) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<tau>)\<rfloor>" by simp
text\<open>  \<open>\<beta>\<eta>\<close>-redex is valid for relativized terms as long as no modal operators occur inside the predicate abstract:  \<close>
lemma "\<lfloor>((\<lambda>\<alpha>. \<phi> \<alpha>) \<downharpoonleft>(\<tau>::\<up>\<zero>)) \<^bold>\<leftrightarrow> (\<phi> \<downharpoonleft>\<tau>)\<rfloor>" by simp
text\<open>  \<open>\<beta>\<eta>\<close>-redex is non-valid for relativized terms when modal operators are present:  \<close>
lemma "\<lfloor>((\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) \<downharpoonleft>(\<tau>::\<up>\<zero>)) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<downharpoonleft>\<tau>)\<rfloor>" nitpick oops   \<comment> \<open>countersatisfiable\<close>

subsubsection \<open>Equality Axioms (Subsection 1.1)\<close>

text\<open>  Example 9.1:  \<close>
lemma "\<lfloor>((\<lambda>X. \<^bold>\<box>(X \<downharpoonleft>(p::\<up>\<zero>))) \<^bold>\<down>(\<lambda>x. \<^bold>\<diamond>(\<lambda>z. z \<^bold>\<approx> x) \<downharpoonleft>p))\<rfloor>"
  by auto \<comment> \<open>using normal equality\<close>
lemma "\<lfloor>((\<lambda>X. \<^bold>\<box>(X \<downharpoonleft>(p::\<up>\<zero>))) \<^bold>\<down>(\<lambda>x. \<^bold>\<diamond>(\<lambda>z. z \<^bold>\<approx>\<^sup>L x) \<downharpoonleft>p))\<rfloor>"
  by auto \<comment> \<open>using Leibniz equality\<close>
lemma "\<lfloor>((\<lambda>X. \<^bold>\<box>(X  (p::\<up>\<zero>))) \<^bold>\<down>(\<lambda>x. \<^bold>\<diamond>(\<lambda>z. z \<^bold>\<approx>\<^sup>C x) p))\<rfloor>"
  by simp  \<comment> \<open>using equality as defined for individual concepts\<close>

subsubsection \<open>Extensionality (Subsection 1.2)\<close>

text\<open>  In Fitting's book (p. 118), extensionality is assumed (globally) for extensional terms. While Fitting introduces
the following extensionality principles as axioms, they are already implicitly valid in Isabelle/HOL:  \<close>

text\<open>  \emph{De re} is equivalent to \emph{de dicto} for non-relativized (extensional or intensional) terms:  \<close>
lemma "\<lfloor>\<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) (\<tau>::\<zero>))   \<^bold>\<leftrightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<tau>)\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) (\<tau>::\<up>\<zero>))  \<^bold>\<leftrightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<tau>)\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) (\<tau>::\<langle>\<zero>\<rangle>))  \<^bold>\<leftrightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<tau>)\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) (\<tau>::\<up>\<langle>\<zero>\<rangle>)) \<^bold>\<leftrightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<tau>)\<rfloor>" by simp

text\<open>  \emph{De re} is not equivalent to \emph{de dicto} for relativized terms:  \<close>
lemma "\<lfloor>\<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<downharpoonleft>(\<tau>::\<up>\<zero>)) \<^bold>\<leftrightarrow> \<^bold>\<box>( (\<lambda>\<beta>. (\<alpha> \<beta>)) \<downharpoonleft>\<tau>)\<rfloor>"
  nitpick[card 't=2, card i=2] oops \<comment> \<open>countersatisfiable\<close>
lemma "\<lfloor>\<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<^bold>\<down>(\<tau>::\<up>\<langle>\<zero>\<rangle>)) \<^bold>\<leftrightarrow> \<^bold>\<box>( (\<lambda>\<beta>. (\<alpha> \<beta>)) \<^bold>\<down>\<tau>)\<rfloor>"
  nitpick[card 't=1, card i=2] oops \<comment> \<open>countersatisfiable\<close>

text\<open>  Proposition 9.6 - If we can prove one side of the equivalence, then we can prove the other (p. 120):  \<close>
abbreviation deDictoImplDeRe::"\<up>\<zero>\<Rightarrow>io"
  where "deDictoImplDeRe \<tau> \<equiv> \<^bold>\<forall>\<alpha>. \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<downharpoonleft>\<tau>) \<^bold>\<rightarrow> ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<downharpoonleft>\<tau>)"
abbreviation deReImplDeDicto::"\<up>\<zero>\<Rightarrow>io"
  where "deReImplDeDicto \<tau> \<equiv> \<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<downharpoonleft>\<tau>) \<^bold>\<rightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<downharpoonleft>\<tau>)"
abbreviation deReEquDeDicto::"\<up>\<zero>\<Rightarrow>io"
  where "deReEquDeDicto \<tau> \<equiv> \<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<downharpoonleft>\<tau>) \<^bold>\<leftrightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<downharpoonleft>\<tau>)"
text\<open> \bigbreak \<close>
abbreviation deDictoImplDeRe_pred::"('t\<Rightarrow>io)\<Rightarrow>io"
  where "deDictoImplDeRe_pred \<tau> \<equiv> \<^bold>\<forall>\<alpha>. \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<^bold>\<down>\<tau>) \<^bold>\<rightarrow> ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<^bold>\<down>\<tau>)"
abbreviation deReImplDeDicto_pred::"('t\<Rightarrow>io)\<Rightarrow>io"
  where "deReImplDeDicto_pred \<tau> \<equiv> \<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<^bold>\<down>\<tau>) \<^bold>\<rightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<^bold>\<down>\<tau>)"
abbreviation deReEquDeDicto_pred::"('t\<Rightarrow>io)\<Rightarrow>io"
  where "deReEquDeDicto_pred \<tau> \<equiv> \<^bold>\<forall>\<alpha>. ((\<lambda>\<beta>. \<^bold>\<box>(\<alpha> \<beta>)) \<^bold>\<down>\<tau>) \<^bold>\<leftrightarrow> \<^bold>\<box>((\<lambda>\<beta>. (\<alpha> \<beta>)) \<^bold>\<down>\<tau>)"

text\<open>  We can prove local consequence: \<close>
lemma AimpB: "\<lfloor>deReImplDeDicto (\<tau>::\<up>\<zero>) \<^bold>\<rightarrow> deDictoImplDeRe \<tau>\<rfloor>"
  by force \<comment> \<open>for individuals\<close>
lemma AimpB_p: "\<lfloor>deReImplDeDicto_pred (\<tau>::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<rightarrow> deDictoImplDeRe_pred \<tau>\<rfloor>"
  by force \<comment> \<open>for predicates\<close>

text\<open>  And global consequence follows directly (since local consequence implies global consequence, as shown before): \<close>
lemma "\<lfloor>deReImplDeDicto (\<tau>::\<up>\<zero>)\<rfloor> \<longrightarrow> \<lfloor>deDictoImplDeRe \<tau>\<rfloor>"
  using AimpB by (rule localImpGlobalCons) \<comment> \<open>for individuals\<close>
lemma "\<lfloor>deReImplDeDicto_pred (\<tau>::\<up>\<langle>\<zero>\<rangle>)\<rfloor> \<longrightarrow> \<lfloor>deDictoImplDeRe_pred \<tau>\<rfloor>"
  using AimpB_p by (rule localImpGlobalCons) \<comment> \<open>for predicates\<close>

subsubsection \<open>Rigidity (Subsection 3)\<close>

text\<open>  (Local) rigidity for intensional individuals:  \<close>
abbreviation rigidIndiv::"\<up>\<langle>\<up>\<zero>\<rangle>" where
  "rigidIndiv \<tau> \<equiv> (\<lambda>\<beta>. \<^bold>\<box>((\<lambda>z. \<beta> \<^bold>\<approx> z) \<downharpoonleft>\<tau>)) \<downharpoonleft>\<tau>"
text\<open>  (Local) rigidity for intensional predicates:  \<close>
abbreviation rigidPred::"('t\<Rightarrow>io)\<Rightarrow>io" where
  "rigidPred \<tau> \<equiv> (\<lambda>\<beta>. \<^bold>\<box>((\<lambda>z. \<beta> \<^bold>\<approx> z) \<^bold>\<down>\<tau>)) \<^bold>\<down>\<tau>"

text\<open>  Proposition 9.8 - An intensional term is rigid if and only if the \emph{de re/de dicto} distinction vanishes.
Note that we can prove this theorem for local consequence (global consequence follows directly).  \<close>
lemma "\<lfloor>rigidIndiv (\<tau>::\<up>\<zero>) \<^bold>\<rightarrow> deReEquDeDicto \<tau>\<rfloor>" by simp
lemma "\<lfloor>deReImplDeDicto (\<tau>::\<up>\<zero>) \<^bold>\<rightarrow> rigidIndiv \<tau>\<rfloor>" by auto
lemma "\<lfloor>rigidPred (\<tau>::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<rightarrow> deReEquDeDicto_pred \<tau>\<rfloor>" by simp
lemma "\<lfloor>deReImplDeDicto_pred (\<tau>::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<rightarrow> rigidPred \<tau>\<rfloor>" by auto

subsubsection \<open>Stability Conditions (Subsection 4)\<close>

axiomatization where
 S5: "equivalence aRel" \<comment> \<open>using Sahlqvist correspondence for improved performance\<close>

text\<open>  Definition 9.10 - Stability conditions come in pairs:  \<close>
abbreviation stabilityA::"('t\<Rightarrow>io)\<Rightarrow>io" where "stabilityA \<tau> \<equiv> \<^bold>\<forall>\<alpha>. (\<tau> \<alpha>) \<^bold>\<rightarrow> \<^bold>\<box>(\<tau> \<alpha>)"
abbreviation stabilityB::"('t\<Rightarrow>io)\<Rightarrow>io" where "stabilityB \<tau> \<equiv> \<^bold>\<forall>\<alpha>. \<^bold>\<diamond>(\<tau> \<alpha>) \<^bold>\<rightarrow> (\<tau> \<alpha>)"

text\<open>  Proposition 9.10 - In an \emph{S5} modal logic both stability conditions are equivalent. \<close>
text\<open>  The last proposition holds for global consequence: \<close>
lemma "\<lfloor>stabilityA (\<tau>::\<up>\<langle>\<zero>\<rangle>)\<rfloor> \<longrightarrow> \<lfloor>stabilityB \<tau>\<rfloor>" using S5 by blast
lemma "\<lfloor>stabilityB (\<tau>::\<up>\<langle>\<zero>\<rangle>)\<rfloor> \<longrightarrow> \<lfloor>stabilityA \<tau>\<rfloor>" using S5 by blast
text\<open>  But it does not hold for local consequence: \<close>
lemma "\<lfloor>stabilityA (\<tau>::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<rightarrow> stabilityB \<tau>\<rfloor>"
  nitpick[card 't=1, card i=2] oops \<comment> \<open>countersatisfiable\<close>
lemma "\<lfloor>stabilityB (\<tau>::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<rightarrow> stabilityA \<tau>\<rfloor>"
  nitpick[card 't=1, card i=2] oops \<comment> \<open>countersatisfiable\<close>

text\<open>  Theorem 9.11 - A term is rigid if and only if it satisfies the stability conditions. Note that
 we can prove this theorem for local consequence (global consequence follows directly).  \<close>
theorem "\<lfloor>rigidPred (\<tau>::\<up>\<langle>\<zero>\<rangle>) \<^bold>\<leftrightarrow> (stabilityA \<tau> \<^bold>\<and> stabilityB \<tau>)\<rfloor>" by meson
theorem "\<lfloor>rigidPred (\<tau>::\<up>\<langle>\<up>\<zero>\<rangle>) \<^bold>\<leftrightarrow> (stabilityA \<tau> \<^bold>\<and> stabilityB \<tau>)\<rfloor>" by meson
theorem "\<lfloor>rigidPred (\<tau>::\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>) \<^bold>\<leftrightarrow> (stabilityA \<tau> \<^bold>\<and> stabilityB \<tau>)\<rfloor>" by meson
text\<open>  \pagebreak \<close>
(*<*)
end
(*>*)


theory Height
  imports "../Nominal"
begin

text \<open>
  A small problem suggested by D. Wang. It shows how
  the height of a lambda-terms behaves under substitution.
\<close>

atom_decl name

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text \<open>Definition of the height-function on lambda-terms.\<close>

nominal_primrec
  height :: "lam \<Rightarrow> int"
where
  "height (Var x) = 1"
| "height (App t1 t2) = (max (height t1) (height t2)) + 1"
| "height (Lam [a].t) = (height t) + 1"
  apply(finite_guess add: perm_int_def)+
  apply(rule TrueI)+
  apply(simp add: fresh_int)
  apply(fresh_guess add: perm_int_def)+
  done

text \<open>Definition of capture-avoiding substitution.\<close>

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

text\<open>The next lemma is needed in the Var-case of the theorem below.\<close>

lemma height_ge_one:
  shows "1 \<le> (height e)"
by (nominal_induct e rule: lam.strong_induct) (simp_all)

text \<open>
  Unlike the proplem suggested by Wang, however, the
  theorem is here formulated entirely by using functions.
\<close>

theorem height_subst:
  shows "height (e[x::=e']) \<le> ((height e) - 1) + (height e')"
proof (nominal_induct e avoiding: x e' rule: lam.strong_induct)
  case (Var y)
  have "1 \<le> height e'" by (rule height_ge_one)
  then show "height (Var y[x::=e']) \<le> height (Var y) - 1 + height e'" by simp
next
  case (Lam y e1)
  hence ih: "height (e1[x::=e']) \<le> ((height e1) - 1) + (height e')" by simp
  moreover
  have vc: "y\<sharp>x" "y\<sharp>e'" by fact+ (* usual variable convention *)
  ultimately show "height ((Lam [y].e1)[x::=e']) \<le> height (Lam [y].e1) - 1 + height e'" by simp
next
  case (App e1 e2)
  hence ih1: "height (e1[x::=e']) \<le> ((height e1) - 1) + (height e')"
    and ih2: "height (e2[x::=e']) \<le> ((height e2) - 1) + (height e')" by simp_all
  then show "height ((App e1 e2)[x::=e']) \<le> height (App e1 e2) - 1 + height e'"  by simp
qed

end


section \<open>Graphs\<close>
theory Graph
imports Main
begin
text \<open>
  This theory defines a notion of graphs. A graph is a record that
  contains a set of nodes \<open>V\<close> and a set of labeled edges
  \<open>E \<subseteq> V\<times>W\<times>V\<close>, where \<open>W\<close> are the edge labels.
\<close>

subsection \<open>Definitions\<close>
  text \<open>A graph is represented by a record.\<close>
  record ('v,'w) graph =
    nodes :: "'v set"
    edges :: "('v \<times> 'w \<times> 'v) set"

  text \<open>In a valid graph, edges only go from nodes to nodes.\<close>
  locale valid_graph =
    fixes G :: "('v,'w) graph"
    assumes E_valid: "fst`edges G \<subseteq> nodes G"
                     "snd`snd`edges G \<subseteq> nodes G"
  begin
    abbreviation "V \<equiv> nodes G"
    abbreviation "E \<equiv> edges G"

    lemma E_validD: assumes "(v,e,v')\<in>E"
      shows "v\<in>V" "v'\<in>V"
      apply -
      apply (rule subsetD[OF E_valid(1)])
      using assms apply force
      apply (rule subsetD[OF E_valid(2)])
      using assms apply force
      done

  end

  subsection \<open>Basic operations on Graphs\<close>

  text \<open>The empty graph.\<close>
  definition empty where
    "empty \<equiv> \<lparr> nodes = {}, edges = {} \<rparr>"
  text \<open>Adds a node to a graph.\<close>
  definition add_node where
    "add_node v g \<equiv> \<lparr> nodes = insert v (nodes g), edges=edges g\<rparr>"
  text \<open>Deletes a node from a graph. Also deletes all adjacent edges.\<close>
  definition delete_node where "delete_node v g \<equiv> \<lparr>
    nodes = nodes g - {v},
    edges = edges g \<inter> (-{v})\<times>UNIV\<times>(-{v})
    \<rparr>"
  text \<open>Adds an edge to a graph.\<close>
  definition add_edge where "add_edge v e v' g \<equiv> \<lparr>
    nodes = {v,v'} \<union> nodes g,
    edges = insert (v,e,v') (edges g)
    \<rparr>"
  text \<open>Deletes an edge from a graph.\<close>
  definition delete_edge where "delete_edge v e v' g \<equiv> \<lparr>
    nodes = nodes g, edges = edges g - {(v,e,v')} \<rparr>"
  text \<open>Successors of a node.\<close>
  definition succ :: "('v,'w) graph \<Rightarrow> 'v \<Rightarrow> ('w\<times>'v) set"
    where "succ G v \<equiv> {(w,v'). (v,w,v')\<in>edges G}"

  text \<open>Now follow some simplification lemmas.\<close>
  lemma empty_valid[simp]: "valid_graph empty"
    unfolding empty_def by unfold_locales auto
  lemma add_node_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (add_node v g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding add_node_def
      by unfold_locales (auto dest: E_validD)
  qed
  lemma delete_node_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (delete_node v g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding delete_node_def
      by unfold_locales (auto dest: E_validD)
  qed
  lemma add_edge_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (add_edge v e v' g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding add_edge_def
      by unfold_locales (auto dest: E_validD)
  qed
  lemma delete_edge_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (delete_edge v e v' g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding delete_edge_def
      by unfold_locales (auto dest: E_validD)
  qed

  lemma succ_finite[simp, intro]: "finite (edges G) \<Longrightarrow> finite (succ G v)"
    unfolding succ_def
    by (rule finite_subset[where B="snd`edges G"]) force+

  lemma nodes_empty[simp]: "nodes empty = {}" unfolding empty_def by simp
  lemma edges_empty[simp]: "edges empty = {}" unfolding empty_def by simp
  lemma succ_empty[simp]: "succ empty v = {}" unfolding empty_def succ_def by auto

  lemma nodes_add_node[simp]: "nodes (add_node v g) = insert v (nodes g)"
    by (simp add: add_node_def)
  lemma nodes_add_edge[simp]:
    "nodes (add_edge v e v' g) = insert v (insert v' (nodes g))"
    by (simp add: add_edge_def)

  lemma (in valid_graph) succ_subset: "succ G v \<subseteq> UNIV\<times>V"
    unfolding succ_def using E_valid
    by (force)

subsection \<open>Paths\<close>
  text \<open>A path is represented by a list of adjacent edges.\<close>
  type_synonym ('v,'w) path = "('v\<times>'w\<times>'v) list"

  context valid_graph
  begin
    text \<open>The following predicate describes a valid path:\<close>
    fun is_path :: "'v \<Rightarrow> ('v,'w) path \<Rightarrow> 'v \<Rightarrow> bool" where
      "is_path v [] v' \<longleftrightarrow> v=v' \<and> v'\<in>V" |
      "is_path v ((v1,w,v2)#p) v' \<longleftrightarrow> v=v1 \<and> (v1,w,v2)\<in>E \<and> is_path v2 p v'"

    lemma is_path_simps[simp, intro!]:
      "is_path v [] v \<longleftrightarrow> v\<in>V"
      "is_path v [(v,w,v')] v' \<longleftrightarrow> (v,w,v')\<in>E"
      by (auto dest: E_validD)

    lemma is_path_memb[simp]:
      "is_path v p v' \<Longrightarrow> v\<in>V \<and> v'\<in>V"
      apply (induct p arbitrary: v)
      apply (auto dest: E_validD)
      done

    lemma is_path_split:
      "is_path v (p1@p2) v' \<longleftrightarrow> (\<exists>u. is_path v p1 u \<and> is_path u p2 v')"
      by (induct p1 arbitrary: v) auto

    lemma is_path_split'[simp]:
      "is_path v (p1@(u,w,u')#p2) v'
        \<longleftrightarrow> is_path v p1 u \<and> (u,w,u')\<in>E \<and> is_path u' p2 v'"
      by (auto simp add: is_path_split)
  end

  text \<open>Set of intermediate vertices of a path. These are all vertices but
    the last one. Note that, if the last vertex also occurs earlier on the path,
    it is contained in \<open>int_vertices\<close>.\<close>
  definition int_vertices :: "('v,'w) path \<Rightarrow> 'v set" where
    "int_vertices p \<equiv> set (map fst p)"

  lemma int_vertices_simps[simp]:
    "int_vertices [] = {}"
    "int_vertices (vv#p) = insert (fst vv) (int_vertices p)"
    "int_vertices (p1@p2) = int_vertices p1 \<union> int_vertices p2"
    by (auto simp add: int_vertices_def)

  lemma (in valid_graph) int_vertices_subset:
    "is_path v p v' \<Longrightarrow> int_vertices p \<subseteq> V"
    apply (induct p arbitrary: v)
    apply (simp)
    apply (force dest: E_validD)
    done

  lemma int_vertices_empty[simp]: "int_vertices p = {} \<longleftrightarrow> p=[]"
    by (cases p) auto

subsubsection \<open>Splitting Paths\<close>
  text \<open>Split a path at the point where it first leaves the set \<open>W\<close>:\<close>
  lemma (in valid_graph) path_split_set:
    assumes "is_path v p v'" and "v\<in>W" and "v'\<notin>W"
    obtains p1 p2 u w u' where
    "p=p1@(u,w,u')#p2" and
    "int_vertices p1 \<subseteq> W" and "u\<in>W" and "u'\<notin>W"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    note [simp, intro!] = \<open>v\<in>W\<close> \<open>v'\<notin>W\<close>
    from Cons.prems obtain w u' where
      [simp]: "vv=(v,w,u')" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    txt \<open>Distinguish wether the second node \<open>u'\<close> of the path is
      in \<open>W\<close>. If yes, the proposition follows by the
      induction hypothesis, otherwise it is straightforward, as
      the split takes place at the first edge of the path.\<close>
    {
      assume A [simp, intro!]: "u'\<in>W"
      from Cons.hyps[OF _ REST] obtain p1 uu ww uu' p2 where
        "p=p1@(uu,ww,uu')#p2" "int_vertices p1 \<subseteq> W" "uu \<in> W" "uu' \<notin> W"
        by blast
      with Cons.prems(1)[of "vv#p1" uu ww uu' p2] have thesis by auto
    } moreover {
      assume "u'\<notin>W"
      with Cons.prems(1)[of "[]" v w u' p] have thesis by auto
    } ultimately show thesis by blast
  qed

  text \<open>Split a path at the point where it first enters the set \<open>W\<close>:\<close>
  lemma (in valid_graph) path_split_set':
    assumes "is_path v p v'" and "v'\<in>W"
    obtains p1 p2 u where
    "p=p1@p2" and
    "is_path v p1 u" and
    "is_path u p2 v'" and
    "int_vertices p1 \<subseteq> -W" and "u\<in>W"
    using assms
  proof (cases "v\<in>W")
    case True with that[of "[]" p] assms show ?thesis
      by auto
  next
    case False with assms that show ?thesis
    proof (induct p arbitrary: v thesis)
      case Nil thus ?case by auto
    next
      case (Cons vv p)
      note [simp, intro!] = \<open>v'\<in>W\<close> \<open>v\<notin>W\<close>
      from Cons.prems obtain w u' where
        [simp]: "vv=(v,w,u')" and [simp]: "(v,w,u')\<in>E" and
          REST: "is_path u' p v'"
        by (cases vv) auto

      txt \<open>Distinguish wether the second node \<open>u'\<close> of the path is
        in \<open>W\<close>. If yes, the proposition is straightforward, otherwise,
        it follows by the induction hypothesis.
\<close>
      {
        assume A [simp, intro!]: "u'\<in>W"
        from Cons.prems(3)[of "[vv]" p u'] REST have ?case by auto
      } moreover {
        assume [simp, intro!]: "u'\<notin>W"
        from Cons.hyps[OF REST] obtain p1 p2 u'' where
          [simp]: "p=p1@p2" and
            "is_path u' p1 u''" and
            "is_path u'' p2 v'" and
            "int_vertices p1 \<subseteq> -W" and
            "u''\<in>W" by blast
        with Cons.prems(3)[of "vv#p1"] have ?case by auto
      } ultimately show ?case by blast
    qed
  qed

  text \<open>Split a path at the point where a given vertex is first visited:\<close>
  lemma (in valid_graph) path_split_vertex:
    assumes "is_path v p v'" and "u\<in>int_vertices p"
    obtains p1 p2 where
    "p=p1@p2" and
    "is_path v p1 u" and
    "u \<notin> int_vertices p1"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    from Cons.prems obtain w u' where
      [simp]: "vv=(v,w,u')" "v\<in>V" "(v,w,u')\<in>E" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    {
      assume "u=v"
      with Cons.prems(1)[of "[]" "vv#p"] have thesis by auto
    } moreover {
      assume [simp]: "u\<noteq>v"
      with Cons.hyps(1)[OF _ REST] Cons.prems(3) obtain p1 p2 where
        "p=p1@p2" "is_path u' p1 u" "u\<notin>int_vertices p1"
        by auto
      with Cons.prems(1)[of "vv#p1" p2] have thesis
        by auto
    } ultimately show ?case by blast
  qed

subsection \<open>Weighted Graphs\<close>
  locale valid_mgraph = valid_graph G for G::"('v,'w::monoid_add) graph"

  definition path_weight :: "('v,'w::monoid_add) path \<Rightarrow> 'w"
    where "path_weight p \<equiv> sum_list (map (fst \<circ> snd) p)"

  (*
    lemma path_weight_alt: "path_weight p \<equiv> sum_list (map (fst \<circ> snd) p)"
    unfolding path_weight_def foldl_conv_fold
    by (simp add: sum_list_foldl)
  *)

  lemma path_weight_split[simp]:
    "(path_weight (p1@p2)::'w::monoid_add) = path_weight p1 + path_weight p2"
    unfolding path_weight_def
    by (auto)

  lemma path_weight_empty[simp]: "path_weight [] = 0"
    unfolding path_weight_def
    by auto

  lemma path_weight_cons[simp]:
    "(path_weight (e#p)::'w::monoid_add) = fst (snd e) + path_weight p"
    unfolding path_weight_def
    by (auto)

end