(*  Title:      HOL/Metis_Examples/Tarski.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring the full theorem of Tarski.
*)

section {* Metis Example Featuring the Full Theorem of Tarski *}

theory Tarski
imports Main "~~/src/HOL/Library/FuncSet"
begin

declare [[metis_new_skolem]]

(*Many of these higher-order problems appear to be impossible using the
current linkup. They often seem to need either higher-order unification
or explicit reasoning about connectives such as conjunction. The numerous
set comprehensions are to blame.*)

record 'a potype =
  pset  :: "'a set"
  order :: "('a * 'a) set"

definition monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool" where
  "monotone f A r == \<forall>x\<in>A. \<forall>y\<in>A. (x, y): r --> ((f x), (f y)) : r"

definition least :: "['a => bool, 'a potype] => 'a" where
  "least P po == @ x. x: pset po & P x &
                       (\<forall>y \<in> pset po. P y --> (x,y): order po)"

definition greatest :: "['a => bool, 'a potype] => 'a" where
  "greatest P po == @ x. x: pset po & P x &
                          (\<forall>y \<in> pset po. P y --> (y,x): order po)"

definition lub  :: "['a set, 'a potype] => 'a" where
  "lub S po == least (%x. \<forall>y\<in>S. (y,x): order po) po"

definition glb  :: "['a set, 'a potype] => 'a" where
  "glb S po == greatest (%x. \<forall>y\<in>S. (x,y): order po) po"

definition isLub :: "['a set, 'a potype, 'a] => bool" where
  "isLub S po == %L. (L: pset po & (\<forall>y\<in>S. (y,L): order po) &
                   (\<forall>z\<in>pset po. (\<forall>y\<in>S. (y,z): order po) --> (L,z): order po))"

definition isGlb :: "['a set, 'a potype, 'a] => bool" where
  "isGlb S po == %G. (G: pset po & (\<forall>y\<in>S. (G,y): order po) &
                 (\<forall>z \<in> pset po. (\<forall>y\<in>S. (z,y): order po) --> (z,G): order po))"

definition "fix"    :: "[('a => 'a), 'a set] => 'a set" where
  "fix f A  == {x. x: A & f x = x}"

definition interval :: "[('a*'a) set,'a, 'a ] => 'a set" where
  "interval r a b == {x. (a,x): r & (x,b): r}"

definition Bot :: "'a potype => 'a" where
  "Bot po == least (%x. True) po"

definition Top :: "'a potype => 'a" where
  "Top po == greatest (%x. True) po"

definition PartialOrder :: "('a potype) set" where
  "PartialOrder == {P. refl_on (pset P) (order P) & antisym (order P) &
                       trans (order P)}"

definition CompleteLattice :: "('a potype) set" where
  "CompleteLattice == {cl. cl: PartialOrder &
                        (\<forall>S. S \<subseteq> pset cl --> (\<exists>L. isLub S cl L)) &
                        (\<forall>S. S \<subseteq> pset cl --> (\<exists>G. isGlb S cl G))}"

definition induced :: "['a set, ('a * 'a) set] => ('a *'a)set" where
  "induced A r == {(a,b). a : A & b: A & (a,b): r}"

definition sublattice :: "('a potype * 'a set)set" where
  "sublattice ==
      SIGMA cl: CompleteLattice.
          {S. S \<subseteq> pset cl &
           (| pset = S, order = induced S (order cl) |): CompleteLattice }"

abbreviation
  sublattice_syntax :: "['a set, 'a potype] => bool" ("_ <<= _" [51, 50] 50)
  where "S <<= cl \<equiv> S : sublattice `` {cl}"

definition dual :: "'a potype => 'a potype" where
  "dual po == (| pset = pset po, order = converse (order po) |)"

locale PO =
  fixes cl :: "'a potype"
    and A  :: "'a set"
    and r  :: "('a * 'a) set"
  assumes cl_po:  "cl : PartialOrder"
  defines A_def: "A == pset cl"
     and  r_def: "r == order cl"

locale CL = PO +
  assumes cl_co:  "cl : CompleteLattice"

definition CLF_set :: "('a potype * ('a => 'a)) set" where
  "CLF_set = (SIGMA cl: CompleteLattice.
            {f. f: pset cl -> pset cl & monotone f (pset cl) (order cl)})"

locale CLF = CL +
  fixes f :: "'a => 'a"
    and P :: "'a set"
  assumes f_cl:  "(cl,f) : CLF_set" (*was the equivalent "f : CLF``{cl}"*)
  defines P_def: "P == fix f A"

locale Tarski = CLF +
  fixes Y     :: "'a set"
    and intY1 :: "'a set"
    and v     :: "'a"
  assumes
    Y_ss: "Y \<subseteq> P"
  defines
    intY1_def: "intY1 == interval r (lub Y cl) (Top cl)"
    and v_def: "v == glb {x. ((%x: intY1. f x) x, x): induced intY1 r &
                             x: intY1}
                      (| pset=intY1, order=induced intY1 r|)"

subsection {* Partial Order *}

lemma (in PO) PO_imp_refl_on: "refl_on A r"
apply (insert cl_po)
apply (simp add: PartialOrder_def A_def r_def)
done

lemma (in PO) PO_imp_sym: "antisym r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) PO_imp_trans: "trans r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) reflE: "x \<in> A ==> (x, x) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def refl_on_def A_def r_def)
done

lemma (in PO) antisymE: "[| (a, b) \<in> r; (b, a) \<in> r |] ==> a = b"
apply (insert cl_po)
apply (simp add: PartialOrder_def antisym_def r_def)
done

lemma (in PO) transE: "[| (a, b) \<in> r; (b, c) \<in> r|] ==> (a,c) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
apply (unfold trans_def, fast)
done

lemma (in PO) monotoneE:
     "[| monotone f A r;  x \<in> A; y \<in> A; (x, y) \<in> r |] ==> (f x, f y) \<in> r"
by (simp add: monotone_def)

lemma (in PO) po_subset_po:
     "S \<subseteq> A ==> (| pset = S, order = induced S r |) \<in> PartialOrder"
apply (simp (no_asm) add: PartialOrder_def)
apply auto
-- {* refl *}
apply (simp add: refl_on_def induced_def)
apply (blast intro: reflE)
-- {* antisym *}
apply (simp add: antisym_def induced_def)
apply (blast intro: antisymE)
-- {* trans *}
apply (simp add: trans_def induced_def)
apply (blast intro: transE)
done

lemma (in PO) indE: "[| (x, y) \<in> induced S r; S \<subseteq> A |] ==> (x, y) \<in> r"
by (simp add: add: induced_def)

lemma (in PO) indI: "[| (x, y) \<in> r; x \<in> S; y \<in> S |] ==> (x, y) \<in> induced S r"
by (simp add: add: induced_def)

lemma (in CL) CL_imp_ex_isLub: "S \<subseteq> A ==> \<exists>L. isLub S cl L"
apply (insert cl_co)
apply (simp add: CompleteLattice_def A_def)
done

declare (in CL) cl_co [simp]

lemma isLub_lub: "(\<exists>L. isLub S cl L) = isLub S cl (lub S cl)"
by (simp add: lub_def least_def isLub_def some_eq_ex [symmetric])

lemma isGlb_glb: "(\<exists>G. isGlb S cl G) = isGlb S cl (glb S cl)"
by (simp add: glb_def greatest_def isGlb_def some_eq_ex [symmetric])

lemma isGlb_dual_isLub: "isGlb S cl = isLub S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma isLub_dual_isGlb: "isLub S cl = isGlb S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma (in PO) dualPO: "dual cl \<in> PartialOrder"
apply (insert cl_po)
apply (simp add: PartialOrder_def dual_def)
done

lemma Rdual:
     "\<forall>S. (S \<subseteq> A -->( \<exists>L. isLub S (| pset = A, order = r|) L))
      ==> \<forall>S. (S \<subseteq> A --> (\<exists>G. isGlb S (| pset = A, order = r|) G))"
apply safe
apply (rule_tac x = "lub {y. y \<in> A & (\<forall>k \<in> S. (y, k) \<in> r)}
                      (|pset = A, order = r|) " in exI)
apply (drule_tac x = "{y. y \<in> A & (\<forall>k \<in> S. (y,k) \<in> r) }" in spec)
apply (drule mp, fast)
apply (simp add: isLub_lub isGlb_def)
apply (simp add: isLub_def, blast)
done

lemma lub_dual_glb: "lub S cl = glb S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma glb_dual_lub: "glb S cl = lub S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma CL_subset_PO: "CompleteLattice \<subseteq> PartialOrder"
by (simp add: PartialOrder_def CompleteLattice_def, fast)

lemmas CL_imp_PO = CL_subset_PO [THEN subsetD]

declare PO.PO_imp_refl_on  [OF PO.intro [OF CL_imp_PO], simp]
declare PO.PO_imp_sym   [OF PO.intro [OF CL_imp_PO], simp]
declare PO.PO_imp_trans [OF PO.intro [OF CL_imp_PO], simp]

lemma (in CL) CO_refl_on: "refl_on A r"
by (rule PO_imp_refl_on)

lemma (in CL) CO_antisym: "antisym r"
by (rule PO_imp_sym)

lemma (in CL) CO_trans: "trans r"
by (rule PO_imp_trans)

lemma CompleteLatticeI:
     "[| po \<in> PartialOrder; (\<forall>S. S \<subseteq> pset po --> (\<exists>L. isLub S po L));
         (\<forall>S. S \<subseteq> pset po --> (\<exists>G. isGlb S po G))|]
      ==> po \<in> CompleteLattice"
apply (unfold CompleteLattice_def, blast)
done

lemma (in CL) CL_dualCL: "dual cl \<in> CompleteLattice"
apply (insert cl_co)
apply (simp add: CompleteLattice_def dual_def)
apply (fold dual_def)
apply (simp add: isLub_dual_isGlb [symmetric] isGlb_dual_isLub [symmetric]
                 dualPO)
done

lemma (in PO) dualA_iff: "pset (dual cl) = pset cl"
by (simp add: dual_def)

lemma (in PO) dualr_iff: "((x, y) \<in> (order(dual cl))) = ((y, x) \<in> order cl)"
by (simp add: dual_def)

lemma (in PO) monotone_dual:
     "monotone f (pset cl) (order cl)
     ==> monotone f (pset (dual cl)) (order(dual cl))"
by (simp add: monotone_def dualA_iff dualr_iff)

lemma (in PO) interval_dual:
     "[| x \<in> A; y \<in> A|] ==> interval r x y = interval (order(dual cl)) y x"
apply (simp add: interval_def dualr_iff)
apply (fold r_def, fast)
done

lemma (in PO) interval_not_empty:
     "[| trans r; interval r a b \<noteq> {} |] ==> (a, b) \<in> r"
apply (simp add: interval_def)
apply (unfold trans_def, blast)
done

lemma (in PO) interval_imp_mem: "x \<in> interval r a b ==> (a, x) \<in> r"
by (simp add: interval_def)

lemma (in PO) left_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> a \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

lemma (in PO) right_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> b \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

subsection {* sublattice *}

lemma (in PO) sublattice_imp_CL:
     "S <<= cl  ==> (| pset = S, order = induced S r |) \<in> CompleteLattice"
by (simp add: sublattice_def CompleteLattice_def A_def r_def)

lemma (in CL) sublatticeI:
     "[| S \<subseteq> A; (| pset = S, order = induced S r |) \<in> CompleteLattice |]
      ==> S <<= cl"
by (simp add: sublattice_def A_def r_def)

subsection {* lub *}

lemma (in CL) lub_unique: "[| S \<subseteq> A; isLub S cl x; isLub S cl L|] ==> x = L"
apply (rule antisymE)
apply (auto simp add: isLub_def r_def)
done

lemma (in CL) lub_upper: "[|S \<subseteq> A; x \<in> S|] ==> (x, lub S cl) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def)
done

lemma (in CL) lub_least:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r |] ==> (lub S cl, L) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule_tac s=x in some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def A_def)
done

lemma (in CL) lub_in_lattice: "S \<subseteq> A ==> lub S cl \<in> A"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (subst some_equality)
apply (simp add: isLub_def)
prefer 2 apply (simp add: isLub_def A_def)
apply (simp add: lub_unique A_def isLub_def)
done

lemma (in CL) lubI:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r;
         \<forall>z \<in> A. (\<forall>y \<in> S. (y,z) \<in> r) --> (L,z) \<in> r |] ==> L = lub S cl"
apply (rule lub_unique, assumption)
apply (simp add: isLub_def A_def r_def)
apply (unfold isLub_def)
apply (rule conjI)
apply (fold A_def r_def)
apply (rule lub_in_lattice, assumption)
apply (simp add: lub_upper lub_least)
done

lemma (in CL) lubIa: "[| S \<subseteq> A; isLub S cl L |] ==> L = lub S cl"
by (simp add: lubI isLub_def A_def r_def)

lemma (in CL) isLub_in_lattice: "isLub S cl L ==> L \<in> A"
by (simp add: isLub_def  A_def)

lemma (in CL) isLub_upper: "[|isLub S cl L; y \<in> S|] ==> (y, L) \<in> r"
by (simp add: isLub_def r_def)

lemma (in CL) isLub_least:
     "[| isLub S cl L; z \<in> A; \<forall>y \<in> S. (y, z) \<in> r|] ==> (L, z) \<in> r"
by (simp add: isLub_def A_def r_def)

lemma (in CL) isLubI:
     "[| L \<in> A; \<forall>y \<in> S. (y, L) \<in> r;
         (\<forall>z \<in> A. (\<forall>y \<in> S. (y, z):r) --> (L, z) \<in> r)|] ==> isLub S cl L"
by (simp add: isLub_def A_def r_def)

subsection {* glb *}

lemma (in CL) glb_in_lattice: "S \<subseteq> A ==> glb S cl \<in> A"
apply (subst glb_dual_lub)
apply (simp add: A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CL.lub_in_lattice)
apply (rule CL.intro)
apply (rule PO.intro)
apply (rule dualPO)
apply (rule CL_axioms.intro)
apply (rule CL_dualCL)
apply (simp add: dualA_iff)
done

lemma (in CL) glb_lower: "[|S \<subseteq> A; x \<in> S|] ==> (glb S cl, x) \<in> r"
apply (subst glb_dual_lub)
apply (simp add: r_def)
apply (rule dualr_iff [THEN subst])
apply (rule CL.lub_upper)
apply (rule CL.intro)
apply (rule PO.intro)
apply (rule dualPO)
apply (rule CL_axioms.intro)
apply (rule CL_dualCL)
apply (simp add: dualA_iff A_def, assumption)
done

text {*
  Reduce the sublattice property by using substructural properties;
  abandoned see @{text "Tarski_4.ML"}.
*}

declare (in CLF) f_cl [simp]

lemma (in CLF) [simp]:
    "f: pset cl -> pset cl & monotone f (pset cl) (order cl)"
proof -
  have "\<forall>u v. (v, u) \<in> CLF_set \<longrightarrow> u \<in> {R \<in> pset v \<rightarrow> pset v. monotone R (pset v) (order v)}"
    unfolding CLF_set_def using SigmaE2 by blast
  hence F1: "\<forall>u v. (v, u) \<in> CLF_set \<longrightarrow> u \<in> pset v \<rightarrow> pset v \<and> monotone u (pset v) (order v)"
    using CollectE by blast
  hence "Tarski.monotone f (pset cl) (order cl)" by (metis f_cl)
  hence "(cl, f) \<in> CLF_set \<and> Tarski.monotone f (pset cl) (order cl)"
    by (metis f_cl)
  thus "f \<in> pset cl \<rightarrow> pset cl \<and> Tarski.monotone f (pset cl) (order cl)"
    using F1 by metis
qed

lemma (in CLF) f_in_funcset: "f \<in> A -> A"
by (simp add: A_def)

lemma (in CLF) monotone_f: "monotone f A r"
by (simp add: A_def r_def)

(*never proved, 2007-01-22*)

declare (in CLF) CLF_set_def [simp] CL_dualCL [simp] monotone_dual [simp] dualA_iff [simp]

lemma (in CLF) CLF_dual: "(dual cl, f) \<in> CLF_set"
apply (simp del: dualA_iff)
apply (simp)
done

declare (in CLF) CLF_set_def[simp del] CL_dualCL[simp del] monotone_dual[simp del]
          dualA_iff[simp del]

subsection {* fixed points *}

lemma fix_subset: "fix f A \<subseteq> A"
by (simp add: fix_def, fast)

lemma fix_imp_eq: "x \<in> fix f A ==> f x = x"
by (simp add: fix_def)

lemma fixf_subset:
     "[| A \<subseteq> B; x \<in> fix (%y: A. f y) A |] ==> x \<in> fix f B"
by (simp add: fix_def, auto)

subsection {* lemmas for Tarski, lub *}

(*never proved, 2007-01-22*)

declare CL.lub_least[intro] CLF.f_in_funcset[intro] funcset_mem[intro] CL.lub_in_lattice[intro] PO.transE[intro] PO.monotoneE[intro] CLF.monotone_f[intro] CL.lub_upper[intro]

lemma (in CLF) lubH_le_flubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> (lub H cl, f (lub H cl)) \<in> r"
apply (rule lub_least, fast)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lub_in_lattice, fast)
-- {* @{text "\<forall>x:H. (x, f (lub H r)) \<in> r"} *}
apply (rule ballI)
(*never proved, 2007-01-22*)
apply (rule transE)
-- {* instantiates @{text "(x, ?z) \<in> order cl to (x, f x)"}, *}
-- {* because of the def of @{text H} *}
apply fast
-- {* so it remains to show @{text "(f x, f (lub H cl)) \<in> r"} *}
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f, fast)
apply (rule lub_in_lattice, fast)
apply (rule lub_upper, fast)
apply assumption
done

declare CL.lub_least[rule del] CLF.f_in_funcset[rule del]
        funcset_mem[rule del] CL.lub_in_lattice[rule del]
        PO.transE[rule del] PO.monotoneE[rule del]
        CLF.monotone_f[rule del] CL.lub_upper[rule del]

(*never proved, 2007-01-22*)

declare CLF.f_in_funcset[intro] funcset_mem[intro] CL.lub_in_lattice[intro]
     PO.monotoneE[intro] CLF.monotone_f[intro] CL.lub_upper[intro]
     CLF.lubH_le_flubH[simp]

lemma (in CLF) flubH_le_lubH:
     "[|  H = {x. (x, f x) \<in> r & x \<in> A} |] ==> (f (lub H cl), lub H cl) \<in> r"
apply (rule lub_upper, fast)
apply (rule_tac t = "H" in ssubst, assumption)
apply (rule CollectI)
by (metis (lifting) CO_refl_on lubH_le_flubH monotone_def monotone_f refl_onD1 refl_onD2)

declare CLF.f_in_funcset[rule del] funcset_mem[rule del]
        CL.lub_in_lattice[rule del] PO.monotoneE[rule del]
        CLF.monotone_f[rule del] CL.lub_upper[rule del]
        CLF.lubH_le_flubH[simp del]

(*never proved, 2007-01-22*)

(* Single-step version fails. The conjecture clauses refer to local abstraction
functions (Frees). *)
lemma (in CLF) lubH_is_fixp:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> lub H cl \<in> fix f A"
apply (simp add: fix_def)
apply (rule conjI)
proof -
  assume A1: "H = {x. (x, f x) \<in> r \<and> x \<in> A}"
  have F1: "\<forall>u v. v \<inter> u \<subseteq> u" by (metis Int_commute Int_lower1)
  have "{R. (R, f R) \<in> r} \<inter> {R. R \<in> A} = H" using A1 by (metis Collect_conj_eq)
  hence "H \<subseteq> {R. R \<in> A}" using F1 by metis
  hence "H \<subseteq> A" by (metis Collect_mem_eq)
  hence "lub H cl \<in> A" by (metis lub_in_lattice)
  thus "lub {x. (x, f x) \<in> r \<and> x \<in> A} cl \<in> A" using A1 by metis
next
  assume A1: "H = {x. (x, f x) \<in> r \<and> x \<in> A}"
  have F1: "\<forall>v. {R. R \<in> v} = v" by (metis Collect_mem_eq)
  have F2: "\<forall>w u. {R. R \<in> u \<and> R \<in> w} = u \<inter> w"
    by (metis Collect_conj_eq Collect_mem_eq)
  have F3: "\<forall>x v. {R. v R \<in> x} = v -` x" by (metis vimage_def)
  hence F4: "A \<inter> (\<lambda>R. (R, f R)) -` r = H" using A1 by auto
  hence F5: "(f (lub H cl), lub H cl) \<in> r"
    by (metis A1 flubH_le_lubH)
  have F6: "(lub H cl, f (lub H cl)) \<in> r"
    by (metis A1 lubH_le_flubH)
  have "(lub H cl, f (lub H cl)) \<in> r \<longrightarrow> f (lub H cl) = lub H cl"
    using F5 by (metis antisymE)
  hence "f (lub H cl) = lub H cl" using F6 by metis
  thus "H = {x. (x, f x) \<in> r \<and> x \<in> A}
        \<Longrightarrow> f (lub {x. (x, f x) \<in> r \<and> x \<in> A} cl) =
           lub {x. (x, f x) \<in> r \<and> x \<in> A} cl"
    by metis
qed

lemma (in CLF) (*lubH_is_fixp:*)
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> lub H cl \<in> fix f A"
apply (simp add: fix_def)
apply (rule conjI)
apply (metis CO_refl_on lubH_le_flubH refl_onD1)
apply (metis antisymE flubH_le_lubH lubH_le_flubH)
done

lemma (in CLF) fix_in_H:
     "[| H = {x. (x, f x) \<in> r & x \<in> A};  x \<in> P |] ==> x \<in> H"
by (simp add: P_def fix_imp_eq [of _ f A] reflE CO_refl_on
                    fix_subset [of f A, THEN subsetD])

lemma (in CLF) fixf_le_lubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> \<forall>x \<in> fix f A. (x, lub H cl) \<in> r"
apply (rule ballI)
apply (rule lub_upper, fast)
apply (rule fix_in_H)
apply (simp_all add: P_def)
done

lemma (in CLF) lubH_least_fixf:
     "H = {x. (x, f x) \<in> r & x \<in> A}
      ==> \<forall>L. (\<forall>y \<in> fix f A. (y,L) \<in> r) --> (lub H cl, L) \<in> r"
apply (metis P_def lubH_is_fixp)
done

subsection {* Tarski fixpoint theorem 1, first part *}

declare CL.lubI[intro] fix_subset[intro] CL.lub_in_lattice[intro]
        CLF.fixf_le_lubH[simp] CLF.lubH_least_fixf[simp]

lemma (in CLF) T_thm_1_lub: "lub P cl = lub {x. (x, f x) \<in> r & x \<in> A} cl"
(*sledgehammer;*)
apply (rule sym)
apply (simp add: P_def)
apply (rule lubI)
apply (simp add: fix_subset)
using fix_subset lubH_is_fixp apply fastforce
apply (simp add: fixf_le_lubH)
using lubH_is_fixp apply blast
done

declare CL.lubI[rule del] fix_subset[rule del] CL.lub_in_lattice[rule del]
        CLF.fixf_le_lubH[simp del] CLF.lubH_least_fixf[simp del]

(*never proved, 2007-01-22*)

declare glb_dual_lub[simp] PO.dualA_iff[intro] CLF.lubH_is_fixp[intro]
        PO.dualPO[intro] CL.CL_dualCL[intro] PO.dualr_iff[simp]

lemma (in CLF) glbH_is_fixp: "H = {x. (f x, x) \<in> r & x \<in> A} ==> glb H cl \<in> P"
  -- {* Tarski for glb *}
(*sledgehammer;*)
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.lubH_is_fixp)
apply (rule CLF.intro)
apply (rule CL.intro)
apply (rule PO.intro)
apply (rule dualPO)
apply (rule CL_axioms.intro)
apply (rule CL_dualCL)
apply (rule CLF_axioms.intro)
apply (rule CLF_dual)
apply (simp add: dualr_iff dualA_iff)
done

declare glb_dual_lub[simp del] PO.dualA_iff[rule del] CLF.lubH_is_fixp[rule del]
        PO.dualPO[rule del] CL.CL_dualCL[rule del] PO.dualr_iff[simp del]

(*never proved, 2007-01-22*)

lemma (in CLF) T_thm_1_glb: "glb P cl = glb {x. (f x, x) \<in> r & x \<in> A} cl"
(*sledgehammer;*)
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
(*never proved, 2007-01-22*)
(*sledgehammer;*)
apply (simp add: CLF.T_thm_1_lub [of _ f, OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro,
  OF dualPO CL_dualCL] dualPO CL_dualCL CLF_dual dualr_iff)
done

subsection {* interval *}

declare (in CLF) CO_refl_on[simp] refl_on_def [simp]

lemma (in CLF) rel_imp_elem: "(x, y) \<in> r ==> x \<in> A"
by (metis CO_refl_on refl_onD1)

declare (in CLF) CO_refl_on[simp del]  refl_on_def [simp del]

declare (in CLF) rel_imp_elem[intro]
declare interval_def [simp]

lemma (in CLF) interval_subset: "[| a \<in> A; b \<in> A |] ==> interval r a b \<subseteq> A"
by (metis CO_refl_on interval_imp_mem refl_onD refl_onD2 rel_imp_elem subset_eq)

declare (in CLF) rel_imp_elem[rule del]
declare interval_def [simp del]

lemma (in CLF) intervalI:
     "[| (a, x) \<in> r; (x, b) \<in> r |] ==> x \<in> interval r a b"
by (simp add: interval_def)

lemma (in CLF) interval_lemma1:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (a, x) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) interval_lemma2:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (x, b) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) a_less_lub:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (a,x) \<in> r; \<forall>y \<in> S. (y, L) \<in> r |] ==> (a,L) \<in> r"
by (blast intro: transE)

lemma (in CLF) glb_less_b:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (x,b) \<in> r; \<forall>y \<in> S. (G, y) \<in> r |] ==> (G,b) \<in> r"
by (blast intro: transE)

lemma (in CLF) S_intv_cl:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b |]==> S \<subseteq> A"
by (simp add: subset_trans [OF _ interval_subset])

lemma (in CLF) L_in_interval:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b;
         S \<noteq> {}; isLub S cl L; interval r a b \<noteq> {} |] ==> L \<in> interval r a b"
(*WON'T TERMINATE
apply (metis CO_trans intervalI interval_lemma1 interval_lemma2 isLub_least isLub_upper subset_empty subset_iff trans_def)
*)
apply (rule intervalI)
apply (rule a_less_lub)
prefer 2 apply assumption
apply (simp add: S_intv_cl)
apply (rule ballI)
apply (simp add: interval_lemma1)
apply (simp add: isLub_upper)
-- {* @{text "(L, b) \<in> r"} *}
apply (simp add: isLub_least interval_lemma2)
done

(*never proved, 2007-01-22*)

lemma (in CLF) G_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {}; S \<subseteq> interval r a b; isGlb S cl G;
         S \<noteq> {} |] ==> G \<in> interval r a b"
apply (simp add: interval_dual)
apply (simp add: CLF.L_in_interval [of _ f, OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro]
                 dualA_iff A_def dualPO CL_dualCL CLF_dual isGlb_dual_isLub)
done

lemma (in CLF) intervalPO:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
      ==> (| pset = interval r a b, order = induced (interval r a b) r |)
          \<in> PartialOrder"
proof -
  assume A1: "a \<in> A"
  assume "b \<in> A"
  hence "\<forall>u. u \<in> A \<longrightarrow> interval r u b \<subseteq> A" by (metis interval_subset)
  hence "interval r a b \<subseteq> A" using A1 by metis
  hence "interval r a b \<subseteq> A" by metis
  thus ?thesis by (metis po_subset_po)
qed

lemma (in CLF) intv_CL_lub:
 "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
  ==> \<forall>S. S \<subseteq> interval r a b -->
          (\<exists>L. isLub S (| pset = interval r a b,
                          order = induced (interval r a b) r |)  L)"
apply (intro strip)
apply (frule S_intv_cl [THEN CL_imp_ex_isLub])
prefer 2 apply assumption
apply assumption
apply (erule exE)
-- {* define the lub for the interval as *}
apply (rule_tac x = "if S = {} then a else L" in exI)
apply (simp (no_asm_simp) add: isLub_def split del: split_if)
apply (intro impI conjI)
-- {* @{text "(if S = {} then a else L) \<in> interval r a b"} *}
apply (simp add: CL_imp_PO L_in_interval)
apply (simp add: left_in_interval)
-- {* lub prop 1 *}
apply (case_tac "S = {}")
-- {* @{text "S = {}, y \<in> S = False => everything"} *}
apply fast
-- {* @{text "S \<noteq> {}"} *}
apply simp
-- {* @{text "\<forall>y:S. (y, L) \<in> induced (interval r a b) r"} *}
apply (rule ballI)
apply (simp add: induced_def  L_in_interval)
apply (rule conjI)
apply (rule subsetD)
apply (simp add: S_intv_cl, assumption)
apply (simp add: isLub_upper)
-- {* @{text "\<forall>z:interval r a b. (\<forall>y:S. (y, z) \<in> induced (interval r a b) r \<longrightarrow> (if S = {} then a else L, z) \<in> induced (interval r a b) r"} *}
apply (rule ballI)
apply (rule impI)
apply (case_tac "S = {}")
-- {* @{text "S = {}"} *}
apply simp
apply (simp add: induced_def  interval_def)
apply (rule conjI)
apply (rule reflE, assumption)
apply (rule interval_not_empty)
apply (rule CO_trans)
apply (simp add: interval_def)
-- {* @{text "S \<noteq> {}"} *}
apply simp
apply (simp add: induced_def  L_in_interval)
apply (rule isLub_least, assumption)
apply (rule subsetD)
prefer 2 apply assumption
apply (simp add: S_intv_cl, fast)
done

lemmas (in CLF) intv_CL_glb = intv_CL_lub [THEN Rdual]

(*never proved, 2007-01-22*)

lemma (in CLF) interval_is_sublattice:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
        ==> interval r a b <<= cl"
(*sledgehammer *)
apply (rule sublatticeI)
apply (simp add: interval_subset)
(*never proved, 2007-01-22*)
(*sledgehammer *)
apply (rule CompleteLatticeI)
apply (simp add: intervalPO)
 apply (simp add: intv_CL_lub)
apply (simp add: intv_CL_glb)
done

lemmas (in CLF) interv_is_compl_latt =
    interval_is_sublattice [THEN sublattice_imp_CL]

subsection {* Top and Bottom *}
lemma (in CLF) Top_dual_Bot: "Top cl = Bot (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_dual_Top: "Bot cl = Top (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_in_lattice: "Bot cl \<in> A"
(*sledgehammer; *)
apply (simp add: Bot_def least_def)
apply (rule_tac a="glb A cl" in someI2)
apply (simp_all add: glb_in_lattice glb_lower
                     r_def [symmetric] A_def [symmetric])
done

(*first proved 2007-01-25 after relaxing relevance*)

lemma (in CLF) Top_in_lattice: "Top cl \<in> A"
(*sledgehammer;*)
apply (simp add: Top_dual_Bot A_def)
(*first proved 2007-01-25 after relaxing relevance*)
(*sledgehammer*)
apply (rule dualA_iff [THEN subst])
apply (blast intro!: CLF.Bot_in_lattice [OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro] dualPO CL_dualCL CLF_dual)
done

lemma (in CLF) Top_prop: "x \<in> A ==> (x, Top cl) \<in> r"
apply (simp add: Top_def greatest_def)
apply (rule_tac a="lub A cl" in someI2)
apply (rule someI2)
apply (simp_all add: lub_in_lattice lub_upper
                     r_def [symmetric] A_def [symmetric])
done

(*never proved, 2007-01-22*)

lemma (in CLF) Bot_prop: "x \<in> A ==> (Bot cl, x) \<in> r"
(*sledgehammer*)
apply (simp add: Bot_dual_Top r_def)
apply (rule dualr_iff [THEN subst])
apply (simp add: CLF.Top_prop [of _ f, OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro]
                 dualA_iff A_def dualPO CL_dualCL CLF_dual)
done

lemma (in CLF) Top_intv_not_empty: "x \<in> A  ==> interval r x (Top cl) \<noteq> {}"
apply (metis Top_in_lattice Top_prop empty_iff intervalI reflE)
done

lemma (in CLF) Bot_intv_not_empty: "x \<in> A ==> interval r (Bot cl) x \<noteq> {}"
apply (metis Bot_prop ex_in_conv intervalI reflE rel_imp_elem)
done

subsection {* fixed points form a partial order *}

lemma (in CLF) fixf_po: "(| pset = P, order = induced P r|) \<in> PartialOrder"
by (simp add: P_def fix_subset po_subset_po)

(*first proved 2007-01-25 after relaxing relevance*)

declare (in Tarski) P_def[simp] Y_ss [simp]
declare fix_subset [intro] subset_trans [intro]

lemma (in Tarski) Y_subset_A: "Y \<subseteq> A"
(*sledgehammer*)
apply (rule subset_trans [OF _ fix_subset])
apply (rule Y_ss [simplified P_def])
done

declare (in Tarski) P_def[simp del] Y_ss [simp del]
declare fix_subset [rule del] subset_trans [rule del]

lemma (in Tarski) lubY_in_A: "lub Y cl \<in> A"
  by (rule Y_subset_A [THEN lub_in_lattice])

(*never proved, 2007-01-22*)

lemma (in Tarski) lubY_le_flubY: "(lub Y cl, f (lub Y cl)) \<in> r"
(*sledgehammer*)
apply (rule lub_least)
apply (rule Y_subset_A)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lubY_in_A)
-- {* @{text "Y \<subseteq> P ==> f x = x"} *}
apply (rule ballI)
(*sledgehammer *)
apply (rule_tac t = "x" in fix_imp_eq [THEN subst])
apply (erule Y_ss [simplified P_def, THEN subsetD])
-- {* @{text "reduce (f x, f (lub Y cl)) \<in> r to (x, lub Y cl) \<in> r"} by monotonicity *}
(*sledgehammer*)
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f)
apply (simp add: Y_subset_A [THEN subsetD])
apply (rule lubY_in_A)
apply (simp add: lub_upper Y_subset_A)
done

(*first proved 2007-01-25 after relaxing relevance*)

lemma (in Tarski) intY1_subset: "intY1 \<subseteq> A"
(*sledgehammer*)
apply (unfold intY1_def)
apply (rule interval_subset)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
done

lemmas (in Tarski) intY1_elem = intY1_subset [THEN subsetD]

(*never proved, 2007-01-22*)

lemma (in Tarski) intY1_f_closed: "x \<in> intY1 \<Longrightarrow> f x \<in> intY1"
(*sledgehammer*)
apply (simp add: intY1_def  interval_def)
apply (rule conjI)
apply (rule transE)
apply (rule lubY_le_flubY)
-- {* @{text "(f (lub Y cl), f x) \<in> r"} *}
(*sledgehammer [has been proved before now...]*)
apply (rule_tac f=f in monotoneE)
apply (rule monotone_f)
apply (rule lubY_in_A)
apply (simp add: intY1_def interval_def  intY1_elem)
apply (simp add: intY1_def  interval_def)
-- {* @{text "(f x, Top cl) \<in> r"} *}
apply (rule Top_prop)
apply (rule f_in_funcset [THEN funcset_mem])
apply (simp add: intY1_def interval_def  intY1_elem)
done

lemma (in Tarski) intY1_func: "(%x: intY1. f x) \<in> intY1 -> intY1"
apply (rule restrict_in_funcset)
apply (metis intY1_f_closed restrict_in_funcset)
done

lemma (in Tarski) intY1_mono:
     "monotone (%x: intY1. f x) intY1 (induced intY1 r)"
(*sledgehammer *)
apply (auto simp add: monotone_def induced_def intY1_f_closed)
apply (blast intro: intY1_elem monotone_f [THEN monotoneE])
done

(*proof requires relaxing relevance: 2007-01-25*)

lemma (in Tarski) intY1_is_cl:
    "(| pset = intY1, order = induced intY1 r |) \<in> CompleteLattice"
(*sledgehammer*)
apply (unfold intY1_def)
apply (rule interv_is_compl_latt)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
apply (rule Top_intv_not_empty)
apply (rule lubY_in_A)
done

(*never proved, 2007-01-22*)

lemma (in Tarski) v_in_P: "v \<in> P"
(*sledgehammer*)
apply (unfold P_def)
apply (rule_tac A = "intY1" in fixf_subset)
apply (rule intY1_subset)
apply (simp add: CLF.glbH_is_fixp [OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro, OF _ intY1_is_cl, simplified]
                 v_def CL_imp_PO intY1_is_cl CLF_set_def intY1_func intY1_mono)
done

lemma (in Tarski) z_in_interval:
     "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |] ==> z \<in> intY1"
(*sledgehammer *)
apply (unfold intY1_def P_def)
apply (rule intervalI)
prefer 2
 apply (erule fix_subset [THEN subsetD, THEN Top_prop])
apply (rule lub_least)
apply (rule Y_subset_A)
apply (fast elim!: fix_subset [THEN subsetD])
apply (simp add: induced_def)
done

lemma (in Tarski) f'z_in_int_rel: "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |]
      ==> ((%x: intY1. f x) z, z) \<in> induced intY1 r"
using P_def fix_imp_eq indI intY1_elem reflE z_in_interval by fastforce

(*never proved, 2007-01-22*)

lemma (in Tarski) tarski_full_lemma:
     "\<exists>L. isLub Y (| pset = P, order = induced P r |) L"
apply (rule_tac x = "v" in exI)
apply (simp add: isLub_def)
-- {* @{text "v \<in> P"} *}
apply (simp add: v_in_P)
apply (rule conjI)
(*sledgehammer*)
-- {* @{text v} is lub *}
-- {* @{text "1. \<forall>y:Y. (y, v) \<in> induced P r"} *}
apply (rule ballI)
apply (simp add: induced_def subsetD v_in_P)
apply (rule conjI)
apply (erule Y_ss [THEN subsetD])
apply (rule_tac b = "lub Y cl" in transE)
apply (rule lub_upper)
apply (rule Y_subset_A, assumption)
apply (rule_tac b = "Top cl" in interval_imp_mem)
apply (simp add: v_def)
apply (fold intY1_def)
apply (rule CL.glb_in_lattice [OF CL.intro, OF PO.intro CL_axioms.intro, OF _ intY1_is_cl, simplified])
 apply (simp add: CL_imp_PO intY1_is_cl, force)
-- {* @{text v} is LEAST ub *}
apply clarify
apply (rule indI)
  prefer 3 apply assumption
 prefer 2 apply (simp add: v_in_P)
apply (unfold v_def)
(*never proved, 2007-01-22*)
(*sledgehammer*)
apply (rule indE)
apply (rule_tac [2] intY1_subset)
(*never proved, 2007-01-22*)
(*sledgehammer*)
apply (rule CL.glb_lower [OF CL.intro, OF PO.intro CL_axioms.intro, OF _ intY1_is_cl, simplified])
  apply (simp add: CL_imp_PO intY1_is_cl)
 apply force
apply (simp add: induced_def intY1_f_closed z_in_interval)
apply (simp add: P_def fix_imp_eq [of _ f A] reflE
                 fix_subset [of f A, THEN subsetD])
done

lemma CompleteLatticeI_simp:
     "[| (| pset = A, order = r |) \<in> PartialOrder;
         \<forall>S. S \<subseteq> A --> (\<exists>L. isLub S (| pset = A, order = r |)  L) |]
    ==> (| pset = A, order = r |) \<in> CompleteLattice"
by (simp add: CompleteLatticeI Rdual)

(*never proved, 2007-01-22*)

declare (in CLF) fixf_po[intro] P_def [simp] A_def [simp] r_def [simp]
             Tarski.tarski_full_lemma [intro] cl_po [intro] cl_co [intro]
             CompleteLatticeI_simp [intro]

theorem (in CLF) Tarski_full:
     "(| pset = P, order = induced P r|) \<in> CompleteLattice"
(*sledgehammer*)
apply (rule CompleteLatticeI_simp)
apply (rule fixf_po, clarify)
(*never proved, 2007-01-22*)
(*sledgehammer*)
apply (simp add: P_def A_def r_def)
apply (blast intro!: Tarski.tarski_full_lemma [OF Tarski.intro, OF CLF.intro Tarski_axioms.intro,
  OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro] cl_po cl_co f_cl)
done

declare (in CLF) fixf_po [rule del] P_def [simp del] A_def [simp del] r_def [simp del]
         Tarski.tarski_full_lemma [rule del] cl_po [rule del] cl_co [rule del]
         CompleteLatticeI_simp [rule del]

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>Multisets of Pairs of Terms\<close>

theory Term_Pair_Multiset
  imports
    Term
    "HOL-Library.Multiset"
begin

text \<open>Multisets of pairs of terms are used in abstract inference systems for
matching and unification.\<close>

subsection \<open>Size\<close>

text \<open>Make sure that every pair has size at least @{term "1::nat"}.\<close>
definition "pair_size p = size (fst p) + size (snd p) + 1"

text \<open>Compute the number of symbols in a multiset of term pairs.\<close>
definition "size_mset M = fold_mset ((+) \<circ> pair_size) 0 M"

interpretation size_mset_fun:
  comp_fun_commute "(+) \<circ> pair_size"
  by standard auto

lemma fold_pair_size_plus:
  "fold_mset ((+) \<circ> pair_size) 0 M + n = fold_mset ((+) \<circ> pair_size) n M"
  by (induct M arbitrary: n) (simp add: size_mset_def)+

lemma size_mset_union [simp]:
  "size_mset (M + N) = size_mset N + size_mset M"
  by (auto simp: size_mset_def fold_pair_size_plus)

lemma size_mset_add_mset [simp]:
  "size_mset (add_mset x M) = pair_size x + (size_mset M)"
by (auto simp: size_mset_def)

lemma nonempty_size_mset [simp]:
  assumes "M \<noteq> {#}"
  shows "size_mset M > 0"
  using assms by (induct M) (simp add: size_mset_def pair_size_def)+

lemma size_mset_singleton [simp]:
  "size_mset {#(l, r)#} = size l + size r + 1"
  by (auto simp: size_mset_def pair_size_def)

lemma size_mset_empty [simp]:
  "size_mset {#} = 0"
  by (auto simp: size_mset_def)

lemma size_mset_set_zip_leq:
  "size_mset (mset (zip ss ts)) \<le> size_list size ss + size_list size ts"
proof (induct ss arbitrary: ts)
  case (Cons s ss)
  then show ?case
    by (cases ts) (auto intro: le_SucI simp: pair_size_def)
qed simp

lemma size_mset_Fun_less:
  "size_mset {#(Fun f ss, Fun g ts)#} > size_mset (mset (zip ss ts))"
  by (auto simp: pair_size_def intro: order_le_less_trans size_mset_set_zip_leq)

lemma decomp_size_mset_less:
  assumes "length ss = length ts"
  shows "size_mset (M + mset (zip ss ts)) < size_mset (M + {#(Fun f ss, Fun f ts)#})"
  using assms and size_mset_Fun_less [of ss ts f f] by simp

subsubsection \<open>Substitutions\<close>

text \<open>Applying a substitution to a multiset of term pairs.\<close>
definition "subst_mset \<sigma> M = image_mset (\<lambda>p. (fst p \<cdot> \<sigma>, snd p \<cdot> \<sigma>)) M"
lemma subst_mset_empty [simp]:
  "subst_mset \<sigma> {#} = {#}"
  by (auto simp: subst_mset_def)

lemma subst_mset_union:
  "subst_mset \<sigma> (M + N) = subst_mset \<sigma> M + subst_mset \<sigma> N"
  by (auto simp: subst_mset_def)

lemma subst_mset_Var [simp]:
  "subst_mset Var M = M"
  by (auto simp: subst_mset_def)

lemma subst_mset_subst_compose [simp]:
  "subst_mset (\<sigma> \<circ>\<^sub>s \<tau>) M = subst_mset \<tau> (subst_mset \<sigma> M)"
  by (simp add: subst_mset_def image_mset.compositionality o_def)

subsubsection \<open>Variables\<close>

text \<open>Compute the set of variables occurring in a multiset of term pairs.\<close>
definition "vars_mset M = \<Union>(set_mset (image_mset (\<lambda>r. vars_term (fst r) \<union> vars_term (snd r)) M))"

lemma vars_mset_singleton [simp]:
  "vars_mset {#p#} = vars_term (fst p) \<union> vars_term (snd p)"
  by (auto simp: vars_mset_def)

lemma vars_mset_union [simp]:
  "vars_mset (A + B) = vars_mset A \<union> vars_mset B"
  by (auto simp: vars_mset_def)

lemma vars_mset_add_mset [simp]:
  "vars_mset (add_mset x M) = vars_term (fst x) \<union> vars_term (snd x) \<union> vars_mset M"
  by (auto simp: vars_mset_def)

lemma vars_mset_set_zip [simp]:
  assumes "length xs = length ys"
  shows "vars_mset (mset (zip xs ys)) = (\<Union>x\<in>set xs \<union> set ys. vars_term x)"
  using assms by (induct xs ys rule: list_induct2) (auto simp: vars_mset_def)

lemma not_in_vars_mset_subst_mset [simp]:
  assumes "x \<notin> vars_term t"
  shows "x \<notin> vars_mset (subst_mset (subst x t) M)"
  using assms by (auto simp: vars_mset_def subst_mset_def vars_term_subst subst_def)
lemma vars_mset_subst_mset_subset:
  "vars_mset (subst_mset (subst x t) M) \<subseteq> vars_mset M \<union> vars_term t \<union> {x}" (is "?L \<subseteq> ?R")
proof
  fix y
  assume "y \<in> ?L"
  then obtain u v where "(u, v) \<in># M"
    and "y \<in> vars_term (u \<cdot> subst x t) \<union> vars_term (v \<cdot> subst x t)"
    by (auto simp: vars_mset_def subst_mset_def)
  moreover then have "y \<in> vars_term u \<union> vars_term v \<union> vars_term t"
    unfolding vars_term_subst subst_def fun_upd_def
    by (auto) (metis empty_iff)+
  ultimately show "y \<in> ?R" by (force simp: vars_mset_def)
qed

lemma Var_left_vars_mset_less:
  assumes "x \<notin> vars_term t"
  shows "vars_mset (subst_mset (subst x t) M) \<subset> vars_mset (add_mset (Var x, t) M)" (is "?L \<subset> ?R")
proof
  show "?L \<subseteq> ?R" using vars_mset_subst_mset_subset [of x t M] by (simp add: ac_simps)
next
  have "x \<in> ?R" using assms by (force simp: vars_mset_def)
  moreover have "x \<notin> ?L" using assms by simp
  ultimately show "?L \<noteq> ?R" by blast
qed

lemma Var_right_vars_mset_less:
  assumes "x \<notin> vars_term t"
  shows "vars_mset (subst_mset (subst x t) M) \<subset> vars_mset (add_mset (t, Var x) M)"
  using Var_left_vars_mset_less [OF assms] by simp

lemma mem_vars_mset_subst_mset:
  assumes "y \<in> vars_mset (subst_mset (subst x t) M)"
    and "y \<noteq> x"
    and "y \<notin> vars_term t"
  shows "y \<in> vars_mset M"
  using vars_mset_subst_mset_subset [of x t M] and assms by blast

lemma finite_vars_mset:
  "finite (vars_mset A)"
  by (auto simp: vars_mset_def)

end


(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "CleanQ Modular Intervals Helper Functions"

theory CleanQ_ModularIntervals imports Main begin

locale nonzero_modulus =
  fixes N::nat
  assumes Npos: "0 < N"
begin

definition mod_dist :: "nat \<Rightarrow> nat \<Rightarrow> nat" (infixl "\<ominus>" 51)
  where "mod_dist a b = (LEAST i. (b + i) mod N = a mod N)"

lemma mod_dist_witness:
  fixes a b
  shows "\<exists>i. (b + i) mod N = a mod N"
proof
  have "(b + (((a mod N) + N) - b mod N)) mod N =
        (b mod N + (((a mod N) + N) - b mod N) mod N) mod N"
    by(simp add:mod_add_eq)
  also have "... = nat (int ((b mod N + (((a mod N) + N) - b mod N) mod N) mod N))"
    by(simp)
  also {
    have "int ((b mod N + (((a mod N) + N) - b mod N) mod N) mod N) =
          int (b mod N + (((a mod N) + N) - b mod N) mod N) mod int N"
      by(simp add:zmod_int)
    also {
      have "int (b mod N + (((a mod N) + N) - b mod N) mod N) =
            int (b mod N) + int ((((a mod N) + N) - b mod N) mod N)"
        by(simp)
      also have "... = int b mod int N + int ((((a mod N) + N) - b mod N)) mod int N"
        by(simp add:zmod_int)
      also {
        from Npos have "b mod N \<le> N" by(auto)
        also have "N \<le> (a mod N) + N" by(auto)
        finally have "int (((a mod N) + N) - b mod N) =
                      int ((a mod N) + N) - int (b mod N)"
          by(auto)
        hence "int b mod int N + int ((((a mod N) + N) - b mod N)) mod int N =
               int b mod int N + (int ((a mod N) + N) - int (b mod N)) mod int N"
          by(simp)
      }
      also have "int b mod int N + (int ((a mod N) + N) - int (b mod N)) mod int N =
                 int b mod int N + ((int (a mod N) + int N) - int (b mod N)) mod int N"
        by(simp)
      also have "... = int b mod int N + ((int a mod int N + int N) - int b mod int N) mod int N"
        by(simp add:zmod_int)
      finally have "int (b mod N + (((a mod N) + N) - b mod N) mod N) mod int N =
                    (int b mod int N +
                     ((int a mod int N + int N) - int b mod int N) mod int N) mod int N"
        by(simp)
    }
    also have "(int b mod int N + ((int a mod int N + int N) - int b mod int N) mod int N) mod int N =
               (int b mod int N + ((int a mod int N + int N) - int b mod int N)) mod int N"
      by(simp add:mod_add_right_eq)
    finally have "nat (int ((b mod N + (((a mod N) + N) - b mod N) mod N) mod N)) =
                  nat (int a mod int N)"
      by(simp add:ac_simps)
  }
  also have "nat (int a mod int N) = a mod N"
    by(fold zmod_int, simp)
  finally show "(b + (a mod N + N - b mod N)) mod N = a mod N" .
qed

lemma mod_dist_least:
  "\<And>a b i. (b + i) mod N = a mod N \<Longrightarrow> a \<ominus> b \<le> i"
  unfolding mod_dist_def by(auto intro:Least_le)

lemma mod_dist_left_inverse:
  "\<And>a b. (b + (a \<ominus> b)) mod N = a mod N"
  unfolding mod_dist_def by(rule LeastI_ex[OF mod_dist_witness])

lemma mod_dist_right_inverse:
  "\<And>a b. ((a \<ominus> b) + b) mod N = a mod N"
  using mod_dist_left_inverse by(simp add:ac_simps)

lemma mod_dist_bounded:
  fixes a b shows "a \<ominus> b < N"
proof(rule ccontr)
  assume "\<not> a \<ominus> b < N"
  hence Nle: "N \<le> a \<ominus> b" by(auto)
  hence "(b + ((a \<ominus> b) - N)) mod N = ((b + (a \<ominus> b)) - N) mod N" by(auto)
  also {
    from Nle have "N \<le> b + (a \<ominus> b)" by(auto)
    hence "((b + (a \<ominus> b)) - N) mod N = (b + (a \<ominus> b)) mod N"
      by(simp add:le_mod_geq[symmetric])
  }
  also note mod_dist_left_inverse
  finally have "a \<ominus> b \<le> (a \<ominus> b) - N"
    by(rule mod_dist_least)
  moreover from Nle Npos have "(a \<ominus> b) - N < a \<ominus> b" by(auto)
  ultimately show False by(auto)
qed

lemma mod_dist_unique:
  fixes a b i
  assumes iN: "i < N"
      and P: "(b + i) mod N = a mod N"
    shows "i = a \<ominus> b"
proof(rule contrapos_pp[OF iN])
  from P have ab_le: "a \<ominus> b \<le> i" by(rule mod_dist_least)
  hence "b + (a \<ominus> b) \<le> b + i" by(simp)
  moreover from P mod_dist_left_inverse
  have "(b + i) mod N = (b + (a \<ominus> b)) mod N" by(simp)
  ultimately obtain q where quot: "b + i = (b + (a \<ominus> b)) + N * q"
    by(blast dest:nat_mod_eq_lemma)

  assume "i \<noteq> a \<ominus> b"
  with quot have "0 < q" by(auto)
  hence "b + N * 1 \<le> (b + (a \<ominus> b)) + N * q"
    by(intro add_le_mono, auto)
  hence "b + N \<le> (b + (a \<ominus> b)) + N * q" by(simp)
  with quot have "N \<le> i" by(simp)
  thus "\<not> i < N" by(simp)
qed

lemma mod_dist_self:
  "a \<ominus> a = 0"
proof -
  have "(a + 0) mod N = a mod N" by(simp)
  hence "a \<ominus> a \<le> 0" by(rule mod_dist_least)
  thus "a \<ominus> a = 0" by(simp)
qed

lemma mod_dist_zero:
  fixes a b
  shows "a \<ominus> b = 0 \<Longrightarrow> a mod N = b mod N"
  using mod_dist_left_inverse[of b a] by(simp)

lemma mod_dist_modeq:
  "a mod N = b mod N \<Longrightarrow> a \<ominus> b = 0"
  unfolding mod_dist_def by(auto)

lemma mod_dist_rzero:
  "a \<ominus> 0 = a mod N"
proof -
  from mod_dist_bounded have "a \<ominus> 0 = (0 + (a \<ominus> 0)) mod N" by(simp)
  also have "(0 + (a \<ominus> 0)) mod N = a mod N" by(rule mod_dist_left_inverse)
  finally show ?thesis .
qed

lemma mod_dist_mod_right:
  "a \<ominus> b mod N = a \<ominus> b"
proof(rule antisym)
  have "(b + (a \<ominus> b mod N)) mod N =
        (b mod N + (a \<ominus> b mod N)) mod N"
    by(simp add:mod_add_left_eq)
  also have "... = a mod N"
    by(simp add:mod_dist_left_inverse)
  finally show "a \<ominus> b \<le> a \<ominus> b mod N"
    by(rule mod_dist_least)
next
  have "(b mod N + (a \<ominus> b)) mod N =
        (b + (a \<ominus> b)) mod N"
    by(simp add:mod_add_left_eq)
  also have "... = a mod N"
    by(simp add:mod_dist_left_inverse)
  finally show "a \<ominus> b mod N \<le> a \<ominus> b"
    by(rule mod_dist_least)
qed

lemma mod_dist_mod_left:
  "a mod N \<ominus> b = a \<ominus> b"
proof(rule antisym)
  have "(b + (a mod N \<ominus> b)) mod N = a mod N"
    by(simp add:mod_dist_left_inverse)
  thus "a \<ominus> b \<le> a mod N \<ominus> b"
    by(rule mod_dist_least)
next
  have "(b + (a \<ominus> b)) mod N = (a mod N) mod N"
    by(simp add:mod_dist_left_inverse)
  thus "a mod N \<ominus> b \<le> a \<ominus> b"
    by(rule mod_dist_least)
qed

lemmas mod_dist_simps =
  mod_dist_mod_left mod_dist_mod_right mod_dist_modeq mod_dist_self

definition between :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"  ("_ \<sqsubseteq> _ \<sqsubseteq> _" 200)
  where "between l x h \<longleftrightarrow> x \<ominus> l \<le> h \<ominus> l"

lemma squeezed_between:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
      and ca: "c = a"
      and aN: "a < N"
      and bN: "b < N"
    shows "b = a"
proof -
  from abc ca have "b \<ominus> a = 0" unfolding between_def by(auto simp:mod_dist_simps)
  hence "b mod N = a mod N" by(simp add:mod_dist_zero)
  with aN bN show ?thesis by(auto)
qed

definition between_strict :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"  ("_ \<sqsubseteq> _ \<sqsubset> _" 200)
  where "between_strict l x h \<longleftrightarrow> x \<ominus> l < h \<ominus> l"

lemma between_strict_eq:
  assumes betw: "a \<sqsubseteq> b \<sqsubset> c"
  shows "a \<noteq> c"
proof(rule contrapos_pn[OF betw])
  assume eq: "a = c"
  with betw have "b = c"
    unfolding between_strict_def by(simp add:mod_dist_simps)
  thus "\<not> (a \<sqsubseteq> b \<sqsubset> c)"
    unfolding between_strict_def by(simp)
qed

lemma between_strict_between:
  "\<And>a b c. a \<sqsubseteq> b \<sqsubset> c \<Longrightarrow> a \<sqsubseteq> b \<sqsubseteq> c"
  unfolding between_def between_strict_def by(auto)

lemma mod_dist_triangle:
  fixes a b c shows "c \<ominus> a \<le> (c \<ominus> b) + (b \<ominus> a)"
proof -
  have "(a + ((c \<ominus> b) + (b \<ominus> a))) mod N =
        ((c \<ominus> b) + ((b \<ominus> a) + a)) mod N"
    by(simp add:ac_simps)
  also have "... = ((c \<ominus> b) mod N + ((b \<ominus> a) + a) mod N) mod N"
    by(simp add:mod_add_eq)
  also have "... = ((c \<ominus> b) mod N + b mod N) mod N"
    by(simp add:mod_dist_right_inverse)
  also have "... = ((c \<ominus> b) + b) mod N"
    by(simp add:mod_add_eq)
  also have "... = c mod N"
    by(simp add:mod_dist_right_inverse)
  finally show "c \<ominus> a \<le> (c \<ominus> b) + (b \<ominus> a)"
    by(rule mod_dist_least)
qed

lemma interval_split:
  assumes betw: "a \<sqsubseteq> b \<sqsubseteq> c"
  shows "(c \<ominus> b) + (b \<ominus> a) = c \<ominus> a"
proof(rule antisym[OF _ mod_dist_triangle], rule ccontr)
  assume "\<not> (c \<ominus> b) + (b \<ominus> a) \<le> c \<ominus> a"
  hence less: "c \<ominus> a < (c \<ominus> b) + (b \<ominus> a)" by(simp)

  from betw have le_ba: "b \<ominus> a \<le> c \<ominus> a" by(simp add:between_def)

  let ?i = "(c \<ominus> a) - (b \<ominus> a)"
  have "(b + ?i) mod N = (?i + b) mod N"
    by(simp add:ac_simps)
  also have "... = (?i mod N + b mod N) mod N"
    by(simp add:mod_add_eq)
  also have "... = (?i mod N + ((b \<ominus> a) + a) mod N) mod N"
    by(simp add:mod_dist_right_inverse)
  also have "... = (?i + ((b \<ominus> a) + a)) mod N"
    by(simp add:mod_add_eq)
  also from le_ba have "... = ((c \<ominus> a) + a) mod N"
    by(simp add:ac_simps)
  also have "... = c mod N"
    by(simp add:mod_dist_right_inverse)
  finally have X: "c \<ominus> b \<le> ?i"
    by(rule mod_dist_least)

  with less have "(c \<ominus> a) + (c \<ominus> b) < ((c \<ominus> b) + (b \<ominus> a)) + ((c \<ominus> a) - (b \<ominus> a))"
    by(auto)
  with le_ba show False by(simp)
qed

lemmas interval_split_strict = interval_split[OF between_strict_between]

lemma between_extend_right:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
      and axb: "a \<sqsubseteq> x \<sqsubset> b"
    shows "a \<sqsubseteq> x \<sqsubset> c"
  using assms unfolding between_def between_strict_def by(auto)

lemma between_strict_rhs:
    fixes a b c
  assumes betw: "a \<sqsubseteq> b \<sqsubset> c"
    shows "0 < c \<ominus> b"
proof(rule contrapos_pp[OF betw])
  assume "\<not> 0 < c \<ominus> b"
  hence "c \<ominus> b = 0" by(auto)
  moreover from betw have "(c \<ominus> b) + (b \<ominus> a) = c \<ominus> a"
    by(rule interval_split_strict)
  ultimately have "b \<ominus> a = c \<ominus> a" by(simp)
  thus "\<not> (a \<sqsubseteq> b \<sqsubset> c)" by(simp add:between_strict_def)
qed

lemma between_strict_disj:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
      and axb: "a \<sqsubseteq> x \<sqsubset> c"
    obtains (Left) "a \<sqsubseteq> x \<sqsubset> b" |
            (Right) "b \<sqsubseteq> x \<sqsubset> c"
proof(cases "x \<ominus> a < b \<ominus> a")
  case True thus thesis by(auto simp:between_strict_def intro:Left)
next
  case False
  hence le_bx: "b \<ominus> a \<le> x \<ominus> a" by(auto)
  hence abx: "a \<sqsubseteq> b \<sqsubseteq> x" by(simp add:between_def)

  from axb have part_axb: "c \<ominus> a = (c \<ominus> x) + (x \<ominus> a)"
    by(simp add:interval_split_strict)
  moreover from abx have "x \<ominus> a = (x \<ominus> b) + (b \<ominus> a)"
    by(simp add:interval_split)
  ultimately have "c \<ominus> a = (c \<ominus> x) + (x \<ominus> b) + (b \<ominus> a)"
    by(simp)
  moreover from abc have "c \<ominus> a = (c \<ominus> b) + (b \<ominus> a)"
    by(simp add:interval_split)
  ultimately have "c \<ominus> b = (c \<ominus> x) + (x \<ominus> b)"
    by(simp)
  moreover from axb have "0 < c \<ominus> x"
    by(rule between_strict_rhs)
  ultimately have "x \<ominus> b < c \<ominus> b"
    by(auto)
  hence "b \<sqsubseteq> x \<sqsubset> c"
    by(simp add:between_strict_def)
  thus thesis
    by(rule Right)
qed

lemma between_lhs:
  "\<And>a b. a \<sqsubseteq> a \<sqsubseteq> b"
  unfolding between_def by(simp add:mod_dist_simps)

lemma between_rhs:
  "\<And>a b. a \<sqsubseteq> b \<sqsubseteq> b"
  unfolding between_def by(simp)

lemma between_mod_left_iff:
  "\<And>a b c. ((a mod N) \<sqsubseteq> b \<sqsubseteq> c) = (a \<sqsubseteq> b \<sqsubseteq> c)"
  by(simp add:between_def mod_dist_simps)

lemma between_mod_middle_iff:
  "\<And>a b c. (a \<sqsubseteq> (b mod N) \<sqsubseteq> c) = (a \<sqsubseteq> b \<sqsubseteq> c)"
  by(simp add:between_def mod_dist_simps)

lemma between_mod_right_iff:
  "\<And>a b c. (a \<sqsubseteq> b \<sqsubseteq> (c mod N)) = (a \<sqsubseteq> b \<sqsubseteq> c)"
  by(simp add:between_def mod_dist_simps)

lemma between_strict_mod_left_iff:
  "\<And>a b c. ((a mod N) \<sqsubseteq> b \<sqsubset> c) = (a \<sqsubseteq> b \<sqsubset> c)"
  by(simp add:between_strict_def mod_dist_simps)

lemma between_strict_mod_middle_iff:
  "\<And>a b c. (a \<sqsubseteq> (b mod N) \<sqsubset> c) = (a \<sqsubseteq> b \<sqsubset> c)"
  by(simp add:between_strict_def mod_dist_simps)

lemma between_strict_mod_right_iff:
  "\<And>a b c. (a \<sqsubseteq> b \<sqsubset> (c mod N)) = (a \<sqsubseteq> b \<sqsubset> c)"
  by(simp add:between_strict_def mod_dist_simps)

lemmas between_simps =
  between_lhs between_rhs
  between_mod_left_iff between_mod_middle_iff between_mod_right_iff
  between_strict_mod_left_iff between_strict_mod_middle_iff between_strict_mod_right_iff

lemma between_disj:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
      and axb: "a \<sqsubseteq> x \<sqsubseteq> c"
    obtains (Left) "a \<sqsubseteq> x \<sqsubseteq> b" |
            (Right) "b \<sqsubseteq> x \<sqsubseteq> c"
proof(cases "x mod N = c mod N")
  case True
  hence "b \<sqsubseteq> (x mod N) \<sqsubseteq> (c mod N)" by(simp add:between_simps)
  hence "b \<sqsubseteq> x \<sqsubseteq> c" by(simp add:between_simps)
  thus thesis by(rule Right)
next
  case False
  hence "0 < c \<ominus> x"
    by(auto intro:mod_dist_zero[symmetric])
  moreover from axb have "c \<ominus> a = (c \<ominus> x) + (x \<ominus> a)"
    by(simp add:interval_split)
  ultimately have "x \<ominus> a < c \<ominus> a"
    by(auto)
  hence "a \<sqsubseteq> x \<sqsubset> c" by(simp add:between_strict_def)
  with abc show thesis
    by(blast intro:between_strict_disj between_strict_between Left Right)
qed

lemma between_extend_left:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
      and bxc: "b \<sqsubseteq> x \<sqsubset> c"
    shows "a \<sqsubseteq> x \<sqsubset> c"
proof -
  have "x \<ominus> a \<le> (x \<ominus> b) + (b \<ominus> a)"
    by(rule mod_dist_triangle)
  also {
    from abc bxc have part: "(c \<ominus> x) + (x \<ominus> b) + (b \<ominus> a) = c \<ominus> a"
      by(simp add:interval_split interval_split_strict)
    moreover from bxc have "0 < c \<ominus> x" by(rule between_strict_rhs)
    ultimately have "(x \<ominus> b) + (b \<ominus> a) < c \<ominus> a" by(auto)
  }
  finally show ?thesis by(simp add:between_strict_def)
qed

definition set_between :: "nat \<Rightarrow> nat \<Rightarrow> nat set" (infix "upto" 500)
  where "l upto h = {i. i < N \<and> (l \<sqsubseteq> i \<sqsubset> h)}"

definition list_between :: "nat \<Rightarrow> nat \<Rightarrow> nat list" (infix "uptol" 500)
  where "l uptol h = filter (\<lambda>i.  (l \<sqsubseteq> i \<sqsubset> h)) [0..<N]"

lemma upto_set_list_eq:
  "l upto h = set (l uptol h)"
  unfolding set_between_def list_between_def by(simp)

lemma upto_eq:
  assumes eq: "l = h"
  shows "l upto h = {}"
proof
  show "{} \<subseteq> l upto h" by(auto)
  show "l upto h \<subseteq> {}"
  proof
    fix x
    assume "x \<in> l upto h"
    hence "l \<noteq> h" unfolding set_between_def
      by(auto dest:between_strict_eq)
    with eq show "x \<in> {}" by(auto)
  qed
qed

lemma upto_eq_mod:
  "l mod N = h mod N \<longleftrightarrow> l upto h = {}"
proof
  show "l mod N = h mod N \<Longrightarrow> l upto h = {}"
    by (simp add: between_strict_def nonzero_modulus.mod_dist_modeq
                  nonzero_modulus.set_between_def nonzero_modulus_axioms)
  show " l upto h = {} \<Longrightarrow>l mod N = h mod N"
    unfolding set_between_def
    by (metis (no_types, lifting) Collect_empty_eq Npos between_strict_def le_zero_eq
              mod_dist_def mod_dist_zero mod_less_divisor nonzero_modulus.mod_dist_mod_left
              nonzero_modulus.mod_dist_modeq nonzero_modulus_axioms not_less)
qed

lemma upto_eq_both :
  assumes ll: "l < N" and hh: " h < N"
  shows " l = h \<longleftrightarrow> l upto h = {}"
proof -
  from ll have X1: " l = l mod N"
    by(auto)
  from hh  have X2: " h = h mod N"
    by(auto)
  show ?thesis
    apply(subst X1)
    apply(subst X2)
    using upto_eq_mod by(auto)
qed

lemma uptol_eq_both :
  assumes ll: "l < N" and hh: " h < N"
  shows " l = h \<longleftrightarrow> l uptol h = []"
  using ll hh upto_eq_both upto_set_list_eq
  by simp

lemma uptol_eq:
  assumes eq: "l = h"
  shows "l uptol h = []"
  using eq upto_set_list_eq upto_eq by(simp)

lemma upto_mono_right:
  "\<And>a b c. a \<sqsubseteq> b \<sqsubseteq> c \<Longrightarrow> a upto b \<subseteq> a upto c"
  unfolding set_between_def by(auto dest:between_extend_right)

lemma upto_mono_left:
  "\<And>a b c. a \<sqsubseteq> b \<sqsubseteq> c \<Longrightarrow> b upto c \<subseteq> a upto c"
  unfolding set_between_def by(auto dest:between_extend_left)

lemma upto_between_strict_eq:
  "(b < N \<and> (a \<sqsubseteq> b \<sqsubset> c)) = (b \<in> a upto c)"
  unfolding set_between_def between_strict_def by(auto)

lemma upto_union:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
  shows "a upto b \<union> b upto c = a upto c"
proof(intro antisym subsetI)
  fix x
  assume "x \<in> a upto b \<union> b upto c"
  thus "x \<in> a upto c"
  proof(rule UnE)
    assume "x \<in> a upto b"
    with abc show "x \<in> a upto c" by(auto dest:upto_mono_right)
  next
    assume "x \<in> b upto c"
    with abc show "x \<in> a upto c" by(auto dest:upto_mono_left)
  qed
next
  fix x
  assume "x \<in> a upto c"
  hence "a \<sqsubseteq> x \<sqsubset> c" and "x < N" by(simp_all add:set_between_def)
  with abc show "x \<in> a upto b \<union> b upto c"
    by(cases rule:between_strict_disj, simp_all add:set_between_def)
qed

lemma upto_inter:
  assumes abc: "a \<sqsubseteq> b \<sqsubseteq> c"
  shows "a upto b \<inter> b upto c = {}"
proof(intro iffD1[OF subset_empty] subsetI)
  fix x
  assume "x \<in> a upto b \<inter> b upto c"
  hence btw_axb: "a \<sqsubseteq> x \<sqsubset> b" and "b \<sqsubseteq> x \<sqsubset> c" by(simp_all add:set_between_def)
  hence part_axb: "b \<ominus> a = (b \<ominus> x) + (x \<ominus> a)" and pos_bx: "0 < b \<ominus> x"
    and part_bxc: "c \<ominus> b = (c \<ominus> x) + (x \<ominus> b)"
    by(auto dest:interval_split_strict between_strict_rhs)

  from abc have "c \<ominus> a = (c \<ominus> b) + (b \<ominus> a)" by(simp add:interval_split)
  with part_axb part_bxc
  have part_ac: "c \<ominus> a = (c \<ominus> x) + (x \<ominus> b) + (b \<ominus> x) + (x \<ominus> a)"
    by(simp)

  from abc btw_axb have "a \<sqsubseteq> x \<sqsubset> c" by(rule between_extend_right)
  hence "c \<ominus> a = (c \<ominus> x) + (x \<ominus> a)" by(simp add:interval_split_strict)
  txt {* Derive a contradiction. *}
  with part_ac pos_bx show "x \<in> {}" by(simp)
qed

lemma
  assumes leq: "l \<le> h" and ll: "l < N" and hh: "h \<le> N"
  shows "l \<sqsubseteq> h \<sqsubset> N"
  unfolding between_strict_def mod_dist_def
  using leq ll hh
  oops

lemma
  between_strict_geq_lt:
  assumes leq: "l \<le> h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows "(k < N \<and> (l \<sqsubseteq> k \<sqsubset> h)) \<Longrightarrow> (l \<le> k \<and> k < h)"
proof -
    assume pre: "k < N \<and> (l \<sqsubseteq> k \<sqsubset> h)"

    from pre have X1:
      "((LEAST i. (l + i) mod N = k mod N) < (LEAST i. (l + i) mod N = h mod N))"
      unfolding between_strict_def mod_dist_def by(auto)

    from pre have Y1: "(LEAST i. (l + i) mod N = k mod N) = k - l"
    proof -
      have P: "(\<lambda>i.(l + i) mod N = k mod N) (k - l)"
        by (smt ab_semigroup_add_class.add_ac(1) add.left_commute add_diff_cancel_right'
                hh le_add_diff_inverse leq less_imp_le_nat linorder_neqE_nat
                mod_dist_right_inverse mod_less nonzero_modulus.between_strict_def
                nonzero_modulus.mod_dist_unique nonzero_modulus_axioms not_add_less1 pre)
      have I: "\<And>y. (\<lambda>i. (l + i) mod N = k mod N) y \<Longrightarrow> (k - l) \<le> y"
        using le_diff_conv mod_less_eq_dividend
        using pre by fastforce

      show ?thesis
         using P I by(simp add:Least_equality)
     qed

    have Y2: "(LEAST i. (l + i) mod N = h mod N) = h - l"
    proof -
      have P: "(\<lambda>i. (l + i) mod N = h mod N) (h - l)"
        by (simp add: leq)
      have I: "\<And>y. (\<lambda>i.  (l + i) mod N = h mod N) y \<Longrightarrow> (h - l) \<le> y"
         using le_diff_conv mod_less_eq_dividend
         by (metis add.commute between_strict_eq between_strict_mod_right_iff hh
                   le_add1 le_neq_implies_less mod_if not_less pre)

      show ?thesis
         using P I by(simp add:Least_equality)
     qed

    from X1 Y1 Y2 have X2:
      "(k - l) < (h - l)"
      by(simp)

    from X2 have X3: "k < h"
      by(auto)

    have Z1:
      "(\<lambda>i.(l + i) mod N = k mod N) (k - l)"
      by (metis (mono_tags, lifting) LeastI_ex Y1 mod_dist_left_inverse)

    have  X4: "l \<le> k"
      using pre ll hh leq Y1 Y2 Z1
      by (metis X2 add_cancel_right_right diff_is_0_eq' le_neq_implies_less less_or_eq_imp_le mod_less nat_neq_iff)

    from X3 X4 show ?thesis by(simp)
qed

(*
lemma
  assumes leq: "l \<le> h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows "(k < N \<and> (l \<sqsubseteq> k \<sqsubset> h)) = (l \<le> k \<and> k < h)"
proof(rule iffI)
  show "k < N \<and> (l \<sqsubseteq> k \<sqsubset> h) \<Longrightarrow> l \<le> k \<and> k < h"
  proof -
    assume pre: "k < N \<and> (l \<sqsubseteq> k \<sqsubset> h)"

    from pre have X1:
      "((LEAST i. (l + i) mod N = k mod N) < (LEAST i. (l + i) mod N = h mod N))"
      unfolding between_strict_def mod_dist_def by(auto)

    from pre have Y1: "(LEAST i. (l + i) mod N = k mod N) = k - l"
    proof -
      have P: "(\<lambda>i.(l + i) mod N = k mod N) (k - l)"
        by (smt ab_semigroup_add_class.add_ac(1) add.left_commute add_diff_cancel_right' hh le_add_diff_inverse leq less_imp_le_nat linorder_neqE_nat mod_dist_right_inverse mod_less nonzero_modulus.between_strict_def nonzero_modulus.mod_dist_unique nonzero_modulus_axioms not_add_less1 pre)
      have I: "\<And>y. (\<lambda>i. (l + i) mod N = k mod N) y \<Longrightarrow> (k - l) \<le> y"
        using le_diff_conv mod_less_eq_dividend
        using pre by fastforce

      show ?thesis
         using P I by(simp add:Least_equality)
     qed

    have Y2: "(LEAST i. (l + i) mod N = h mod N) = h - l"
    proof -
      have P: "(\<lambda>i. (l + i) mod N = h mod N) (h - l)"
        by (simp add: leq)
      have I: "\<And>y. (\<lambda>i.  (l + i) mod N = h mod N) y \<Longrightarrow> (h - l) \<le> y"
         using le_diff_conv mod_less_eq_dividend
         by (metis add.commute between_strict_eq between_strict_mod_right_iff hh le_add1 le_neq_implies_less mod_if not_less pre)  (*by presburger *)

      show ?thesis
         using P I by(simp add:Least_equality)
     qed

    from X1 Y1 Y2 have X2:
      "(k - l) < (h - l)"
      by(simp)

    from X2 have X3: "k < h"
      by(auto)

    have Z1:
      "(\<lambda>i.(l + i) mod N = k mod N) (k - l)"
      by (metis (mono_tags, lifting) LeastI_ex Y1 mod_dist_left_inverse)

    have  X4: "l \<le> k"
      using pre ll hh leq Y1 Y2 Z1
      by (metis X2 add_cancel_right_right diff_is_0_eq' le_neq_implies_less less_or_eq_imp_le mod_less nat_neq_iff)

    from X3 X4 show ?thesis by(simp)
  qed
  show " l \<le> k \<and> k < h \<Longrightarrow> k < N \<and> (l \<sqsubseteq> k \<sqsubset> h)"
  proof -
    assume pre: "l \<le> k \<and> k < h"

    from pre have Y1: "(LEAST i. (l + i) mod N = k mod N) = k - l"
    proof -
      have P: "(\<lambda>i.(l + i) mod N = k mod N) (k - l)"
        by (smt ab_semigroup_add_class.add_ac(1) add.left_commute add_diff_cancel_right' hh le_add_diff_inverse leq less_imp_le_nat linorder_neqE_nat mod_dist_right_inverse mod_less nonzero_modulus.between_strict_def nonzero_modulus.mod_dist_unique nonzero_modulus_axioms not_add_less1 pre)
      have I: "\<And>y. (\<lambda>i. (l + i) mod N = k mod N) y \<Longrightarrow> (k - l) \<le> y"
        using le_diff_conv mod_less_eq_dividend
        using pre ll hh leq
        by fastforce

      show ?thesis
         using P I by(simp add:Least_equality)
     qed

    have Y2: "(LEAST i. (l + i) mod N = h mod N) = h - l"
    proof -
      have P: "(\<lambda>i. (l + i) mod N = h mod N) (h - l)"
        by (simp add: leq)
      have I: "\<And>y.  (\<lambda>i.  (l + i) mod N = h mod N) y \<Longrightarrow> (h - l) \<le> y"
      proof cases
        assume heq: "h \<noteq> N"
        then show "\<And>y.  (\<lambda>i.  (l + i) mod N = h mod N) y \<Longrightarrow> (h - l) \<le> y"
          using hh le_diff_conv by fastforce
      next
        assume heq: "\<not>(h \<noteq> N)"
        then show "\<And>y.  (\<lambda>i.  (l + i) mod N = h mod N) y \<Longrightarrow> (h - l) \<le> y"
        proof -
          from heq have equa: "h = N"
            by(auto)

          have rep:
            "\<And>y.  (\<lambda>i.  (l + i) mod N = 0) y \<Longrightarrow> (h - l) \<le> y"
            try
            sorry

          show "\<And>y.  (\<lambda>i.  (l + i) mod N = h mod N) y \<Longrightarrow> (h - l) \<le> y"
            using equa heq rep by(auto)
        qed
      qed

      show ?thesis
         using P I by(simp add:Least_equality)
     qed

    from pre have Y3:  "(k - l) < (h - l)"
       by(auto)

    have X1: "k < N"
      using pre hh by(simp)

    have X2: "(l \<sqsubseteq> k \<sqsubset> h)"
      using Y1 Y2 Y3 unfolding between_strict_def mod_dist_def by(auto)

    show ?thesis
      using X1 X2 by(auto)
  qed
qed

lemma uptol_elements:
  assumes leq: "l \<le> h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows "l uptol h = [l..<h]"
proof -
  have X0:
    "(l uptol h) = filter (\<lambda>i. (l \<sqsubseteq> i \<sqsubset> h)) [0..<N]"
    unfolding list_between_def by(simp)

  have xx:
    "0 \<le> l"
    by(auto)

  from leq ll hh xx have par :
    "[0..<N] = [0..<l] @ [l..<h] @ [h..<N]"
     by (metis le_Suc_ex upt_add_eq_append)

   from par have splitlist:
     "filter (\<lambda>i. (l \<le> i \<and> i < h)) [0..<N] =
        filter (\<lambda>i. (l \<le> i \<and> i < h)) ([0..<l] @ [l..<h] @ [h..<N])"
    by(auto)

  have splitfilter:
    "filter (\<lambda>i. (l \<le> i \<and> i < h)) ([0..<l] @ [l..<h] @ [h..<N]) =
        filter (\<lambda>i. (l \<le> i \<and> i < h)) ([0..<l])
      @ filter (\<lambda>i. (l \<le> i \<and> i < h)) ( [l..<h])
      @ filter (\<lambda>i. (l \<le> i \<and> i < h)) ( [h..<N])"
    by(auto)

  have upper:
    "\<forall>x \<in> set([h..<N]). \<not>((\<lambda>i. (l \<le> i \<and> i < h)) x)"
    by(auto)

  from upper have upperfilter:
    "filter (\<lambda>i. (l \<le> i \<and> i < h)) ( [h..<N]) = []"
    by(simp)

  have lower:
    "\<forall>x \<in> set([0..<l]). \<not>((\<lambda>i. (l \<le> i \<and> i < h)) x)"
    by(auto)

  from lower have lowerfilter:
    "filter (\<lambda>i. (l \<le> i \<and> i < h)) ([0..<l]) = []"
    by(auto)

  from upperfilter lowerfilter have drop:
    "filter (\<lambda>i. (l \<le> i \<and> i < h)) ([0..<l] @ [l..<h] @ [h..<N]) =
     filter (\<lambda>i. (l \<le> i \<and> i < h)) ( [l..<h])"
    by(auto)

  have mid:
    "\<forall>x \<in> set [l..<h].  (\<lambda>i. (l \<le> i \<and> i < h)) x"
    by(auto)

  from mid have midfilter:
    "filter (\<lambda>i. (l \<le> i \<and> i < h)) ( [l..<h]) = [l..<h]"
    by(auto)

  from splitlist drop midfilter have X1:
    "[l..<h] = filter (\<lambda>i. (l \<le> i \<and> i < h)) [0..<N]"
    by(auto)

  from leq ll hh have X2:
    "\<And>i. i < N \<and> (l \<sqsubseteq> i \<sqsubset> h) = (l \<le> i \<and> i < h)"
    using between_strict_geq_lt oops
    sorry

  show ?thesis
    using X0 X1 X2 by(auto)
qed

lemma "0 uptol N = [0..<N]"
  by (simp add: uptol_elements)

lemma "0 upto N = {0..<N}"
  by (simp add: upto_set_list_eq uptol_elements)

lemma uptol_elements_wrap:
  assumes geq: "l > h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows  "l uptol h = [0..<h] @ [l..<N]"
  oops

lemma upto_elements:
  assumes leq: "l \<le> h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows "l upto h = {l..<h}"
  using leq ll hh uptol_elements upto_set_list_eq
  by(auto)

lemma upto_elements_wrap:
  assumes geq: "l > h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows "l upto h = {0..<h} \<union> {l..<N}"
  using geq ll hh uptol_elements_wrap upto_set_list_eq
  by(auto)

lemma
  assumes leq: "l \<le> h" and ll: "l \<le> N" and hh: "h \<le> N"
  shows "[0..<N] = (0 uptol l) @ (l uptol h) @ (h uptol N)"
proof -
  from ll have X0:
    "0 \<le> l \<and> l \<le> N"
    by(auto)

  from X0 have X1:
    "0 uptol l = [0..<l]"
    using uptol_elements by(auto)

  from leq ll hh have X2:
    "l uptol h = [l..<h]"
    using uptol_elements by(auto)

  from hh  have X3:
    "h uptol N = [h..<N]"
    using uptol_elements by(auto)

  from X1 X2 X3 have X4:
    "(0 uptol l) @ (l uptol h) @ (h uptol N) = [0..<l] @ [l..<h] @ [h..<N]"
    by(auto)

  also have
    "[0..<l] @ [l..<h] @ [h..<N] = [0..<N]"
    by (metis X0 hh le_Suc_ex leq upt_add_eq_append)

  with X4 show ?thesis
    by(auto)
qed
    *)

(*
lemma send_help_2:
  "\<And>a c. ((c \<ominus> a) + 1) \<noteq> N \<Longrightarrow> (c \<ominus> a) + 1 = ((c+1) \<ominus> a)"
  sorry

lemma send_help:
  fixes a :: "nat" and c :: "nat"
  assumes a1: "0 < a \<ominus> (c+1)"
  shows "(c \<ominus> a) \<le> ((c+1) \<ominus> a)"
proof -
  from a1 have "((c \<ominus> a) + 1) \<noteq> N"
  have hx: "((c \<ominus> a) + 1) \<noteq> N" sorry
  have "((c + 1) \<ominus> a) = (c \<ominus> a) + 1" using hx send_help_2 by(auto)
  thus ?thesis by(auto)
qed

lemma tail_increment:
  fixes a :: "nat" and b :: "nat" and c :: "nat"
  assumes a1: "a \<sqsubseteq> b \<sqsubseteq> c"
      and a2: "b \<sqsubseteq> (c+1) \<sqsubset> a" (* c + 1 mod N /= a *)
    shows "a \<sqsubseteq> b \<sqsubseteq> (c+1)"
proof -
  from a1 have hx1: "(b \<ominus> a \<le> c \<ominus> a)" using between_def by(simp)
  from a2 have h1: "a \<ominus> (c+1) > 0" using between_strict_rhs by(blast)
  have h2: "(c \<ominus> a) \<le> ((c+1) \<ominus> a)" using h1 by(simp only:send_help)
  from hx1 h2 have "b \<ominus> a \<le> ((c+1) \<ominus> a)" by(auto)
  thus ?thesis by(auto simp: between_def)
qed
*)

end (* locale nonzero_modulus *)

end


(*  Title       : NSPrimes.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2002 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section\<open>The Nonstandard Primes as an Extension of the Prime Numbers\<close>

theory NSPrimes
imports "~~/src/HOL/Number_Theory/Primes" "../Hyperreal"
begin

text\<open>These can be used to derive an alternative proof of the infinitude of
primes by considering a property of nonstandard sets.\<close>

definition
  starprime :: "hypnat set" where
  [transfer_unfold]: "starprime = ( *s* {p. prime p})"

definition
  choicefun :: "'a set => 'a" where
  "choicefun E = (@x. \<exists>X \<in> Pow(E) -{{}}. x : X)"

primrec injf_max :: "nat => ('a::{order} set) => 'a"
where
  injf_max_zero: "injf_max 0 E = choicefun E"
| injf_max_Suc:  "injf_max (Suc n) E = choicefun({e. e:E & injf_max n E < e})"

lemma dvd_by_all2:
  fixes M :: nat
  shows "\<exists>N>0. \<forall>m. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N"
apply (induct M)
apply auto
apply (rule_tac x = "N * (Suc M) " in exI)
apply auto
apply (metis dvdI dvd_add_times_triv_left_iff dvd_add_triv_right_iff dvd_refl dvd_trans le_Suc_eq mult_Suc_right)
done

lemma dvd_by_all:
  "\<forall>M::nat. \<exists>N>0. \<forall>m. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N"
  using dvd_by_all2 by blast

lemma hypnat_of_nat_le_zero_iff [simp]: "(hypnat_of_nat n <= 0) = (n = 0)"
by (transfer, simp)

(* Goldblatt: Exercise 5.11(2) - p. 57 *)
lemma hdvd_by_all: "\<forall>M. \<exists>N. 0 < N & (\<forall>m. 0 < m & (m::hypnat) <= M --> m dvd N)"
by (transfer, rule dvd_by_all)

lemmas hdvd_by_all2 = hdvd_by_all [THEN spec]

(* Goldblatt: Exercise 5.11(2) - p. 57 *)
lemma hypnat_dvd_all_hypnat_of_nat:
     "\<exists>(N::hypnat). 0 < N & (\<forall>n \<in> -{0::nat}. hypnat_of_nat(n) dvd N)"
apply (cut_tac hdvd_by_all)
apply (drule_tac x = whn in spec, auto)
apply (rule exI, auto)
apply (drule_tac x = "hypnat_of_nat n" in spec)
apply (auto simp add: linorder_not_less)
done

text\<open>The nonstandard extension of the set prime numbers consists of precisely
those hypernaturals exceeding 1 that have no nontrivial factors\<close>

(* Goldblatt: Exercise 5.11(3a) - p 57  *)
lemma starprime:
  "starprime = {p. 1 < p & (\<forall>m. m dvd p --> m = 1 | m = p)}"
by (transfer, auto simp add: prime_nat_iff)

(* Goldblatt Exercise 5.11(3b) - p 57  *)
lemma hyperprime_factor_exists [rule_format]:
  "!!n. 1 < n ==> (\<exists>k \<in> starprime. k dvd n)"
by (transfer, simp add: prime_factor_nat)

(* Goldblatt Exercise 3.10(1) - p. 29 *)
lemma NatStar_hypnat_of_nat: "finite A ==> *s* A = hypnat_of_nat ` A"
by (rule starset_finite)

subsection\<open>Another characterization of infinite set of natural numbers\<close>

lemma finite_nat_set_bounded: "finite N ==> \<exists>n. (\<forall>i \<in> N. i<(n::nat))"
apply (erule_tac F = N in finite_induct, auto)
apply (rule_tac x = "Suc n + x" in exI, auto)
done

lemma finite_nat_set_bounded_iff: "finite N = (\<exists>n. (\<forall>i \<in> N. i<(n::nat)))"
by (blast intro: finite_nat_set_bounded bounded_nat_set_is_finite)

lemma not_finite_nat_set_iff: "(~ finite N) = (\<forall>n. \<exists>i \<in> N. n <= (i::nat))"
by (auto simp add: finite_nat_set_bounded_iff not_less)

lemma bounded_nat_set_is_finite2: "(\<forall>i \<in> N. i<=(n::nat)) ==> finite N"
apply (rule finite_subset)
 apply (rule_tac [2] finite_atMost, auto)
done

lemma finite_nat_set_bounded2: "finite N ==> \<exists>n. (\<forall>i \<in> N. i<=(n::nat))"
apply (erule_tac F = N in finite_induct, auto)
apply (rule_tac x = "n + x" in exI, auto)
done

lemma finite_nat_set_bounded_iff2: "finite N = (\<exists>n. (\<forall>i \<in> N. i<=(n::nat)))"
by (blast intro: finite_nat_set_bounded2 bounded_nat_set_is_finite2)

lemma not_finite_nat_set_iff2: "(~ finite N) = (\<forall>n. \<exists>i \<in> N. n < (i::nat))"
by (auto simp add: finite_nat_set_bounded_iff2 not_le)

subsection\<open>An injective function cannot define an embedded natural number\<close>

lemma lemma_infinite_set_singleton: "\<forall>m n. m \<noteq> n --> f n \<noteq> f m
      ==>  {n. f n = N} = {} |  (\<exists>m. {n. f n = N} = {m})"
apply auto
apply (drule_tac x = x in spec, auto)
apply (subgoal_tac "\<forall>n. (f n = f x) = (x = n) ")
apply auto
done

lemma inj_fun_not_hypnat_in_SHNat:
  assumes inj_f: "inj (f::nat=>nat)"
  shows "starfun f whn \<notin> Nats"
proof
  from inj_f have inj_f': "inj (starfun f)"
    by (transfer inj_on_def Ball_def UNIV_def)
  assume "starfun f whn \<in> Nats"
  then obtain N where N: "starfun f whn = hypnat_of_nat N"
    by (auto simp add: Nats_def)
  hence "\<exists>n. starfun f n = hypnat_of_nat N" ..
  hence "\<exists>n. f n = N" by transfer
  then obtain n where n: "f n = N" ..
  hence "starfun f (hypnat_of_nat n) = hypnat_of_nat N"
    by transfer
  with N have "starfun f whn = starfun f (hypnat_of_nat n)"
    by simp
  with inj_f' have "whn = hypnat_of_nat n"
    by (rule injD)
  thus "False"
    by (simp add: whn_neq_hypnat_of_nat)
qed

lemma range_subset_mem_starsetNat:
   "range f <= A ==> starfun f whn \<in> *s* A"
apply (rule_tac x="whn" in spec)
apply (transfer, auto)
done

(*--------------------------------------------------------------------------------*)
(* Gleason Proposition 11-5.5. pg 149, pg 155 (ex. 3) and pg. 360                 *)
(* Let E be a nonvoid ordered set with no maximal elements (note: effectively an  *)
(* infinite set if we take E = N (Nats)). Then there exists an order-preserving   *)
(* injection from N to E. Of course, (as some doofus will undoubtedly point out!  *)
(* :-)) can use notion of least element in proof (i.e. no need for choice) if     *)
(* dealing with nats as we have well-ordering property                            *)
(*--------------------------------------------------------------------------------*)

lemma lemmaPow3: "E \<noteq> {} ==> \<exists>x. \<exists>X \<in> (Pow E - {{}}). x: X"
by auto

lemma choicefun_mem_set [simp]: "E \<noteq> {} ==> choicefun E \<in> E"
apply (unfold choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex], auto)
done

lemma injf_max_mem_set: "[| E \<noteq>{}; \<forall>x. \<exists>y \<in> E. x < y |] ==> injf_max n E \<in> E"
apply (induct_tac "n", force)
apply (simp (no_asm) add: choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex], auto)
done

lemma injf_max_order_preserving: "\<forall>x. \<exists>y \<in> E. x < y ==> injf_max n E < injf_max (Suc n) E"
apply (simp (no_asm) add: choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex], auto)
done

lemma injf_max_order_preserving2: "\<forall>x. \<exists>y \<in> E. x < y
      ==> \<forall>n m. m < n --> injf_max m E < injf_max n E"
apply (rule allI)
apply (induct_tac "n", auto)
apply (simp (no_asm) add: choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex])
apply (auto simp add: less_Suc_eq)
apply (drule_tac x = m in spec)
apply (drule subsetD, auto)
apply (drule_tac x = "injf_max m E" in order_less_trans, auto)
done

lemma inj_injf_max: "\<forall>x. \<exists>y \<in> E. x < y ==> inj (%n. injf_max n E)"
apply (rule inj_onI)
apply (rule ccontr, auto)
apply (drule injf_max_order_preserving2)
apply (metis linorder_antisym_conv3 order_less_le)
done

lemma infinite_set_has_order_preserving_inj:
     "[| (E::('a::{order} set)) \<noteq> {}; \<forall>x. \<exists>y \<in> E. x < y |]
      ==> \<exists>f. range f <= E & inj (f::nat => 'a) & (\<forall>m. f m < f(Suc m))"
apply (rule_tac x = "%n. injf_max n E" in exI, safe)
apply (rule injf_max_mem_set)
apply (rule_tac [3] inj_injf_max)
apply (rule_tac [4] injf_max_order_preserving, auto)
done

text\<open>Only need the existence of an injective function from N to A for proof\<close>

lemma hypnat_infinite_has_nonstandard:
     "~ finite A ==> hypnat_of_nat ` A < ( *s* A)"
apply auto
apply (subgoal_tac "A \<noteq> {}")
prefer 2 apply force
apply (drule infinite_set_has_order_preserving_inj)
apply (erule not_finite_nat_set_iff2 [THEN iffD1], auto)
apply (drule inj_fun_not_hypnat_in_SHNat)
apply (drule range_subset_mem_starsetNat)
apply (auto simp add: SHNat_eq)
done

lemma starsetNat_eq_hypnat_of_nat_image_finite: "*s* A =  hypnat_of_nat ` A ==> finite A"
by (metis hypnat_infinite_has_nonstandard less_irrefl)

lemma finite_starsetNat_iff: "( *s* A = hypnat_of_nat ` A) = (finite A)"
by (blast intro!: starsetNat_eq_hypnat_of_nat_image_finite NatStar_hypnat_of_nat)

lemma hypnat_infinite_has_nonstandard_iff: "(~ finite A) = (hypnat_of_nat ` A < *s* A)"
apply (rule iffI)
apply (blast intro!: hypnat_infinite_has_nonstandard)
apply (auto simp add: finite_starsetNat_iff [symmetric])
done

subsection\<open>Existence of Infinitely Many Primes: a Nonstandard Proof\<close>

lemma lemma_not_dvd_hypnat_one [simp]: "~ (\<forall>n \<in> - {0}. hypnat_of_nat n dvd 1)"
apply auto
apply (rule_tac x = 2 in bexI)
apply (transfer, auto)
done

lemma lemma_not_dvd_hypnat_one2 [simp]: "\<exists>n \<in> - {0}. ~ hypnat_of_nat n dvd 1"
apply (cut_tac lemma_not_dvd_hypnat_one)
apply (auto simp del: lemma_not_dvd_hypnat_one)
done

lemma hypnat_add_one_gt_one:
    "!!N. 0 < N ==> 1 < (N::hypnat) + 1"
by (transfer, simp)

lemma hypnat_of_nat_zero_not_prime [simp]: "hypnat_of_nat 0 \<notin> starprime"
by (transfer, simp)

lemma hypnat_zero_not_prime [simp]:
   "0 \<notin> starprime"
by (cut_tac hypnat_of_nat_zero_not_prime, simp)

lemma hypnat_of_nat_one_not_prime [simp]: "hypnat_of_nat 1 \<notin> starprime"
by (transfer, simp)

lemma hypnat_one_not_prime [simp]: "1 \<notin> starprime"
by (cut_tac hypnat_of_nat_one_not_prime, simp)

lemma hdvd_diff: "!!k m n :: hypnat. [| k dvd m; k dvd n |] ==> k dvd (m - n)"
by (transfer, rule dvd_diff_nat)

lemma hdvd_one_eq_one:
  "\<And>x::hypnat. is_unit x \<Longrightarrow> x = 1"
  by transfer simp

text\<open>Already proved as \<open>primes_infinite\<close>, but now using non-standard naturals.\<close>
theorem not_finite_prime: "~ finite {p::nat. prime p}"
apply (rule hypnat_infinite_has_nonstandard_iff [THEN iffD2])
using hypnat_dvd_all_hypnat_of_nat
apply clarify
apply (drule hypnat_add_one_gt_one)
apply (drule hyperprime_factor_exists)
apply clarify
apply (subgoal_tac "k \<notin> hypnat_of_nat ` {p. prime p}")
apply (force simp add: starprime_def)
  apply (metis Compl_iff add.commute dvd_add_left_iff empty_iff hdvd_one_eq_one hypnat_one_not_prime
           imageE insert_iff mem_Collect_eq not_prime_0)
done

end