theory TeslDenotationalOperators

imports TeslDenotationalCore NatStrongInduct

begin
text \<open>
  We define here operators on the semantic domain of TESL that will be used to define
  the semantics of the relations between clocks.
\<close>

text \<open>
  Tell whether a clock ticks in an event.
\<close>
definition ticks :: \<open>('a::orderedrank, 'b)\<H> \<Rightarrow> event \<Rightarrow> bool\<close>
where     \<open>ticks clk evt \<equiv> (let n = (index clk) in if n < length evt then evt ! n else False)\<close>

text \<open>
  When no tick occurs, no clock ticks.
\<close>
lemma not_tick_occurs:
  assumes \<open>\<not>tick_occurs (h n)\<close>
    shows \<open>\<not>ticks c (h n)\<close>
proof -
  from assms have \<open>\<forall>i. i < length (h n) \<longrightarrow> (h n)!i = False\<close>
    using nth_mem tick_occurs_def by blast
  thus ?thesis unfolding ticks_def by auto
qed

text \<open>
  A clock can tick in an event only if its index is in the range of the event.
\<close>
lemma ticks_idx:
  \<open>ticks c evt \<Longrightarrow> (index c) < length evt\<close>
proof -
  assume h:\<open>ticks c evt\<close>
  { assume \<open>\<not>((index c < length evt))\<close>
    hence \<open>\<not>ticks c evt\<close> unfolding ticks_def by simp
    with h have False by simp
  }
  thus ?thesis by blast
qed

text \<open>
  When a clock ticks in an event, there is True at the index of the clock in that event.
\<close>
lemma ticks_ham:\<open>ticks c evt \<Longrightarrow> evt!(index c)\<close>
proof -
  assume h:\<open>ticks c evt\<close>
  have \<open>index c < length evt\<close> using ticks_idx[OF h] .
  with h show ?thesis unfolding ticks_def by simp
qed

text \<open>
  When either a or b ticks, there is a tick.
  Notice that since clocks a and b may not have the same type, this lemma is not so easy
  to prove automatically.
\<close>
lemma either_ticks_tick_occurs:
  assumes \<open>ticks a evt \<or> ticks b evt\<close>
  shows   \<open>tick_occurs evt\<close>
proof -
  from assms show ?thesis
  proof
    { assume \<open>ticks a evt\<close>
      from ticks_idx[OF this] ticks_ham[OF this] tick_occurs_def nth_mem show ?thesis by blast
    }
    { assume \<open>ticks b evt\<close>
      from ticks_idx[OF this] ticks_ham[OF this] tick_occurs_def nth_mem show ?thesis by blast
    }
  qed
qed

text \<open>
  For any nat, there exists a clock with that index.
\<close>
lemma clock_exists_idx:\<open>\<exists>c::('a::orderedrank, 'b)\<H>. (index c) = k\<close>
proof -
  have \<open>\<exists>f::'a\<Rightarrow>'b. True\<close> by simp
  from this obtain f::\<open>'a\<Rightarrow>'b\<close> where True by blast
  have \<open>index (f, k) = k\<close> by simp
  thus ?thesis by simp
qed

text \<open>
  A tick occurs in an event iff there is a clock that ticks in that event.
\<close>
lemma one_tick_occurs:\<open>(\<exists>c::('a::orderedrank, 'b)\<H>. ticks c i) = tick_occurs i\<close>
proof
  { assume \<open>\<exists>c::('a::orderedrank, 'b)\<H>. ticks c i\<close>
    from this obtain c::\<open>('a::orderedrank, 'b)\<H>\<close> where cprop:\<open>ticks c i\<close> by blast
    from ticks_idx[OF this] have idx:\<open>index c < length i\<close> .
    with cprop have \<open>i!(index c)\<close> unfolding ticks_def by simp
    with idx have \<open>\<exists>x \<in> set i. x\<close> using nth_mem by blast
  } thus \<open>\<exists>c::('a::orderedrank, 'b)\<H>. ticks c i \<Longrightarrow> tick_occurs i\<close> unfolding tick_occurs_def .
next
  { assume \<open>tick_occurs i\<close>
    from this obtain x where \<open>x \<in> set i \<and> x\<close> unfolding tick_occurs_def by blast
    hence \<open>\<exists>k. k < length i \<and> i!k\<close> by (auto simp add: in_set_conv_nth)
    from this obtain k where \<open>k < length i \<and> i!k\<close> by blast
    hence \<open>\<exists>c::('a::orderedrank, 'b)\<H>. ticks c i\<close>
      unfolding ticks_def using clock_exists_idx by auto
  } thus \<open>tick_occurs i \<Longrightarrow> \<exists>c::('a::orderedrank, 'b)\<H>. ticks c i\<close> .
qed

text \<open>
  Instant of the first tick of a clock:
  first_tick c h = Some k if c ticked for the first time at k in hamlet h
                   None if c does not tick in hamlet k
\<close>
definition first_tick :: \<open>('a::orderedrank, 'b)\<H> \<Rightarrow> hamlet \<rightharpoonup> nat\<close>
where
  \<open>first_tick clk hmt = (if (\<exists>k. ticks clk (hmt k))
                         then Some (LEAST k. ticks clk (hmt k))
                         else None)\<close>

text \<open>
  If a clock has a first tick, it ticks at some instant.
\<close>
lemma first_tick_ticks:
  assumes \<open>first_tick c h \<noteq> None\<close>
  shows   \<open>\<exists>t. ticks c (h t)\<close>
proof -
  {
    assume \<open>\<nexists>t. ticks c (h t)\<close>
    with first_tick_def[of \<open>c\<close> \<open>h\<close>] have \<open>first_tick c h = None\<close> by simp
    with assms have False by simp
  }
  thus ?thesis by blast
qed

text \<open>
  If a clock has no first tick, it never ticks.
\<close>
lemma no_first_tick_no_tick:
  assumes \<open>first_tick c h = None\<close>
  shows   \<open>\<nexists>k. ticks c (h k)\<close>
proof -
  {
    assume \<open>\<exists>k. ticks c (h k)\<close>
    hence \<open>first_tick c h \<noteq> None\<close> unfolding first_tick_def by simp
    with assms have False by simp
  }
  thus ?thesis by blast
qed

text \<open>
  A non empty set of nats has a least element.
\<close>
lemma Least_nat_ex:
  \<open>(n::nat) \<in> S \<Longrightarrow> \<exists>x \<in> S. (\<forall>y \<in> S. x \<le> y)\<close>
by (induction n rule: nat_less_induct, insert not_le_imp_less, blast)

text \<open>
  tick_count c h n = number of ticks of clock c in hamlet h upto instant n
\<close>
definition tick_count :: \<open>('a::orderedrank, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat\<close>
where
  \<open>tick_count c h n = card {i. i \<le> n \<and> ticks c (h i)}\<close>

text \<open>
  Another definition as a function.
\<close>
fun tick_count_fun :: \<open>('a::orderedrank, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat\<close>
where
  \<open>tick_count_fun clk hmt 0 = (if ticks clk (hmt 0) then 1 else 0)\<close>
| \<open>tick_count_fun clk hmt (Suc k) = (if ticks clk (hmt (Suc k))
                                     then Suc (tick_count_fun clk hmt k)
                                     else tick_count_fun clk hmt k)\<close>
text \<open>
  A singleton of nat can be defined with a weaker property.
\<close>
lemma nat_sing_prop:
  \<open>{i::nat. i = k \<and> P(i)} = {i::nat. i = k \<and> P(k)}\<close>
by auto

text \<open>
  The set definition and the function definition of tick_count are equivalent.
\<close>
lemma tick_count_is_fun[code]:\<open>tick_count c h n = tick_count_fun c h n\<close>
proof (induction n)
  case 0
    have \<open>tick_count c h 0 = card {i. i \<le> 0 \<and> ticks c (h i)}\<close>
      by (simp add: tick_count_def)
    also have \<open>... = card {i::nat. i = 0 \<and> ticks c (h 0)}\<close>
      using le_zero_eq nat_sing_prop[of \<open>0\<close> \<open>\<lambda>i. ticks c (h i)\<close>] by simp
    also have \<open>... = (if ticks c (h 0) then 1 else 0)\<close> by simp
    also have \<open>... = tick_count_fun c h 0\<close> by simp
    finally show ?case .
next
  case (Suc k)
    show ?case
    proof (cases \<open>ticks c (h (Suc k))\<close>)
      case True
        hence \<open>{i. i \<le> Suc k \<and> ticks c (h i)} = insert (Suc k) {i. i \<le> k \<and> ticks c (h i)}\<close>
          by auto
        hence \<open>tick_count c h (Suc k) = Suc (tick_count c h k)\<close>
          by (simp add: tick_count_def)
        with Suc.IH have \<open>tick_count c h (Suc k) = Suc (tick_count_fun c h k)\<close> by simp
        thus ?thesis by (simp add: True)
    next
      case False
        hence \<open>{i. i \<le> Suc k \<and> ticks c (h i)} = {i. i \<le> k \<and> ticks c (h i)}\<close>
          using le_Suc_eq by auto
        hence \<open>tick_count c h (Suc k) = tick_count c h k\<close> by (simp add: tick_count_def)
        thus ?thesis using Suc.IH by (simp add: False)
    qed
qed

text \<open>
  Number of ticks of a clock in the interval ]m, n]
\<close>
definition tick_count_between ::\<open>('a::orderedrank, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> instant \<Rightarrow> nat\<close>
where \<open>tick_count_between c h m n \<equiv> card {p. m < p \<and> p \<le> n \<and> ticks c (h p)}\<close>

text \<open>
  The tick count between m and n is the difference of the tick counts at n and m.
\<close>
lemma count_diff:
  assumes \<open>n \<ge> m\<close>
  shows   \<open>tick_count_between c h m n = (tick_count c h n) - (tick_count c h m)\<close>
proof -
  have finite:\<open>finite {p. p \<le> m \<and> ticks c (h p)}\<close> by simp
  have incl:\<open>{p. p \<le> m \<and> ticks c (h p)} \<subseteq> {p. p \<le> n \<and> ticks c (h p)}\<close> using assms by auto
  have \<open>{p. m < p \<and> p \<le> n \<and> ticks c (h p)} =
        {p. p \<le> n \<and> ticks c (h p)} - {p. p \<le> m \<and> ticks c (h p)}\<close> by auto
  with card_Diff_subset[OF finite incl] have
    \<open>card {p. m < p \<and> p \<le> n \<and> ticks c (h p)} =
     card {p. p \<le> n \<and> ticks c (h p)} - card {p. p \<le> m \<and> ticks c (h p)}\<close>
    by simp
  thus ?thesis unfolding tick_count_def tick_count_between_def .
qed

lemma count_fun_diff:
  assumes \<open>n \<ge> m\<close>
  shows   \<open>tick_count_between c h m n = (tick_count_fun c h n) - (tick_count_fun c h m)\<close>
using count_diff[of \<open>m\<close> \<open>n\<close> \<open>c\<close> \<open>h\<close>, OF assms] tick_count_is_fun[of \<open>c\<close> \<open>h\<close>] by simp

text \<open>
  There are no ticks in an empty interval.
\<close>
lemma count_null:
  assumes \<open>n \<le> m\<close>
  shows   \<open>tick_count_between c h m n = 0\<close>
proof -
  from assms have \<open>{p. m < p \<and> p \<le> n} = {}\<close> by auto
  thus ?thesis unfolding tick_count_between_def by auto
qed

text \<open>
  filter s k rs rk x tells whether the filter which skips s ticks, then keep k ticks,
  then repeatedly skips rs ticks and keeps rk ticks is active after x ticks.

  For instance, the filter \texttt{1 2 (1 1)* } is active:
  \begin{itemize}
    \item for x = 2 and 3
    \item for any odd x starting from 5
  \end{itemize}

  Some ASCII art explaining how filter works:
  \begin{verbatim}
  --+--+--+--+--+--+--+--+--+--+--+-- ...
  -- --+--+-- --+-- --+-- --+-- --+-- ...
    1  2  3  4  5  6  7  8  9  10 11  ...
  \end{verbatim}
\<close>
definition filter
where
  \<open>filter s k rs rk x \<equiv> (s < x \<and> x \<le> s + k)
                       \<or> ((x > s+k) \<and> (rk > 0) \<and> ((x - (s+k+1)) mod (rs + rk) \<ge> rs))\<close>

text \<open>
  first_tick_since c h from now = there is a tick on clock c now in hamlet h,
                                  and there was no tick on c in the interval [from, now[ of h.
\<close>
definition first_tick_since :: \<open>('\<AA>::orderedrank,'a)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> instant \<Rightarrow> bool\<close>
where
  \<open>first_tick_since c h from now \<equiv> ticks c (h now)
                                 \<and> (now \<ge> from)
                                 \<and> (\<forall>t. (from \<le> t \<and> t < now) \<longrightarrow> \<not>ticks c (h t))\<close>

text \<open>
  has_ticked_since c h from now = there was at least a tick on clock c
                                  in the interval [from , now] of hamlet h.
\<close>
definition has_ticked_since :: \<open>('\<AA>::orderedrank,'a)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> instant \<Rightarrow> bool\<close>
where
  \<open>has_ticked_since c h from now \<equiv> (\<exists>t. from \<le> t \<and> t \<le> now \<and> ticks c (h t))\<close>

text \<open>
  An item in an interval belongs to either split parts of the interval.
\<close>
lemma interval_split:
  assumes \<open>(a::nat) \<le> m \<and> m \<le> b\<close>
    shows \<open>(a \<le> t \<and> t \<le> b) = ((a \<le> t \<and> t \<le> m) \<or> (m \<le> t \<and> t \<le> b))\<close>
using assms by linarith

text \<open>
  A tick in an interval belongs to either split parts of the interval.
\<close>
lemma has_ticked_since_split:
  assumes \<open>from \<le> interm \<and> interm \<le> now\<close>
    shows \<open>has_ticked_since c h from now
         = (has_ticked_since c h from interm \<or> has_ticked_since c h interm now)\<close>
unfolding has_ticked_since_def using interval_split[OF assms] by auto

text \<open>
  If a clock ticks at the beginning of an interval, it ticks in this interval.
\<close>
lemma has_ticked_since_from:
  assumes \<open>ticks c (h fr)\<close>
  and     \<open>fr \<le> now\<close>
  shows   \<open>has_ticked_since c h fr now\<close>
using assms unfolding has_ticked_since_def by blast

text \<open>
  If a clock ticks at the end of an interval, it ticks in this interval.
\<close>
lemma has_ticked_since_now:
  assumes \<open>ticks c (h now)\<close>
  and     \<open>fr \<le> now\<close>
  shows   \<open>has_ticked_since c h fr now\<close>
using assms unfolding has_ticked_since_def by blast

text \<open>
  Corollaries of the previous two lemmas.
\<close>
lemma has_ticked_since_from_idem:
  assumes \<open>fr \<le> now\<close>
  shows   \<open>has_ticked_since c h fr now = (ticks c (h fr) \<or> has_ticked_since c h fr now)\<close>
using assms has_ticked_since_from by blast

lemma has_ticked_since_now_idem:
  assumes \<open>fr \<le> now\<close>
  shows   \<open>has_ticked_since c h fr now = (ticks c (h now) \<or> has_ticked_since c h fr now)\<close>
using assms has_ticked_since_now by blast

text \<open>
  If a clock has ticked in [n0, n], the interval cannot be empty.
\<close>
lemma ht_not_empty:
  assumes \<open>has_ticked_since c h n\<^sub>0 n\<close>
    shows \<open>n\<^sub>0 \<le> n\<close>
using assms has_ticked_since_def le_trans by blast

text \<open>
  A clock has necessarily ticked in [from , now] if it ticks for the first time in [from, now]
\<close>
lemma first_tick_has_ticked:
  assumes \<open>first_tick_since c h from now\<close>
  shows   \<open>has_ticked_since c h from now\<close>
proof -
  from assms(1) have \<open>ticks c (h now) \<and> (now \<ge> from)\<close>
    using first_tick_since_def by blast
  thus ?thesis using has_ticked_since_def by blast
qed

text \<open>
  have_both_ticked a b h n = clocks a and b have both ticked at instant n in hamlet h.
  This means that either a has ticked before and b has just ticked at n, or b has ticked before
  and a has just ticked at n.
  Each time both clocks have ticked, they must tick again both in order to consider that
  they have both ticked later.

  Example:
  \begin{verbatim}
                     a --*-----*--*--*----------*--
                     b -----*--*-------*--*--*-----
  have both ticked a b -----*--*-------*--------*--
  \end{verbatim}
\<close>
text \<open>
  A definition of the condition of have_both_ticked:
\<close>
definition has_first_since ::\<open>('a::orderedrank, 'b)\<H>
                           \<Rightarrow> ('a, 'c)\<H>
                           \<Rightarrow> hamlet \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool\<close>
where
  \<open>has_first_since a b h n\<^sub>0 n \<equiv> has_ticked_since a h n\<^sub>0 n \<and> first_tick_since b h n\<^sub>0 n\<close>

text \<open>
  This condition implies that both clock have ticked since n0.
\<close>
lemma hft_ht:
  assumes \<open>has_first_since a b h n\<^sub>0 n\<close>
    shows \<open>has_ticked_since a h n\<^sub>0 n \<and> has_ticked_since b h n\<^sub>0 n\<close>
using assms first_tick_has_ticked has_first_since_def by blast

text \<open>
  Inductive definition of have_both_ticked:
\<close>
inductive have_both_ticked ::\<open>('\<AA>::orderedrank,'a)\<H> \<Rightarrow> ('\<AA>,'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> bool\<close>
where
  \<comment> \<open> First ticks since origin \<close>
  \<open>has_first_since a b h 0 n \<Longrightarrow> have_both_ticked a b h n\<close>
| \<open>has_first_since b a h 0 n \<Longrightarrow> have_both_ticked a b h n\<close>
  \<comment> \<open> Induction \<close>
| \<open>\<lbrakk>have_both_ticked a b h n\<^sub>0; has_first_since a b h (Suc n\<^sub>0) n\<rbrakk> \<Longrightarrow> have_both_ticked a b h n\<close>
| \<open>\<lbrakk>have_both_ticked a b h n\<^sub>0; has_first_since b a h (Suc n\<^sub>0) n\<rbrakk> \<Longrightarrow> have_both_ticked a b h n\<close>

inductive_cases hbt0: \<open>have_both_ticked a b h 0\<close>
thm hbt0
inductive_cases hbtn: \<open>have_both_ticked a b h n\<close>
thm hbtn

text \<open>
  A disjunctive form of the inductive case for have_both_ticked a b h 0.
\<close>
lemma hbt0':
  assumes \<open>have_both_ticked a b h 0\<close>
  shows   \<open>has_first_since a b h 0 0 \<or> has_first_since b a h 0 0\<close>
proof -
    from hbt0[OF assms] consider
      (a) \<open>has_ticked_since a h 0 0 \<and> first_tick_since b h 0 0\<close>
    | (b) \<open>has_ticked_since b h 0 0 \<and> first_tick_since a h 0 0\<close>
    | (c) \<open>\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since a b h (Suc n\<^sub>0) 0\<close>
    | (d) \<open>\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since b a h (Suc n\<^sub>0) 0\<close>
    using has_first_since_def[of \<open>a\<close> \<open>b\<close> \<open>h\<close> \<open>0\<close> \<open>0\<close>]
          has_first_since_def[of \<open>b\<close> \<open>a\<close> \<open>h\<close> \<open>0\<close> \<open>0\<close>] by blast
    hence \<open>has_first_since a b h 0 0 \<or> has_first_since b a h 0 0\<close>
    proof cases
      case a thus ?thesis by (simp add: has_first_since_def)
    next
      case b thus ?thesis by (simp add: has_first_since_def)
    next
      case c
        from this obtain n\<^sub>0 where \<open>has_first_since a b h (Suc n\<^sub>0) 0\<close> by auto
        hence \<open>0 \<ge> Suc n\<^sub>0\<close> using first_tick_since_def has_first_since_def by blast
        hence False by simp
        thus ?thesis ..
    next
      case d
        from this obtain n\<^sub>0 where \<open>has_first_since b a h (Suc n\<^sub>0) 0\<close> by auto
        hence \<open>0 \<ge> Suc n\<^sub>0\<close> using first_tick_since_def has_first_since_def by blast
        hence False by simp
        thus ?thesis ..
    qed
    thus ?thesis .
qed

text \<open>
  Disjunctive form of the inductive case "have_both_ticked a b h n"
\<close>
lemma btn_btn0:
  assumes \<open>have_both_ticked a b h n\<close>
    shows \<open>has_first_since a b h 0 n
         \<or> has_first_since b a h 0 n
         \<or> (\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0
              \<and> (has_first_since a b h (Suc n\<^sub>0) n \<or> has_first_since b a h (Suc n\<^sub>0) n))\<close>
using hbtn[OF assms] by auto

text \<open>
  Same lemma, but with distributed existential quantification.
\<close>
lemma btn_btn0':
  assumes \<open>have_both_ticked a b h n\<close>
    shows \<open>has_first_since a b h 0 n
         \<or> has_first_since b a h 0 n
         \<or> (\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since a b h (Suc n\<^sub>0) n)
         \<or> (\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since b a h (Suc n\<^sub>0) n)\<close>
using hbtn[OF assms] by auto

text \<open>
  This lemma is in fact an equivalence.
\<close>
lemma hbt_disj:\<open>have_both_ticked a b h n =
                has_first_since a b h 0 n
                 \<or> has_first_since b a h 0 n
                 \<or> (\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since a b h (Suc n\<^sub>0) n)
                 \<or> (\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since b a h (Suc n\<^sub>0) n)\<close>
using btn_btn0' have_both_ticked.intros by blast

text \<open>
  have_both_ticked is commutative on clocks.
\<close>
lemma hbt_commutes: \<open>have_both_ticked a b h n \<Longrightarrow> have_both_ticked b a h n\<close>
proof (induction n rule: nat_strong_induct)
  case 0 thus ?case using hbt0' have_both_ticked.intros(1,2) by blast
next
  case (Suc k)
    assume \<open>have_both_ticked a b h (Suc k)\<close>
    from btn_btn0'[OF this] consider
      (a) \<open>has_first_since a b h 0 (Suc k)\<close>
    | (b) \<open>has_first_since b a h 0 (Suc k)\<close>
    | (c) \<open>\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since a b h (Suc n\<^sub>0) (Suc k)\<close>
    | (d) \<open>\<exists>n\<^sub>0. have_both_ticked a b h n\<^sub>0 \<and> has_first_since b a h (Suc n\<^sub>0) (Suc k)\<close>
    by blast
    thus ?case
    proof cases
      case a thus ?thesis by (rule have_both_ticked.intros(2))
    next
      case b thus ?thesis by (rule have_both_ticked.intros(1))
    next
      case c
      from this obtain n\<^sub>0 where
        hbt:\<open>have_both_ticked a b h n\<^sub>0\<close> and hfs:\<open>has_first_since a b h (Suc n\<^sub>0) (Suc k)\<close> by blast
      from hfs have \<open>Suc n\<^sub>0 \<le> Suc k\<close> using ht_not_empty hft_ht by blast
      hence \<open>n\<^sub>0 \<le> k\<close> using Suc_le_mono by simp
      with Suc.IH hbt have \<open>have_both_ticked b a h n\<^sub>0\<close> by simp
      from have_both_ticked.intros(4)[OF this hfs] show ?thesis .
    next
      case d
      from this obtain n\<^sub>0 where
        hbt:\<open>have_both_ticked a b h n\<^sub>0\<close> and hfs:\<open>has_first_since b a h (Suc n\<^sub>0) (Suc k)\<close> by blast
      from hfs have \<open>Suc n\<^sub>0 \<le> Suc k\<close> using ht_not_empty hft_ht by blast
      hence \<open>n\<^sub>0 \<le> k\<close> using Suc_le_mono by simp
      with Suc.IH hbt have \<open>have_both_ticked b a h n\<^sub>0\<close> by simp
      from have_both_ticked.intros(3)[OF this hfs] show ?thesis .
    qed
qed

text \<open>
  If both clocks have ticked at instant 0, each clock ticks at 0
\<close>
lemma bt0_bt0:
  assumes \<open>have_both_ticked a b h 0\<close>
  shows   \<open>ticks a (h 0) \<and> ticks b (h 0)\<close>
using hbt0[OF assms]
by (auto simp add:first_tick_since_def has_ticked_since_def has_first_since_def)

text \<open>
  If a clock has ticked in [n1, n], it also has ticked at n since an earlier instant.
\<close>
lemma has_ticked_since_earlier:
  assumes \<open>has_ticked_since a h n\<^sub>1 n\<close>
      and \<open>n\<^sub>1 \<ge> n\<^sub>0\<close>
    shows \<open>has_ticked_since a h n\<^sub>0 n\<close>
proof -
  from assms(1) have \<open>(\<exists>t. n\<^sub>1 \<le> t \<and> t \<le> n \<and> ticks a (h t))\<close> unfolding has_ticked_since_def .
  with assms(2) have \<open>(\<exists>t. n\<^sub>0 \<le> t \<and> t \<le> n \<and> ticks a (h t))\<close> using le_trans by blast
  thus ?thesis unfolding has_ticked_since_def .
qed

text \<open>
  If a clock has ticked in [n0, n], it also has ticked at a later instant since n0.
\<close>
lemma has_ticked_since_later:
  assumes \<open>has_ticked_since a h n\<^sub>0 n\<close>
      and \<open>n' \<ge> n\<close>
    shows \<open>has_ticked_since a h n\<^sub>0 n'\<close>
proof -
  from assms(1) have \<open>(\<exists>t. n\<^sub>0 \<le> t \<and> t \<le> n \<and> ticks a (h t))\<close> unfolding has_ticked_since_def .
  with assms(2) have \<open>(\<exists>t. n\<^sub>0 \<le> t \<and> t \<le> n' \<and> ticks a (h t))\<close> using le_trans by blast
  thus ?thesis unfolding has_ticked_since_def .
qed

text \<open>
  When two clocks have both ticked at instant n, at least one of them ticks at instant n.
\<close>
lemma hbt_t:
  assumes \<open>have_both_ticked a b h n\<close>
    shows \<open>ticks a (h n) \<or> ticks b (h n)\<close>
using btn_btn0[OF assms] unfolding has_first_since_def first_tick_since_def by blast

text \<open>
  When two clocks have both ticked at instant n, the first one has ticked since instant 0.
\<close>
lemma hbt_hta:
  assumes \<open>have_both_ticked a b h n\<close>
    shows \<open>has_ticked_since a h 0 n\<close>
using btn_btn0[OF assms] unfolding has_first_since_def
                         using first_tick_has_ticked[of \<open>a\<close> \<open>h\<close> _ \<open>n\<close>]
                               has_ticked_since_earlier[of \<open>a\<close> \<open>h\<close> _ \<open>n\<close> \<open>0\<close>]
                               le0
by blast

text \<open>
  When two clocks have both ticked at instant n, the second one has ticked since instant 0.
\<close>
lemma hbt_htb:
  assumes \<open>have_both_ticked a b h n\<close>
    shows \<open>has_ticked_since b h 0 n\<close>
using btn_btn0[OF assms] unfolding has_first_since_def
                         using first_tick_has_ticked[of \<open>b\<close> \<open>h\<close> _ \<open>n\<close>]
                               has_ticked_since_earlier[of \<open>b\<close> \<open>h\<close> _ \<open>n\<close> \<open>0\<close>]
                               le0
by blast

text \<open>
  When a clock has ticked in [n0, n], it cannot have its first tick since n0 at n+1.
\<close>
lemma ht_nft:
  assumes \<open>has_ticked_since a h n\<^sub>0 n\<close>
    shows \<open>\<not>first_tick_since a h n\<^sub>0 (Suc n)\<close>
proof
  assume h:\<open>first_tick_since a h n\<^sub>0 (Suc n)\<close>
  hence \<open>\<forall>t. (n\<^sub>0 \<le> t \<and> t \<le> n) \<longrightarrow> \<not>ticks a (h t)\<close>
    by (simp add: first_tick_since_def)
  moreover from assms have \<open>\<exists>t. n\<^sub>0 \<le> t \<and> t \<le> n \<and> ticks a (h t)\<close>
    by (simp add: has_ticked_since_def)
  ultimately show False by blast
qed

text \<open>
  If two clocks have both ticked at n0, and then later at n, each of these clocks
  has necessarily ticked in ]n0, n].
  This theorem shows that when the inductive introduction rules of have_both_ticked
  are used, n0 is necessarily the latest instant which satisfies the introduction rule.
\<close>

lemma hbt_hts:\<open>\<lbrakk>have_both_ticked a b h n; have_both_ticked a b h n\<^sub>0; n > n\<^sub>0 \<rbrakk>
            \<Longrightarrow> has_ticked_since a h (Suc n\<^sub>0) n \<and> has_ticked_since b h (Suc n\<^sub>0) n\<close>
proof (induction n arbitrary: n\<^sub>0 rule: nat_strong_induct)
  case 0 thus ?case by simp
next
  case (Suc k)
    from Suc.prems(1) and btn_btn0 have
      *:\<open>\<exists>m. has_first_since a b h 0 (Suc k)
           \<or> has_first_since b a h 0 (Suc k)
           \<or> (have_both_ticked a b h m \<and>
               (has_first_since a b h (Suc m) (Suc k) \<or> has_first_since b a h (Suc m) (Suc k))
             )\<close> by blast
    let ?S = \<open>{m. have_both_ticked a b h m
               \<and> (has_first_since a b h (Suc m) (Suc k) \<or> has_first_since b a h (Suc m) (Suc k))}\<close>
    from Suc.prems(2,3) have \<open>\<not>first_tick_since b h 0 (Suc k)\<close>
      using has_ticked_since_later hbt_htb ht_nft less_Suc_eq_le by blast
    moreover from Suc.prems(2,3) have \<open>\<not>first_tick_since a h 0 (Suc k)\<close>
      using has_ticked_since_later hbt_hta ht_nft less_Suc_eq_le by blast
    moreover have \<open>\<not>has_first_since b a h 0 (Suc k)\<close>
      by (simp add: calculation(2) has_first_since_def)
    moreover have \<open>\<not>has_first_since a b h 0 (Suc k)\<close>
      by (simp add: calculation(1) has_first_since_def)
    ultimately have s_not_empty:\<open>?S \<noteq> {}\<close> using * by simp
    have \<open>has_ticked_since a h (Suc n\<^sub>0) (Suc k) \<and> has_ticked_since b h (Suc n\<^sub>0) (Suc k)\<close>
    proof (cases \<open>\<forall>m \<in> ?S. m < n\<^sub>0\<close>)
      case True \<comment> \<open> Impossible case \<close>
        with True Suc.prems Suc.IH have
          mht:\<open>\<forall>m\<in>?S. has_ticked_since a h (Suc m) n\<^sub>0 \<and> has_ticked_since b h (Suc m) n\<^sub>0\<close> by simp
        have nft:
          \<open>\<forall>m \<in> ?S. \<not>first_tick_since a h (Suc m) (Suc k) \<and> \<not>first_tick_since b h (Suc m) (Suc k)\<close>
        proof -
          { fix m assume mS:\<open>m \<in> ?S\<close>
            with mht have \<open>has_ticked_since a h (Suc m) n\<^sub>0\<close> by simp
            with Suc.prems(3) have \<open>has_ticked_since a h (Suc m) k\<close>
              by (simp add:has_ticked_since_later)
            hence \<open>\<not>first_tick_since a h (Suc m) (Suc k)\<close> by (rule ht_nft)
            moreover from mS mht have \<open>has_ticked_since b h (Suc m) n\<^sub>0\<close> by simp
            with Suc.prems(3) have \<open>has_ticked_since b h (Suc m) k\<close>
              by (simp add:has_ticked_since_later)
            hence \<open>\<not>first_tick_since b h (Suc m) (Suc k)\<close> by (rule ht_nft)
            ultimately have
              \<open>\<not>first_tick_since a h (Suc m) (Suc k) \<and> \<not>first_tick_since b h (Suc m) (Suc k)\<close>
            by simp
          }
          thus ?thesis ..
        qed

        have False
        proof -
          { fix m assume mS:\<open>m\<in>?S\<close>
            with nft have
              \<open>\<not>first_tick_since a h (Suc m) (Suc k) \<and> \<not>first_tick_since b h (Suc m) (Suc k)\<close>
            by blast
            moreover from mS have
              \<open>have_both_ticked a b h m \<and>
              (has_first_since a b h (Suc m) (Suc k)
                \<or> has_first_since b a h (Suc m) (Suc k))\<close> by simp
            hence
              \<open>first_tick_since a h (Suc m) (Suc k) \<or> first_tick_since b h (Suc m) (Suc k)\<close>
            unfolding has_first_since_def by auto
            ultimately have False by simp
          }
          with s_not_empty show ?thesis by blast
        qed
        thus ?thesis ..
    next
      case False
        hence \<open>\<exists>m \<in> ?S. m\<ge>n\<^sub>0\<close> by auto
        from this obtain m where mprop:\<open>m\<in>?S \<and> m \<ge>n\<^sub>0\<close> by blast
        hence \<open>has_first_since a b h (Suc m) (Suc k)
             \<or> has_first_since b a h (Suc m) (Suc k)\<close> by simp
        with hft_ht[of \<open>a\<close> \<open>b\<close> \<open>h\<close> \<open>Suc m\<close> \<open>Suc k\<close>]
             hft_ht[of \<open>b\<close> \<open>a\<close> \<open>h\<close> \<open>Suc m\<close> \<open>Suc k\<close>] have
          \<open>(has_ticked_since a h (Suc m) (Suc k) \<and> has_ticked_since b h (Suc m) (Suc k))
         \<or> (has_ticked_since b h (Suc m) (Suc k) \<and> has_ticked_since a h (Suc m) (Suc k))\<close>
        by blast
        hence \<open>has_ticked_since a h (Suc m) (Suc k) \<and> has_ticked_since b h (Suc m) (Suc k)\<close>
          by blast
        hence htsa:\<open>has_ticked_since a h (Suc m) (Suc k)\<close>
        and   htsb:\<open>has_ticked_since b h (Suc m) (Suc k)\<close> by simp+
        from mprop have \<open>n\<^sub>0 \<le> m\<close> by simp
        hence \<open>Suc n\<^sub>0 \<le> Suc m\<close> by simp
        from has_ticked_since_earlier[OF htsa this]
             has_ticked_since_earlier[OF htsb this] show ?thesis ..
    qed
    with Suc.IH show ?case by simp
qed

(* Same proof with the less practical nat_less_induct induction rule *)
lemma \<open>\<lbrakk>have_both_ticked a b h n; have_both_ticked a b h n\<^sub>0; n > n\<^sub>0 \<rbrakk>
    \<Longrightarrow> has_ticked_since a h (Suc n\<^sub>0) n \<and> has_ticked_since b h (Suc n\<^sub>0) n\<close>
proof (induction n arbitrary: n\<^sub>0 rule: nat_less_induct)
  case (1 n) print_facts
    from "1.prems"(3) have \<open>0 < n\<close> by simp
    hence \<open>\<exists>n\<^sub>1. Suc n\<^sub>1 = n\<close> by presburger
    from this obtain n\<^sub>1 where n1prop:\<open>Suc n\<^sub>1 = n\<close> by blast
    with "1.prems"(3) have n1prop':\<open>n\<^sub>0 \<le> n\<^sub>1\<close> by simp
    from "1.prems"(1) and btn_btn0 have
      *:\<open>\<exists>m. has_first_since a b h 0 n
           \<or> has_first_since b a h 0 n
           \<or> (have_both_ticked a b h m \<and>
               (has_first_since a b h (Suc m) n \<or> has_first_since b a h (Suc m) n)
             )\<close> by blast
    let ?S = \<open>{m. have_both_ticked a b h m
               \<and> (has_first_since a b h (Suc m) n \<or> has_first_since b a h (Suc m) n)}\<close>
    from ht_nft[OF has_ticked_since_later[OF hbt_htb[OF "1.prems"(2)] n1prop']]
      have \<open>\<not>first_tick_since b h 0 n\<close> using n1prop by simp
    moreover from ht_nft[OF has_ticked_since_later[OF hbt_hta[OF "1.prems"(2)] n1prop']]
      have \<open>\<not>first_tick_since a h 0 n\<close> using n1prop by simp
    moreover have \<open>\<not>has_first_since a b h 0 n\<close> by (simp add: calculation(1) has_first_since_def)
    moreover have \<open>\<not>has_first_since b a h 0 n\<close> by (simp add: calculation(2) has_first_since_def)
    ultimately have s_not_empty:\<open>?S \<noteq> {}\<close> using * by simp
    have \<open>has_ticked_since a h (Suc n\<^sub>0) n \<and> has_ticked_since b h (Suc n\<^sub>0) n\<close>
    proof (cases \<open>\<forall>m \<in> ?S. m < n\<^sub>0\<close>)
      case True \<comment> \<open> Impossible case \<close>
        with True "1.prems" "1.IH" have
          mht:\<open>\<forall>m\<in>?S. has_ticked_since a h (Suc m) n\<^sub>0 \<and> has_ticked_since b h (Suc m) n\<^sub>0\<close> by simp
        have
          nft:\<open>\<forall>m \<in> ?S. \<not>first_tick_since a h (Suc m) n \<and> \<not>first_tick_since b h (Suc m) n\<close>
        proof -
          { fix m assume mS:\<open>m \<in> ?S\<close>
            with mht have \<open>has_ticked_since a h (Suc m) n\<^sub>0\<close> by simp
            \<comment> \<open> This part is awkward because of the form of the induction rule
               which gives P n instead of P (Suc n) \<close>
            with "1.prems"(3) have \<open>has_ticked_since a h (Suc m) (n - 1)\<close>
              by (simp add:has_ticked_since_later)
            hence \<open>\<not>first_tick_since a h (Suc m) n\<close> using ht_nft "1.prems"(3) by fastforce
            moreover from mS mht have \<open>has_ticked_since b h (Suc m) n\<^sub>0\<close> by simp
            with "1.prems"(3) have \<open>has_ticked_since b h (Suc m) (n - 1)\<close>
              by (simp add:has_ticked_since_later)
            hence \<open>\<not>first_tick_since b h (Suc m) n\<close> using ht_nft "1.prems"(3) by fastforce
            ultimately have \<open>\<not>first_tick_since a h (Suc m) n \<and> \<not>first_tick_since b h (Suc m) n\<close>
              by simp
          }
          thus ?thesis ..
        qed
        have False
        proof -
          { fix m assume mS:\<open>m\<in>?S\<close>
            with nft have \<open>\<not>first_tick_since a h (Suc m) n \<and> \<not>first_tick_since b h (Suc m) n\<close>
              by blast
            moreover from mS have
              \<open>have_both_ticked a b h m \<and>
              (has_first_since a b h (Suc m) n
                \<or> has_first_since b a h (Suc m) n)\<close> by simp
            hence
              \<open>first_tick_since a h (Suc m) n \<or> first_tick_since b h (Suc m) n\<close>
            unfolding has_first_since_def by auto
            ultimately have False by simp
          }
          with s_not_empty show ?thesis by blast
        qed
        thus ?thesis ..
    next
      case False
        hence \<open>\<exists>m \<in> ?S. m\<ge>n\<^sub>0\<close> by auto
        from this obtain m where mprop:\<open>m\<in>?S \<and> m \<ge>n\<^sub>0\<close> by blast
        hence \<open>has_first_since a b h (Suc m) n \<or> has_first_since b a h (Suc m) n\<close> by simp
        with hft_ht[of \<open>a\<close> \<open>b\<close> \<open>h\<close> \<open>Suc m\<close> \<open>n\<close>]
             hft_ht[of \<open>b\<close> \<open>a\<close> \<open>h\<close> \<open>Suc m\<close> \<open>n\<close>] have
          \<open>(has_ticked_since a h (Suc m) n \<and> has_ticked_since b h (Suc m) n)
         \<or> (has_ticked_since b h (Suc m) n \<and> has_ticked_since a h (Suc m) n)\<close>
        by blast
        hence \<open>has_ticked_since a h (Suc m) n \<and> has_ticked_since b h (Suc m) n\<close> by blast
        hence htsa:\<open>has_ticked_since a h (Suc m) n\<close>
        and   htsb:\<open>has_ticked_since b h (Suc m) n\<close> by simp+
        from mprop have \<open>n\<^sub>0 \<le> m\<close> by simp
        hence \<open>Suc n\<^sub>0 \<le> Suc m\<close> by simp
        from has_ticked_since_earlier[OF htsa this]
             has_ticked_since_earlier[OF htsb this] show ?thesis ..
    qed
    with "1.IH" show ?case by simp
qed

text \<open>
  Two useful corollaries of the previous theorem:
  When two clocks have both ticked at an instant, they cannot both tick again
  unless each of them ticks after this instant.
\<close>
corollary nhtsa:
  assumes \<open>have_both_ticked a b h n\<^sub>0\<close>
      and \<open>n > n\<^sub>0\<close>
      and \<open>\<not>has_ticked_since a h (Suc n\<^sub>0) n\<close>
    shows \<open>\<not>have_both_ticked a b h n\<close>
using assms hbt_hts by blast

corollary nhtsb:
  assumes \<open>have_both_ticked a b h n\<^sub>0\<close>
      and \<open>n > n\<^sub>0\<close>
      and \<open>\<not>has_ticked_since b h (Suc n\<^sub>0) n\<close>
    shows \<open>\<not>have_both_ticked a b h n\<close>
using assms hbt_hts by blast

text \<open>
  between a b h n
  Tell at instant n whether we are still waiting for a tick on b
  since the last tick of a on hamlet h.
\<close>
definition between :: \<open>('\<AA>::orderedrank,'a)\<H> \<Rightarrow> ('\<AA>,'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> bool\<close>
where
  \<open>between a b h n \<equiv> (\<exists>m < n. (ticks a (h m) \<and> (\<forall>k. m \<le> k \<and> k < n \<longrightarrow> \<not>ticks b (h k))))\<close>

text \<open>
  Same, defined as a function.
\<close>
fun between_fun :: \<open>('\<AA>::orderedrank,'a)\<H> \<Rightarrow> ('\<AA>,'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> bool\<close>
where
  \<open>between_fun a b h 0 = False\<close>
| \<open>between_fun a b h (Suc n) = (\<not>ticks b (h n) \<and> (between_fun a b h n \<or> ticks a (h n)))\<close>

text \<open>
  Same, defined as an inductive predicate.
\<close>
inductive between_ind :: \<open>('\<AA>::orderedrank,'a)\<H> \<Rightarrow> ('\<AA>,'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> bool\<close>
where
  \<open>\<lbrakk>between_ind a b h n; \<not>ticks b (h n)\<rbrakk> \<Longrightarrow> between_ind a b h (Suc n)\<close>
| \<open>\<lbrakk>ticks a (h n); \<not>ticks b (h n)\<rbrakk> \<Longrightarrow> between_ind a b h (Suc n)\<close>

inductive_cases btwn[elim!]:\<open>between_ind a b h (Suc n)\<close>

text \<open>
  The function and the inductive predicate are equivalent.
\<close>
lemma between_ind_is_fun:\<open>between_ind a b h n = between_fun a b h n\<close>
proof (induction n)
  case 0 thus ?case
    using between_fun.simps(1) between_ind.cases by blast
next
  case (Suc k) thus ?case
    using between_ind.intros(1,2) between_fun.simps(2) by blast
qed

text \<open>
  The definition and the inductive predicate are equivalent.
\<close>
lemma between_is_ind:\<open>between a b h n = between_ind a b h n\<close>
proof (induction n rule: nat_strong_induct)
  case 0
    have \<open>between a b h 0 = False\<close> by (simp add: between_def)
    moreover have \<open>between_ind a b h 0 = False\<close> using between_ind.cases by blast
    ultimately show ?case by simp
next
  case (Suc p)
    show ?case
    proof
      assume \<open>between a b h (Suc p)\<close>
      hence \<open>\<exists>m < Suc p. (ticks a (h m) \<and> (\<forall>k. m \<le> k \<and> k < Suc p \<longrightarrow> \<not>ticks b (h k)))\<close>
        by (simp add: between_def)
      from this obtain m where
        mprop:\<open>m < Suc p \<and> (ticks a (h m) \<and> (\<forall>k. m \<le> k \<and> k < Suc p \<longrightarrow> \<not>ticks b (h k)))\<close>
      by blast
      hence ntb:\<open>\<not>ticks b (h p)\<close> by simp
      show \<open>between_ind a b h (Suc p)\<close>
      proof (cases \<open>m = p\<close>)
        case True
          hence \<open>ticks a (h p)\<close> using mprop by blast
          with ntb show ?thesis using between_ind.intros(2) by blast
      next
        case False
          hence \<open>m < p\<close> using mprop by simp
          hence \<open>between a b h p\<close> unfolding between_def using mprop by auto
          hence \<open>between_ind a b h p\<close> using Suc.IH by simp
          with ntb show ?thesis using between_ind.intros(1) by blast
      qed
  next
      assume \<open>between_ind a b h (Suc p)\<close>
      hence \<open>\<not>ticks b (h p) \<and> (between_ind a b h p \<or> ticks a (h p))\<close> by auto
      hence *:\<open>\<not>ticks b (h p) \<and> (between a b h p \<or> ticks a (h p))\<close> using Suc.IH by simp
      thus \<open>between a b h (Suc p)\<close>
      proof (cases \<open>ticks a (h p)\<close>)
        case True thus \<open>between a b h (Suc p)\<close> unfolding between_def
                        using * le_less_Suc_eq by auto
      next
        case False
        with * have \<open>between a b h p\<close> by simp
        moreover from * have \<open>\<not> ticks b (h p)\<close> by simp
        ultimately show \<open>between a b h (Suc p)\<close> unfolding between_def using less_Suc_eq by auto
      qed
  qed
qed

text \<open>
  The definition and the function are equivalent.
\<close>
lemma between_is_fun[code]:
  \<open>between a b h n = between_fun a b h n\<close>
proof (induction n rule: nat_strong_induct)
  case 0 thus ?case using between_def between_fun.simps(1) by blast
next
  case (Suc p)
    from between_fun.simps(2) Suc.IH
      have \<open>between_fun a b h (Suc p) = (\<not>ticks b (h p) \<and> (between a b h p \<or> ticks a (h p)))\<close>
        by simp
    also have \<open>... = between a b h (Suc p)\<close>
    proof (cases \<open>ticks b (h p)\<close>)
      case True thus ?thesis unfolding between_def using less_Suc_eq_le by blast
    next
      case False thus ?thesis unfolding between_def using less_Suc_eq by auto
    qed
    finally show ?case ..
qed

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
\<^marker>\<open>creator "Larry Paulson"\<close>
section \<open>Unordered Pairs\<close>
theory Unordered_Pairs
  imports
    Powerset
    Replacement
begin

text \<open>We define an unordered pair \<open>upair\<close> using replacement.
We then use it to define finite sets in @{file "Finite_Sets.thy"}.\<close>

definition "upair a b \<equiv> {if i = {} then a else b | i \<in> powerset (powerset {})}"

lemma mem_upair_leftI [intro]: "a \<in> upair a b" unfolding upair_def by auto
lemma mem_upair_rightI [intro]: "b \<in> upair a b" unfolding upair_def by auto

lemma mem_upairE [elim!]:
  assumes "x \<in> upair a b"
  obtains "x = a" | "x = b"
  using assms unfolding upair_def by (auto split: if_splits)

lemma mem_upair_iff: "x \<in> upair a b \<longleftrightarrow> x = a \<or> x = b" by auto

definition "insert x A \<equiv> \<Union>(upair A (upair x x))"

lemma mem_insert_leftI [intro]: "x \<in> insert x A"
  unfolding insert_def by auto
lemma mem_insert_rightI [intro]: "y \<in> A \<Longrightarrow> y \<in> insert x A"
  unfolding insert_def by auto

lemma mem_insertE [elim]:
  assumes "y \<in> insert x A"
  obtains "y = x" | "y \<noteq> x" "y \<in> A"
  using assms unfolding insert_def by auto

lemma mem_insert_iff: "y \<in> insert x A \<longleftrightarrow> y = x \<or> y \<in> A" by auto

lemma not_mem_insert_if_not_mem_if_ne: "\<lbrakk>x \<noteq> a; x \<notin> A\<rbrakk> \<Longrightarrow> x \<notin> insert a A" by auto

lemma insert_eq_if_mem [simp]: "a \<in> A \<Longrightarrow> insert a A = A" by auto

(*LP: Classical introduction rule*)
lemma mem_insert_if_not_mem_imp_eq [intro!]:
  "(a \<notin> B \<Longrightarrow> a = b) \<Longrightarrow> a \<in> insert b B"
  by auto

lemma insert_ne_empty [iff]: "insert a B \<noteq> {}"
  by auto

lemma insert_comm: "insert x (insert y A) = insert y (insert x A)"
  by auto

lemma insert_insert_eq_insert [simp]: "insert x (insert x A) = insert x A"
  by auto

lemma bex_insert_iff_or_bex [iff]:
  "(\<exists>x \<in> insert a A. P x) \<longleftrightarrow> (P a \<or> (\<exists>x \<in> A. P x))"
  by auto

lemma ball_insert_iff_and_ball [iff]:
  "(\<forall>x \<in> insert a A. P x) \<longleftrightarrow> (P a \<and> (\<forall>x \<in> A. P x))"
  by auto

lemma mono_insert_set: "mono (insert x)"
  by (intro monoI) auto

subsection \<open>Subsets\<close>

lemma insert_subset_iff_mem_subset [iff]: "insert x A \<subseteq> B \<longleftrightarrow> x \<in> B \<and> A \<subseteq> B"
  by blast

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Proving Falling Factorial of a Sum with Combinatorics\<close>

theory Falling_Factorial_Sum_Combinatorics
imports
  Discrete_Summation.Factorials
  Card_Partitions.Injectivity_Solver
begin

subsection \<open>Preliminaries\<close>

subsubsection \<open>Addition to Factorials Theory\<close>

lemma card_lists_distinct_length_eq:
  assumes "finite A"
  shows "card {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A} = ffact n (card A)"
proof cases
  assume "n \<le> card A"
  have "card {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - n + 1..card A}"
    using \<open>finite A\<close> \<open>n \<le> card A\<close> by (rule card_lists_distinct_length_eq)
  also have "\<dots> = ffact n (card A)"
    using \<open>n \<le> card A\<close> by (simp add: prod_rev_ffact_nat'[symmetric])
  finally show ?thesis .
next
  assume "\<not> n \<le> card A"
  from this \<open>finite A\<close> have "\<forall>xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A \<longrightarrow> False"
    by (metis card_mono distinct_card)
  from this have eq_empty: "{xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A} = {}"
    using \<open>finite A\<close> by auto
  from \<open>\<not> n \<le> card A\<close> show ?thesis
    by (simp add: ffact_nat_triv eq_empty)
qed

subsection \<open>Interleavings of Two Lists\<close>

inductive interleavings :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "interleavings [] ys ys"
| "interleavings xs [] xs"
| "interleavings xs ys zs \<Longrightarrow> interleavings (x#xs) ys (x#zs)"
| "interleavings xs ys zs \<Longrightarrow> interleavings xs (y#ys) (y#zs)"

lemma interleaving_Nil_implies_eq1:
  assumes "interleavings xs ys zs"
  assumes "xs = []"
  shows "ys = zs"
using assms by (induct rule: interleavings.induct) auto

lemma interleaving_Nil_iff1:
  "interleavings [] ys zs \<longleftrightarrow> (ys = zs)"
using interleaving_Nil_implies_eq1
by (auto simp add: interleavings.intros(1))

lemma interleaving_Nil_implies_eq2:
  assumes "interleavings xs ys zs"
  assumes "ys = []"
  shows "xs = zs"
using assms by (induct rule: interleavings.induct) auto

lemma interleaving_Nil_iff2:
  "interleavings xs [] zs \<longleftrightarrow> (xs = zs)"
using interleaving_Nil_implies_eq2
by (auto simp add: interleavings.intros(2))

lemma interleavings_Cons:
  "{zs. interleavings (x#xs) (y#ys) zs} =
    {x#zs|zs. interleavings xs (y#ys) zs} \<union> {y#zs|zs. interleavings (x#xs) ys zs}"
  (is "?S = ?expr")
proof
  show "?S \<subseteq> ?expr"
    by (auto elim: interleavings.cases)
next
  show "?expr \<subseteq> ?S"
    by (auto intro: interleavings.intros)
qed

lemma interleavings_filter:
  assumes "X \<inter> Y = {}" "set zs \<subseteq> X \<union> Y"
  shows "interleavings [z\<leftarrow>zs . z \<in> X] [z\<leftarrow>zs . z \<in> Y] zs"
using assms by (induct zs) (auto intro: interleavings.intros)

lemma interleavings_filter_eq1:
  assumes "interleavings xs ys zs"
  assumes "(\<forall>x\<in>set xs. P x) \<and> (\<forall>y\<in>set ys. \<not> P y)"
  shows "filter P zs = xs"
using assms by (induct rule: interleavings.induct) auto

lemma interleavings_filter_eq2:
  assumes "interleavings xs ys zs"
  assumes "(\<forall>x\<in>set xs. \<not> P x) \<and> (\<forall>y\<in>set ys. P y)"
  shows "filter P zs = ys"
using assms by (induct rule: interleavings.induct) auto

lemma interleavings_set:
  assumes "interleavings xs ys zs"
  shows "set xs \<union> set ys = set zs"
using assms by (induct xs ys zs rule: interleavings.induct) auto

lemma interleavings_distinct:
  assumes "interleavings xs ys zs"
  shows "distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {} \<longleftrightarrow> distinct zs"
using assms interleavings_set by (induct xs ys zs rule: interleavings.induct) fastforce+

lemma two_mutual_lists_induction:
  assumes "\<And>ys. P [] ys"
  assumes "\<And>xs. P xs []"
  assumes "\<And>x xs y ys. P xs (y#ys) \<Longrightarrow> P (x#xs) ys \<Longrightarrow> P (x#xs) (y#ys)"
  shows "P xs ys"
using assms by (induction_schema) (pat_completeness, lexicographic_order)

lemma finite_interleavings:
  "finite {zs. interleavings xs ys zs}"
proof (induct xs ys rule: two_mutual_lists_induction)
  case (1 ys)
  show ?case by (simp add: interleaving_Nil_iff1)
next
  case (2 xs)
  then show ?case by (simp add: interleaving_Nil_iff2)
next
  case (3 x xs y ys)
  then show ?case by (simp add: interleavings_Cons)
qed

lemma card_interleavings:
  assumes "set xs \<inter> set ys = {}"
  shows "card {zs. interleavings xs ys zs} = (length xs + length ys choose (length xs))"
using assms
proof (induct xs ys rule: two_mutual_lists_induction)
  case (1 ys)
  have "card {zs. interleavings [] ys zs} = card {ys}"
    by (simp add: interleaving_Nil_iff1)
  also have "\<dots> = (length [] + length ys choose (length []))" by simp
  finally show ?case .
next
  case (2 xs)
  have "card {zs. interleavings xs [] zs} = card {xs}"
    by (simp add: interleaving_Nil_iff2)
  also have "\<dots> = (length xs + length [] choose (length xs))" by simp
  finally show ?case .
next
  case (3 x xs y ys)
  have "card {zs. interleavings (x # xs) (y # ys) zs} =
    card ({x#zs|zs. interleavings xs (y#ys) zs} \<union> {y#zs|zs. interleavings (x#xs) ys zs})"
    by (simp add: interleavings_Cons)
  also have "\<dots> = card {x#zs|zs. interleavings xs (y#ys) zs} + card {y#zs|zs. interleavings (x#xs) ys zs}"
  proof -
    have "finite {x # zs |zs. interleavings xs (y # ys) zs}"
      by (simp add: finite_interleavings)
    moreover have "finite {y # zs |zs. interleavings (x # xs) ys zs}"
      by (simp add: finite_interleavings)
    moreover have "{x # zs |zs. interleavings xs (y # ys) zs} \<inter> {y # zs |zs. interleavings (x # xs) ys zs} = {}"
      using \<open>set (x # xs) \<inter> set (y # ys) = {}\<close> by auto
    ultimately show ?thesis by (simp add: card_Un_disjoint)
  qed
  also have "\<dots> = card ((\<lambda>zs. x # zs) ` {zs. interleavings xs (y # ys) zs}) +
    card ((\<lambda>zs. y # zs) ` {zs. interleavings (x#xs) ys zs})"
    by (simp add: setcompr_eq_image)
  also have "\<dots> = card {zs. interleavings xs (y # ys) zs} + card {zs. interleavings (x#xs) ys zs}"
    by (simp add: card_image)
  also have "\<dots> = (length xs + length (y # ys) choose length xs) + (length (x # xs) + length ys choose length (x # xs))"
    using 3 by simp
  also have "\<dots> = length (x # xs) + length (y # ys) choose length (x # xs)" by simp
  finally show ?case .
qed

subsection \<open>Cardinality of Distinct Fixed-Length Lists from a Union of Two Sets\<close>

lemma lists_distinct_union_by_interleavings:
  assumes "X \<inter> Y = {}"
  shows "{zs. length zs = n \<and> distinct zs \<and> set zs \<subseteq> X \<union> Y} = do {
    k \<leftarrow> {0..n};
    xs \<leftarrow> {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X};
    ys \<leftarrow> {ys. length ys = n - k \<and> distinct ys \<and> set ys \<subseteq> Y};
    {zs. interleavings xs ys zs}
  }" (is "?S = ?expr")
proof
  show "?S \<subseteq> ?expr"
  proof
    fix zs
    assume "zs \<in> ?S"
    from this have "length zs = n" and "distinct zs" and "set zs \<subseteq> X \<union> Y" by auto
    define xs where "xs = filter (\<lambda>z. z \<in> X) zs"
    define ys where "ys = filter (\<lambda>z. z \<in> Y) zs"
    have eq: "[z\<leftarrow>zs . z \<in> Y] = [z\<leftarrow>zs . z \<notin> X]"
      using \<open>set zs \<subseteq> X \<union> Y\<close> \<open>X \<inter> Y = {}\<close>
      by (auto intro: filter_cong)
    have "length xs \<le> n \<and> distinct xs \<and> set xs \<subseteq> X"
      using \<open>length zs = n\<close> \<open>distinct zs\<close> unfolding xs_def by auto
    moreover have "length ys = n - length xs"
      using \<open>set zs \<subseteq> X \<union> Y\<close> \<open>length zs = n\<close>
      unfolding xs_def ys_def eq
      by (metis diff_add_inverse sum_length_filter_compl)
    moreover have "distinct ys \<and> set ys \<subseteq> Y"
      using \<open>distinct zs\<close> unfolding ys_def by auto
    moreover have "interleavings xs ys zs"
      using xs_def ys_def \<open>X \<inter> Y = {}\<close> \<open>set zs \<subseteq> X \<union> Y\<close>
      by (simp add: interleavings_filter)
    ultimately show "zs \<in> ?expr" by force
  qed
next
  show "?expr \<subseteq> ?S"
  proof
    fix zs
    assume "zs \<in> ?expr"
    from this obtain xs ys where "length xs \<le> n" "distinct xs" "set xs \<subseteq> X"
      and "length ys = n - length xs" "distinct ys" "set ys \<subseteq> Y" "interleavings xs ys zs" by auto
    have "length zs = n"
      using \<open>length xs \<le> n\<close> \<open>length ys = n - length xs\<close> \<open>interleavings xs ys zs\<close>
      using interleavings_length by force
    moreover have "distinct zs"
      using \<open>distinct xs\<close> \<open>distinct ys\<close> \<open>interleavings xs ys zs\<close> \<open>set xs \<subseteq> X\<close> \<open>set ys \<subseteq> Y\<close>
      using \<open>X \<inter> Y = {}\<close> interleavings_distinct by fastforce
    moreover have "set zs \<subseteq> X \<union> Y"
      using \<open>interleavings xs ys zs\<close> \<open>set xs \<subseteq> X\<close> \<open>set ys \<subseteq> Y\<close> interleavings_set by blast
    ultimately show "zs \<in> ?S" by blast
  qed
qed

lemma interleavings_inject:
  assumes "(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}"
  assumes "interleavings xs ys zs" "interleavings xs' ys' zs'"
  assumes "zs = zs'"
  shows "xs = xs'" and "ys = ys'"
proof -
  have "xs = filter (\<lambda>z. z \<in> set xs \<union> set xs') zs"
    using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs ys zs\<close>
    by (auto intro: interleavings_filter_eq1[symmetric])
  also have "\<dots> = filter (\<lambda>z. z \<in> set xs \<union> set xs') zs'"
    using \<open>zs = zs'\<close> by simp
  also have "\<dots> = xs'"
    using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs' ys' zs'\<close>
    by (auto intro: interleavings_filter_eq1)
  finally show "xs = xs'" by simp
  have "ys = filter (\<lambda>z. z \<in> set ys \<union> set ys') zs"
    using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs ys zs\<close>
    by (auto intro: interleavings_filter_eq2[symmetric])
  also have "\<dots> = filter (\<lambda>z. z \<in> set ys \<union> set ys') zs'"
    using \<open>zs = zs'\<close> by simp
  also have "\<dots> = ys'"
    using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs' ys' zs'\<close>
    by (auto intro: interleavings_filter_eq2)
  finally show "ys = ys'" .
qed

lemma injectivity:
  assumes "X \<inter> Y = {}"
  assumes "k \<in> {0..n} \<and> k' \<in> {0..n}"
  assumes "(length xs = k \<and> distinct xs \<and> set xs \<subseteq> X) \<and> (length xs' = k' \<and> distinct xs' \<and> set xs' \<subseteq> X)"
  assumes "(length ys = n - k \<and> distinct ys \<and> set ys \<subseteq> Y) \<and> (length ys' = n - k' \<and> distinct ys' \<and> set ys' \<subseteq> Y)"
  assumes "interleavings xs ys zs \<and> interleavings xs' ys' zs'"
  assumes "zs = zs'"
  shows "k = k'" and "xs = xs'" and "ys = ys'"
proof -
  from assms(1,3,4) have "(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}" by blast
  from this assms(5) \<open>zs = zs'\<close> show "xs = xs'" and "ys = ys'"
    using interleavings_inject by fastforce+
  from this assms(3) show "k = k'" by auto
qed

lemma card_lists_distinct_length_eq_union:
  assumes "finite X" "finite Y" "X \<inter> Y = {}"
  shows "card {zs. length zs = n \<and> distinct zs \<and> set zs \<subseteq> X \<union> Y} =
    (\<Sum>k=0..n. (n choose k) * ffact k (card X) * ffact (n - k) (card Y))"
  (is "card ?S = _")
proof -
  let ?expr = "do {
    k \<leftarrow> {0..n};
    xs \<leftarrow> {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X};
    ys \<leftarrow> {ys. length ys = n - k \<and> distinct ys \<and> set ys \<subseteq> Y};
    {zs. interleavings xs ys zs}
  }"
  from \<open>X \<inter> Y = {}\<close> have "card ?S = card ?expr"
    by (simp add: lists_distinct_union_by_interleavings)
  let "?S \<bind> ?comp" = "?expr"
  {
    fix k
    assume "k \<in> ?S"
    let "?expr" = "?comp k"
    let "?S \<bind> ?comp" = "?expr"
    from \<open>finite X\<close> have "finite ?S" by auto
    moreover {
      fix xs
      assume xs: "xs \<in> ?S"
      let ?expr = "?comp xs"
      let "?S \<bind> ?comp" = ?expr
      from \<open>finite Y\<close> have "finite ?S" by auto
      moreover {
        fix ys
        assume ys: "ys \<in> ?S"
        let ?expr = "?comp ys"
        have "finite ?expr"
          by (simp add: finite_interleavings)
        moreover have "card ?expr = (n choose k)"
          using xs ys \<open>X \<inter> Y = {}\<close> \<open>k \<in> _\<close>
          by (subst card_interleavings) auto
        ultimately have "finite ?expr \<and> card ?expr = (n choose k)" ..
      }
      moreover have "disjoint_family_on ?comp ?S"
        using \<open>k \<in> {0..n}\<close> \<open>xs \<in> {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X}\<close>
        by (injectivity_solver rule: injectivity(3)[OF \<open>X \<inter> Y = {}\<close>])
      moreover have "card ?S = ffact (n - k) (card Y)"
        using \<open>finite Y\<close> by (simp add: card_lists_distinct_length_eq)
      ultimately have "card ?expr = (n choose k) * ffact (n - k) (card Y)"
        by (subst card_bind_constant) auto
      moreover have "finite ?expr"
        using \<open>finite ?S\<close> by (auto intro!: finite_bind finite_interleavings)
      ultimately have "finite ?expr \<and> card ?expr = (n choose k) * ffact (n - k) (card Y)"
        by blast
    }
    moreover have "disjoint_family_on ?comp ?S"
      using \<open>k \<in> {0..n}\<close>
      by (injectivity_solver rule: injectivity(2)[OF \<open>X \<inter> Y = {}\<close>])
    moreover have "card ?S = ffact k (card X)"
      using \<open>finite X\<close> by (simp add: card_lists_distinct_length_eq)
    ultimately have "card ?expr = (n choose k) * ffact k (card X) * ffact (n - k) (card Y)"
      by (subst card_bind_constant) auto
    moreover have "finite ?expr"
      using \<open>finite ?S\<close> \<open>finite Y\<close> by (auto intro!: finite_bind finite_interleavings)
    ultimately have "finite ?expr \<and> card ?expr = (n choose k) * ffact k (card X) * ffact (n - k) (card Y)"
      by blast
  }
  moreover have "disjoint_family_on ?comp ?S"
    by (injectivity_solver rule: injectivity(1)[OF \<open>X \<inter> Y = {}\<close>])
  ultimately have "card ?expr = (\<Sum>k=0..n. (n choose k) * ffact k (card X) * ffact (n - k) (card Y))"
    by (auto simp add: card_bind)
  from \<open>card _ = card ?expr\<close> this show ?thesis by simp
qed

lemma
  "ffact n (x + y) = (\<Sum>k=0..n. (n choose k) * ffact k x * ffact (n - k) y)"
proof -
  define X where "X = {..<x}"
  define Y where "Y = {x..<x+y}"
  have "finite X" and "card X = x" unfolding X_def by auto
  have "finite Y" and "card Y = y" unfolding Y_def by auto
  have "X \<inter> Y = {}" unfolding X_def Y_def by auto
  have "ffact n (x + y) = ffact n (card X + card Y)"
    using \<open>card X = x\<close> \<open>card Y = y\<close> by simp
  also have "\<dots> = ffact n (card (X \<union> Y))"
    using \<open>X \<inter> Y = {}\<close> \<open>finite X\<close> \<open>finite Y\<close> by (simp add: card_Un_disjoint)
  also have "\<dots> = card {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> X \<union> Y}"
   using \<open>finite X\<close> \<open>finite Y\<close> by (simp add: card_lists_distinct_length_eq)
  also have "\<dots> = (\<Sum>k=0..n. (n choose k) * ffact k (card X) * ffact (n - k) (card Y))"
    using \<open>X \<inter> Y = {}\<close> \<open>finite X\<close> \<open>finite Y\<close> by (simp add: card_lists_distinct_length_eq_union)
  also have "\<dots> = (\<Sum>k=0..n. (n choose k) * ffact k x * ffact (n - k) y)"
    using \<open>card X = x\<close> \<open>card Y = y\<close> by simp
  finally show ?thesis .
qed

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
\<^marker>\<open>creator "Larry Paulson"\<close>
section \<open>Bounded Quantifiers\<close>
theory Bounded_Quantifiers
  imports Order_Set
begin

definition ball :: \<open>set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> bool\<close>
  where "ball A P \<equiv> (\<forall>x. x \<in> A \<longrightarrow> P x)"

definition bex :: \<open>set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> bool\<close>
  where "bex A P \<equiv> \<exists>x. x \<in> A \<and> P x"

definition bex1 :: \<open>set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> bool\<close>
  where "bex1 A P \<equiv> \<exists>!x. x \<in> A \<and> P x"

bundle hotg_bounded_quantifiers_syntax
begin
syntax
  "_ball"  :: \<open>[idts, set, bool] \<Rightarrow> bool\<close> ("(2\<forall>_ \<in> _./ _)" 10)
  "_ball2" :: \<open>[idts, set, bool] \<Rightarrow> bool\<close>
  "_bex"   :: \<open>[idts, set, bool] \<Rightarrow> bool\<close> ("(2\<exists>_ \<in> _./ _)" 10)
  "_bex2"  :: \<open>[idts, set, bool] \<Rightarrow> bool\<close>
  "_bex1"  :: \<open>[idt, set, bool] \<Rightarrow> bool\<close> ("(2\<exists>!_ \<in> _./ _)" 10)
end
bundle no_hotg_bounded_quantifiers_syntax
begin
no_syntax
  "_ball"  :: \<open>[idts, set, bool] \<Rightarrow> bool\<close> ("(2\<forall>_ \<in> _./ _)" 10)
  "_ball2" :: \<open>[idts, set, bool] \<Rightarrow> bool\<close>
  "_bex"   :: \<open>[idts, set, bool] \<Rightarrow> bool\<close> ("(2\<exists>_ \<in> _./ _)" 10)
  "_bex2"  :: \<open>[idts, set, bool] \<Rightarrow> bool\<close>
  "_bex1"  :: \<open>[idt, set, bool] \<Rightarrow> bool\<close> ("(2\<exists>!_ \<in> _./ _)" 10)
end
unbundle hotg_bounded_quantifiers_syntax
translations
  "\<forall>x xs \<in> A. P" \<rightharpoonup> "CONST ball A (\<lambda>x. _ball2 xs A P)"
  "_ball2 x A P" \<rightharpoonup> "\<forall>x \<in> A. P"
  "\<forall>x \<in> A. P" \<rightleftharpoons> "CONST ball A (\<lambda>x. P)"

  "\<exists>x xs \<in> A. P" \<rightharpoonup> "CONST bex A (\<lambda>x. _bex2 xs A P)"
  "_bex2 x A P" \<rightharpoonup> "\<exists>x \<in> A. P"
  "\<exists>x \<in> A. P" \<rightleftharpoons> "CONST bex A (\<lambda>x. P)"

  "\<exists>!x \<in> A. P" \<rightleftharpoons> "CONST bex1 A (\<lambda>x. P)"

text\<open>Setup of one point rules.\<close>

simproc_setup defined_bex ("\<exists>x \<in> A. P x \<and> Q x") =
  \<open>fn _ => Quantifier1.rearrange_Bex
    (fn ctxt => unfold_tac ctxt @{thms bex_def})\<close>

simproc_setup defined_ball ("\<forall>x \<in> A. P x \<longrightarrow> Q x") =
  \<open>fn _ => Quantifier1.rearrange_Ball
    (fn ctxt => unfold_tac ctxt @{thms ball_def})\<close>

lemma ballI [intro!]: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> P x\<rbrakk> \<Longrightarrow> \<forall>x \<in> A. P x"
  by (simp add: ball_def)

lemma ballD [dest?]: "\<lbrakk>\<forall>x \<in> A. P x; x \<in> A\<rbrakk> \<Longrightarrow> P x"
  by (simp add: ball_def)

lemma ballE:
  assumes "\<forall>x \<in> A. P x"
  obtains "\<And>x. x \<in> A \<Longrightarrow> P x"
  using assms unfolding ball_def by auto

lemma ballE' [elim]:
  assumes "\<forall>x \<in> A. P x"
  obtains "x \<notin> A" | "P x"
  using assms by (auto elim: ballE)

(*LP: Trival rewrite rule: \<open>(\<forall>x \<in> A. P) \<longleftrightarrow> P\<close> holds only if A is nonempty!*)
lemma ball_iff_ex_mem [iff]: "(\<forall>x \<in> A. P) \<longleftrightarrow> ((\<exists>x. x \<in> A) \<longrightarrow> P)"
  by (simp add: ball_def)

lemma ball_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x \<in> A' \<Longrightarrow> P x \<longleftrightarrow> P' x\<rbrakk> \<Longrightarrow> (\<forall>x \<in> A. P x) \<longleftrightarrow> (\<forall>x \<in> A'. P' x)"
  by (simp add: ball_def)

lemma ball_or_iff_ball_or [iff]: "(\<forall>x \<in> A. P x \<or> Q) \<longleftrightarrow> ((\<forall>x \<in> A. P x) \<or> Q)"
  by auto

lemma ball_or_iff_or_ball [iff]: "(\<forall>x \<in> A. P \<or> Q x) \<longleftrightarrow> (P \<or> (\<forall>x \<in> A. Q x))"
  by auto

lemma ball_imp_iff_imp_ball [iff]: "(\<forall>x \<in> A. P \<longrightarrow> Q x) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x \<in> A. Q x))"
  by auto

lemma ball_empty [iff]: "\<forall>x \<in> {}. P x" by auto

lemma atomize_ball:
  "(\<And>x. x \<in> A \<Longrightarrow> P x) \<equiv> Trueprop (\<forall>x \<in> A. P x)"
  by (simp only: ball_def atomize_all atomize_imp)

declare atomize_ball[symmetric, rulify]
declare atomize_ball[symmetric, defn]

lemma bexI [intro]: "\<lbrakk>P x; x \<in> A\<rbrakk> \<Longrightarrow> \<exists>x \<in> A. P x"
  by (simp add: bex_def, blast)

(*LP: The best argument order when there is only one @{term "x \<in> A"}*)
corollary bexI': "\<lbrakk>x \<in> A; P x\<rbrakk> \<Longrightarrow> \<exists>x \<in> A. P x" ..

lemma bexE [elim!]: "\<lbrakk>\<exists>x \<in> A. P x; \<And>x. \<lbrakk>x \<in> A; P x\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding bex_def by blast

(*LP: We do not even have @{term "(\<exists>x \<in> A. True) \<longleftrightarrow> True"} unless @{term "A"} is
  nonempty.*)
lemma bex_iff_ex_and [simp]: "(\<exists>x \<in> A. P) \<longleftrightarrow> ((\<exists>x. x \<in> A) \<and> P)"
  unfolding bex_def by simp

lemma bex_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x \<in> A' \<Longrightarrow> P x \<longleftrightarrow> P' x\<rbrakk> \<Longrightarrow> (\<exists>x \<in> A. P x) \<longleftrightarrow> (\<exists>x \<in> A'. P' x)"
  unfolding bex_def by (simp cong: conj_cong)

lemma bex_and_iff_bex_and [simp]: "(\<exists>x \<in> A. P x \<and> Q) \<longleftrightarrow> ((\<exists>x \<in> A. P x) \<and> Q)"
  by auto

lemma bex_and_iff_or_bex [simp]: "(\<exists>x \<in> A. P \<and> Q x) \<longleftrightarrow> (P \<and> (\<exists>x \<in> A. Q x))"
  by auto

lemma not_bex_empty [iff]: "\<not>(\<exists>x \<in> {}. P x)" by auto

lemma ball_imp_iff_bex_imp [simp]: "(\<forall>x \<in> A. P x \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x \<in> A. P x) \<longrightarrow> Q)"
  by auto

lemma not_ball_iff_bex_not [simp]: "(\<not>(\<forall>x \<in> A. P x)) \<longleftrightarrow> (\<exists>x \<in> A. \<not>P x)"
  by auto

lemma not_bex_iff_ball_not [simp]: "(\<not>(\<exists>x \<in> A. P x)) \<longleftrightarrow> (\<forall>x \<in> A. \<not>P x)"
  by auto

lemma bex1I [intro]: "\<lbrakk>P x; x \<in> A; \<And>z. \<lbrakk>P z; z \<in> A\<rbrakk> \<Longrightarrow> z = x\<rbrakk> \<Longrightarrow> \<exists>!x \<in> A. P x"
  by (simp add: bex1_def, blast)

lemma bex1I': "\<lbrakk>x \<in> A; P x; \<And>z. \<lbrakk>P z; z \<in> A\<rbrakk> \<Longrightarrow> z = x\<rbrakk> \<Longrightarrow> \<exists>!x \<in> A. P x"
  by blast

lemma bex1E [elim!]: "\<lbrakk>\<exists>!x \<in> A. P x; \<And>x. \<lbrakk>x \<in> A; P x\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (simp add: bex1_def, blast)

lemma bex1_triv [simp]: "(\<exists>!x \<in> A. P) \<longleftrightarrow> ((\<exists>!x. x \<in> A) \<and> P)"
  by (auto simp add: bex1_def)

lemma bex1_iff: "(\<exists>!x \<in> A. P x) \<longleftrightarrow> (\<exists>!x. x \<in> A \<and> P x)"
  by (auto simp add: bex1_def)

lemma bex1_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x \<in> A' \<Longrightarrow> P x \<longleftrightarrow> P' x\<rbrakk> \<Longrightarrow> (\<exists>!x \<in> A. P x) \<longleftrightarrow> (\<exists>!x \<in> A'. P' x)"
  by (simp add: bex1_def cong: conj_cong)

lemma bex_if_bex1: "\<exists>!x \<in> A. P x \<Longrightarrow> \<exists>x \<in> A. P x"
  by auto

lemma ball_conj_distrib: "(\<forall>x \<in> A. P x \<and> Q x) \<longleftrightarrow> (\<forall>x \<in> A. P x) \<and> (\<forall>x \<in> A. Q x)"
  by auto

lemma antimono_ball_set: "antimono (\<lambda>A. \<forall>x \<in> A. P x)"
  by (intro antimonoI) auto

lemma mono_ball_pred: "mono (\<lambda>P. \<forall>x \<in> A. P x)"
  by (intro monoI) auto

lemma mono_bex_set: "mono (\<lambda>A. \<exists>x \<in> A. P x)"
  by (intro monoI) auto

lemma mono_bex_pred: "mono (\<lambda>P. \<exists>x \<in> A. P x)"
  by (intro monoI) auto

section \<open>Bounded definite description\<close>

definition bthe :: "set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> set"
  where "bthe A P \<equiv> The (\<lambda>x. x \<in> A \<and> P x)"

bundle hotg_bounded_the_syntax
begin
syntax "_bthe" :: "[pttrn, set, bool] \<Rightarrow> set" ("(3THE _ \<in> _./ _)" [0, 0, 10] 10)
end
bundle no_hotg_bounded_the_syntax
begin
no_syntax "_bthe" :: "[pttrn, set, bool] \<Rightarrow> set" ("(3THE _ \<in> _./ _)" [0, 0, 10] 10)
end
unbundle hotg_bounded_the_syntax

translations "THE x \<in> A. P" \<rightleftharpoons> "CONST bthe A (\<lambda>x. P)"

lemma bthe_eqI [intro]:
  assumes "P a"
  and "a \<in> A"
  and "\<And>x. \<lbrakk>x \<in> A; P x\<rbrakk> \<Longrightarrow> x = a"
  shows "(THE x \<in> A. P x) = a"
  unfolding bthe_def by (auto intro: assms)

lemma
  bthe_memI: "\<exists>!x \<in> A. P x \<Longrightarrow> (THE x \<in> A. P x) \<in> A" and
  btheI: "\<exists>!x \<in> A. P x \<Longrightarrow> P (THE x \<in> A. P x)"
  unfolding bex1_def bthe_def by (auto simp: theI'[of "\<lambda>x. x \<in> A \<and> P x"])

end


(*  Title:      FourSquares.thy
    Author:     Roelof Oosterhuis, 2007  Rijksuniversiteit Groningen
*)

header {* Lagrange's four-square theorem *}

theory FourSquares
imports "../Fermat3_4/IntNatAux" "~~/src/HOL/Old_Number_Theory/Quadratic_Reciprocity"
begin

text {* Shows that all nonnegative integers can be written as the sum of four squares. The proof consists of the following steps:
\begin{itemize}\item For every prime $p=2n+1$ the two sets of residue classes $$\{x^2 \bmod p\mid 0\le x\le n\} ~{\rm and}~ \{-1-y^2 \bmod p \mid 0 \le y \le n\}$$ both contain $n+1$ different elements and therefore they must have at least one element in common.
\item Hence there exist $x,y$ such that $x^2+y^2+1^2+0^2$ is a multiple of $p$.
\item The next step is to show, by an infinite descent, that $p$ itself can be written as the sum of four squares.
\item Finally, using the multiplicity of this form, the same holds for all positive numbers.
\end{itemize} *}

definition
  sum4sq :: "int \<times> int \<times> int \<times> int \<Rightarrow> int" where
  "sum4sq = (\<lambda>(a,b,c,d). a^2+b^2+c^2+d^2)"

definition
  is_sum4sq :: "int \<Rightarrow> bool" where
  "is_sum4sq x \<longleftrightarrow> (\<exists> a b c d. sum4sq(a,b,c,d) = x)"

lemma mult_sum4sq: "sum4sq(a,b,c,d) * sum4sq(p,q,r,s) =
  sum4sq(a*p+b*q+c*r+d*s, a*q-b*p-c*s+d*r,
         a*r+b*s-c*p-d*q, a*s-b*r+c*q-d*p)"
  by (unfold sum4sq_def, simp add: eval_nat_numeral field_simps)

lemma is_mult_sum4sq: "is_sum4sq x \<Longrightarrow> is_sum4sq y \<Longrightarrow> is_sum4sq (x*y)"
  by (unfold is_sum4sq_def, auto simp only: mult_sum4sq, blast)

lemma mult_oddprime_is_sum4sq: "\<lbrakk> zprime p; p \<in> zOdd \<rbrakk> \<Longrightarrow>
  \<exists> t. 0<t \<and> t<p \<and> is_sum4sq (p*t)"
proof -
  assume p1: "zprime p"
  hence p0: "p > 1" by (simp add: zprime_def)
  assume p2: "p \<in> zOdd"
  then obtain n where n: "p = 2*n+1" by (auto simp add: zOdd_def)
  with p1 have n0: "n > 0" by (auto simp add: zprime_def)
  let ?C = "{y. 0 \<le> y \<and> y < p}"
  let ?D = "{y. 0 \<le> y \<and> y \<le> n}"
  let ?f = "%x. x^2 mod p"
  let ?g = "%x. (-1-x^2) mod p"
  let ?A = "?f ` ?D"
  let ?B = "?g ` ?D"
  have finC: "finite ?C" by (rule bdd_int_set_l_finite)
  have finD: "finite ?D" by (rule bdd_int_set_le_finite)
  from p0 have AsubC: "?A \<subseteq> ?C" and BsubC: "?B \<subseteq> ?C"
    by (auto simp add: pos_mod_conj)
  with finC have finA: "finite ?A" and finB: "finite ?B"
    by (auto simp add: finite_subset)
  from AsubC BsubC have AunBsubC: "?A \<union> ?B \<subseteq> ?C" by (rule Un_least)
  from p0 have cardC: "card ?C = nat p" by (simp only: card_bdd_int_set_l)
  from n0 have cardD: "card ?D = 1+ nat n" by (simp only: card_bdd_int_set_le)
  have cardA: "card ?A = card ?D"
  proof -
    have "inj_on ?f ?D"
    proof (unfold inj_on_def, auto)
      fix x fix y
      assume x0: "0 \<le> x" and xn: "x \<le> n" and y0: "0 \<le> y" and yn: " y \<le> n"
        and xyp: "x^2 mod p = y^2 mod p"
      with p0 have "[x^2 = y^2] (mod p)" by (simp only: zcong_zmod_eq)
      hence "p dvd x^2-y^2" by (simp only: zcong_def)
      hence "p dvd (x+y)*(x-y)" by (simp only: zspecial_product)
      with p1 have "p dvd x+y \<or> p dvd x-y" by (simp only: zprime_zdvd_zmult_general)
      moreover
      { assume "p dvd x+y"
        moreover from xn yn n have "x+y < p" by auto
        ultimately have "\<not> x+y > 0" by (auto simp add: zdvd_not_zless)
        with x0 y0 have "x = y" by auto } -- "both are zero"
      moreover
      { assume ass: "p dvd x-y"
        have "x = y"
        proof (rule ccontr, case_tac "x-y \<ge> 0", auto)
          assume "x-y \<ge> 0" and "x \<noteq> y" hence "x-y > 0" by auto
          with ass have "\<not> x-y < p" by (auto simp add: zdvd_not_zless)
          with xn y0 n p0 show "False" by auto
        next
          assume "\<not> 0 \<le> x-y" hence "y-x > 0" by auto
          moreover from x0 yn n p0 have "y-x < p" by auto
          ultimately have "\<not> p dvd y-x" by (auto simp add: zdvd_not_zless)
          moreover from ass have "p dvd -(x-y)" by (simp only: dvd_minus_iff)
          ultimately show "False" by auto
        qed }
      ultimately show "x=y" by auto
    qed
    with finD show ?thesis by (simp only: inj_on_iff_eq_card)
  qed
  have cardB: "card ?B = card ?D"
  proof -
    have "inj_on ?g ?D"
    proof (unfold inj_on_def, auto)
      fix x fix y
      assume x0: "0 \<le> x" and xn: "x \<le> n" and y0: "0 \<le> y" and yn: " y \<le> n"
        and xyp: "(-1-x^2) mod p = (-1-y^2) mod p"
      with p0 have "[-1-y^2 = -1-x^2] (mod p)" by (simp only: zcong_zmod_eq)
      hence "p dvd (-1-y^2) - (-1-x^2)" by (simp only: zcong_def)
      moreover have "-1-y^2 - (-1-x^2) = x^2 - y^2" by arith
      ultimately have "p dvd x^2-y^2" by simp
      hence "p dvd (x+y)*(x-y)" by (simp only: zspecial_product)
      with p1 have "p dvd x+y \<or> p dvd x-y" by (simp only: zprime_zdvd_zmult_general)
      moreover
      { assume "p dvd x+y"
        moreover from xn yn n have "x+y < p" by auto
        ultimately have "\<not> x+y > 0" by (auto simp add: zdvd_not_zless)
        with x0 y0 have "x = y" by auto } -- "both are zero"
      moreover
      { assume ass: "p dvd x-y"
        have "x = y"
        proof (rule ccontr, case_tac "x-y \<ge> 0", auto)
          assume "x-y \<ge> 0" and "x \<noteq> y" hence "x-y > 0" by auto
          with ass have "\<not> x-y < p" by (auto simp add: zdvd_not_zless)
          with xn y0 n p0 show "False" by auto
        next
          assume "\<not> 0 \<le> x-y" hence "y-x > 0" by auto
          moreover from x0 yn n p0 have "y-x < p" by auto
          ultimately have "\<not> p dvd y-x" by (auto simp add: zdvd_not_zless)
          moreover from ass have "p dvd -(x-y)" by (simp only: dvd_minus_iff)
          ultimately show "False" by auto
        qed }
      ultimately show "x=y" by auto
    qed
    with finD show ?thesis by (simp only: inj_on_iff_eq_card)
  qed
  have "?A \<inter> ?B \<noteq> {}"
  proof (rule ccontr, auto)
    assume ABdisj: "?A \<inter> ?B = {}"
    from cardA cardB cardD have "2 + 2*(nat n) = card ?A + card ?B" by auto
    also with finA finB ABdisj have "\<dots> = card (?A \<union> ?B)"
      by (simp only: card_Un_disjoint)
    also with finC AunBsubC have "\<dots> \<le> card ?C" by (simp only: card_mono)
    also with cardC have "\<dots> = nat p" by simp
    finally have "2 + 2*(nat n) \<le> nat p" by simp
    with n show "False" by arith
  qed
  then obtain z where "z \<in> ?A \<and> z \<in> ?B" by auto
  then obtain x y where xy: "x \<in> ?D \<and> y \<in> ?D \<and> z = x^2 mod p \<and>
    z = (-1-y^2) mod p" by auto
  with p0 have "[x^2=-1-y^2](mod p)" by (simp add: zcong_zmod_eq)
  hence "p dvd x^2-(-1-y^2)" by (simp only: zcong_def)
  moreover have "x^2-(-1-y^2)=x^2+y^2+1" by arith
  ultimately have "p dvd sum4sq(x,y,1,0)" by (auto simp add: sum4sq_def)
  then obtain t where t: "sum4sq(x,y,1,0) = p*t" by (auto simp add: dvd_def)
  hence "is_sum4sq (p*t)" by (unfold is_sum4sq_def, auto)
  moreover have "t > 0 \<and> t < p"
  proof
    have "x^2 \<ge> 0 \<and> y^2 \<ge> 0" by (simp add: zero_le_power2)
    hence "x^2+y^2+1 > 0" by arith
    with t have "p*t > 0" by (unfold sum4sq_def, auto)
    moreover
    { assume "t < 0" with p0 have "p*t < p*0" by (simp only: zmult_zless_mono2)
      hence "p*t < 0" by simp }
    moreover
    { assume "t = 0" hence "p*t = 0" by simp }
    ultimately have "\<not> t < 0 \<and> t \<noteq> 0" by auto
    thus "t > 0" by simp
    from xy have "x^2 \<le> n^2 \<and> y^2 \<le> n^2" by (auto simp add: power_mono)
    hence "x^2+y^2+1 \<le> 2*n^2 + 1" by auto
    with t have contr: "p*t \<le> 2*n^2+1" by (simp add: sum4sq_def)
    moreover
    { assume "t > n+1"
      with p0 have "p*(n+1) < p*t" by (simp only: zmult_zless_mono2)
      with n have "p*t > (2*n+1)*n + (2*n+1)*1" by (simp only: distrib_left)
      hence "p*t > 2*n*n + n + 2*n + 1" by (simp only: distrib_right mult_1_left)
      with n0 have "p*t > 2*n^2 + 1" by (simp add: power2_eq_square) }
    ultimately have "\<not> t > n+1" by auto
    with n0 n show "t < p" by auto
  qed
  ultimately show ?thesis by blast
qed

lemma zprime_is_sum4sq: "zprime p \<Longrightarrow> is_sum4sq p"
proof (cases)
  assume p2: "p=2"
  hence "p = sum4sq(1,1,0,0)" by (auto simp add: sum4sq_def)
  thus ?thesis by (auto simp add: is_sum4sq_def)
next
  assume "\<not> p =2" and prp: "zprime p"
  hence "2 < p" by (simp add: zprime_def)
  with prp have "p \<in> zOdd" by (simp only: zprime_zOdd_eq_grt_2)
  with prp have "\<exists> t. 0<t \<and> t<p \<and> is_sum4sq (p*t)"
    by (rule mult_oddprime_is_sum4sq)
  then obtain a b c d t where pt_sol: "0<t \<and> t<p \<and> sum4sq(a,b,c,d)=p*t"
    by (unfold is_sum4sq_def, blast)
  hence Qt: "0<t \<and> t<p \<and> (\<exists> a1 a2 a3 a4. sum4sq(a1,a2,a3,a4)=p*t)"
    (is "?Q t") by blast
  have "?Q 1"
  proof (rule ccontr)
    assume nQ1: "\<not> ?Q 1"
    have "\<not> ?Q t"
    proof (induct t rule: infinite_descent0_measure[where V="\<lambda>x. (nat x)- 1"], clarify)
      fix x a b c d
      assume "nat x - 1 = 0" and "x > 0" and s: "sum4sq(a,b,c,d)=p*x" and "x < p"
      moreover hence "x = 1" by arith
      ultimately have "?Q 1" by auto
      with nQ1 show False by auto
    next
      fix x
      assume "0 < nat x - 1" and "\<not> \<not> ?Q x"
      then obtain a1 a2 a3 a4 where ass: "1<x \<and> x<p \<and> sum4sq(a1,a2,a3,a4)=p*x"
        by auto
      have "\<exists> y. nat y - 1 < nat x - 1 \<and> ?Q y"
      proof (cases)
        assume evx: "x \<in> zEven"
        hence "x*p \<in> zEven" by (rule even_times_either)
        with ass have ev1234: "a1^2+a2^2 + a3^2+a4^2 \<in> zEven"
          by (auto simp add: sum4sq_def ac_simps)
        have "\<exists> b1 b2 b3 b4. sum4sq(b1,b2,b3,b4)=p*x \<and>
          b1+b2 \<in> zEven \<and> b3+b4 \<in> zEven"
        proof (cases)
          assume ev12: "a1^2+a2^2 \<in> zEven"
          moreover have "2*a1*a2 \<in> zEven" by (auto simp add: zEven_def)
          ultimately have"a1^2+a2^2+2*a1*a2 \<in> zEven" by (rule even_plus_even)
          hence "(a1+a2)^2 \<in> zEven" by (auto simp add: zadd_power2 ac_simps)
          hence tmp: "a1+a2 \<in> zEven" by (auto simp add: power_preserves_even)
          from ev12 ev1234 have "a1^2+a2^2+a3^2+a4^2-(a1^2+a2^2) \<in> zEven"
            by (simp only: even_minus_even)
          hence "a3^2+a4^2 \<in> zEven" by auto
          moreover have "2*a3*a4 \<in> zEven" by (auto simp add: zEven_def)
          ultimately have"a3^2+a4^2+2*a3*a4 \<in> zEven" by (rule even_plus_even)
          hence "(a3+a4)^2 \<in> zEven" by (auto simp add: zadd_power2 ac_simps)
          hence "a3+a4 \<in> zEven" by (auto simp add: power_preserves_even)
          with tmp ass show ?thesis by blast
        next
          assume "\<not> a1^2+a2^2 \<in> zEven"
          hence odd12: "a1^2+a2^2 \<in> zOdd" by (simp add: odd_iff_not_even)
          with ev1234 have "a1^2+a2^2+a3^2+a4^2-(a1^2+a2^2) \<in> zOdd"
            by (simp only: even_minus_odd)
          hence odd34: "a3^2+a4^2 \<in> zOdd" by auto
          show ?thesis
          proof (cases)
            assume ev1: "a1^2 \<in> zEven"
            with odd12 have odd2: "a2^2 \<in> zOdd" by (rule even_plus_odd_prop2)
            show ?thesis
            proof (cases)
              assume ev3: "a3^2 \<in> zEven"
              with odd34 have "a4^2 \<in> zOdd" by (rule even_plus_odd_prop2)
              with odd2 have "a2 \<in> zOdd \<and>  a4 \<in> zOdd"
                by (auto simp add: power_preserves_odd)
              hence tmp: "a2+a4 \<in> zEven" by (simp only: odd_plus_odd)
              from ev3 ev1 have "a1 \<in> zEven \<and> a3 \<in> zEven"
                by (auto simp add: power_preserves_even)
              hence tmp2: "a1+a3 \<in> zEven" by (simp only: even_plus_even)
              from ass have "sum4sq(a1,a3,a2,a4)=p*x"
                by (auto simp add: sum4sq_def)
              with tmp tmp2 show ?thesis by blast
            next
              assume "\<not> a3^2 \<in> zEven"
              hence odd3: "a3^2 \<in> zOdd" by (simp add: odd_iff_not_even)
              with odd34 have "a4^2 \<in> zEven" by (rule even_plus_odd_prop1)
              with ev1 have "a1 \<in> zEven \<and>  a4 \<in> zEven"
                by (auto simp add: power_preserves_even)
              hence tmp: "a1+a4 \<in> zEven" by (simp only: even_plus_even)
              from odd2 odd3 have "a2 \<in> zOdd \<and> a3 \<in> zOdd"
                by (auto simp add: power_preserves_odd)
              hence tmp2: "a2+a3 \<in> zEven" by (simp only: odd_plus_odd)
              from ass have "sum4sq(a1,a4,a2,a3)=p*x"
                by (auto simp add: sum4sq_def)
              with tmp tmp2 show ?thesis by blast
            qed
          next
            assume "\<not> a1^2 \<in> zEven"
            hence odd1: "a1^2 \<in> zOdd" by (simp add: odd_iff_not_even)
            with odd12 have ev2: "a2^2 \<in> zEven" by (rule even_plus_odd_prop1)
            show ?thesis
            proof (cases)
              assume ev3: "a3^2 \<in> zEven"
              with odd34 have "a4^2 \<in> zOdd" by (rule even_plus_odd_prop2)
              with odd1 have "a1 \<in> zOdd \<and>  a4 \<in> zOdd"
                by (auto simp add: power_preserves_odd)
              hence tmp: "a1+a4 \<in> zEven" by (simp only: odd_plus_odd)
              from ev3 ev2 have "a2 \<in> zEven \<and> a3 \<in> zEven"
                by (auto simp add: power_preserves_even)
              hence tmp2: "a2+a3 \<in> zEven" by (simp only: even_plus_even)
              from ass have "sum4sq(a1,a4,a2,a3)=p*x"
                by (auto simp add: sum4sq_def)
              with tmp tmp2 show ?thesis by blast
            next
              assume "\<not> a3^2 \<in> zEven"
              hence odd3: "a3^2 \<in> zOdd" by (simp add: odd_iff_not_even)
              with odd34 have "a4^2 \<in> zEven" by (rule even_plus_odd_prop1)
              with ev2 have "a2 \<in> zEven \<and> a4 \<in> zEven"
                by (auto simp add: power_preserves_even)
              hence tmp: "a2+a4 \<in> zEven" by (simp only: even_plus_even)
              from odd1 odd3 have "a1 \<in> zOdd \<and> a3 \<in> zOdd"
                by (auto simp add: power_preserves_odd)
              hence tmp2: "a1+a3 \<in> zEven" by (simp only: odd_plus_odd)
              from ass have "sum4sq(a1,a3,a2,a4)=p*x"
                by (auto simp add: sum4sq_def)
              with tmp tmp2 show ?thesis by blast
            qed
          qed
        qed
        then obtain b1 b2 b3 b4 where b: "sum4sq(b1,b2,b3,b4)=p*x \<and>
          b1+b2 \<in> zEven \<and> b3+b4 \<in> zEven" by auto
        then obtain c1 c3 where c13: "b1+b2 = 2*c1 \<and> b3+b4 = 2*c3"
          by (auto simp add: zEven_def)
        have "2*b2 \<in> zEven \<and> 2*b4 \<in> zEven" by (auto simp add: zEven_def)
        with b have "b1+b2 - 2*b2 \<in> zEven \<and> b3+b4 - 2*b4 \<in> zEven"
          by (auto simp only: even_minus_even)
        moreover have "b1+b2 - 2*b2 = b1-b2 \<and> b3+b4 - 2*b4 = b3-b4" by auto
        ultimately have "b1-b2 \<in> zEven \<and> b3-b4 \<in> zEven" by simp
        then obtain c2 c4 where c24: "b1-b2 = 2*c2 \<and> b3-b4 = 2*c4"
          by (auto simp add: zEven_def)
        from evx obtain y where y: "x = 2*y" by (auto simp add: zEven_def)
        hence "4*(p*y) = 2*(p*x)" by (simp add: ac_simps)
        also from b have "\<dots> = 2*b1^2 + 2*b2^2 + 2*b3^2 + 2*b4^2"
          by (auto simp only: sum4sq_def)
        also have "\<dots> = (b1 + b2)^2 + (b1 - b2)^2 + (b3 + b4)^2 + (b3 - b4)^2"
          by (auto simp add: zadd_power2 zdiff_power2)
        also with c13 c24 have "\<dots> = 4*(c1^2 + c2^2 + c3^2 + c4^2)"
          by (auto simp add: power_mult_distrib)
        finally have "sum4sq(c1,c2,c3,c4) = p*y" by (auto simp add: sum4sq_def)
        moreover from y ass have "0 < y \<and> y < p \<and> (nat y) - 1 < (nat x) - 1" by arith
        ultimately show ?thesis by blast
      next
        assume "\<not> x \<in> zEven"
        hence xodd: "x \<in> zOdd" by (simp add: odd_iff_not_even)
        with ass have "\<exists> c1 c2 c3 c4. 2*\<bar>a1-c1*x\<bar><x \<and> 2*\<bar>a2-c2*x\<bar><x
          \<and> 2*\<bar>a3-c3*x\<bar><x \<and> 2*\<bar>a4-c4*x\<bar><x"
          by (simp add: best_odd_division_abs)
        then obtain b1 c1 b2 c2 b3 c3 b4 c4 where
          bc_def: "b1 = a1-c1*x \<and> b2 = a2-c2*x \<and> b3 = a3-c3*x \<and> b4 = a4-c4*x"
          and bc_abs: "2*\<bar>b1\<bar><x \<and> 2*\<bar>b2\<bar><x \<and> 2*\<bar>b3\<bar><x \<and> 2*\<bar>b4\<bar><x"
          by blast
        let ?B = "b1^2 + b2^2 + b3^2 + b4^2"
        let ?C = "c1^2 + c2^2 + c3^2 + c4^2"
        have "x dvd ?B"
        proof
          from bc_def ass have
            "?B = p*x - 2*(a1*c1+a2*c2+a3*c3+a4*c4)*x + ?C*x^2"
            by (auto simp add: zdiff_power2 sum4sq_def
              distrib_right power_mult_distrib)
          thus "?B = x*(p - 2*(a1*c1+a2*c2+a3*c3+a4*c4) + ?C*x)"
            by (auto simp add: ac_simps power2_eq_square
              distrib_left right_diff_distrib)
        qed
        then obtain y where y: "?B = x * y" by (auto simp add: dvd_def)
        let ?A1 = "a1*b1 + a2*b2 + a3*b3 + a4*b4"
        let ?A2 = "a1*b2 - a2*b1 - a3*b4 + a4*b3"
        let ?A3 = "a1*b3 + a2*b4 - a3*b1 - a4*b2"
        let ?A4 = "a1*b4 - a2*b3 + a3*b2 - a4*b1"
        let ?A = "sum4sq(?A1,?A2,?A3,?A4)"
        have "x dvd ?A1 \<and> x dvd ?A2 \<and> x dvd ?A3 \<and> x dvd ?A4"
        proof (safe)
          from bc_def have
            "?A1 = (b1+c1*x)*b1 + (b2+c2*x)*b2 + (b3+c3*x)*b3 + (b4+c4*x)*b4"
            by simp
          also with y have "\<dots> = x*(y + c1*b1 + c2*b2 + c3*b3 + c4*b4)"
            by (auto simp add: distrib_left power2_eq_square ac_simps)
          finally show "x dvd ?A1" by auto
          from bc_def have
            "?A2 = (b1+c1*x)*b2 - (b2+c2*x)*b1 - (b3+c3*x)*b4 + (b4+c4*x)*b3"
            by simp
          also have "\<dots> = x*(c1*b2 - c2*b1 - c3*b4 + c4*b3)"
            by (auto simp add: distrib_left right_diff_distrib ac_simps)
          finally show "x dvd ?A2" by auto
          from bc_def have
            "?A3 = (b1+c1*x)*b3 + (b2+c2*x)*b4 - (b3+c3*x)*b1 - (b4+c4*x)*b2"
            by simp
          also have "\<dots> = x*(c1*b3 + c2*b4 - c3*b1 - c4*b2)"
            by (auto simp add: distrib_left right_diff_distrib ac_simps)
          finally show "x dvd ?A3" by auto
          from bc_def have
            "?A4 = (b1+c1*x)*b4 - (b2+c2*x)*b3 + (b3+c3*x)*b2 - (b4+c4*x)*b1"
            by simp
          also have "\<dots> = x*(c1*b4 - c2*b3 + c3*b2 - c4*b1)"
            by (auto simp add: distrib_left right_diff_distrib ac_simps)
          finally show "x dvd ?A4" by auto
        qed
        then obtain d1 d2 d3 d4 where d:
          "?A1=x*d1 \<and> ?A2=x*d2 \<and> ?A3=x*d3 \<and> ?A4=x*d4"
          by (auto simp add: dvd_def)
        let ?D = "sum4sq(d1,d2,d3,d4)"
        from d have "x^2*?D = ?A"
          by (auto simp only: sum4sq_def power_mult_distrib distrib_left)
        also have "\<dots> = sum4sq(a1,a2,a3,a4)*sum4sq(b1,b2,b3,b4)"
          by (simp only: mult_sum4sq)
        also with y ass have "\<dots> = (p*x)*(x*y)" by (auto simp add: sum4sq_def)
        also have "\<dots> = x^2*(p*y)" by (simp only: power2_eq_square ac_simps)
        finally have "x^2*(?D - p*y) = 0" by (auto simp add: right_diff_distrib)
        with ass have "?D = p*y" by auto
        moreover have y_l_x: "y < x"
        proof -
          have "4*b1^2 = (2*\<bar>b1\<bar>)^2 \<and> 4*b2^2 = (2*\<bar>b2\<bar>)^2 \<and>
            4*b3^2 = (2*\<bar>b3\<bar>)^2 \<and> 4*b4^2 = (2*\<bar>b4\<bar>)^2"
            by (auto simp add: power_mult_distrib abs_mult power2_abs)
          with bc_abs have "4*b1^2<x^2 \<and> 4*b2^2<x^2 \<and> 4*b3^2<x^2 \<and> 4*b4^2<x^2"
            by (auto simp add: power_strict_mono)
          hence "?B < x^2" by auto
          with y have "x*(x-y) > 0"
            by (auto simp add: power2_eq_square right_diff_distrib)
          moreover from ass have "x > 0" by simp
          ultimately show ?thesis by (auto dest: pos_zmult_pos)
        qed
        moreover have "y > 0"
        proof -
          have b2pos: "b1^2 \<ge> 0 \<and> b2^2 \<ge> 0 \<and> b3^2 \<ge> 0 \<and> b4^2 \<ge> 0"
            by (auto simp add: zero_le_power2)
          hence "?B = 0 \<or> ?B > 0" by arith
          moreover
          { assume "?B = 0"
            moreover from b2pos have
              "?B-b1^2 \<ge> 0 \<and> ?B-b2^2 \<ge> 0 \<and> ?B-b3^2 \<ge> 0 \<and> ?B-b4^2 \<ge> 0" by arith
            ultimately have "b1^2 \<le> 0 \<and> b2^2 \<le> 0 \<and> b3^2 \<le> 0 \<and> b4^2 \<le> 0" by auto
            with b2pos have  "b1^2 = 0 \<and> b2^2 = 0 \<and> b3^2 = 0 \<and> b4^2 = 0" by arith
            hence "b1 = 0 \<and> b2 = 0 \<and> b3 = 0 \<and> b4 = 0" by auto
            with bc_def have "x dvd a1 \<and> x dvd a2 \<and> x dvd a3 \<and> x dvd a4"
              by auto
            hence "x^2 dvd a1^2 \<and> x^2 dvd a2^2 \<and> x^2 dvd a3^2 \<and> x^2 dvd a4^2"
              by (auto simp only: zpower_zdvd_mono)
            hence "x^2 dvd a1^2+a2^2+a3^2+a4^2" by (simp only: dvd_add)
            with ass have "x^2 dvd p*x" by (auto simp only: sum4sq_def)
            hence "x*x dvd x*p" by (simp only: power2_eq_square ac_simps)
            with ass have "x dvd p" by (auto dest: zdvd_mult_cancel)
            moreover from ass prp have "x \<ge> 0 \<and> x \<noteq> 1 \<and> x \<noteq> p \<and> zprime p" by simp
            ultimately have "False" by (unfold zprime_def, auto) }
          moreover
          { assume "?B > 0"
            with y have "x*y > 0" by simp
            moreover from ass have "x > 0" by simp
            ultimately have ?thesis by (auto dest: pos_zmult_pos) }
          ultimately show ?thesis by auto
        qed
        moreover with y_l_x have "(nat y) - 1 < (nat x) - 1" by arith
        moreover from y_l_x ass have "y < p" by auto
        ultimately show ?thesis by blast
      qed
      thus "\<exists> y. nat y - 1 < nat x - 1 \<and> \<not> \<not> ?Q y" by blast
    qed
    with Qt show "False" by simp
  qed
  thus "is_sum4sq p" by (auto simp add: is_sum4sq_def)
qed

theorem four_squares: "(n::int) \<ge> 0 \<Longrightarrow> \<exists> a b c d. a^2 + b^2 + c^2 + d^2 = n"
proof -
  assume "n \<ge> 0"
  hence "n = 0 \<or> n > 0" by auto
  moreover
  { assume "n = 0"
    hence "n = sum4sq(0,0,0,0)" by (auto simp add: sum4sq_def)
    hence "is_sum4sq n" by (auto simp add: is_sum4sq_def) }
  moreover
  { assume npos: "n > 0"
    hence "nat n \<noteq> 0" by simp
    then obtain ps where ps: "primel ps \<and> prod ps = nat n"
      by (frule_tac a="nat n" in factor_exists_general, auto)
    have "primel ps \<Longrightarrow> is_sum4sq (int (prod ps))"
    proof (induct ps, auto)
      have "sum4sq(1,0,0,0) = 1" by (auto simp add: sum4sq_def)
      thus "is_sum4sq 1" by (auto simp add: is_sum4sq_def)
    next
      fix p ps
      let ?X = "int (prod ps)"
      assume "primel ps \<Longrightarrow> is_sum4sq ?X" and "primel (p#ps)"
      hence "prime p" and x: "is_sum4sq ?X" by (auto simp add: primel_hd_tl)
      hence "zprime (int p)" by (simp only: prime_impl_zprime_int)
      hence "is_sum4sq (int p)" by (rule zprime_is_sum4sq)
      with x have "is_sum4sq((int p)*?X)" by (simp add: is_mult_sum4sq)
      thus "is_sum4sq (int (p*prod ps))" by (auto simp only: int_mult)
    qed
    with ps npos have "is_sum4sq n" by auto }
  ultimately have "is_sum4sq n" by auto
  thus ?thesis by (auto simp only: is_sum4sq_def sum4sq_def)
qed

end