section\<open>Priority Queue\<close>
theory PriorityQueue
imports Main "HOL-Library.Multiset"
begin

type_synonym 'e pq = \<open>'e multiset\<close>

definition top :: \<open>('e :: linorder) pq \<Rightarrow> 'e option\<close> where
  \<open>top pq = (if pq = {#} then None else Some (Min_mset pq))\<close>

definition pop :: \<open>('e :: linorder) pq \<Rightarrow> 'e pq\<close> where
  \<open>pop pq = (pq - {# Min_mset pq #})\<close>

lemma top_in[termination_simp]:
  "x \<in># pq" if "top pq = Some x"
  by (metis Min_in finite_set_mset not_None_eq option.inject set_mset_eq_empty_iff that top_def)

lemma top_eq_None_iff:
  "top pq = None \<longleftrightarrow> pq = {#}"
  unfolding top_def by simp

lemma top_Min:
  "x \<le> y" if "top pq = Some x" "y \<in># pq"
  by (metis Min_le finite_set_mset option.discI option.sel that top_def)

lemma size_Diff1_less_iff[termination_simp]:
  "size (ms - {#x#}) < size ms \<longleftrightarrow> x \<in># ms"
  by (metis diff_single_trivial less_irrefl size_Diff1_less)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_MSortBU2Count
imports "../../Test_Base"
begin

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

fun risers :: "int list => (int list) list" where
"risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
"lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
"pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(int list) list => int list" where
"mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu2 :: "int list => int list" where
"msortbu2 x = mergingbu2 (risers x)"

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

theorem property0 :
  "((count x (msortbu2 xs)) = (count x xs))"
  oops

end


theory ExF005
  imports Main
begin

lemma "(\<forall>x . (P x \<and> Q x)) \<longrightarrow> ((\<forall>x . P x) \<and> (\<forall> x . Q x))"
proof -
  {
    assume "\<forall>x . (P x \<and> Q x)"
    {
      fix a
      from \<open>\<forall>x . (P x \<and> Q x)\<close> have "P a \<and> Q a" by (rule allE)
      hence "P a" by (rule conjE)
    }
    hence "\<forall>x . P x" by (rule allI)
    {
      fix a
      from \<open>\<forall>x . (P x \<and> Q x)\<close> have "P a \<and> Q a" by (rule allE)
      hence "Q a" by (rule conjE)
    }
    hence "\<forall>x . Q x" by (rule allI)
    with \<open>\<forall>x . P x\<close> have "(\<forall>x . P x) \<and> (\<forall> x . Q x)" by (rule conjI)
  }
  thus ?thesis by (rule impI)
qed


theory equal
imports Main
        "../data/Natu"
        "$HIPSTER_HOME/IsaHipster"
begin

fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
| "equal2 (Z) (S z) = False"
| "equal2 (S x2) (Z) = False"
| "equal2 (S x2) (S y2) = equal2 x2 y2"

(*hipster equal2*)
lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa' : "y = x2 \<Longrightarrow> equal2 x2 y"
by (hipster_induct_schemes equal2.simps)

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

(*hipster_cond equal2*)

lemma lemma_ac [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps)

end


theory Product_Separation_Algebra
imports "Separation_Algebra.Separation_Algebra"
begin

instantiation "prod" :: (sep_algebra, sep_algebra) sep_algebra
begin

definition
  zero_prod_def: "0 \<equiv> (0, 0)"

definition
  plus_prod_def: "m1 + m2 \<equiv> (fst m1 + fst m2 , snd m1 + snd m2) "

definition
  sep_disj_prod_def: "sep_disj m1 m2 \<equiv> sep_disj (fst m1) (fst m2) \<and> sep_disj (snd m1) (snd m2)"

instance
  apply standard  unfolding sep_disj_prod_def zero_prod_def plus_prod_def
  subgoal by auto
  subgoal by (auto simp: sep_disj_commuteI)
  subgoal by (auto )
  subgoal using sep_add_commute by metis
  subgoal by (auto simp: sep_add_assoc)
  subgoal apply auto  using sep_disj_addD1 by metis+
  subgoal apply auto using sep_disj_addI1  apply auto done
  done

end

lemma sep_disj_prod_commute[simp]: "(ps, 0) ## (0, n)"   "(0, n) ## (ps, 0)" unfolding sep_disj_prod_def by auto

lemma sep_disj_prod_conv[simp]: "(a, x) ## (b, y) = (a##b \<and> x##y)" unfolding sep_disj_prod_def by auto

lemma sep_plus_prod_conv[simp]: "(ps, n) + (ps', n') = (ps + ps', n + n')" unfolding plus_prod_def by auto

lemma
  fixes h :: "('a::sep_algebra) * ('b::sep_algebra)"
  shows "((%(a,b). P a \<and> b = 0) ** (%(a,b). a = 0 \<and> Q b)) =
   (%(a,b). P a \<and> Q b)" unfolding sep_conj_def sep_disj_prod_def plus_prod_def
  apply auto apply(rule ext) apply auto by force

instantiation nat :: sep_algebra
begin

definition
  sep_disj_nat_def[simp]: "sep_disj (m1::nat) m2 \<equiv> True"

instance
  apply standard by(auto)
end

(* examples *)

(* now nat can be used as a separation algebra *)
lemma
  fixes h :: "nat"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)

(* and any pair of separation algebras also is *)
lemma
  fixes h :: "('a::sep_algebra) * ('b::sep_algebra)"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)

lemma
  fixes h :: "nat * nat"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)

end


(*  Title:      RSAPSS/Crypt.thy

    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

section "Definition of rsacrypt"

theory Crypt
imports Main Mod
begin

text \<open>
  This theory defines the rsacrypt function which implements RSA using fast
  exponentiation. An proof, that this function calculates RSA is also given
\<close>

definition rsa_crypt :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
where
  cryptcorrect: "rsa_crypt M e n = M ^ e mod n"

lemma rsa_crypt_code [code]:
  "rsa_crypt M e n = (if e = 0 then 1 mod n
    else if even e then rsa_crypt M (e div 2) n ^ 2 mod n
    else (M * rsa_crypt M (e div 2) n ^ 2 mod n) mod n)"
proof -
  { fix m
    have "(M ^ m mod n)\<^sup>2 mod n = (M ^ m)\<^sup>2 mod n"
      by (simp add: power_mod)
    then have "(M mod n) * ((M ^ m mod n)\<^sup>2 mod n) = (M mod n) * ((M ^ m)\<^sup>2 mod n)"
      by simp
    have "M * (M ^ m mod n)\<^sup>2 mod n = M * (M ^ m)\<^sup>2 mod n"
      by (metis mod_mult_right_eq power_mod)
  }
  then show ?thesis
    by (auto simp add: cryptcorrect power_even_eq remainderexp elim!: evenE oddE)
qed

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Positive.thy                                                         *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Positive Subtypes \<close>

theory Positive
imports
  Infinity
  "HOL-Library.Countable"
begin

subsection \<open> Type Definition \<close>

typedef (overloaded) 'a::"{zero, linorder}" pos = "{x::'a. x \<ge> 0}"
  apply (rule_tac x = "0" in exI)
  apply (clarsimp)
  done

syntax
  "_type_pos" :: "type \<Rightarrow> type" ("_\<^sup>+" [999] 999)

translations
  (type) "'a\<^sup>+" == (type) "'a pos"

setup_lifting type_definition_pos

type_synonym preal = "real pos"

subsection \<open> Operators \<close>

lift_definition mk_pos :: "'a::{zero, linorder} \<Rightarrow> 'a pos" is
"\<lambda> n. if (n \<ge> 0) then n else 0" by auto

lift_definition real_of_pos :: "real pos \<Rightarrow> real" is id .

declare [[coercion real_of_pos]]

subsection \<open> Instantiations \<close>

instantiation pos :: ("{zero, linorder}") zero
begin
  lift_definition zero_pos :: "'a pos"
    is "0 :: 'a" ..
  instance ..
end

instantiation pos :: ("{zero, linorder}") linorder
begin
  lift_definition less_eq_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> bool"
    is "(\<le>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" .
  lift_definition less_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> bool"
    is "(<) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" .
  instance
    apply (intro_classes; transfer)
        apply (auto)
  done
end

instance pos :: ("{zero, linorder, no_top}") no_top
  apply (intro_classes)
  apply (transfer)
  apply (clarsimp)
  apply (meson gt_ex less_imp_le order.strict_trans1)
  done

instance pos :: ("{zero, linorder, no_top}") infinite
  apply (intro_classes)
  apply (rule notI)
  apply (subgoal_tac "\<forall>x::'a pos. x \<le> Max UNIV")
  using gt_ex leD apply (blast)
  apply (simp)
  done

instantiation pos :: (linordered_semidom) linordered_semidom
begin
  lift_definition one_pos :: "'a pos"
    is "1 :: 'a" by (simp)
  lift_definition plus_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
    is "(+)" by (simp)
  lift_definition minus_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
    is "\<lambda>x y. if y \<le> x then x - y else 0"
    by (simp add: add_le_imp_le_diff)
  lift_definition times_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
    is "times" by (simp)
  instance
    apply (intro_classes; transfer; simp?)
            apply (simp add: add.assoc)
           apply (simp add: add.commute)
          apply (safe; clarsimp?) [1]
             apply (simp add: diff_diff_add)
            apply (metis add_le_cancel_left le_add_diff_inverse)
           apply (simp add: add.commute add_le_imp_le_diff)
          apply (metis add_increasing2 antisym linear)
         apply (simp add: mult.assoc)
        apply (simp add: mult.commute)
       apply (simp add: comm_semiring_class.distrib)
      apply (simp add: mult_strict_left_mono)
     apply (safe; clarsimp?) [1]
       apply (simp add: right_diff_distrib')
      apply (simp add: mult_left_mono)
    using mult_left_le_imp_le apply (fastforce)
    apply (simp add: distrib_left)
    done
end

instantiation pos :: ("linordered_field") semidom_divide
begin
  lift_definition divide_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
    is "divide" by (simp)
  instance
    apply (intro_classes; transfer)
     apply (simp_all)
    done
end

instantiation pos :: (linordered_field) inverse
begin
  lift_definition inverse_pos :: "'a pos \<Rightarrow> 'a pos"
    is "inverse" by (simp)
  instance ..
end

lemma pos_positive [simp]: "0 \<le> (x::'a::{zero,linorder} pos)"
  by (transfer, simp)

subsection \<open> Theorems \<close>

lemma mk_pos_zero [simp]: "mk_pos 0 = 0"
  by (transfer, simp)

lemma mk_pos_one [simp]: "mk_pos 1 = 1"
  by (transfer, simp)

lemma mk_pos_leq:
  "\<lbrakk> 0 \<le> x; x \<le> y \<rbrakk> \<Longrightarrow> mk_pos x \<le> mk_pos y"
  by (transfer, auto)

lemma mk_pos_less:
  "\<lbrakk> 0 \<le> x; x < y \<rbrakk> \<Longrightarrow> mk_pos x < mk_pos y"
  by (transfer, auto)

lemma real_of_pos [simp]: "x \<ge> 0 \<Longrightarrow> real_of_pos (mk_pos x) = x"
  by (transfer, simp)

lemma mk_pos_real_of_pos [simp]: "mk_pos (real_of_pos x) = x"
  by (transfer, simp)

subsection \<open> Transfer to Reals \<close>

named_theorems pos_transfer

lemma real_of_pos_0 [pos_transfer]:
  "real_of_pos 0 = 0"
  by (transfer, auto)

lemma real_of_pos_1 [pos_transfer]:
  "real_of_pos 1 = 1"
  by (transfer, auto)

lemma real_op_pos_plus [pos_transfer]:
  "real_of_pos (x + y) = real_of_pos x + real_of_pos y"
  by (transfer, simp)

lemma real_op_pos_minus [pos_transfer]:
  "x \<ge> y \<Longrightarrow> real_of_pos (x - y) = real_of_pos x - real_of_pos y"
  by (transfer, simp)

lemma real_op_pos_mult [pos_transfer]:
  "real_of_pos (x * y) = real_of_pos x * real_of_pos y"
  by (transfer, simp)

lemma real_op_pos_div [pos_transfer]:
  "real_of_pos (x / y) = real_of_pos x / real_of_pos y"
  by (transfer, simp)

lemma real_of_pos_numeral [pos_transfer]:
  "real_of_pos (numeral n) = numeral n"
  by (induct n, simp_all only: numeral.simps pos_transfer)

lemma real_of_pos_eq_transfer [pos_transfer]:
  "x = y \<longleftrightarrow> real_of_pos x = real_of_pos y"
  by (transfer, auto)

lemma real_of_pos_less_eq_transfer [pos_transfer]:
  "x \<le> y \<longleftrightarrow> real_of_pos x \<le> real_of_pos y"
  by (transfer, auto)

lemma real_of_pos_less_transfer [pos_transfer]:
  "x < y \<longleftrightarrow> real_of_pos x < real_of_pos y"
  by (transfer, auto)

end


(*
    $Id: ex.thy,v 1.3 2011/06/28 18:11:38 webertj Exp $
    Author: Martin Strecker
*)

header {* Sets as Lists *}

(*<*) theory ex imports Main begin (*>*)

text {* Finite sets can obviously be implemented by lists.  In the
following, you will be asked to implement the set operations union,
intersection and difference and to show that these implementations are
correct.  Thus, for a function *}

(*<*)consts(*>*)
  list_union :: "['a list, 'a list] \<Rightarrow> 'a list"

text {* to be defined by you it has to be shown that *}

lemma "set (list_union xs ys) = set xs \<union> set ys"
(*<*)oops(*>*)

text {* In addition, the functions should be space efficient in the
sense that one obtains lists without duplicates (@{text "distinct"})
whenever the parameters of the functions are duplicate-free.  Thus, for
example, *}

lemma [rule_format]:
  "distinct xs \<longrightarrow> distinct ys \<longrightarrow> (distinct (list_union xs ys))"
(*<*)oops(*>*)

text {* \emph{Hint:} @{text "distinct"} is defined in @{text List.thy}. *}

subsubsection {* Quantification over Sets *}

text {* Define a (non-trivial) set @{text S} such that the following
proposition holds: *}

lemma "((\<forall> x \<in> A. P x) \<and> (\<forall> x \<in> B. P x)) \<longrightarrow> (\<forall> x \<in> S. P x)"
(*<*)oops(*>*)

text {* Define a (non-trivial) predicate @{text P} such that *}

lemma "\<forall> x \<in> A. P (f x) \<Longrightarrow>  \<forall> y \<in> f ` A. Q y"
(*<*)oops(*>*)

(*<*) end (*>*)


theory LexicalVals
  imports Lexer "HOL-Library.Sublist"
begin

section \<open> Sets of Lexical Values \<close>

text \<open>
  Shows that lexical values are finite for a given regex and string.
\<close>

definition
  LV :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> ('a val) set"
where  "LV r s \<equiv> {v. \<turnstile> v : r \<and> flat v = s}"

lemma LV_simps:
  shows "LV Zero s = {}"
  and   "LV One s = (if s = [] then {Void} else {})"
  and   "LV (Atom c) s = (if s = [c] then {Atm c} else {})"
  and   "LV (Plus r1 r2) s = Left ` LV r1 s \<union> Right ` LV r2 s"
unfolding LV_def
by (auto intro: Prf.intros elim: Prf.cases)

abbreviation
  "Prefixes s \<equiv> {s'. prefix s' s}"

abbreviation
  "Suffixes s \<equiv> {s'. suffix s' s}"

abbreviation
  "SSuffixes s \<equiv> {s'. strict_suffix s' s}"

lemma Suffixes_cons [simp]:
  shows "Suffixes (c # s) = Suffixes s \<union> {c # s}"
by (auto simp add: suffix_def Cons_eq_append_conv)

lemma finite_Suffixes:
  shows "finite (Suffixes s)"
by (induct s) (simp_all)

lemma finite_SSuffixes:
  shows "finite (SSuffixes s)"
proof -
  have "SSuffixes s \<subseteq> Suffixes s"
   unfolding strict_suffix_def suffix_def by auto
  then show "finite (SSuffixes s)"
   using finite_Suffixes finite_subset by blast
qed

lemma finite_Prefixes:
  shows "finite (Prefixes s)"
proof -
  have "finite (Suffixes (rev s))"
    by (rule finite_Suffixes)
  then have "finite (rev ` Suffixes (rev s))" by simp
  moreover
  have "rev ` (Suffixes (rev s)) = Prefixes s"
  unfolding suffix_def prefix_def image_def
   by (auto)(metis rev_append rev_rev_ident)+
  ultimately show "finite (Prefixes s)" by simp
qed

lemma LV_STAR_finite:
  assumes "\<forall>s. finite (LV r s)"
  shows "finite (LV (Star r) s)"
proof(induct s rule: length_induct)
  fix s::"'a list"
  assume "\<forall>s'. length s' < length s \<longrightarrow> finite (LV (Star r) s')"
  then have IH: "\<forall>s' \<in> SSuffixes s. finite (LV (Star r) s')"
    by (force simp add: strict_suffix_def suffix_def)
  define f where "f \<equiv> \<lambda>(v::'a val, vs). Stars (v # vs)"
  define S1 where "S1 \<equiv> \<Union>s' \<in> Prefixes s. LV r s'"
  define S2 where "S2 \<equiv> \<Union>s2 \<in> SSuffixes s. Stars -` (LV (Star r) s2)"
  have "finite S1" using assms
    unfolding S1_def by (simp_all add: finite_Prefixes)
  moreover
  with IH have "finite S2" unfolding S2_def
    by (auto simp add: finite_SSuffixes inj_on_def finite_vimageI)
  ultimately
  have "finite ({Stars []} \<union> f ` (S1 \<times> S2))" by simp
  moreover
  have "LV (Star r) s \<subseteq> {Stars []} \<union> f ` (S1 \<times> S2)"
  unfolding S1_def S2_def f_def
  unfolding LV_def image_def prefix_def strict_suffix_def
  apply(auto)
  apply(case_tac x)
  apply(auto elim: Prf_elims)
  apply(erule Prf_elims)
  apply(auto)
  apply(case_tac vs)
  apply(auto intro: Prf.intros)
  apply(rule exI)
  apply(rule conjI)
  apply(rule_tac x="flat a" in exI)
  apply(rule conjI)
  apply(rule_tac x="flats list" in exI)
  apply(simp)
  apply(blast)
  apply(simp add: suffix_def)
  using Prf.intros(6) by blast
  ultimately
  show "finite (LV (Star r) s)" by (simp add: finite_subset)
qed

lemma LV_finite:
  shows "finite (LV r s)"
proof(induct r arbitrary: s)
  case (Zero s)
  show "finite (LV Zero s)" by (simp add: LV_simps)
next
  case (One s)
  show "finite (LV One s)" by (simp add: LV_simps)
next
  case (Atom c s)
  show "finite (LV (Atom c) s)" by (simp add: LV_simps)
next
  case (Plus r1 r2 s)
  then show "finite (LV (Plus r1 r2) s)" by (simp add: LV_simps)
next
  case (Times r1 r2 s)
  define f where "f \<equiv> \<lambda>(v1::'a val, v2). Seq v1 v2"
  define S1 where "S1 \<equiv> \<Union>s' \<in> Prefixes s. LV r1 s'"
  define S2 where "S2 \<equiv> \<Union>s' \<in> Suffixes s. LV r2 s'"
  have IHs: "\<And>s. finite (LV r1 s)" "\<And>s. finite (LV r2 s)" by fact+
  then have "finite S1" "finite S2" unfolding S1_def S2_def
    by (simp_all add: finite_Prefixes finite_Suffixes)
  moreover
  have "LV (Times r1 r2) s \<subseteq> f ` (S1 \<times> S2)"
    unfolding f_def S1_def S2_def
    unfolding LV_def image_def prefix_def suffix_def
    apply (auto elim!: Prf_elims)
    by (metis (mono_tags, lifting) mem_Collect_eq)
  ultimately
  show "finite (LV (Times r1 r2) s)"
    by (simp add: finite_subset)
next
  case (Star r s)
  then show "finite (LV (Star r) s)" by (simp add: LV_STAR_finite)
qed

text \<open>
  Our POSIX values are lexical values.
\<close>

lemma Posix_LV:
  assumes "s \<in> r \<rightarrow> v"
  shows "v \<in> LV r s"
  using assms unfolding LV_def
  apply(induct rule: Posix.induct)
  apply(auto simp add: intro!: Prf.intros elim!: Prf_elims)
  done

lemma Posix_Prf:
  assumes "s \<in> r \<rightarrow> v"
  shows "\<turnstile> v : r"
  using assms Posix_LV LV_def
  by blast

end


(*  Title:      HOL/UNITY/Comp/Counter.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

From Charpentier and Chandy,
Examples of Program Composition Illustrating the Use of Universal Properties
   In J. Rolim (editor), Parallel and Distributed Processing,
   Springer LNCS 1586 (1999), pages 1215-1227.
*)

section\<open>A Family of Similar Counters: Original Version\<close>

theory Counter imports "../UNITY_Main" begin

(* Variables are names *)
datatype name = C | c nat
type_synonym state = "name=>int"

primrec sum  :: "[nat,state]=>int" where
  (* sum I s = sigma_{i<I}. s (c i) *)
  "sum 0 s = 0"
| "sum (Suc i) s = s (c i) + sum i s"

primrec sumj :: "[nat, nat, state]=>int" where
  "sumj 0 i s = 0"
| "sumj (Suc n) i s = (if n=i then sum n s else s (c n) + sumj n i s)"

type_synonym command = "(state*state)set"

definition a :: "nat=>command" where
 "a i = {(s, s'). s'=s(c i:= s (c i) + 1, C:= s C + 1)}"

definition Component :: "nat => state program" where
  "Component i =
    mk_total_program({s. s C = 0 & s (c i) = 0}, {a i},
                     \<Union>G \<in> preserves (%s. s (c i)). Acts G)"

declare Component_def [THEN def_prg_Init, simp]
declare a_def [THEN def_act_simp, simp]

(* Theorems about sum and sumj *)
lemma sum_upd_gt: "I<n ==> sum I (s(c n := x)) = sum I s"
  by (induct I) auto

lemma sum_upd_eq: "sum I (s(c I := x)) = sum I s"
  by (induct I) (auto simp add: sum_upd_gt [unfolded fun_upd_def])

lemma sum_upd_C: "sum I (s(C := x)) = sum I s"
  by (induct I) auto

lemma sumj_upd_ci: "sumj I i (s(c i := x)) = sumj I i s"
  by (induct I) (auto simp add: sum_upd_eq [unfolded fun_upd_def])

lemma sumj_upd_C: "sumj I i (s(C := x)) = sumj I i s"
  by (induct I) (auto simp add: sum_upd_C [unfolded fun_upd_def])

lemma sumj_sum_gt: "I<i ==> sumj I i s = sum I s"
  by (induct I) auto

lemma sumj_sum_eq: "(sumj I I s = sum I s)"
  by (induct I) (auto simp add: sumj_sum_gt)

lemma sum_sumj: "i<I ==> sum I s = s (c i) +  sumj I i s"
  by (induct I) (auto simp add: linorder_neq_iff sumj_sum_eq)

(* Correctness proofs for Components *)
(* p2 and p3 proofs *)
lemma p2: "Component i \<in> stable {s. s C = s (c i) + k}"
by (simp add: Component_def, safety)

lemma p3: "Component i \<in> stable {s. \<forall>v. v\<noteq>c i & v\<noteq>C --> s v = k v}"
by (simp add: Component_def, safety)

lemma p2_p3_lemma1:
"(\<forall>k. Component i \<in> stable ({s. s C = s (c i) + sumj I i k}
                   \<inter> {s. \<forall>v. v\<noteq>c i & v\<noteq>C --> s v = k v}))
   = (Component i \<in> stable {s. s C = s (c i) + sumj I i s})"
apply (simp add: Component_def mk_total_program_def)
apply (auto simp add: constrains_def stable_def sumj_upd_C sumj_upd_ci)
done

lemma p2_p3_lemma2:
"\<forall>k. Component i \<in> stable ({s. s C = s (c i) + sumj I i k} Int
                            {s. \<forall>v. v\<noteq>c i & v\<noteq>C --> s v = k v})"
by (blast intro: stable_Int [OF p2 p3])

lemma p2_p3: "Component i \<in> stable {s.  s C = s (c i) + sumj I i s}"
by (auto intro!: p2_p3_lemma2 simp add: p2_p3_lemma1 [symmetric])

(* Compositional Proof *)

lemma sum_0': "(\<And>i. i < I ==> s (c i) = 0) ==> sum I s = 0"
  by (induct I) auto

(* I cannot be empty *)
lemma safety:
     "0<I ==> (\<Squnion>i \<in> {i. i<I}. Component i) \<in> invariant {s. s C = sum I s}"
apply (simp (no_asm) add: invariant_def JN_stable sum_sumj)
apply (force intro: p2_p3 sum_0')
done

end


theory LTL
  imports Main
begin

datatype 'a LTL
  = Latom 'a
  | Ltrue
  | Lor "'a LTL" "'a LTL" (infixl "\<or>t" 81)
  | Lnot "'a LTL" ("\<not>t _" [85] 85)
  | Lnext "'a LTL" ("\<circle> _" [88] 87)
  | Luntil "'a LTL" "'a LTL" (infixr "\<union>t" 83)

definition Land (infixl "\<and>t" 82) where
  "Land p q = \<not>t (\<not>t p \<or>t \<not>t q)"

definition Limp (infixr "\<rightarrow>t" 80) where
  "Limp p q = \<not>t p \<or>t q"

definition Liff (infixl "\<leftrightarrow>t" 80) where
  "Liff p q = (p \<rightarrow>t q) \<and>t (q \<rightarrow>t p)"

definition Lfalse where
  "Lfalse = \<not>t Ltrue"

definition Lrelease (infixr "Rt" 83) where
  "Lrelease p q = \<not>t (\<not>t p \<union>t \<not>t q)"

definition Lfinally ("\<diamond> _" [88] 87) where
  "Lfinally p = Ltrue \<union>t p"

definition Lglobally ("\<box> _" [88] 87) where
  "Lglobally p = Lfalse Rt p"

fun shift :: "(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a set)" where
  "shift w n = (\<lambda>k. w (n + k))"

primrec kripke_semantics :: "(nat \<Rightarrow> 'a set) \<Rightarrow> 'a LTL \<Rightarrow> bool" ("_ \<Turnstile> _" [80,80] 80) where
  "w \<Turnstile> Latom p = (p \<in> w 0)"
| "w \<Turnstile> Ltrue = True"
| "w \<Turnstile> p \<or>t q = (w \<Turnstile> p \<or> w \<Turnstile> q)"
| "w \<Turnstile> \<not>t p = (\<not> w \<Turnstile> p)"
| "w \<Turnstile> \<circle> p = shift w 1 \<Turnstile> p"
| "w \<Turnstile> p \<union>t q = (\<exists>i \<ge> 0. shift w i \<Turnstile> q \<and> (\<forall>k. 0 \<le> k \<and> k < i \<longrightarrow> shift w k \<Turnstile> p))"

lemma and_sem: "w \<Turnstile> p \<and>t q = (w \<Turnstile> p \<and> w \<Turnstile> q)"
  unfolding Land_def
  by simp

definition valid ("\<Turnstile> _" [80] 80) where
  "\<Turnstile> p = (\<forall>w. w \<Turnstile> p)"

lemma notF_iff_G: "\<Turnstile> (\<not>t \<diamond> (\<not>t p)) = \<Turnstile> \<box> p"
  unfolding Lfinally_def Lglobally_def Lrelease_def Lfalse_def valid_def
  apply simp
  done

lemma conjunct1_sem: "\<Turnstile> p \<and>t q \<Longrightarrow> \<Turnstile> p"
  by (simp add: and_sem valid_def)

lemma conjunct2_sem: "\<Turnstile> p \<and>t q \<Longrightarrow> \<Turnstile> q"
  by (simp add: and_sem valid_def)

(* Examples *)

datatype Color = red | green | yellow

locale traffic =
  assumes red_to_green: "\<Turnstile> Latom red \<union>t Latom green"
  and green_to_yellow: "\<Turnstile> Latom green \<union>t Latom yellow"
  and yellow_to_red: "\<Turnstile> Latom yellow \<union>t Latom red"

lemma (in traffic) "\<Turnstile> \<diamond> Latom green"
  by (metis Lfinally_def kripke_semantics.simps(2) kripke_semantics.simps(6) red_to_green valid_def)

end


(*  Title:      HOL/Number_Theory/Pocklington.thy
    Author:     Amine Chaieb
*)

section \<open>Pocklington's Theorem for Primes\<close>

theory Pocklington
imports Residues
begin

subsection\<open>Lemmas about previously defined terms\<close>

lemma prime_nat_iff'':
  "prime (p::nat) \<longleftrightarrow> p \<noteq> 0 \<and> p \<noteq> 1 \<and> (\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m)"
  unfolding prime_nat_iff
proof safe
  fix m assume p: "p > 0" "p \<noteq> 1" and m: "m dvd p" "m \<noteq> p"
           and *: "\<forall>m. m > 0 \<and> m < p \<longrightarrow> coprime p m"
  from p m have "m \<noteq> 0" by (intro notI) auto
  moreover from p m have "m < p" by (auto dest: dvd_imp_le)
  ultimately have "coprime p m" using * by blast
  with m show "m = 1" by simp
qed (auto simp: prime_nat_iff simp del: One_nat_def
          intro!: prime_imp_coprime dest: dvd_imp_le)

lemma finite_number_segment: "card { m. 0 < m \<and> m < n } = n - 1"
proof-
  have "{ m. 0 < m \<and> m < n } = {1..<n}" by auto
  thus ?thesis by simp
qed

subsection\<open>Some basic theorems about solving congruences\<close>

lemma cong_solve:
  fixes n::nat assumes an: "coprime a n" shows "\<exists>x. [a * x = b] (mod n)"
proof-
  {assume "a=0" hence ?thesis using an by (simp add: cong_nat_def)}
  moreover
  {assume az: "a\<noteq>0"
  from bezout_add_strong_nat[OF az, of n]
  obtain d x y where dxy: "d dvd a" "d dvd n" "a*x = n*y + d" by blast
  from dxy(1,2) have d1: "d = 1"
    by (metis assms coprime_nat)
  hence "a*x*b = (n*y + 1)*b" using dxy(3) by simp
  hence "a*(x*b) = n*(y*b) + b"
    by (auto simp add: algebra_simps)
  hence "a*(x*b) mod n = (n*(y*b) + b) mod n" by simp
  hence "a*(x*b) mod n = b mod n" by (simp add: mod_add_left_eq)
  hence "[a*(x*b) = b] (mod n)" unfolding cong_nat_def .
  hence ?thesis by blast}
ultimately  show ?thesis by blast
qed

lemma cong_solve_unique:
  fixes n::nat assumes an: "coprime a n" and nz: "n \<noteq> 0"
  shows "\<exists>!x. x < n \<and> [a * x = b] (mod n)"
proof-
  let ?P = "\<lambda>x. x < n \<and> [a * x = b] (mod n)"
  from cong_solve[OF an] obtain x where x: "[a*x = b] (mod n)" by blast
  let ?x = "x mod n"
  from x have th: "[a * ?x = b] (mod n)"
    by (simp add: cong_nat_def mod_mult_right_eq[of a x n])
  from mod_less_divisor[ of n x] nz th have Px: "?P ?x" by simp
  {fix y assume Py: "y < n" "[a * y = b] (mod n)"
    from Py(2) th have "[a * y = a*?x] (mod n)" by (simp add: cong_nat_def)
    hence "[y = ?x] (mod n)"
      by (metis an cong_mult_lcancel_nat)
    with mod_less[OF Py(1)] mod_less_divisor[ of n x] nz
    have "y = ?x" by (simp add: cong_nat_def)}
  with Px show ?thesis by blast
qed

lemma cong_solve_unique_nontrivial:
  assumes p: "prime (p::nat)" and pa: "coprime p a" and x0: "0 < x" and xp: "x < p"
  shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = a] (mod p)"
proof-
  from pa have ap: "coprime a p"
    by (metis gcd.commute)
  have px:"coprime x p"
    by (metis gcd.commute p prime_nat_iff'' x0 xp)
  obtain y where y: "y < p" "[x * y = a] (mod p)" "\<forall>z. z < p \<and> [x * z = a] (mod p) \<longrightarrow> z = y"
    by (metis cong_solve_unique neq0_conv p prime_gt_0_nat px)
  {assume y0: "y = 0"
    with y(2) have th: "p dvd a"
      by (auto dest: cong_dvd_eq_nat)
    have False
      by (metis gcd_nat.absorb1 not_prime_1 p pa th)}
  with y show ?thesis unfolding Ex1_def using neq0_conv by blast
qed

lemma cong_unique_inverse_prime:
  assumes "prime (p::nat)" and "0 < x" and "x < p"
  shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = 1] (mod p)"
  by (rule cong_solve_unique_nontrivial) (insert assms, simp_all)

lemma chinese_remainder_coprime_unique:
  fixes a::nat
  assumes ab: "coprime a b" and az: "a \<noteq> 0" and bz: "b \<noteq> 0"
  and ma: "coprime m a" and nb: "coprime n b"
  shows "\<exists>!x. coprime x (a * b) \<and> x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
proof-
  let ?P = "\<lambda>x. x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
  from binary_chinese_remainder_unique_nat[OF ab az bz]
  obtain x where x: "x < a * b" "[x = m] (mod a)" "[x = n] (mod b)"
    "\<forall>y. ?P y \<longrightarrow> y = x" by blast
  from ma nb x
  have "coprime x a" "coprime x b"
    by (metis cong_gcd_eq_nat)+
  then have "coprime x (a*b)"
    by (metis coprime_mul_eq)
  with x show ?thesis by blast
qed

subsection\<open>Lucas's theorem\<close>

lemma phi_limit_strong: "phi(n) \<le> n - 1"
proof -
  have "phi n = card {x. 0 < x \<and> x < int n \<and> coprime x (int n)}"
    by (simp add: phi_def)
  also have "... \<le> card {0 <..< int n}"
    by (rule card_mono) auto
  also have "... = card {0 <..< n}"
    by (simp add: transfer_nat_int_set_functions)
  also have "... \<le> n - 1"
    by (metis card_greaterThanLessThan le_refl One_nat_def)
  finally show ?thesis .
qed

lemma phi_lowerbound_1: assumes n: "n \<ge> 2"
  shows "phi n \<ge> 1"
proof -
  have "1 \<le> card {0::int <.. 1}"
    by auto
  also have "... \<le> card {x. 0 < x \<and> x < n \<and> coprime x n}"
    apply (rule card_mono) using assms
    by auto (metis dual_order.antisym gcd_1_int gcd.commute int_one_le_iff_zero_less)
  also have "... = phi n"
    by (simp add: phi_def)
  finally show ?thesis .
qed

lemma phi_lowerbound_1_nat: assumes n: "n \<ge> 2"
  shows "phi(int n) \<ge> 1"
by (metis n nat_le_iff nat_numeral phi_lowerbound_1)

lemma euler_theorem_nat:
  fixes m::nat
  assumes "coprime a m"
  shows "[a ^ phi m = 1] (mod m)"
by (metis assms le0 euler_theorem [transferred])

lemma lucas_coprime_lemma:
  fixes n::nat
  assumes m: "m\<noteq>0" and am: "[a^m = 1] (mod n)"
  shows "coprime a n"
proof-
  {assume "n=1" hence ?thesis by simp}
  moreover
  {assume "n = 0" hence ?thesis using am m
     by (metis am cong_0_nat gcd_nat.right_neutral power_eq_one_eq_nat)}
  moreover
  {assume n: "n\<noteq>0" "n\<noteq>1"
    from m obtain m' where m': "m = Suc m'" by (cases m, blast+)
    {fix d
      assume d: "d dvd a" "d dvd n"
      from n have n1: "1 < n" by arith
      from am mod_less[OF n1] have am1: "a^m mod n = 1" unfolding cong_nat_def by simp
      from dvd_mult2[OF d(1), of "a^m'"] have dam:"d dvd a^m" by (simp add: m')
      from dvd_mod_iff[OF d(2), of "a^m"] dam am1
      have "d = 1" by simp }
    hence ?thesis by auto
  }
  ultimately show ?thesis by blast
qed

lemma lucas_weak:
  fixes n::nat
  assumes n: "n \<ge> 2" and an:"[a^(n - 1) = 1] (mod n)"
  and nm: "\<forall>m. 0 <m \<and> m < n - 1 \<longrightarrow> \<not> [a^m = 1] (mod n)"
  shows "prime n"
proof-
  from n have n1: "n \<noteq> 1" "n\<noteq>0" "n - 1 \<noteq> 0" "n - 1 > 0" "n - 1 < n" by arith+
  from lucas_coprime_lemma[OF n1(3) an] have can: "coprime a n" .
  from euler_theorem_nat[OF can] have afn: "[a ^ phi n = 1] (mod n)"
    by auto
  {assume "phi n \<noteq> n - 1"
    with phi_limit_strong phi_lowerbound_1_nat [OF n]
    have c:"phi n > 0 \<and> phi n < n - 1"
      by (metis gr0I leD less_linear not_one_le_zero)
    from nm[rule_format, OF c] afn have False ..}
  hence "phi n = n - 1" by blast
  with prime_phi phi_prime n1(1,2) show ?thesis
    by auto
qed

lemma nat_exists_least_iff: "(\<exists>(n::nat). P n) \<longleftrightarrow> (\<exists>n. P n \<and> (\<forall>m < n. \<not> P m))"
  by (metis ex_least_nat_le not_less0)

lemma nat_exists_least_iff': "(\<exists>(n::nat). P n) \<longleftrightarrow> (P (Least P) \<and> (\<forall>m < (Least P). \<not> P m))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  {assume ?rhs hence ?lhs by blast}
  moreover
  { assume H: ?lhs then obtain n where n: "P n" by blast
    let ?x = "Least P"
    {fix m assume m: "m < ?x"
      from not_less_Least[OF m] have "\<not> P m" .}
    with LeastI_ex[OF H] have ?rhs by blast}
  ultimately show ?thesis by blast
qed

theorem lucas:
  assumes n2: "n \<ge> 2" and an1: "[a^(n - 1) = 1] (mod n)"
  and pn: "\<forall>p. prime p \<and> p dvd n - 1 \<longrightarrow> [a^((n - 1) div p) \<noteq> 1] (mod n)"
  shows "prime n"
proof-
  from n2 have n01: "n\<noteq>0" "n\<noteq>1" "n - 1 \<noteq> 0" by arith+
  from mod_less_divisor[of n 1] n01 have onen: "1 mod n = 1" by simp
  from lucas_coprime_lemma[OF n01(3) an1] cong_imp_coprime_nat an1
  have an: "coprime a n" "coprime (a^(n - 1)) n"
    by (auto simp add: coprime_exp gcd.commute)
  {assume H0: "\<exists>m. 0 < m \<and> m < n - 1 \<and> [a ^ m = 1] (mod n)" (is "EX m. ?P m")
    from H0[unfolded nat_exists_least_iff[of ?P]] obtain m where
      m: "0 < m" "m < n - 1" "[a ^ m = 1] (mod n)" "\<forall>k <m. \<not>?P k" by blast
    {assume nm1: "(n - 1) mod m > 0"
      from mod_less_divisor[OF m(1)] have th0:"(n - 1) mod m < m" by blast
      let ?y = "a^ ((n - 1) div m * m)"
      note mdeq = div_mult_mod_eq[of "(n - 1)" m]
      have yn: "coprime ?y n"
        by (metis an(1) coprime_exp gcd.commute)
      have "?y mod n = (a^m)^((n - 1) div m) mod n"
        by (simp add: algebra_simps power_mult)
      also have "\<dots> = (a^m mod n)^((n - 1) div m) mod n"
        using power_mod[of "a^m" n "(n - 1) div m"] by simp
      also have "\<dots> = 1" using m(3)[unfolded cong_nat_def onen] onen
        by (metis power_one)
      finally have th3: "?y mod n = 1"  .
      have th2: "[?y * a ^ ((n - 1) mod m) = ?y* 1] (mod n)"
        using an1[unfolded cong_nat_def onen] onen
          div_mult_mod_eq[of "(n - 1)" m, symmetric]
        by (simp add:power_add[symmetric] cong_nat_def th3 del: One_nat_def)
      have th1: "[a ^ ((n - 1) mod m) = 1] (mod n)"
        by (metis cong_mult_rcancel_nat mult.commute th2 yn)
      from m(4)[rule_format, OF th0] nm1
        less_trans[OF mod_less_divisor[OF m(1), of "n - 1"] m(2)] th1
      have False by blast }
    hence "(n - 1) mod m = 0" by auto
    then have mn: "m dvd n - 1" by presburger
    then obtain r where r: "n - 1 = m*r" unfolding dvd_def by blast
    from n01 r m(2) have r01: "r\<noteq>0" "r\<noteq>1" by - (rule ccontr, simp)+
    obtain p where p: "prime p" "p dvd r"
      by (metis prime_factor_nat r01(2))
    hence th: "prime p \<and> p dvd n - 1" unfolding r by (auto intro: dvd_mult)
    have "(a ^ ((n - 1) div p)) mod n = (a^(m*r div p)) mod n" using r
      by (simp add: power_mult)
    also have "\<dots> = (a^(m*(r div p))) mod n"
      using div_mult1_eq[of m r p] p(2)[unfolded dvd_eq_mod_eq_0]
      by simp
    also have "\<dots> = ((a^m)^(r div p)) mod n" by (simp add: power_mult)
    also have "\<dots> = ((a^m mod n)^(r div p)) mod n" using power_mod ..
    also have "\<dots> = 1" using m(3) onen by (simp add: cong_nat_def)
    finally have "[(a ^ ((n - 1) div p))= 1] (mod n)"
      using onen by (simp add: cong_nat_def)
    with pn th have False by blast}
  hence th: "\<forall>m. 0 < m \<and> m < n - 1 \<longrightarrow> \<not> [a ^ m = 1] (mod n)" by blast
  from lucas_weak[OF n2 an1 th] show ?thesis .
qed

subsection\<open>Definition of the order of a number mod n (0 in non-coprime case)\<close>

definition "ord n a = (if coprime n a then Least (\<lambda>d. d > 0 \<and> [a ^d = 1] (mod n)) else 0)"

(* This has the expected properties.                                         *)

lemma coprime_ord:
  fixes n::nat
  assumes "coprime n a"
  shows "ord n a > 0 \<and> [a ^(ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> [a^ m \<noteq> 1] (mod n))"
proof-
  let ?P = "\<lambda>d. 0 < d \<and> [a ^ d = 1] (mod n)"
  from bigger_prime[of a] obtain p where p: "prime p" "a < p" by blast
  from assms have o: "ord n a = Least ?P" by (simp add: ord_def)
  {assume "n=0 \<or> n=1" with assms have "\<exists>m>0. ?P m"
      by auto}
  moreover
  {assume "n\<noteq>0 \<and> n\<noteq>1" hence n2:"n \<ge> 2" by arith
    from assms have na': "coprime a n"
      by (metis gcd.commute)
    from phi_lowerbound_1_nat[OF n2] euler_theorem_nat [OF na']
    have ex: "\<exists>m>0. ?P m" by - (rule exI[where x="phi n"], auto) }
  ultimately have ex: "\<exists>m>0. ?P m" by blast
  from nat_exists_least_iff'[of ?P] ex assms show ?thesis
    unfolding o[symmetric] by auto
qed

(* With the special value 0 for non-coprime case, it's more convenient.      *)
lemma ord_works:
  fixes n::nat
  shows "[a ^ (ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> ~[a^ m = 1] (mod n))"
apply (cases "coprime n a")
using coprime_ord[of n a]
by (auto simp add: ord_def cong_nat_def)

lemma ord:
  fixes n::nat
  shows "[a^(ord n a) = 1] (mod n)" using ord_works by blast

lemma ord_minimal:
  fixes n::nat
  shows "0 < m \<Longrightarrow> m < ord n a \<Longrightarrow> ~[a^m = 1] (mod n)"
  using ord_works by blast

lemma ord_eq_0:
  fixes n::nat
  shows "ord n a = 0 \<longleftrightarrow> ~coprime n a"
by (cases "coprime n a", simp add: coprime_ord, simp add: ord_def)

lemma divides_rexp:
  "x dvd y \<Longrightarrow> (x::nat) dvd (y^(Suc n))"
  by (simp add: dvd_mult2[of x y])

lemma ord_divides:
  fixes n::nat
  shows "[a ^ d = 1] (mod n) \<longleftrightarrow> ord n a dvd d" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume rh: ?rhs
  then obtain k where "d = ord n a * k" unfolding dvd_def by blast
  hence "[a ^ d = (a ^ (ord n a) mod n)^k] (mod n)"
    by (simp add : cong_nat_def power_mult power_mod)
  also have "[(a ^ (ord n a) mod n)^k = 1] (mod n)"
    using ord[of a n, unfolded cong_nat_def]
    by (simp add: cong_nat_def power_mod)
  finally  show ?lhs .
next
  assume lh: ?lhs
  { assume H: "\<not> coprime n a"
    hence o: "ord n a = 0" by (simp add: ord_def)
    {assume d: "d=0" with o H have ?rhs by (simp add: cong_nat_def)}
    moreover
    {assume d0: "d\<noteq>0" then obtain d' where d': "d = Suc d'" by (cases d, auto)
      from H
      obtain p where p: "p dvd n" "p dvd a" "p \<noteq> 1" by auto
      from lh
      obtain q1 q2 where q12:"a ^ d + n * q1 = 1 + n * q2"
        by (metis H d0 gcd.commute lucas_coprime_lemma)
      hence "a ^ d + n * q1 - n * q2 = 1" by simp
      with dvd_diff_nat [OF dvd_add [OF divides_rexp]]  dvd_mult2  d' p
      have "p dvd 1"
        by metis
      with p(3) have False by simp
      hence ?rhs ..}
    ultimately have ?rhs by blast}
  moreover
  {assume H: "coprime n a"
    let ?o = "ord n a"
    let ?q = "d div ord n a"
    let ?r = "d mod ord n a"
    have eqo: "[(a^?o)^?q = 1] (mod n)"
      by (metis cong_exp_nat ord power_one)
    from H have onz: "?o \<noteq> 0" by (simp add: ord_eq_0)
    hence op: "?o > 0" by simp
    from div_mult_mod_eq[of d "ord n a"] lh
    have "[a^(?o*?q + ?r) = 1] (mod n)" by (simp add: cong_nat_def mult.commute)
    hence "[(a^?o)^?q * (a^?r) = 1] (mod n)"
      by (simp add: cong_nat_def power_mult[symmetric] power_add[symmetric])
    hence th: "[a^?r = 1] (mod n)"
      using eqo mod_mult_left_eq[of "(a^?o)^?q" "a^?r" n]
      apply (simp add: cong_nat_def del: One_nat_def)
      by (simp add: mod_mult_left_eq[symmetric])
    {assume r: "?r = 0" hence ?rhs by (simp add: dvd_eq_mod_eq_0)}
    moreover
    {assume r: "?r \<noteq> 0"
      with mod_less_divisor[OF op, of d] have r0o:"?r >0 \<and> ?r < ?o" by simp
      from conjunct2[OF ord_works[of a n], rule_format, OF r0o] th
      have ?rhs by blast}
    ultimately have ?rhs by blast}
  ultimately  show ?rhs by blast
qed

lemma order_divides_phi:
  fixes n::nat shows "coprime n a \<Longrightarrow> ord n a dvd phi n"
  by (metis ord_divides euler_theorem_nat gcd.commute)

lemma order_divides_expdiff:
  fixes n::nat and a::nat assumes na: "coprime n a"
  shows "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
proof-
  {fix n::nat and a::nat and d::nat and e::nat
    assume na: "coprime n a" and ed: "(e::nat) \<le> d"
    hence "\<exists>c. d = e + c" by presburger
    then obtain c where c: "d = e + c" by presburger
    from na have an: "coprime a n"
      by (metis gcd.commute)
    have aen: "coprime (a^e) n"
      by (metis coprime_exp gcd.commute na)
    have acn: "coprime (a^c) n"
      by (metis coprime_exp gcd.commute na)
    have "[a^d = a^e] (mod n) \<longleftrightarrow> [a^(e + c) = a^(e + 0)] (mod n)"
      using c by simp
    also have "\<dots> \<longleftrightarrow> [a^e* a^c = a^e *a^0] (mod n)" by (simp add: power_add)
    also have  "\<dots> \<longleftrightarrow> [a ^ c = 1] (mod n)"
      using cong_mult_lcancel_nat [OF aen, of "a^c" "a^0"] by simp
    also  have "\<dots> \<longleftrightarrow> ord n a dvd c" by (simp only: ord_divides)
    also have "\<dots> \<longleftrightarrow> [e + c = e + 0] (mod ord n a)"
      using cong_add_lcancel_nat
      by (metis cong_dvd_eq_nat dvd_0_right cong_dvd_modulus_nat cong_mult_self_nat nat_mult_1)
    finally have "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
      using c by simp }
  note th = this
  have "e \<le> d \<or> d \<le> e" by arith
  moreover
  {assume ed: "e \<le> d" from th[OF na ed] have ?thesis .}
  moreover
  {assume de: "d \<le> e"
    from th[OF na de] have ?thesis
    by (metis cong_sym_nat)}
  ultimately show ?thesis by blast
qed

subsection\<open>Another trivial primality characterization\<close>

lemma prime_prime_factor:
  "prime (n::nat) \<longleftrightarrow> n \<noteq> 1 \<and> (\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof (cases "n=0 \<or> n=1")
  case True
  then show ?thesis
     by (metis bigger_prime dvd_0_right not_prime_1 not_prime_0)
next
  case False
  show ?thesis
  proof
    assume "prime n"
    then show ?rhs
      by (metis  not_prime_1 prime_nat_iff)
  next
    assume ?rhs
    with False show "prime n"
      by (auto simp: prime_nat_iff) (metis One_nat_def prime_factor_nat prime_nat_iff)
  qed
qed

lemma prime_divisor_sqrt:
  "prime (n::nat) \<longleftrightarrow> n \<noteq> 1 \<and> (\<forall>d. d dvd n \<and> d\<^sup>2 \<le> n \<longrightarrow> d = 1)"
proof -
  {assume "n=0 \<or> n=1" hence ?thesis
    by auto}
  moreover
  {assume n: "n\<noteq>0" "n\<noteq>1"
    hence np: "n > 1" by arith
    {fix d assume d: "d dvd n" "d\<^sup>2 \<le> n" and H: "\<forall>m. m dvd n \<longrightarrow> m=1 \<or> m=n"
      from H d have d1n: "d = 1 \<or> d=n" by blast
      {assume dn: "d=n"
        have "n\<^sup>2 > n*1" using n by (simp add: power2_eq_square)
        with dn d(2) have "d=1" by simp}
      with d1n have "d = 1" by blast  }
    moreover
    {fix d assume d: "d dvd n" and H: "\<forall>d'. d' dvd n \<and> d'\<^sup>2 \<le> n \<longrightarrow> d' = 1"
      from d n have "d \<noteq> 0"
        by (metis dvd_0_left_iff)
      hence dp: "d > 0" by simp
      from d[unfolded dvd_def] obtain e where e: "n= d*e" by blast
      from n dp e have ep:"e > 0" by simp
      have "d\<^sup>2 \<le> n \<or> e\<^sup>2 \<le> n" using dp ep
        by (auto simp add: e power2_eq_square mult_le_cancel_left)
      moreover
      {assume h: "d\<^sup>2 \<le> n"
        from H[rule_format, of d] h d have "d = 1" by blast}
      moreover
      {assume h: "e\<^sup>2 \<le> n"
        from e have "e dvd n" unfolding dvd_def by (simp add: mult.commute)
        with H[rule_format, of e] h have "e=1" by simp
        with e have "d = n" by simp}
      ultimately have "d=1 \<or> d=n"  by blast}
    ultimately have ?thesis unfolding prime_nat_iff using np n(2) by blast}
  ultimately show ?thesis by auto
qed

lemma prime_prime_factor_sqrt:
  "prime (n::nat) \<longleftrightarrow> n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p\<^sup>2 \<le> n)"
  (is "?lhs \<longleftrightarrow>?rhs")
proof-
  {assume "n=0 \<or> n=1"
   hence ?thesis
     by (metis not_prime_0 not_prime_1)}
  moreover
  {assume n: "n\<noteq>0" "n\<noteq>1"
    {assume H: ?lhs
      from H[unfolded prime_divisor_sqrt] n
      have ?rhs
        by (metis prime_prime_factor) }
    moreover
    {assume H: ?rhs
      {fix d assume d: "d dvd n" "d\<^sup>2 \<le> n" "d\<noteq>1"
        then obtain p where p: "prime p" "p dvd d"
          by (metis prime_factor_nat)
        from d(1) n have dp: "d > 0"
          by (metis dvd_0_left neq0_conv)
        from mult_mono[OF dvd_imp_le[OF p(2) dp] dvd_imp_le[OF p(2) dp]] d(2)
        have "p\<^sup>2 \<le> n" unfolding power2_eq_square by arith
        with H n p(1) dvd_trans[OF p(2) d(1)] have False  by blast}
      with n prime_divisor_sqrt  have ?lhs by auto}
    ultimately have ?thesis by blast }
  ultimately show ?thesis by (cases "n=0 \<or> n=1", auto)
qed

subsection\<open>Pocklington theorem\<close>

lemma pocklington_lemma:
  assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and an: "[a^ (n - 1) = 1] (mod n)"
  and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
  and pp: "prime (p::nat)" and pn: "p dvd n"
  shows "[p = 1] (mod q)"
proof -
  have p01: "p \<noteq> 0" "p \<noteq> 1" using pp by (auto intro: prime_gt_0_nat)
  obtain k where k: "a ^ (q * r) - 1 = n*k"
    by (metis an cong_to_1_nat dvd_def nqr)
  from pn[unfolded dvd_def] obtain l where l: "n = p*l" by blast
  {assume a0: "a = 0"
    hence "a^ (n - 1) = 0" using n by (simp add: power_0_left)
    with n an mod_less[of 1 n]  have False by (simp add: power_0_left cong_nat_def)}
  hence a0: "a\<noteq>0" ..
  from n nqr have aqr0: "a ^ (q * r) \<noteq> 0" using a0 by simp
  hence "(a ^ (q * r) - 1) + 1  = a ^ (q * r)" by simp
  with k l have "a ^ (q * r) = p*l*k + 1" by simp
  hence "a ^ (r * q) + p * 0 = 1 + p * (l*k)" by (simp add: ac_simps)
  hence odq: "ord p (a^r) dvd q"
    unfolding ord_divides[symmetric] power_mult[symmetric]
    by (metis an cong_dvd_modulus_nat mult.commute nqr pn)
  from odq[unfolded dvd_def] obtain d where d: "q = ord p (a^r) * d" by blast
  {assume d1: "d \<noteq> 1"
    obtain P where P: "prime P" "P dvd d"
      by (metis d1 prime_factor_nat)
    from d dvd_mult[OF P(2), of "ord p (a^r)"] have Pq: "P dvd q" by simp
    from aq P(1) Pq have caP:"coprime (a^ ((n - 1) div P) - 1) n" by blast
    from Pq obtain s where s: "q = P*s" unfolding dvd_def by blast
    have P0: "P \<noteq> 0" using P(1)
      by (metis not_prime_0)
    from P(2) obtain t where t: "d = P*t" unfolding dvd_def by blast
    from d s t P0  have s': "ord p (a^r) * t = s"
      by (metis mult.commute mult_cancel1 mult.assoc)
    have "ord p (a^r) * t*r = r * ord p (a^r) * t"
      by (metis mult.assoc mult.commute)
    hence exps: "a^(ord p (a^r) * t*r) = ((a ^ r) ^ ord p (a^r)) ^ t"
      by (simp only: power_mult)
    then have th: "[((a ^ r) ^ ord p (a^r)) ^ t= 1] (mod p)"
      by (metis cong_exp_nat ord power_one)
    have pd0: "p dvd a^(ord p (a^r) * t*r) - 1"
      by (metis cong_to_1_nat exps th)
    from nqr s s' have "(n - 1) div P = ord p (a^r) * t*r" using P0 by simp
    with caP have "coprime (a^(ord p (a^r) * t*r) - 1) n" by simp
    with p01 pn pd0 coprime_common_divisor_nat have False
      by auto}
  hence d1: "d = 1" by blast
  hence o: "ord p (a^r) = q" using d by simp
  from pp phi_prime[of p] have phip: "phi p = p - 1" by simp
  {fix d assume d: "d dvd p" "d dvd a" "d \<noteq> 1"
    from pp[unfolded prime_nat_iff] d have dp: "d = p" by blast
    from n have "n \<noteq> 0" by simp
    then have False using d dp pn
      by auto (metis One_nat_def Suc_pred an dvd_1_iff_1 gcd_greatest_iff lucas_coprime_lemma)}
  hence cpa: "coprime p a" by auto
  have arp: "coprime (a^r) p"
    by (metis coprime_exp cpa gcd.commute)
  from euler_theorem_nat[OF arp, simplified ord_divides] o phip
  have "q dvd (p - 1)" by simp
  then obtain d where d:"p - 1 = q * d"
    unfolding dvd_def by blast
  have p0:"p \<noteq> 0"
    by (metis p01(1))
  from p0 d have "p + q * 0 = 1 + q * d" by simp
  then show ?thesis
    by (metis cong_iff_lin_nat mult.commute)
qed

theorem pocklington:
  assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q\<^sup>2"
  and an: "[a^ (n - 1) = 1] (mod n)"
  and aq: "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
  shows "prime n"
unfolding prime_prime_factor_sqrt[of n]
proof-
  let ?ths = "n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p\<^sup>2 \<le> n)"
  from n have n01: "n\<noteq>0" "n\<noteq>1" by arith+
  {fix p assume p: "prime p" "p dvd n" "p\<^sup>2 \<le> n"
    from p(3) sqr have "p^(Suc 1) \<le> q^(Suc 1)" by (simp add: power2_eq_square)
    hence pq: "p \<le> q"
      by (metis le0 power_le_imp_le_base)
    from pocklington_lemma[OF n nqr an aq p(1,2)]
    have th: "q dvd p - 1"
      by (metis cong_to_1_nat)
    have "p - 1 \<noteq> 0" using prime_ge_2_nat [OF p(1)] by arith
    with pq th have False
      by (simp add: nat_dvd_not_less)}
  with n01 show ?ths by blast
qed

(* Variant for application, to separate the exponentiation.                  *)
lemma pocklington_alt:
  assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q\<^sup>2"
  and an: "[a^ (n - 1) = 1] (mod n)"
  and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> (\<exists>b. [a^((n - 1) div p) = b] (mod n) \<and> coprime (b - 1) n)"
  shows "prime n"
proof-
  {fix p assume p: "prime p" "p dvd q"
    from aq[rule_format] p obtain b where
      b: "[a^((n - 1) div p) = b] (mod n)" "coprime (b - 1) n" by blast
    {assume a0: "a=0"
      from n an have "[0 = 1] (mod n)" unfolding a0 power_0_left by auto
      hence False using n by (simp add: cong_nat_def dvd_eq_mod_eq_0[symmetric])}
    hence a0: "a\<noteq> 0" ..
    hence a1: "a \<ge> 1" by arith
    from one_le_power[OF a1] have ath: "1 \<le> a ^ ((n - 1) div p)" .
    {assume b0: "b = 0"
      from p(2) nqr have "(n - 1) mod p = 0"
        by (metis mod_0 mod_mod_cancel mod_mult_self1_is_0)
      with div_mult_mod_eq[of "n - 1" p]
      have "(n - 1) div p * p= n - 1" by auto
      hence eq: "(a^((n - 1) div p))^p = a^(n - 1)"
        by (simp only: power_mult[symmetric])
      have "p - 1 \<noteq> 0" using prime_ge_2_nat [OF p(1)] by arith
      then have pS: "Suc (p - 1) = p" by arith
      from b have d: "n dvd a^((n - 1) div p)" unfolding b0
        by auto
      from divides_rexp[OF d, of "p - 1"] pS eq cong_dvd_eq_nat [OF an] n
      have False
        by simp}
    then have b0: "b \<noteq> 0" ..
    hence b1: "b \<ge> 1" by arith
    from cong_imp_coprime_nat[OF Cong.cong_diff_nat[OF cong_sym_nat [OF b(1)] cong_refl_nat[of 1] b1]]
         ath b1 b nqr
    have "coprime (a ^ ((n - 1) div p) - 1) n"
      by simp}
  hence th: "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a ^ ((n - 1) div p) - 1) n "
    by blast
  from pocklington[OF n nqr sqr an th] show ?thesis .
qed

subsection\<open>Prime factorizations\<close>

(* FIXME some overlap with material in UniqueFactorization, class unique_factorization *)

definition "primefact ps n = (foldr op * ps 1 = n \<and> (\<forall>p\<in> set ps. prime p))"

lemma primefact:
  assumes n: "n \<noteq> (0::nat)"
  shows "\<exists>ps. primefact ps n"
proof -
  have "\<exists>xs. mset xs = prime_factorization n" by (rule ex_mset)
  then guess xs .. note xs = this
  from assms have "n = prod_mset (prime_factorization n)"
    by (simp add: prod_mset_prime_factorization)
  also have "\<dots> = prod_mset (mset xs)" by (simp add: xs)
  also have "\<dots> = foldr op * xs 1" by (induction xs) simp_all
  finally have "foldr op * xs 1 = n" ..
  moreover from xs have "\<forall>p\<in>#mset xs. prime p"
    by auto
  ultimately have "primefact xs n" by (auto simp: primefact_def)
  thus ?thesis ..
qed

lemma primefact_contains:
  assumes pf: "primefact ps n" and p: "prime p" and pn: "p dvd n"
  shows "(p::nat) \<in> set ps"
  using pf p pn
proof(induct ps arbitrary: p n)
  case Nil thus ?case by (auto simp add: primefact_def)
next
  case (Cons q qs p n)
  from Cons.prems[unfolded primefact_def]
  have q: "prime q" "q * foldr op * qs 1 = n" "\<forall>p \<in>set qs. prime p"  and p: "prime p" "p dvd q * foldr op * qs 1" by simp_all
  {assume "p dvd q"
    with p(1) q(1) have "p = q" unfolding prime_nat_iff by auto
    hence ?case by simp}
  moreover
  { assume h: "p dvd foldr op * qs 1"
    from q(3) have pqs: "primefact qs (foldr op * qs 1)"
      by (simp add: primefact_def)
    from Cons.hyps[OF pqs p(1) h] have ?case by simp}
  ultimately show ?case
    by (metis p prime_dvd_mult_eq_nat)
qed

lemma primefact_variant: "primefact ps n \<longleftrightarrow> foldr op * ps 1 = n \<and> list_all prime ps"
  by (auto simp add: primefact_def list_all_iff)

(* Variant of Lucas theorem.                                                 *)

lemma lucas_primefact:
  assumes n: "n \<ge> 2" and an: "[a^(n - 1) = 1] (mod n)"
  and psn: "foldr op * ps 1 = n - 1"
  and psp: "list_all (\<lambda>p. prime p \<and> \<not> [a^((n - 1) div p) = 1] (mod n)) ps"
  shows "prime n"
proof-
  {fix p assume p: "prime p" "p dvd n - 1" "[a ^ ((n - 1) div p) = 1] (mod n)"
    from psn psp have psn1: "primefact ps (n - 1)"
      by (auto simp add: list_all_iff primefact_variant)
    from p(3) primefact_contains[OF psn1 p(1,2)] psp
    have False by (induct ps, auto)}
  with lucas[OF n an] show ?thesis by blast
qed

(* Variant of Pocklington theorem.                                           *)

lemma pocklington_primefact:
  assumes n: "n \<ge> 2" and qrn: "q*r = n - 1" and nq2: "n \<le> q\<^sup>2"
  and arnb: "(a^r) mod n = b" and psq: "foldr op * ps 1 = q"
  and bqn: "(b^q) mod n = 1"
  and psp: "list_all (\<lambda>p. prime p \<and> coprime ((b^(q div p)) mod n - 1) n) ps"
  shows "prime n"
proof-
  from bqn psp qrn
  have bqn: "a ^ (n - 1) mod n = 1"
    and psp: "list_all (\<lambda>p. prime p \<and> coprime (a^(r *(q div p)) mod n - 1) n) ps"
    unfolding arnb[symmetric] power_mod
    by (simp_all add: power_mult[symmetric] algebra_simps)
  from n  have n0: "n > 0" by arith
  from div_mult_mod_eq[of "a^(n - 1)" n]
    mod_less_divisor[OF n0, of "a^(n - 1)"]
  have an1: "[a ^ (n - 1) = 1] (mod n)"
    by (metis bqn cong_nat_def mod_mod_trivial)
  {fix p assume p: "prime p" "p dvd q"
    from psp psq have pfpsq: "primefact ps q"
      by (auto simp add: primefact_variant list_all_iff)
    from psp primefact_contains[OF pfpsq p]
    have p': "coprime (a ^ (r * (q div p)) mod n - 1) n"
      by (simp add: list_all_iff)
    from p prime_nat_iff have p01: "p \<noteq> 0" "p \<noteq> 1" "p =Suc(p - 1)"
      by auto
    from div_mult1_eq[of r q p] p(2)
    have eq1: "r* (q div p) = (n - 1) div p"
      unfolding qrn[symmetric] dvd_eq_mod_eq_0 by (simp add: mult.commute)
    have ath: "\<And>a (b::nat). a <= b \<Longrightarrow> a \<noteq> 0 ==> 1 <= a \<and> 1 <= b" by arith
    {assume "a ^ ((n - 1) div p) mod n = 0"
      then obtain s where s: "a ^ ((n - 1) div p) = n*s"
        unfolding mod_eq_0_iff by blast
      hence eq0: "(a^((n - 1) div p))^p = (n*s)^p" by simp
      from qrn[symmetric] have qn1: "q dvd n - 1" unfolding dvd_def by auto
      from dvd_trans[OF p(2) qn1]
      have npp: "(n - 1) div p * p = n - 1" by simp
      with eq0 have "a^ (n - 1) = (n*s)^p"
        by (simp add: power_mult[symmetric])
      hence "1 = (n*s)^(Suc (p - 1)) mod n" using bqn p01 by simp
      also have "\<dots> = 0" by (simp add: mult.assoc)
      finally have False by simp }
      then have th11: "a ^ ((n - 1) div p) mod n \<noteq> 0" by auto
    have th1: "[a ^ ((n - 1) div p) mod n = a ^ ((n - 1) div p)] (mod n)"
      unfolding cong_nat_def by simp
    from  th1   ath[OF mod_less_eq_dividend th11]
    have th: "[a ^ ((n - 1) div p) mod n - 1 = a ^ ((n - 1) div p) - 1] (mod n)"
      by (metis cong_diff_nat cong_refl_nat)
    have "coprime (a ^ ((n - 1) div p) - 1) n"
      by (metis cong_imp_coprime_nat eq1 p' th) }
  with pocklington[OF n qrn[symmetric] nq2 an1]
  show ?thesis by blast
qed

end


theory ClassBinary
imports "../vdm/VDMSeq" "../vdm/VDMSet"
begin

(*************************************************************************)
text {* VDM values *}

text {*
\begin{vdmsl}[breaklines=true]

values
	MAX_BITS: nat1 = 8;
	BITS: set of nat = {0,...,MAX_BITS};
\end{vdmsl}
*}

abbreviation MAX_BITS :: VDMNat where
  "MAX_BITS \<equiv> 8"
abbreviation BITS :: "VDMNat VDMSet" where
  "BITS \<equiv> {0 .. MAX_BITS}"

definition inv_MAX_BITS :: \<bool> where
  "inv_MAX_BITS \<equiv> inv_VDMNat1 MAX_BITS"
definition inv_BITS :: \<bool> where
  "inv_BITS \<equiv> inv_SetElems inv_VDMNat BITS"

(*************************************************************************)
text {* VDM types *}

text {*
\begin{vdmsl}[breaklines=true]
types
	Bits = nat
	inv b == b in set BITS;

	uint = nat
	inv v == v < pow(2,MAX_BITS);

	bin = seq of bool
	inv b == len b <= MAX_BITS;
\end{vdmsl}
*}

type_synonym Bits = VDMNat
type_synonym uint = VDMNat
type_synonym bin = "\<bool> VDMSeq"

fun powProblematic :: "\<int> \<Rightarrow> \<nat> \<Rightarrow> VDMNat1" where
  "powProblematic base exp =
      (if exp = 0 then 1 else base * powProblematic base (exp - 1))"

lemma "powProblematic 2 3 = R" apply simp oops

fun pow0 :: "\<nat> \<Rightarrow> \<nat> \<Rightarrow> \<nat>" where
  "pow0 base 0 = 1" |
  "pow0 base (Suc exp) = base * pow0 base exp"

definition
  pow :: "VDMInt \<Rightarrow> VDMNat \<Rightarrow> VDMNat1"
where
  "pow base exp \<equiv> int (pow0 (nat base) (nat exp))"

definition inv_Bits :: "Bits \<Rightarrow> \<bool>" where
  "inv_Bits b \<equiv> b \<in> BITS"
definition inv_uint :: "uint \<Rightarrow> \<bool>" where
  "inv_uint v \<equiv> inv_VDMNat v \<and> v < (pow 2 MAX_BITS)"
definition inv_bin :: "bin \<Rightarrow> \<bool>" where
  "inv_bin b \<equiv> len b \<le> MAX_BITS"

(*************************************************************************)
text {* VDM functions *}

text {*
\begin{vdmsl}[breaklines=true]
functions

b2n: bool -> nat
b2n(b) == if b then 1 else 0
post RESULT <= 1;

n2b: nat -> bool
n2b(n) == n <> 0

pow : int * nat -> nat1
pow(base, exp) == if exp = 0 then 1 else base * pow(base, exp - 1)
pre base >= 0
post RESULT = base**exp;

bpow : Bits -> uint
bpow(exp) == pow(2,exp);

toNat: bin -> uint
toNat(bs) == if bs = [] then 0 else b2n(hd bs) + 2 * toNat(tl bs)
post RESULT < bpow(len bs);

toBin: uint -> bin
toBin(n) == if n = 0 then [] else toBin(n div 2) ^ [n2b(n mod 2)]
post n < bpow(len RESULT);
\end{vdmsl}
*}

definition pre_pow :: "VDMInt \<Rightarrow> VDMNat \<Rightarrow> \<bool>" where
 "pre_pow base exp \<equiv> inv_VDMNat exp \<and> base \<ge> 0"

definition post_pow :: "VDMInt \<Rightarrow> VDMNat \<Rightarrow> VDMNat1 \<Rightarrow> \<bool>" where
 "post_pow base exp RESULT \<equiv> inv_VDMNat exp \<and>
    inv_VDMNat1 RESULT \<and> pre_pow base exp \<and>
    RESULT = int((nat base) ^ (nat exp))"

definition b2n :: "\<bool> \<Rightarrow> VDMNat" where
  "b2n b \<equiv> if b then 1 else 0"

definition pre_b2n :: "\<bool> \<Rightarrow> \<bool>" where
  "pre_b2n b \<equiv> True"

definition post_b2n :: "\<bool> \<Rightarrow> VDMNat \<Rightarrow> \<bool>" where
  "post_b2n b RESULT \<equiv> inv_VDMNat RESULT \<and> RESULT \<le> 1"

definition n2b :: "VDMNat \<Rightarrow> \<bool>" where "n2b n \<equiv> n \<noteq> 0"

definition pre_n2b :: "VDMNat \<Rightarrow> \<bool>" where
  "pre_n2b n \<equiv> inv_VDMNat n"

definition post_n2b :: "VDMNat \<Rightarrow> \<bool> \<Rightarrow> \<bool>" where
  "post_n2b n RESULT \<equiv> inv_VDMNat n"

definition bpow :: "Bits \<Rightarrow> uint" where "bpow exp \<equiv> pow 2 exp"

definition pre_bpow :: "Bits \<Rightarrow> \<bool>" where
  "pre_bpow exp \<equiv> inv_Bits exp"

definition post_bpow :: "Bits \<Rightarrow> uint \<Rightarrow> \<bool>" where
  "post_bpow exp RESULT \<equiv> inv_Bits exp \<and> inv_uint RESULT"

fun toNatWrong :: "bin \<Rightarrow> uint" where
  "toNatWrong [] = 0" |
  "toNatWrong (b#bs) = (b2n b) + 2 * (toNatWrong bs)"

lemma "toNatWrong [False, True, True] = 6" by (simp add: b2n_def)

fun toNat0 :: "bin \<Rightarrow> \<nat> \<Rightarrow> \<nat>"
where
  "toNat0 [] p = p"
| "toNat0 (b # bs) p = (toNat0 bs (nat (b2n b) + (2 * p)))"

definition toNat :: "bin \<Rightarrow> uint" where
  "toNat bs \<equiv> int (toNat0 bs 0)"

lemma "toNat [True, True, False] = 6"
unfolding toNat_def
apply (simp only: toNat0.simps)
unfolding b2n_def
by simp

definition pre_toNat :: "bin \<Rightarrow> \<bool>" where
  "pre_toNat bs \<equiv> inv_bin bs"

definition post_toNat :: "bin \<Rightarrow> uint \<Rightarrow> \<bool>" where
  "post_toNat bs RESULT \<equiv>
      inv_uint RESULT \<and> inv_bin bs \<and> RESULT < bpow (len bs)"

fun toBin0 :: "\<nat> \<Rightarrow> bin" where
  "toBin0 0 = []" |
  "toBin0 (Suc n) =  toBin0 ((Suc n) div 2) @ [n2b (int ((Suc n) mod 2))] "

definition toBin :: "uint \<Rightarrow> bin" where
  "toBin n \<equiv> toBin0 (nat n)"

lemma "toBin 6 = [True, True, False]" unfolding toBin_def
apply (subgoal_tac "nat 6 = Suc(Suc(Suc(Suc(Suc(Suc 0)))))")
apply (simp only: toBin0.simps)
using n2b_def by simp_all

definition pre_toBin :: "uint \<Rightarrow> \<bool>" where
  "pre_toBin n \<equiv> inv_uint n"

definition post_toBin :: "uint \<Rightarrow> bin \<Rightarrow> \<bool>" where
  "post_toBin n RESULT \<equiv>
      inv_uint n \<and> inv_bin RESULT \<and> n < bpow (len RESULT)"

lemma "toBin0 (toNat0 bs 0) = bs"
  apply (induct bs, simp)
  apply simp
  unfolding b2n_def
  apply (case_tac a, simp)
  oops

lemma "toNat0 (toBin0 n) 0 = n"
  apply (induct n, simp+)
  oops

lemma "toNat0 (toBin0 n) 0 = n"
apply (induct n, simp)
  apply (simp only: toBin0.simps)
  unfolding n2b_def
  apply simp
    oops

lemma "toBin0 (toNat0 bs 0) = bs"
apply (induct bs, simp_all)
unfolding b2n_def apply auto oops

theorem PO_bpow_legal_fcn_appl: "\<forall> exp . inv_Bits exp \<longrightarrow> pre_pow 2 exp"
unfolding pre_pow_def inv_Bits_def inv_VDMNat_def by auto
lemma "0 \<le> exp \<and> exp \<le> (nat MAX_BITS) \<Longrightarrow> pow0 2  exp < pow0 2 8"
apply (induct exp, simp_all)
apply (subgoal_tac "8=Suc(Suc(Suc(Suc(Suc(Suc(Suc(Suc 0)))))))")
apply (simp only: pow0.simps, simp) oops

theorem PO_bpow_type_compatibility: "\<forall> exp . inv_Bits exp \<longrightarrow> inv_uint (pow 2 exp)"
unfolding inv_Bits_def inv_uint_def inv_VDMNat_def pow_def
apply (intro allI impI conjI, simp_all, elim conjE)oops

lemma "powProblematic 2 3 = 8" apply simp done

value "[0 .x \<leftarrow> [0..(3::int)]] = [0,0,0,0]"
end


theory week05A_demo
imports Main
begin

\<comment> \<open>---------------------------------------------------\<close>

text\<open>A manual proof in set theory:\<close>

thm equalityI subsetI UnI1 UnI2 UnE

lemma "(A \<union> B) = (B \<union> A)"
  apply (rule equalityI)
   apply (rule subsetI)
   apply (erule UnE)
    apply (erule UnI2)
   apply (erule UnI1)
  apply (rule subsetI)
  apply (erule UnE)
  apply (rule  UnI2, assumption)
  apply (rule  UnI1, assumption)
  done

thm subsetD
declare [[simp_trace = false]]
lemma "(A\<union>B \<subseteq> C) = (A\<subseteq>C \<and> B\<subseteq>C)"
  apply (rule iffI)
   apply (rule conjI)
    apply (rule subsetI)
    apply (erule subsetD)
    apply (rule UnI1)
    apply (assumption)
   apply (rule subsetI)
   apply (erule subsetD)
   apply (rule UnI2)
   apply assumption
  apply (erule conjE)
  apply (rule subsetI)
  apply (erule UnE)
   apply (erule subsetD, assumption)
  apply (erule subsetD, assumption)
  done
lemma "{a,b} \<inter> {b,c} = (if a \<noteq> c then {b} else {a,b})"
  apply simp
  apply blast
  done

text\<open>Most simple proofs in set theory are automatic:\<close>

lemma "-(A \<union> B) = (-A \<inter> -B)"
  by blast

lemma "{x. P x \<and> Q x} = {x. P x} \<inter> {x. Q x}"
  by blast

\<comment> \<open>--------------------------------------------\<close>

text \<open>Introducing new types\<close>

\<comment> \<open>a new "undefined" type:\<close>
typedecl names
consts blah :: names

\<comment> \<open>simple abbreviation:\<close>
type_synonym 'a myrel = "'a \<Rightarrow> 'a \<Rightarrow> bool"

definition
  eq :: "'a myrel"
where
  "eq x y \<equiv> (x = y)"
term "eq"

\<comment> \<open>type definition: pairs\<close>

typedef three = "{0::nat,1,2}"
 apply (rule_tac x=1 in exI)
 apply blast
 done

print_theorems

definition prd :: "('a \<Rightarrow> 'b \<Rightarrow> bool) set" where
  "prd \<equiv> {f. \<exists>a b. f = (\<lambda>x y. x=a \<and> y=b)}"

typedef
  ('a, 'b) prd = "prd::('a \<Rightarrow> 'b \<Rightarrow> bool) set"
  by (auto simp: prd_def)
  (* To understand this proof, try:
  apply (simp add: prd_def)
  -- "just need to exhibit *one* pair, any"
  apply (rule_tac x="\<lambda>x y. x=blah1 \<and> y=blah2" in exI)
  apply (rule_tac x=blah1 in exI)
  apply (rule_tac x=blah2 in exI)
  apply (rule refl)
  done
  *)

print_theorems

definition
  pair :: "'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) prd"
where
  "pair a b \<equiv> Abs_prd (\<lambda>x y. x = a \<and> y = b)"

definition
  fs :: "('a,'b) prd \<Rightarrow> 'a"
where
  "fs x \<equiv> SOME a. \<exists>b. x = pair a b"

definition
  sn :: "('a,'b) prd \<Rightarrow> 'b"
where
  "sn x \<equiv> SOME b. \<exists>a. x = pair a b"

lemma in_prd: "(\<lambda>x y. x = c \<and> y = d) \<in> prd"
  apply (unfold prd_def)
  apply blast
  done

thm iffD1
thm Abs_prd_inject
thm in_prd
thm fun_cong
lemma pair_inject:
  "pair a b = pair a' b' \<Longrightarrow> a=a' \<and> b=b'"
  (*TODO*)
  apply (unfold pair_def)
  apply (insert in_prd [of a b])
  apply (insert in_prd [of a' b'])
  apply (blast dest:Abs_prd_inject fun_cong)
  done

thm pair_inject
lemma pair_eq:
  "(pair a b = pair a' b') = (a=a' \<and> b=b')"
  by (blast dest: pair_inject)

lemma fs:
  "fs (pair a b) = a"
  apply (unfold fs_def)
  apply (blast dest: pair_inject)
  done

lemma sn:
  "sn (pair a b) = b"
  apply (unfold sn_def)
  apply (blast dest: pair_inject)
  done

\<comment> \<open>--------------------------------------------\<close>

section\<open>Inductive definitions\<close>

subsection\<open>Inductive definition of finite sets\<close>

inductive_set Fin :: "'a set set"
where
emptyI:  "{} \<in> Fin" |
insertI: "A \<in> Fin \<Longrightarrow> insert a A \<in> Fin"

print_theorems

subsection\<open>Inductive definition of the even numbers\<close>

inductive_set Ev :: "nat set"
where
ZeroI: "0 \<in> Ev" |
Add2I: "n \<in> Ev \<Longrightarrow> Suc(Suc n) \<in> Ev"

print_theorems

text\<open>Using the introduction rules:\<close>
lemma "Suc(Suc(Suc(Suc 0))) \<in> Ev"
  apply (rule Add2I)
  apply (rule Add2I)
  apply (rule ZeroI)
  done

text\<open>Using the case elimination rules:\<close>
lemma "n \<in> Ev \<Longrightarrow> n = 0 \<or> (\<exists>n' \<in> Ev. n = Suc (Suc n'))"
  thm Ev.cases
  apply(blast elim: Ev.cases)
  done

text\<open>A simple inductive proof:\<close>
lemma "n \<in> Ev \<Longrightarrow> n+n \<in> Ev"
  thm Ev.induct
  apply (erule Ev.induct)
   apply simp
   apply (rule ZeroI)
  apply simp
  apply (rule Add2I)+
  apply assumption
  done

text\<open>You can also use the rules for Ev as conditional simplification
rules. This can shorten proofs considerably.  \emph{Warning}:
conditional rules can lead to nontermination of the simplifier.  The
rules for Ev are OK because the premises are always `smaller' than the
conclusion. The list of rules for Ev is contained in Ev.intros.\<close>
thm Ev.intros
declare Ev.intros[simp]

text\<open>A shorter proof:\<close>

lemma "n \<in> Ev \<Longrightarrow> n+n \<in> Ev"
  apply(erule Ev.induct)
  apply(simp_all)
  done

text\<open>Nice example, but overkill: don't need assumption
@{prop "n \<in>Ev"} because @{prop"n+n \<in> Ev"} is true for all @{text n}.

However, here we really need the assumptions:\<close>

lemma "\<lbrakk> m \<in> Ev; n \<in> Ev \<rbrakk> \<Longrightarrow> m+n \<in> Ev"
  apply(erule Ev.induct)
  apply(auto)
  done

text\<open>An inductive proof of @{prop "1 \<notin> Ev"}:\<close>
thm Ev.induct
lemma "n \<in> Ev \<Longrightarrow> n \<noteq> 1"
  apply(erule Ev.induct)
  apply(simp)+
  done

text\<open>The general case:\<close>
lemma "n \<in> Ev \<Longrightarrow> \<not>(\<exists>k. n = 2*k+1)"
  apply(erule Ev.induct)
   apply simp
  apply arith
  done

subsection\<open>Proofs about finite sets\<close>

text\<open>Above we declared @{text Ev.intros} as simplification rules.
Now we declare @{text Fin.intros} as introduction rules (via attribute
``intro''). Then fast and blast use them automatically.\<close>

declare Fin.intros [intro]
thm Fin.intros
thm Fin.induct
lemma "\<lbrakk> A \<in> Fin; B \<in> Fin \<rbrakk> \<Longrightarrow> A \<union> B \<in> Fin"
  apply(erule Fin.induct)
   apply simp
  apply auto
  done

lemma "\<lbrakk> A \<in> Fin; B \<subseteq> A \<rbrakk> \<Longrightarrow> B \<in> Fin"
  apply(erule Fin.induct)
txt\<open>The base case looks funny: why is the premise not @{prop "B \<subseteq> {}"}?
Because @{prop "B \<subseteq> A"} was not part of the conclusion we prove.
Relief: pull @{prop "B \<subseteq> A"} into the conclusion with the help of @{text"\<longrightarrow>"}.
\<close>
oops

lemma "A \<in> Fin \<Longrightarrow> B \<subseteq> A \<longrightarrow> B \<in> Fin"
apply(erule Fin.induct)
 apply auto[1]
apply (clarsimp del: subsetI)
txt\<open>We need to strengthen the theorem: quantify @{text B}.\<close>
oops

lemma "A \<in> Fin \<Longrightarrow> \<forall>B. B \<subseteq> A \<longrightarrow> B \<in> Fin"
apply(erule Fin.induct)
 apply(simp)
 apply(rule Fin.emptyI)
apply(rule allI)
apply(rule impI)
apply simp thm subset_insert_iff insert_Diff
apply (simp add:subset_insert_iff)
apply(simp add:subset_insert_iff split:if_split_asm)
apply(drule_tac A = B in insert_Diff)
apply(erule subst)
apply(blast)
done

\<comment> \<open>---------------------------------------------------\<close>

section "Inductive Predicates"

text \<open>The whole thing also works for predicates directly:\<close>

inductive
  even :: "nat \<Rightarrow> bool"
where
  0: "even 0" |
  2: "even n \<Longrightarrow> even (Suc (Suc n))"

print_theorems

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Constructing Minimal Bad Sequences *}

theory Minimal_Bad_Sequences
imports Restricted_Predicates
begin

text {*
  The set of all infinite sequences over elements from @{term A}.
*}
definition "SEQ A = {f::nat \<Rightarrow> 'a. \<forall>i. f i \<in> A}"

lemma SEQ_iff [iff]:
  "f \<in> SEQ A \<longleftrightarrow> (\<forall>i. f i \<in> A)"
  by (auto simp: SEQ_def)

text {*
  An infinite sequence is \emph{good} whenever there are indices @{term "i < j"} such that
  @{term "P (f i) (f j)"}.
*}
definition good :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  "good P f \<longleftrightarrow> (\<exists>i j. i < j \<and> P (f i) (f j))"

text {*
  A sequence that is not good is called \emph{bad}.
*}
abbreviation "bad P f \<equiv> \<not> good P f"

lemma goodI:
  "\<lbrakk>i < j; P (f i) (f j)\<rbrakk> \<Longrightarrow> good P f"
  by (auto simp: good_def)

lemma goodE [elim]:
  "good P f \<Longrightarrow> (\<And>i j. \<lbrakk>i < j; P (f i) (f j)\<rbrakk> \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto simp: good_def)

lemma badE [elim]:
  "bad P f \<Longrightarrow> ((\<And>i j. i < j \<Longrightarrow> \<not> P (f i) (f j)) \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto simp: good_def)

text {*
  A locale capturing the construction of minimal bad sequences over values from @{term "A"}. Where
  minimality is to be understood w.r.t.\ @{term size} of an element.
*}
locale mbs =
  fixes A :: "('a :: size) set"
begin

text {*
  Since the @{term size} is a well-founded measure, whenever some element satisfies a property
  @{term P}, then there is a size-minimal such element.
*}
lemma minimal:
  assumes "x \<in> A" and "P x"
  shows "\<exists>y \<in> A. size y \<le> size x \<and> P y \<and> (\<forall>z \<in> A. size z < size y \<longrightarrow> \<not> P z)"
using assms
proof (induction x taking: size rule: measure_induct)
  case (1 x)
  then show ?case
  proof (cases "\<forall>y \<in> A. size y < size x \<longrightarrow> \<not> P y")
    case True
    with 1 show ?thesis by blast
  next
    case False
    then obtain y where "y \<in> A" and "size y < size x" and "P y" by blast
    with "1.IH" show ?thesis by (fastforce elim!: order_trans)
  qed
qed

lemma less_not_eq [simp]:
  "x \<in> A \<Longrightarrow> size x < size y \<Longrightarrow> x = y \<Longrightarrow> False"
  by simp

text {*
  The set of all bad sequences over @{term A}.
*}
definition "BAD P = {f \<in> SEQ A. bad P f}"

lemma BAD_iff [iff]:
  "f \<in> BAD P \<longleftrightarrow> (\<forall>i. f i \<in> A) \<and> bad P f"
  by (auto simp: BAD_def)

text {*
  A partial order on infinite bad sequences.
*}
definition geseq :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set"
where
  "geseq =
    {(f, g). f \<in> SEQ A \<and> g \<in> SEQ A \<and> (f = g \<or> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j)))}"

text {*
  The strict part of the above order.
*}
definition gseq :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set" where
  "gseq = {(f, g). f \<in> SEQ A \<and> g \<in> SEQ A \<and> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j))}"

lemma geseq_iff:
  "(f, g) \<in> geseq \<longleftrightarrow>
    f \<in> SEQ A \<and> g \<in> SEQ A \<and> (f = g \<or> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j)))"
  by (auto simp: geseq_def)

lemma gseq_iff:
  "(f, g) \<in> gseq \<longleftrightarrow> f \<in> SEQ A \<and> g \<in> SEQ A \<and> (\<exists>i. size (g i) < size (f i) \<and> (\<forall>j < i. f j = g j))"
  by (auto simp: gseq_def)

lemma geseqE:
  assumes "(f, g) \<in> geseq"
    and "\<lbrakk>\<forall>i. f i \<in> A; \<forall>i. g i \<in> A; f = g\<rbrakk> \<Longrightarrow> Q"
    and "\<And>i. \<lbrakk>\<forall>i. f i \<in> A; \<forall>i. g i \<in> A; size (g i) < size (f i); \<forall>j < i. f j = g j\<rbrakk> \<Longrightarrow> Q"
  shows "Q"
  using assms by (auto simp: geseq_iff)

lemma gseqE:
  assumes "(f, g) \<in> gseq"
    and "\<And>i. \<lbrakk>\<forall>i. f i \<in> A; \<forall>i. g i \<in> A; size (g i) < size (f i); \<forall>j < i. f j = g j\<rbrakk> \<Longrightarrow> Q"
  shows "Q"
  using assms by (auto simp: gseq_iff)

text {*
  The @{term i}-th "column" of a set @{term B} of infinite sequences.
*}
definition "ith B i = {f i | f. f \<in> B}"

lemma ithI [intro]:
  "f \<in> B \<Longrightarrow> f i = x \<Longrightarrow> x \<in> ith B i"
  by (auto simp: ith_def)

lemma ithE [elim]:
  "\<lbrakk>x \<in> ith B i; \<And>f. \<lbrakk>f \<in> B; f i = x\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (auto simp: ith_def)

lemma ith_conv:
  "x \<in> ith B i \<longleftrightarrow> (\<exists>f \<in> B. x = f i)"
  by auto

context
  fixes B :: "'a set"
  assumes subset_A: "B \<subseteq> A" and ne: "B \<noteq> {}"
begin

text {*
  A minimal element (w.r.t.~@{term size}) from a set.
*}
definition "min_elt = (SOME x. x \<in> B \<and> (\<forall>y \<in> A. size y < size x \<longrightarrow> y \<notin> B))"

lemma min_elt_ex:
  "\<exists>x. x \<in> B \<and> (\<forall>y \<in> A. size y < size x \<longrightarrow> y \<notin> B)"
  using subset_A and ne using minimal [of _ "\<lambda>x. x \<in> B"] by auto

lemma min_elt_mem:
  "min_elt \<in> B"
  using someI_ex [OF min_elt_ex] by (auto simp: min_elt_def)

lemma min_elt_minimal:
  assumes "y \<in> A" and "size y < size min_elt"
  shows "y \<notin> B"
  using someI_ex [OF min_elt_ex] and assms by (auto simp: min_elt_def)

end

end

text {*
  The restriction of a set @{term "B"} of sequences to sequences that are equal to a given sequence
  @{term f} up to position @{term i}.
*}
definition eq_upto :: "(nat \<Rightarrow> 'a) set \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) set"
where
  "eq_upto B f i = {g \<in> B. \<forall>j < i. f j = g j}"

lemma eq_uptoI [intro]:
  "\<lbrakk>g \<in> B; \<And>j. j < i \<Longrightarrow> f j = g j\<rbrakk> \<Longrightarrow> g \<in> eq_upto B f i"
  by (auto simp: eq_upto_def)

lemma eq_uptoE [elim]:
  "\<lbrakk>g \<in> eq_upto B f i; \<lbrakk>g \<in> B; \<And>j. j < i \<Longrightarrow> f j = g j\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (auto simp: eq_upto_def)

lemma eq_upto_Suc:
  "\<lbrakk>g \<in> eq_upto B f i; g i = f i\<rbrakk> \<Longrightarrow> g \<in> eq_upto B f (Suc i)"
  by (auto simp: eq_upto_def less_Suc_eq)

lemma eq_upto_0 [simp]:
  "eq_upto B f 0 = B"
  by (auto simp: eq_upto_def)

lemma eq_upto_cong [fundef_cong]:
  assumes "\<And>j. j < i \<Longrightarrow> f j = g j" and "B = C"
  shows "eq_upto B f i = eq_upto C g i"
  using assms by (auto simp: eq_upto_def)

context mbs
begin

context
  fixes P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

text {*
  A lower bound to all sequences in a set of sequences @{term B}.
*}
fun lb :: "nat \<Rightarrow> 'a" where
  lb: "lb i = min_elt (ith (eq_upto (BAD P) lb i) i)"

declare lb.simps [simp del]

lemma eq_upto_BAD_mem:
  assumes "f \<in> eq_upto (BAD P) g i"
  shows "f j \<in> A"
  using assms by (auto)

text {*
  Assume that there is some infinite bad sequence @{term h}.
*}
context
  fixes h :: "nat \<Rightarrow> 'a"
  assumes BAD_ex: "h \<in> BAD P"
begin

text {*
  When there is a bad sequence, then filtering @{term "BAD P"} w.r.t.~positions in @{term lb} never
  yields an empty set of sequences.
*}
lemma eq_upto_BAD_non_empty:
  "eq_upto (BAD P) lb i \<noteq> {}"
proof (induct i)
  case 0
  show ?case using BAD_ex by auto
next
  let ?A = "\<lambda>i. ith (eq_upto (BAD P) lb i) i"
  case (Suc i)
  then have "?A i \<noteq> {}" by auto
  moreover have "eq_upto (BAD P) lb i \<subseteq> eq_upto (BAD P) lb 0" by auto
  ultimately have "?A i \<subseteq> A" and "?A i \<noteq> {}" by (auto simp: ith_def)
  from min_elt_mem [OF this, folded lb] obtain f
    where "f \<in> eq_upto (BAD P) lb (Suc i)" by (auto dest: eq_upto_Suc)
  then show ?case by blast
qed

lemma non_empty_ith:
  shows "ith (eq_upto (BAD P) lb i) i \<subseteq> A"
  and "ith (eq_upto (BAD P) lb i) i \<noteq> {}"
  using eq_upto_BAD_non_empty [of i] by auto

lemmas
  lb_minimal = min_elt_minimal [OF non_empty_ith, folded lb] and
  lb_mem = min_elt_mem [OF non_empty_ith, folded lb]

text {*
  @{term "lb"} is a infinite bad sequence.
*}
lemma lb_BAD:
  "lb \<in> BAD P"
proof -
  have *: "\<And>j. lb j \<in> ith (eq_upto (BAD P) lb j) j" by (rule lb_mem)
  then have "\<forall>i. lb i \<in> A" by (auto simp: ith_conv) (metis eq_upto_BAD_mem)
  moreover
  { assume "good P lb"
    then obtain i j where "i < j" and "P (lb i) (lb j)" by (auto simp: good_def)
    from * have "lb j \<in> ith (eq_upto (BAD P) lb j) j" by (auto)
    then obtain g where "g \<in> eq_upto (BAD P) lb j" and "g j = lb j" by force
    then have "\<forall>k \<le> j. g k = lb k" by (auto simp: order_le_less)
    with `i < j` and `P (lb i) (lb j)` have "P (g i) (g j)" by auto
    with `i < j` have "good P g" by (auto simp: good_def)
    with `g \<in> eq_upto (BAD P) lb j` have False by auto }
  ultimately show ?thesis by blast
qed

text {*
  There is no infinite bad sequence that is strictly smaller than @{term lb}.
*}
lemma lb_lower_bound:
  "\<forall>g. (lb, g) \<in> gseq \<longrightarrow> g \<notin> BAD P"
proof (intro allI impI)
  fix g
  assume "(lb, g) \<in> gseq"
  then obtain i where "g i \<in> A" and "size (g i) < size (lb i)"
    and "\<forall>j < i. lb j = g j" by (auto simp: gseq_iff)
  moreover with lb_minimal
    have "g i \<notin> ith (eq_upto (BAD P) lb i) i" by auto
  ultimately show "g \<notin> BAD P" by blast
qed

text {*
  If there is at least one bad sequence, then there is also a minimal one.
*}
lemma lower_bound_ex:
  "\<exists>f \<in> BAD P. \<forall>g. (f, g) \<in> gseq \<longrightarrow> g \<notin> BAD P"
  using lb_BAD and lb_lower_bound by blast

lemma gseq_conv:
  "(f, g) \<in> gseq \<longleftrightarrow> f \<noteq> g \<and> (f, g) \<in> geseq"
  by (auto simp: gseq_def geseq_def dest: less_not_eq)

text {*There is a minimal bad sequence.*}
lemma mbs:
  "\<exists>f \<in> BAD P. \<forall>g. (f, g) \<in> gseq \<longrightarrow> good P g"
  using lower_bound_ex by (auto simp: gseq_conv geseq_iff)

end

end

end

end