(*  Title:      HOL/Nonstandard_Analysis/StarDef.thy
    Author:     Jacques D. Fleuriot and Brian Huffman
*)

section \<open>Construction of Star Types Using Ultrafilters\<close>

theory StarDef
  imports Free_Ultrafilter
begin

subsection \<open>A Free Ultrafilter over the Naturals\<close>

definition FreeUltrafilterNat :: "nat filter"  ("\<U>")
  where "\<U> = (SOME U. freeultrafilter U)"

lemma freeultrafilter_FreeUltrafilterNat: "freeultrafilter \<U>"
  apply (unfold FreeUltrafilterNat_def)
  apply (rule someI_ex)
  apply (rule freeultrafilter_Ex)
  apply (rule infinite_UNIV_nat)
  done

interpretation FreeUltrafilterNat: freeultrafilter \<U>
  by (rule freeultrafilter_FreeUltrafilterNat)

subsection \<open>Definition of \<open>star\<close> type constructor\<close>

definition starrel :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set"
  where "starrel = {(X, Y). eventually (\<lambda>n. X n = Y n) \<U>}"

definition "star = (UNIV :: (nat \<Rightarrow> 'a) set) // starrel"

typedef 'a star = "star :: (nat \<Rightarrow> 'a) set set"
  by (auto simp: star_def intro: quotientI)

definition star_n :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a star"
  where "star_n X = Abs_star (starrel `` {X})"

theorem star_cases [case_names star_n, cases type: star]:
  obtains X where "x = star_n X"
  by (cases x) (auto simp: star_n_def star_def elim: quotientE)

lemma all_star_eq: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>X. P (star_n X))"
  apply auto
  apply (rule_tac x = x in star_cases)
  apply simp
  done

lemma ex_star_eq: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>X. P (star_n X))"
  apply auto
  apply (rule_tac x=x in star_cases)
  apply auto
  done

text \<open>Proving that @{term starrel} is an equivalence relation.\<close>

lemma starrel_iff [iff]: "(X, Y) \<in> starrel \<longleftrightarrow> eventually (\<lambda>n. X n = Y n) \<U>"
  by (simp add: starrel_def)

lemma equiv_starrel: "equiv UNIV starrel"
proof (rule equivI)
  show "refl starrel" by (simp add: refl_on_def)
  show "sym starrel" by (simp add: sym_def eq_commute)
  show "trans starrel" by (intro transI) (auto elim: eventually_elim2)
qed

lemmas equiv_starrel_iff = eq_equiv_class_iff [OF equiv_starrel UNIV_I UNIV_I]

lemma starrel_in_star: "starrel``{x} \<in> star"
  by (simp add: star_def quotientI)

lemma star_n_eq_iff: "star_n X = star_n Y \<longleftrightarrow> eventually (\<lambda>n. X n = Y n) \<U>"
  by (simp add: star_n_def Abs_star_inject starrel_in_star equiv_starrel_iff)

subsection \<open>Transfer principle\<close>

text \<open>This introduction rule starts each transfer proof.\<close>
lemma transfer_start: "P \<equiv> eventually (\<lambda>n. Q) \<U> \<Longrightarrow> Trueprop P \<equiv> Trueprop Q"
  by (simp add: FreeUltrafilterNat.proper)

text \<open>Standard principles that play a central role in the transfer tactic.\<close>
definition Ifun :: "('a \<Rightarrow> 'b) star \<Rightarrow> 'a star \<Rightarrow> 'b star" ("_ \<star> _" [300,301] 300)
  where "Ifun f \<equiv>
    \<lambda>x. Abs_star (\<Union>F\<in>Rep_star f. \<Union>X\<in>Rep_star x. starrel``{\<lambda>n. F n (X n)})"

lemma Ifun_congruent2: "congruent2 starrel starrel (\<lambda>F X. starrel``{\<lambda>n. F n (X n)})"
  by (auto simp add: congruent2_def equiv_starrel_iff elim!: eventually_rev_mp)

lemma Ifun_star_n: "star_n F \<star> star_n X = star_n (\<lambda>n. F n (X n))"
  by (simp add: Ifun_def star_n_def Abs_star_inverse starrel_in_star
      UN_equiv_class2 [OF equiv_starrel equiv_starrel Ifun_congruent2])

lemma transfer_Ifun: "f \<equiv> star_n F \<Longrightarrow> x \<equiv> star_n X \<Longrightarrow> f \<star> x \<equiv> star_n (\<lambda>n. F n (X n))"
  by (simp only: Ifun_star_n)

definition star_of :: "'a \<Rightarrow> 'a star"
  where "star_of x \<equiv> star_n (\<lambda>n. x)"

text \<open>Initialize transfer tactic.\<close>
ML_file "transfer.ML"

method_setup transfer =
  \<open>Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (Transfer_Principle.transfer_tac ctxt ths))\<close>
  "transfer principle"

text \<open>Transfer introduction rules.\<close>

lemma transfer_ex [transfer_intro]:
  "(\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<exists>x::'a star. p x \<equiv> eventually (\<lambda>n. \<exists>x. P n x) \<U>"
  by (simp only: ex_star_eq eventually_ex)

lemma transfer_all [transfer_intro]:
  "(\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<forall>x::'a star. p x \<equiv> eventually (\<lambda>n. \<forall>x. P n x) \<U>"
  by (simp only: all_star_eq FreeUltrafilterNat.eventually_all_iff)

lemma transfer_not [transfer_intro]: "p \<equiv> eventually P \<U> \<Longrightarrow> \<not> p \<equiv> eventually (\<lambda>n. \<not> P n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_not_iff)

lemma transfer_conj [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p \<and> q \<equiv> eventually (\<lambda>n. P n \<and> Q n) \<U>"
  by (simp only: eventually_conj_iff)

lemma transfer_disj [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p \<or> q \<equiv> eventually (\<lambda>n. P n \<or> Q n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_disj_iff)

lemma transfer_imp [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p \<longrightarrow> q \<equiv> eventually (\<lambda>n. P n \<longrightarrow> Q n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_imp_iff)

lemma transfer_iff [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p = q \<equiv> eventually (\<lambda>n. P n = Q n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_iff_iff)

lemma transfer_if_bool [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> x \<equiv> eventually X \<U> \<Longrightarrow> y \<equiv> eventually Y \<U> \<Longrightarrow>
    (if p then x else y) \<equiv> eventually (\<lambda>n. if P n then X n else Y n) \<U>"
  by (simp only: if_bool_eq_conj transfer_conj transfer_imp transfer_not)

lemma transfer_eq [transfer_intro]:
  "x \<equiv> star_n X \<Longrightarrow> y \<equiv> star_n Y \<Longrightarrow> x = y \<equiv> eventually (\<lambda>n. X n = Y n) \<U>"
  by (simp only: star_n_eq_iff)

lemma transfer_if [transfer_intro]:
  "p \<equiv> eventually (\<lambda>n. P n) \<U> \<Longrightarrow> x \<equiv> star_n X \<Longrightarrow> y \<equiv> star_n Y \<Longrightarrow>
    (if p then x else y) \<equiv> star_n (\<lambda>n. if P n then X n else Y n)"
  by (rule eq_reflection) (auto simp: star_n_eq_iff transfer_not elim!: eventually_mono)

lemma transfer_fun_eq [transfer_intro]:
  "(\<And>X. f (star_n X) = g (star_n X) \<equiv> eventually (\<lambda>n. F n (X n) = G n (X n)) \<U>) \<Longrightarrow>
    f = g \<equiv> eventually (\<lambda>n. F n = G n) \<U>"
  by (simp only: fun_eq_iff transfer_all)

lemma transfer_star_n [transfer_intro]: "star_n X \<equiv> star_n (\<lambda>n. X n)"
  by (rule reflexive)

lemma transfer_bool [transfer_intro]: "p \<equiv> eventually (\<lambda>n. p) \<U>"
  by (simp add: FreeUltrafilterNat.proper)

subsection \<open>Standard elements\<close>

definition Standard :: "'a star set"
  where "Standard = range star_of"

text \<open>Transfer tactic should remove occurrences of @{term star_of}.\<close>
setup \<open>Transfer_Principle.add_const @{const_name star_of}\<close>

lemma star_of_inject: "star_of x = star_of y \<longleftrightarrow> x = y"
  by transfer (rule refl)

lemma Standard_star_of [simp]: "star_of x \<in> Standard"
  by (simp add: Standard_def)

subsection \<open>Internal functions\<close>

text \<open>Transfer tactic should remove occurrences of @{term Ifun}.\<close>
setup \<open>Transfer_Principle.add_const @{const_name Ifun}\<close>

lemma Ifun_star_of [simp]: "star_of f \<star> star_of x = star_of (f x)"
  by transfer (rule refl)

lemma Standard_Ifun [simp]: "f \<in> Standard \<Longrightarrow> x \<in> Standard \<Longrightarrow> f \<star> x \<in> Standard"
  by (auto simp add: Standard_def)

text \<open>Nonstandard extensions of functions.\<close>

definition starfun :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a star \<Rightarrow> 'b star"  ("*f* _" [80] 80)
  where "starfun f \<equiv> \<lambda>x. star_of f \<star> x"

definition starfun2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a star \<Rightarrow> 'b star \<Rightarrow> 'c star"  ("*f2* _" [80] 80)
  where "starfun2 f \<equiv> \<lambda>x y. star_of f \<star> x \<star> y"

declare starfun_def [transfer_unfold]
declare starfun2_def [transfer_unfold]

lemma starfun_star_n: "( *f* f) (star_n X) = star_n (\<lambda>n. f (X n))"
  by (simp only: starfun_def star_of_def Ifun_star_n)

lemma starfun2_star_n: "( *f2* f) (star_n X) (star_n Y) = star_n (\<lambda>n. f (X n) (Y n))"
  by (simp only: starfun2_def star_of_def Ifun_star_n)

lemma starfun_star_of [simp]: "( *f* f) (star_of x) = star_of (f x)"
  by transfer (rule refl)

lemma starfun2_star_of [simp]: "( *f2* f) (star_of x) = *f* f x"
  by transfer (rule refl)

lemma Standard_starfun [simp]: "x \<in> Standard \<Longrightarrow> starfun f x \<in> Standard"
  by (simp add: starfun_def)

lemma Standard_starfun2 [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> starfun2 f x y \<in> Standard"
  by (simp add: starfun2_def)

lemma Standard_starfun_iff:
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "starfun f x \<in> Standard \<longleftrightarrow> x \<in> Standard"
proof
  assume "x \<in> Standard"
  then show "starfun f x \<in> Standard" by simp
next
  from inj have inj': "\<And>x y. starfun f x = starfun f y \<Longrightarrow> x = y"
    by transfer
  assume "starfun f x \<in> Standard"
  then obtain b where b: "starfun f x = star_of b"
    unfolding Standard_def ..
  then have "\<exists>x. starfun f x = star_of b" ..
  then have "\<exists>a. f a = b" by transfer
  then obtain a where "f a = b" ..
  then have "starfun f (star_of a) = star_of b" by transfer
  with b have "starfun f x = starfun f (star_of a)" by simp
  then have "x = star_of a" by (rule inj')
  then show "x \<in> Standard" by (simp add: Standard_def)
qed

lemma Standard_starfun2_iff:
  assumes inj: "\<And>a b a' b'. f a b = f a' b' \<Longrightarrow> a = a' \<and> b = b'"
  shows "starfun2 f x y \<in> Standard \<longleftrightarrow> x \<in> Standard \<and> y \<in> Standard"
proof
  assume "x \<in> Standard \<and> y \<in> Standard"
  then show "starfun2 f x y \<in> Standard" by simp
next
  have inj': "\<And>x y z w. starfun2 f x y = starfun2 f z w \<Longrightarrow> x = z \<and> y = w"
    using inj by transfer
  assume "starfun2 f x y \<in> Standard"
  then obtain c where c: "starfun2 f x y = star_of c"
    unfolding Standard_def ..
  then have "\<exists>x y. starfun2 f x y = star_of c" by auto
  then have "\<exists>a b. f a b = c" by transfer
  then obtain a b where "f a b = c" by auto
  then have "starfun2 f (star_of a) (star_of b) = star_of c" by transfer
  with c have "starfun2 f x y = starfun2 f (star_of a) (star_of b)" by simp
  then have "x = star_of a \<and> y = star_of b" by (rule inj')
  then show "x \<in> Standard \<and> y \<in> Standard" by (simp add: Standard_def)
qed

subsection \<open>Internal predicates\<close>

definition unstar :: "bool star \<Rightarrow> bool"
  where "unstar b \<longleftrightarrow> b = star_of True"

lemma unstar_star_n: "unstar (star_n P) \<longleftrightarrow> eventually P \<U>"
  by (simp add: unstar_def star_of_def star_n_eq_iff)

lemma unstar_star_of [simp]: "unstar (star_of p) = p"
  by (simp add: unstar_def star_of_inject)

text \<open>Transfer tactic should remove occurrences of @{term unstar}.\<close>
setup \<open>Transfer_Principle.add_const @{const_name unstar}\<close>

lemma transfer_unstar [transfer_intro]: "p \<equiv> star_n P \<Longrightarrow> unstar p \<equiv> eventually P \<U>"
  by (simp only: unstar_star_n)

definition starP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a star \<Rightarrow> bool"  ("*p* _" [80] 80)
  where "*p* P = (\<lambda>x. unstar (star_of P \<star> x))"

definition starP2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a star \<Rightarrow> 'b star \<Rightarrow> bool"  ("*p2* _" [80] 80)
  where "*p2* P = (\<lambda>x y. unstar (star_of P \<star> x \<star> y))"

declare starP_def [transfer_unfold]
declare starP2_def [transfer_unfold]

lemma starP_star_n: "( *p* P) (star_n X) = eventually (\<lambda>n. P (X n)) \<U>"
  by (simp only: starP_def star_of_def Ifun_star_n unstar_star_n)

lemma starP2_star_n: "( *p2* P) (star_n X) (star_n Y) = (eventually (\<lambda>n. P (X n) (Y n)) \<U>)"
  by (simp only: starP2_def star_of_def Ifun_star_n unstar_star_n)

lemma starP_star_of [simp]: "( *p* P) (star_of x) = P x"
  by transfer (rule refl)

lemma starP2_star_of [simp]: "( *p2* P) (star_of x) = *p* P x"
  by transfer (rule refl)

subsection \<open>Internal sets\<close>

definition Iset :: "'a set star \<Rightarrow> 'a star set"
  where "Iset A = {x. ( *p2* op \<in>) x A}"

lemma Iset_star_n: "(star_n X \<in> Iset (star_n A)) = (eventually (\<lambda>n. X n \<in> A n) \<U>)"
  by (simp add: Iset_def starP2_star_n)

text \<open>Transfer tactic should remove occurrences of @{term Iset}.\<close>
setup \<open>Transfer_Principle.add_const @{const_name Iset}\<close>

lemma transfer_mem [transfer_intro]:
  "x \<equiv> star_n X \<Longrightarrow> a \<equiv> Iset (star_n A) \<Longrightarrow> x \<in> a \<equiv> eventually (\<lambda>n. X n \<in> A n) \<U>"
  by (simp only: Iset_star_n)

lemma transfer_Collect [transfer_intro]:
  "(\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    Collect p \<equiv> Iset (star_n (\<lambda>n. Collect (P n)))"
  by (simp add: atomize_eq set_eq_iff all_star_eq Iset_star_n)

lemma transfer_set_eq [transfer_intro]:
  "a \<equiv> Iset (star_n A) \<Longrightarrow> b \<equiv> Iset (star_n B) \<Longrightarrow> a = b \<equiv> eventually (\<lambda>n. A n = B n) \<U>"
  by (simp only: set_eq_iff transfer_all transfer_iff transfer_mem)

lemma transfer_ball [transfer_intro]:
  "a \<equiv> Iset (star_n A) \<Longrightarrow> (\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<forall>x\<in>a. p x \<equiv> eventually (\<lambda>n. \<forall>x\<in>A n. P n x) \<U>"
  by (simp only: Ball_def transfer_all transfer_imp transfer_mem)

lemma transfer_bex [transfer_intro]:
  "a \<equiv> Iset (star_n A) \<Longrightarrow> (\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<exists>x\<in>a. p x \<equiv> eventually (\<lambda>n. \<exists>x\<in>A n. P n x) \<U>"
  by (simp only: Bex_def transfer_ex transfer_conj transfer_mem)

lemma transfer_Iset [transfer_intro]: "a \<equiv> star_n A \<Longrightarrow> Iset a \<equiv> Iset (star_n (\<lambda>n. A n))"
  by simp

text \<open>Nonstandard extensions of sets.\<close>

definition starset :: "'a set \<Rightarrow> 'a star set" ("*s* _" [80] 80)
  where "starset A = Iset (star_of A)"

declare starset_def [transfer_unfold]

lemma starset_mem: "star_of x \<in> *s* A \<longleftrightarrow> x \<in> A"
  by transfer (rule refl)

lemma starset_UNIV: "*s* (UNIV::'a set) = (UNIV::'a star set)"
  by (transfer UNIV_def) (rule refl)

lemma starset_empty: "*s* {} = {}"
  by (transfer empty_def) (rule refl)

lemma starset_insert: "*s* (insert x A) = insert (star_of x) ( *s* A)"
  by (transfer insert_def Un_def) (rule refl)

lemma starset_Un: "*s* (A \<union> B) = *s* A \<union> *s* B"
  by (transfer Un_def) (rule refl)

lemma starset_Int: "*s* (A \<inter> B) = *s* A \<inter> *s* B"
  by (transfer Int_def) (rule refl)

lemma starset_Compl: "*s* -A = -( *s* A)"
  by (transfer Compl_eq) (rule refl)

lemma starset_diff: "*s* (A - B) = *s* A - *s* B"
  by (transfer set_diff_eq) (rule refl)

lemma starset_image: "*s* (f ` A) = ( *f* f) ` ( *s* A)"
  by (transfer image_def) (rule refl)

lemma starset_vimage: "*s* (f -` A) = ( *f* f) -` ( *s* A)"
  by (transfer vimage_def) (rule refl)

lemma starset_subset: "( *s* A \<subseteq> *s* B) \<longleftrightarrow> A \<subseteq> B"
  by (transfer subset_eq) (rule refl)

lemma starset_eq: "( *s* A = *s* B) \<longleftrightarrow> A = B"
  by transfer (rule refl)

lemmas starset_simps [simp] =
  starset_mem     starset_UNIV
  starset_empty   starset_insert
  starset_Un      starset_Int
  starset_Compl   starset_diff
  starset_image   starset_vimage
  starset_subset  starset_eq

subsection \<open>Syntactic classes\<close>

instantiation star :: (zero) zero
begin
  definition star_zero_def: "0 \<equiv> star_of 0"
  instance ..
end

instantiation star :: (one) one
begin
  definition star_one_def: "1 \<equiv> star_of 1"
  instance ..
end

instantiation star :: (plus) plus
begin
  definition star_add_def: "(op +) \<equiv> *f2* (op +)"
  instance ..
end

instantiation star :: (times) times
begin
  definition star_mult_def: "(op *) \<equiv> *f2* (op *)"
  instance ..
end

instantiation star :: (uminus) uminus
begin
  definition star_minus_def: "uminus \<equiv> *f* uminus"
  instance ..
end

instantiation star :: (minus) minus
begin
  definition star_diff_def: "(op -) \<equiv> *f2* (op -)"
  instance ..
end

instantiation star :: (abs) abs
begin
  definition star_abs_def: "abs \<equiv> *f* abs"
  instance ..
end

instantiation star :: (sgn) sgn
begin
  definition star_sgn_def: "sgn \<equiv> *f* sgn"
  instance ..
end

instantiation star :: (divide) divide
begin
  definition star_divide_def:  "divide \<equiv> *f2* divide"
  instance ..
end

instantiation star :: (inverse) inverse
begin
  definition star_inverse_def: "inverse \<equiv> *f* inverse"
  instance ..
end

instance star :: (Rings.dvd) Rings.dvd ..

instantiation star :: (modulo) modulo
begin
  definition star_mod_def: "(op mod) \<equiv> *f2* (op mod)"
  instance ..
end

instantiation star :: (ord) ord
begin
  definition star_le_def: "(op \<le>) \<equiv> *p2* (op \<le>)"
  definition star_less_def: "(op <) \<equiv> *p2* (op <)"
  instance ..
end

lemmas star_class_defs [transfer_unfold] =
  star_zero_def     star_one_def
  star_add_def      star_diff_def     star_minus_def
  star_mult_def     star_divide_def   star_inverse_def
  star_le_def       star_less_def     star_abs_def       star_sgn_def
  star_mod_def

text \<open>Class operations preserve standard elements.\<close>

lemma Standard_zero: "0 \<in> Standard"
  by (simp add: star_zero_def)

lemma Standard_one: "1 \<in> Standard"
  by (simp add: star_one_def)

lemma Standard_add: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x + y \<in> Standard"
  by (simp add: star_add_def)

lemma Standard_diff: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x - y \<in> Standard"
  by (simp add: star_diff_def)

lemma Standard_minus: "x \<in> Standard \<Longrightarrow> - x \<in> Standard"
  by (simp add: star_minus_def)

lemma Standard_mult: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x * y \<in> Standard"
  by (simp add: star_mult_def)

lemma Standard_divide: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x / y \<in> Standard"
  by (simp add: star_divide_def)

lemma Standard_inverse: "x \<in> Standard \<Longrightarrow> inverse x \<in> Standard"
  by (simp add: star_inverse_def)

lemma Standard_abs: "x \<in> Standard \<Longrightarrow> \<bar>x\<bar> \<in> Standard"
  by (simp add: star_abs_def)

lemma Standard_mod: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x mod y \<in> Standard"
  by (simp add: star_mod_def)

lemmas Standard_simps [simp] =
  Standard_zero  Standard_one
  Standard_add   Standard_diff    Standard_minus
  Standard_mult  Standard_divide  Standard_inverse
  Standard_abs   Standard_mod

text \<open>@{term star_of} preserves class operations.\<close>

lemma star_of_add: "star_of (x + y) = star_of x + star_of y"
  by transfer (rule refl)

lemma star_of_diff: "star_of (x - y) = star_of x - star_of y"
  by transfer (rule refl)

lemma star_of_minus: "star_of (-x) = - star_of x"
  by transfer (rule refl)

lemma star_of_mult: "star_of (x * y) = star_of x * star_of y"
  by transfer (rule refl)

lemma star_of_divide: "star_of (x / y) = star_of x / star_of y"
  by transfer (rule refl)

lemma star_of_inverse: "star_of (inverse x) = inverse (star_of x)"
  by transfer (rule refl)

lemma star_of_mod: "star_of (x mod y) = star_of x mod star_of y"
  by transfer (rule refl)

lemma star_of_abs: "star_of \<bar>x\<bar> = \<bar>star_of x\<bar>"
  by transfer (rule refl)

text \<open>@{term star_of} preserves numerals.\<close>

lemma star_of_zero: "star_of 0 = 0"
  by transfer (rule refl)

lemma star_of_one: "star_of 1 = 1"
  by transfer (rule refl)

text \<open>@{term star_of} preserves orderings.\<close>

lemma star_of_less: "(star_of x < star_of y) = (x < y)"
by transfer (rule refl)

lemma star_of_le: "(star_of x \<le> star_of y) = (x \<le> y)"
by transfer (rule refl)

lemma star_of_eq: "(star_of x = star_of y) = (x = y)"
by transfer (rule refl)

text \<open>As above, for \<open>0\<close>.\<close>

lemmas star_of_0_less = star_of_less [of 0, simplified star_of_zero]
lemmas star_of_0_le   = star_of_le   [of 0, simplified star_of_zero]
lemmas star_of_0_eq   = star_of_eq   [of 0, simplified star_of_zero]

lemmas star_of_less_0 = star_of_less [of _ 0, simplified star_of_zero]
lemmas star_of_le_0   = star_of_le   [of _ 0, simplified star_of_zero]
lemmas star_of_eq_0   = star_of_eq   [of _ 0, simplified star_of_zero]

text \<open>As above, for \<open>1\<close>.\<close>

lemmas star_of_1_less = star_of_less [of 1, simplified star_of_one]
lemmas star_of_1_le   = star_of_le   [of 1, simplified star_of_one]
lemmas star_of_1_eq   = star_of_eq   [of 1, simplified star_of_one]

lemmas star_of_less_1 = star_of_less [of _ 1, simplified star_of_one]
lemmas star_of_le_1   = star_of_le   [of _ 1, simplified star_of_one]
lemmas star_of_eq_1   = star_of_eq   [of _ 1, simplified star_of_one]

lemmas star_of_simps [simp] =
  star_of_add     star_of_diff    star_of_minus
  star_of_mult    star_of_divide  star_of_inverse
  star_of_mod     star_of_abs
  star_of_zero    star_of_one
  star_of_less    star_of_le      star_of_eq
  star_of_0_less  star_of_0_le    star_of_0_eq
  star_of_less_0  star_of_le_0    star_of_eq_0
  star_of_1_less  star_of_1_le    star_of_1_eq
  star_of_less_1  star_of_le_1    star_of_eq_1

subsection \<open>Ordering and lattice classes\<close>

instance star :: (order) order
  apply intro_classes
     apply (transfer, rule less_le_not_le)
    apply (transfer, rule order_refl)
   apply (transfer, erule (1) order_trans)
  apply (transfer, erule (1) order_antisym)
  done

instantiation star :: (semilattice_inf) semilattice_inf
begin
  definition star_inf_def [transfer_unfold]: "inf \<equiv> *f2* inf"
  instance by (standard; transfer) auto
end

instantiation star :: (semilattice_sup) semilattice_sup
begin
  definition star_sup_def [transfer_unfold]: "sup \<equiv> *f2* sup"
  instance by (standard; transfer) auto
end

instance star :: (lattice) lattice ..

instance star :: (distrib_lattice) distrib_lattice
  by (standard; transfer) (auto simp add: sup_inf_distrib1)

lemma Standard_inf [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> inf x y \<in> Standard"
  by (simp add: star_inf_def)

lemma Standard_sup [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> sup x y \<in> Standard"
  by (simp add: star_sup_def)

lemma star_of_inf [simp]: "star_of (inf x y) = inf (star_of x) (star_of y)"
  by transfer (rule refl)

lemma star_of_sup [simp]: "star_of (sup x y) = sup (star_of x) (star_of y)"
  by transfer (rule refl)

instance star :: (linorder) linorder
  by (intro_classes, transfer, rule linorder_linear)

lemma star_max_def [transfer_unfold]: "max = *f2* max"
  apply (rule ext, rule ext)
  apply (unfold max_def, transfer, fold max_def)
  apply (rule refl)
  done

lemma star_min_def [transfer_unfold]: "min = *f2* min"
  apply (rule ext, rule ext)
  apply (unfold min_def, transfer, fold min_def)
  apply (rule refl)
  done

lemma Standard_max [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> max x y \<in> Standard"
  by (simp add: star_max_def)

lemma Standard_min [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> min x y \<in> Standard"
  by (simp add: star_min_def)

lemma star_of_max [simp]: "star_of (max x y) = max (star_of x) (star_of y)"
  by transfer (rule refl)

lemma star_of_min [simp]: "star_of (min x y) = min (star_of x) (star_of y)"
  by transfer (rule refl)

subsection \<open>Ordered group classes\<close>

instance star :: (semigroup_add) semigroup_add
  by (intro_classes, transfer, rule add.assoc)

instance star :: (ab_semigroup_add) ab_semigroup_add
  by (intro_classes, transfer, rule add.commute)

instance star :: (semigroup_mult) semigroup_mult
  by (intro_classes, transfer, rule mult.assoc)

instance star :: (ab_semigroup_mult) ab_semigroup_mult
  by (intro_classes, transfer, rule mult.commute)

instance star :: (comm_monoid_add) comm_monoid_add
  by (intro_classes, transfer, rule comm_monoid_add_class.add_0)

instance star :: (monoid_mult) monoid_mult
  apply intro_classes
   apply (transfer, rule mult_1_left)
  apply (transfer, rule mult_1_right)
  done

instance star :: (power) power ..

instance star :: (comm_monoid_mult) comm_monoid_mult
  by (intro_classes, transfer, rule mult_1)

instance star :: (cancel_semigroup_add) cancel_semigroup_add
  apply intro_classes
   apply (transfer, erule add_left_imp_eq)
  apply (transfer, erule add_right_imp_eq)
  done

instance star :: (cancel_ab_semigroup_add) cancel_ab_semigroup_add
  by intro_classes (transfer, simp add: diff_diff_eq)+

instance star :: (cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance star :: (ab_group_add) ab_group_add
  apply intro_classes
   apply (transfer, rule left_minus)
  apply (transfer, rule diff_conv_add_uminus)
  done

instance star :: (ordered_ab_semigroup_add) ordered_ab_semigroup_add
  by (intro_classes, transfer, rule add_left_mono)

instance star :: (ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..

instance star :: (ordered_ab_semigroup_add_imp_le) ordered_ab_semigroup_add_imp_le
  by (intro_classes, transfer, rule add_le_imp_le_left)

instance star :: (ordered_comm_monoid_add) ordered_comm_monoid_add ..
instance star :: (ordered_ab_semigroup_monoid_add_imp_le) ordered_ab_semigroup_monoid_add_imp_le ..
instance star :: (ordered_cancel_comm_monoid_add) ordered_cancel_comm_monoid_add ..
instance star :: (ordered_ab_group_add) ordered_ab_group_add ..

instance star :: (ordered_ab_group_add_abs) ordered_ab_group_add_abs
  by intro_classes (transfer, simp add: abs_ge_self abs_leI abs_triangle_ineq)+

instance star :: (linordered_cancel_ab_semigroup_add) linordered_cancel_ab_semigroup_add ..

subsection \<open>Ring and field classes\<close>

instance star :: (semiring) semiring
  by (intro_classes; transfer) (fact distrib_right distrib_left)+

instance star :: (semiring_0) semiring_0
  by (intro_classes; transfer) simp_all

instance star :: (semiring_0_cancel) semiring_0_cancel ..

instance star :: (comm_semiring) comm_semiring
  by (intro_classes; transfer) (fact distrib_right)

instance star :: (comm_semiring_0) comm_semiring_0 ..
instance star :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..

instance star :: (zero_neq_one) zero_neq_one
  by (intro_classes; transfer) (fact zero_neq_one)

instance star :: (semiring_1) semiring_1 ..
instance star :: (comm_semiring_1) comm_semiring_1 ..

declare dvd_def [transfer_refold]

instance star :: (comm_semiring_1_cancel) comm_semiring_1_cancel
  by (intro_classes; transfer) (fact right_diff_distrib')

instance star :: (semiring_no_zero_divisors) semiring_no_zero_divisors
  by (intro_classes; transfer) (fact no_zero_divisors)

instance star :: (semiring_1_no_zero_divisors) semiring_1_no_zero_divisors ..

instance star :: (semiring_no_zero_divisors_cancel) semiring_no_zero_divisors_cancel
  by (intro_classes; transfer) simp_all

instance star :: (semiring_1_cancel) semiring_1_cancel ..
instance star :: (ring) ring ..
instance star :: (comm_ring) comm_ring ..
instance star :: (ring_1) ring_1 ..
instance star :: (comm_ring_1) comm_ring_1 ..
instance star :: (semidom) semidom ..

instance star :: (semidom_divide) semidom_divide
  by (intro_classes; transfer) simp_all

instance star :: (semiring_div) semiring_div
  by (intro_classes; transfer) (simp_all add: div_mult_mod_eq)

instance star :: (ring_no_zero_divisors) ring_no_zero_divisors ..
instance star :: (ring_1_no_zero_divisors) ring_1_no_zero_divisors ..
instance star :: (idom) idom ..
instance star :: (idom_divide) idom_divide ..

instance star :: (division_ring) division_ring
  by (intro_classes; transfer) (simp_all add: divide_inverse)

instance star :: (field) field
  by (intro_classes; transfer) (simp_all add: divide_inverse)

instance star :: (ordered_semiring) ordered_semiring
  by (intro_classes; transfer) (fact mult_left_mono mult_right_mono)+

instance star :: (ordered_cancel_semiring) ordered_cancel_semiring ..

instance star :: (linordered_semiring_strict) linordered_semiring_strict
  by (intro_classes; transfer) (fact mult_strict_left_mono mult_strict_right_mono)+

instance star :: (ordered_comm_semiring) ordered_comm_semiring
  by (intro_classes; transfer) (fact mult_left_mono)

instance star :: (ordered_cancel_comm_semiring) ordered_cancel_comm_semiring ..

instance star :: (linordered_comm_semiring_strict) linordered_comm_semiring_strict
  by (intro_classes; transfer) (fact mult_strict_left_mono)

instance star :: (ordered_ring) ordered_ring ..

instance star :: (ordered_ring_abs) ordered_ring_abs
  by (intro_classes; transfer) (fact abs_eq_mult)

instance star :: (abs_if) abs_if
  by (intro_classes; transfer) (fact abs_if)

instance star :: (linordered_ring_strict) linordered_ring_strict ..
instance star :: (ordered_comm_ring) ordered_comm_ring ..

instance star :: (linordered_semidom) linordered_semidom
  by (intro_classes; transfer) (fact zero_less_one le_add_diff_inverse2)+

instance star :: (linordered_idom) linordered_idom
  by (intro_classes; transfer) (fact sgn_if)

instance star :: (linordered_field) linordered_field ..

subsection \<open>Power\<close>

lemma star_power_def [transfer_unfold]: "(op ^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
proof (rule eq_reflection, rule ext, rule ext)
  show "x ^ n = ( *f* (\<lambda>x. x ^ n)) x" for n :: nat and x :: "'a star"
  proof (induct n arbitrary: x)
    case 0
    have "\<And>x::'a star. ( *f* (\<lambda>x. 1)) x = 1"
      by transfer simp
    then show ?case by simp
  next
    case (Suc n)
    have "\<And>x::'a star. x * ( *f* (\<lambda>x::'a. x ^ n)) x = ( *f* (\<lambda>x::'a. x * x ^ n)) x"
      by transfer simp
    with Suc show ?case by simp
  qed
qed

lemma Standard_power [simp]: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
  by (simp add: star_power_def)

lemma star_of_power [simp]: "star_of (x ^ n) = star_of x ^ n"
  by transfer (rule refl)

subsection \<open>Number classes\<close>

instance star :: (numeral) numeral ..

lemma star_numeral_def [transfer_unfold]: "numeral k = star_of (numeral k)"
  by (induct k) (simp_all only: numeral.simps star_of_one star_of_add)

lemma Standard_numeral [simp]: "numeral k \<in> Standard"
  by (simp add: star_numeral_def)

lemma star_of_numeral [simp]: "star_of (numeral k) = numeral k"
  by transfer (rule refl)

lemma star_of_nat_def [transfer_unfold]: "of_nat n = star_of (of_nat n)"
  by (induct n) simp_all

lemmas star_of_compare_numeral [simp] =
  star_of_less [of "numeral k", simplified star_of_numeral]
  star_of_le   [of "numeral k", simplified star_of_numeral]
  star_of_eq   [of "numeral k", simplified star_of_numeral]
  star_of_less [of _ "numeral k", simplified star_of_numeral]
  star_of_le   [of _ "numeral k", simplified star_of_numeral]
  star_of_eq   [of _ "numeral k", simplified star_of_numeral]
  star_of_less [of "- numeral k", simplified star_of_numeral]
  star_of_le   [of "- numeral k", simplified star_of_numeral]
  star_of_eq   [of "- numeral k", simplified star_of_numeral]
  star_of_less [of _ "- numeral k", simplified star_of_numeral]
  star_of_le   [of _ "- numeral k", simplified star_of_numeral]
  star_of_eq   [of _ "- numeral k", simplified star_of_numeral] for k

lemma Standard_of_nat [simp]: "of_nat n \<in> Standard"
  by (simp add: star_of_nat_def)

lemma star_of_of_nat [simp]: "star_of (of_nat n) = of_nat n"
  by transfer (rule refl)

lemma star_of_int_def [transfer_unfold]: "of_int z = star_of (of_int z)"
  by (rule int_diff_cases [of z]) simp

lemma Standard_of_int [simp]: "of_int z \<in> Standard"
  by (simp add: star_of_int_def)

lemma star_of_of_int [simp]: "star_of (of_int z) = of_int z"
  by transfer (rule refl)

instance star :: (semiring_char_0) semiring_char_0
proof
  have "inj (star_of :: 'a \<Rightarrow> 'a star)"
    by (rule injI) simp
  then have "inj (star_of \<circ> of_nat :: nat \<Rightarrow> 'a star)"
    using inj_of_nat by (rule inj_comp)
  then show "inj (of_nat :: nat \<Rightarrow> 'a star)"
    by (simp add: comp_def)
qed

instance star :: (ring_char_0) ring_char_0 ..

instance star :: (semiring_parity) semiring_parity
  apply intro_classes
     apply (transfer, rule odd_one)
    apply (transfer, erule (1) odd_even_add)
   apply (transfer, erule even_multD)
  apply (transfer, erule odd_ex_decrement)
  done

instance star :: (semiring_div_parity) semiring_div_parity
  apply intro_classes
    apply (transfer, rule parity)
   apply (transfer, rule one_mod_two_eq_one)
  apply (transfer, rule zero_not_eq_two)
  done

instantiation star :: (semiring_numeral_div) semiring_numeral_div
begin

definition divmod_star :: "num \<Rightarrow> num \<Rightarrow> 'a star \<times> 'a star"
  where divmod_star_def: "divmod_star m n = (numeral m div numeral n, numeral m mod numeral n)"

definition divmod_step_star :: "num \<Rightarrow> 'a star \<times> 'a star \<Rightarrow> 'a star \<times> 'a star"
  where "divmod_step_star l qr =
    (let (q, r) = qr
     in if r \<ge> numeral l then (2 * q + 1, r - numeral l) else (2 * q, r))"

instance
proof
  show "divmod m n = (numeral m div numeral n :: 'a star, numeral m mod numeral n)" for m n
    by (fact divmod_star_def)
  show "divmod_step l qr =
    (let (q, r) = qr
     in if r \<ge> numeral l then (2 * q + 1, r - numeral l) else (2 * q, r))"
    for l and qr :: "'a star \<times> 'a star"
    by (fact divmod_step_star_def)
qed (transfer,
  fact
  semiring_numeral_div_class.div_less
  semiring_numeral_div_class.mod_less
  semiring_numeral_div_class.div_positive
  semiring_numeral_div_class.mod_less_eq_dividend
  semiring_numeral_div_class.pos_mod_bound
  semiring_numeral_div_class.pos_mod_sign
  semiring_numeral_div_class.mod_mult2_eq
  semiring_numeral_div_class.div_mult2_eq
  semiring_numeral_div_class.discrete)+

end

declare divmod_algorithm_code [where ?'a = "'a::semiring_numeral_div star", code]

subsection \<open>Finite class\<close>

lemma starset_finite: "finite A \<Longrightarrow> *s* A = star_of ` A"
  by (erule finite_induct) simp_all

instance star :: (finite) finite
  apply intro_classes
  apply (subst starset_UNIV [symmetric])
  apply (subst starset_finite [OF finite])
  apply (rule finite_imageI [OF finite])
  done

end


theory Chisholm_SDL imports SDL                     (*Christoph Benzmüller & Xavier Parent, 2019*)
begin     (*Unimportant*) nitpick_params [user_axioms,expect=genuine,show_all,format=2]

(*** Chisholm Example ***)
  consts go::\<sigma> tell::\<sigma> kill::\<sigma>
  abbreviation  "D1 \<equiv> \<^bold>\<circle><go>"  (*It ought to be that Jones goes to assist his neighbors.*)
  abbreviation  "D2w \<equiv> \<^bold>\<circle><go \<^bold>\<rightarrow> tell>"  (*It ought to be that if Jones goes, then he tells them he is coming.*)
  abbreviation  "D2n \<equiv> go \<^bold>\<rightarrow> \<^bold>\<circle><tell>"
  abbreviation  "D3w \<equiv> \<^bold>\<circle><\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell>" (*If Jones doesn't go, then he ought not tell them he is coming.*)
  abbreviation  "D3n \<equiv> \<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<circle><\<^bold>\<not>tell>"
  abbreviation  "D4 \<equiv> \<^bold>\<not>go" (*Jones doesn't go. (This is encoded as a locally valid statement.)*)

(*** Chisholm_A: All-wide scoping is leading to an inadequate, dependent set of the axioms.***)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"  nitpick oops (*countermodel*)
 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by blast (*Should J. tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(*** Chisholm_B: All-narrow scoping is leading to a inadequate, dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops  (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by smt (*Should J. not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  nitpick oops (*Should James tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(*** Chisholm_C: Wide-narrow scoping is leading to an adequate, independence of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4) \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4) \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3n \<^bold>\<and> D4) \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using D assms by smt (*Shld J. not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by blast (*Should J. tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using D assms by blast (*Should J. kill? Yes*)

(*** Chisholm_D: Narrow-wide scoping is leading to a  inadequate, dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  nitpick oops (*Should James tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)
end


theory Identifier_String
  imports
    Main
    Ecore.Model_Namespace
    Namespace_String
begin

section "Identifier to string mapping for string based identifiers"

text "Maps an identifier consisting of strings to a single string, entirely lossless."

definition id_to_string :: "'t \<Rightarrow> 't list Id \<Rightarrow> 't list" where
  "id_to_string d i \<equiv> ns_to_string d (Identifier i)"

definition string_to_id :: "'t \<Rightarrow> 't list \<Rightarrow> 't list Id" where
  "string_to_id d s \<equiv> ns_to_id (string_to_ns d s)"

subsection "Lemma's on definitions"

lemma id_to_string_not_empty: "id_to_string d i \<noteq> []"
  unfolding id_to_string_def ns_to_string_def
  by (induct i) (simp_all add: join_prepend)

lemma id_to_string_identifier: "id_to_string d \<bottom>\<^enum>x = [d] @ x"
  by (simp add: id_to_string_def ns_to_string_def)

lemma id_to_string_append: "id_to_string d (m\<^enum>n) = id_to_string d m @ [d] @ n"
  using id_to_string_def ns_to_string_append
  by metis

lemma string_to_id_identifier: "d \<notin> set x \<Longrightarrow> string_to_id d ([d] @ x) = \<bottom>\<^enum>x"
  using string_to_id_def string_to_ns_identifier ns_to_id.simps(1)
  by metis

lemma string_to_id_append: "d \<notin> set n \<Longrightarrow> string_to_id d (m @ [d] @ n) = ((string_to_ns d m), n)"
  using string_to_id_def string_to_ns_append ns_to_id.simps(1)
  by metis

subsection "Domain & Range"

inductive_set string_identifier_domain :: "'t \<Rightarrow> 't list Id set"
  for d :: "'t"
  where
    rule_identifier: "d \<notin> set name \<Longrightarrow> \<bottom>\<^enum>name \<in> string_identifier_domain d" |
    rule_nested: "identifier \<in> string_identifier_domain d \<Longrightarrow> d \<notin> set name \<Longrightarrow> (identifier\<^enum>name) \<in> string_identifier_domain d"

lemma string_identifier_domain_subset: "Identifier ` string_identifier_domain d \<subseteq> string_namespace_domain d"
proof
  fix x
  assume "x \<in> Identifier ` string_identifier_domain d"
  then show "x \<in> string_namespace_domain d"
  proof
    fix xa
    assume x_is_xa: "x = Identifier xa"
    assume "xa \<in> string_identifier_domain d"
    then have "Identifier xa \<in> string_namespace_domain d"
    proof (induct xa)
      case (rule_identifier name)
      then show ?case
        by (simp add: string_namespace_domain.rule_nested string_namespace_domain.rule_root)
    next
      case (rule_nested identifier name)
      then show ?case
        by (simp add: string_namespace_domain.rule_nested)
    qed
    then show "x \<in> string_namespace_domain d"
      using x_is_xa
      by simp
  qed
qed

lemma string_identifier_domain_subset_alt: "Identifier ` string_identifier_domain d \<subseteq> namespace_domain"
  by (simp add: namespace_domainI subsetI)

inductive_set string_identifier_range :: "'t \<Rightarrow> 't list set"
  for d :: "'t"
  where
    rule_identifier: "d \<notin> set name \<Longrightarrow> [d] @ name \<in> string_identifier_range d" |
    rule_nested: "str \<in> string_identifier_range d \<Longrightarrow> d \<notin> set name \<Longrightarrow> str @ [d] @ name \<in> string_identifier_range d"

lemma string_identifier_range_altdef: "string_identifier_range d = string_namespace_range d - {[]}"
proof
  show "string_identifier_range d \<subseteq> string_namespace_range d - {[]}"
  proof
    fix x
    assume "x \<in> string_identifier_range d"
    then show "x \<in> string_namespace_range d - {[]}"
    proof (induct x)
      case (rule_identifier name)
      then show ?case
        using Diff_iff append_Cons append_self_conv2 empty_iff in_listsD list.set_intros(1) lists_empty string_namespace_range.rule_root string_namespace_range.simps
        by metis
    next
      case (rule_nested str name)
      then show ?case
        using string_namespace_range.rule_nested by auto
    qed
  qed
next
  show "string_namespace_range d - {[]} \<subseteq> string_identifier_range d"
  proof
    fix x
    assume "x \<in> string_namespace_range d - {[]}"
    then have x_not_empty: "x \<noteq> []"
      by blast
    assume "x \<in> string_namespace_range d - {[]}"
    then have "x \<in> string_namespace_range d"
      by blast
    then show "x \<in> string_identifier_range d"
      using x_not_empty
    proof (induct x)
      case rule_root
      then show ?case
        by simp
    next
      case (rule_nested str name)
      then show ?case
        using string_identifier_range.rule_identifier string_identifier_range.rule_nested
        by force
    qed
  qed
qed

lemma string_identifier_range_subset: "string_identifier_range d \<subseteq> string_namespace_range d"
proof
  fix x
  assume "x \<in> string_identifier_range d"
  then show "x \<in> string_namespace_range d"
  proof (induct x)
    case (rule_identifier name)
    then show ?case
      using string_namespace_range.rule_nested string_namespace_range.rule_root
      by fastforce
  next
    case (rule_nested str name)
    then show ?case
      using string_namespace_range.rule_nested
      by simp
  qed
qed

lemma string_identifier_range_subset_alt: "string_identifier_range d \<subseteq> split_bij_domain d"
  using string_identifier_range_altdef string_namespace_range_subset
  by fastforce

subsection "Inverse function"

lemma id_to_string_inverse: "x \<in> string_identifier_domain c \<Longrightarrow> string_to_id c (id_to_string c x) = x"
  unfolding string_to_id_def id_to_string_def
  using ns_to_string_inverse string_identifier_domain_subset by fastforce

lemma string_to_id_inverse: "x \<in> string_identifier_range d \<Longrightarrow> id_to_string d (string_to_id d x) = x"
proof-
  fix x
  assume "x \<in> string_identifier_range d"
  then show "id_to_string d (string_to_id d x) = x"
  proof (induct x)
    case (rule_identifier name)
    then show ?case
      using id_to_string_identifier string_to_id_identifier
      by metis
  next
    case (rule_nested str name)
    then have "id_to_string d (string_to_id d (str @ [d] @ name)) = id_to_string d ((string_to_id d str)\<^enum>name)"
      using string_identifier_range.simps string_to_id_append string_to_id_identifier string_to_ns_append string_to_ns_identifier
      by metis
    then show ?case
      by (simp add: id_to_string_append rule_nested.hyps(2))
  qed
qed

subsection "Range of mapping functions"

lemma id_to_string_range: "id_to_string d ` string_identifier_domain d = string_identifier_range d"
proof
  show "id_to_string d ` string_identifier_domain d \<subseteq> string_identifier_range d"
  proof
    fix x
    assume "x \<in> id_to_string d ` string_identifier_domain d"
    then show "x \<in> string_identifier_range d"
    proof
      fix xa
      assume x_is_string_xa: "x = id_to_string d xa"
      assume "xa \<in> string_identifier_domain d"
      then have "id_to_string d xa \<in> string_identifier_range d"
      proof (induct xa)
        case (rule_identifier name)
        then show ?case
          using id_to_string_identifier string_identifier_range.rule_identifier
          by metis
      next
        case (rule_nested identifier name)
        then show ?case
          using id_to_string_append string_identifier_range.rule_nested
          by metis
      qed
      then show "x \<in> string_identifier_range d"
        using x_is_string_xa
        by blast
    qed
  qed
next
  show "string_identifier_range d \<subseteq> id_to_string d ` string_identifier_domain d"
  proof
    fix x
    assume "x \<in> string_identifier_range d"
    then show "x \<in> id_to_string d ` string_identifier_domain d"
    proof (induct x)
      case (rule_identifier name)
      then show ?case
        using image_iff string_identifier_domain.rule_identifier string_identifier_range.rule_identifier string_to_id_identifier string_to_id_inverse
        by fastforce
    next
      case (rule_nested str name)
      then have id_existance: "\<exists>identifier. identifier \<in> string_identifier_domain d \<and> str = id_to_string d identifier"
        by blast
      have "\<And>identifier. identifier \<in> string_identifier_domain d \<Longrightarrow> (identifier\<^enum>name) \<in> string_identifier_domain d"
        by (simp add: rule_nested.hyps(3) string_identifier_domain.rule_nested)
      then have "\<And>identifier. identifier \<in> string_identifier_domain d \<Longrightarrow> id_to_string d (identifier\<^enum>name) \<in> id_to_string d ` string_identifier_domain d"
        by simp
      then have "\<And>identifier. identifier \<in> string_identifier_domain d \<Longrightarrow> id_to_string d identifier @ [d] @ name \<in> id_to_string d ` string_identifier_domain d"
        by (simp add: id_to_string_append)
      then show ?case
        using id_existance
        by blast
    qed
  qed
qed

lemma string_to_id_range: "string_to_id d ` string_identifier_range d = string_identifier_domain d"
proof
  show "string_to_id d ` string_identifier_range d \<subseteq> string_identifier_domain d"
  proof
    fix x
    assume "x \<in> string_to_id d ` string_identifier_range d"
    then show "x \<in> string_identifier_domain d"
    proof
      fix xa
      assume x_is_xa: "x = string_to_id d xa"
      assume "xa \<in> string_identifier_range d"
      then have "string_to_id d xa \<in> string_identifier_domain d"
      proof (induct xa)
        case (rule_identifier name)
        then show ?case
          using string_identifier_domain.rule_identifier string_to_id_identifier
          by metis
      next
        case (rule_nested str name)
        then show ?case
          using id_to_string_append id_to_string_inverse string_identifier_domain.rule_nested string_to_id_inverse
          by metis
      qed
      then show "x \<in> string_identifier_domain d"
        using x_is_xa
        by simp
    qed
  qed
next
  show "string_identifier_domain d \<subseteq> string_to_id d ` string_identifier_range d"
  proof
    fix x
    assume "x \<in> string_identifier_domain d"
    then show "x \<in> string_to_id d ` string_identifier_range d"
    proof (induct x)
      case (rule_identifier name)
      then show ?case
        using image_iff string_identifier_range.rule_identifier string_to_id_identifier
        by fastforce
    next
      case (rule_nested identifier name)
      then have str_existance: "\<exists>str. str \<in> string_identifier_range d \<and> identifier = string_to_id d str"
        using string_identifier_range_altdef
        by auto
      have "\<And>str. str \<in> string_identifier_range d \<Longrightarrow> str @ [d] @ name \<in> string_identifier_range d"
        using rule_nested.hyps(3) string_identifier_range.rule_nested
        by metis
      then have "\<And>str. str \<in> string_identifier_range d \<Longrightarrow> string_to_id d (str @ [d] @ name) \<in> string_to_id d ` string_identifier_range d"
        by simp
      then have "\<And>str. str \<in> string_identifier_range d \<Longrightarrow> ((string_to_id d str)\<^enum>name) \<in> string_to_id d ` string_identifier_range d"
        using rule_nested.hyps(3) string_identifier_range.simps string_to_id_append string_to_id_identifier string_to_ns_append string_to_ns_identifier
        by metis
      then show ?case
        using str_existance
        by blast
    qed
  qed
qed

subsection "Injectivity"

lemma id_to_string_inj[simp]: "inj_on (id_to_string d) (string_identifier_domain d)"
proof
  fix x y
  assume x_in_domain: "x \<in> string_identifier_domain d"
  assume y_in_domain: "y \<in> string_identifier_domain d"
  assume mapping_eq: "id_to_string d x = id_to_string d y"
  then show "x = y"
    using x_in_domain y_in_domain id_to_string_inverse
    by metis
qed

lemma string_to_id_inj[simp]: "inj_on (string_to_id d) (string_identifier_range d)"
proof
  fix x y
  assume x_in_range: "x \<in> string_identifier_range d"
  assume y_in_range: "y \<in> string_identifier_range d"
  assume mapping_eq: "string_to_id d x = string_to_id d y"
  then show "x = y"
    using x_in_range y_in_range string_to_id_inverse
    by metis
qed

subsection "Bijectivity"

lemma id_to_string_bij[simp]: "bij_betw (id_to_string d) (string_identifier_domain d) (string_identifier_range d)"
  unfolding bij_betw_def
  using id_to_string_inj id_to_string_range
  by simp

lemma string_to_id_bij[simp]: "bij_betw (string_to_id d) (string_identifier_range d) (string_identifier_domain d)"
  unfolding bij_betw_def
  using string_to_id_inj string_to_id_range
  by simp

subsection "Subnamespaces"

definition id_string_in_ns_string :: "char \<Rightarrow> string \<Rightarrow> string \<Rightarrow> bool" where
  "id_string_in_ns_string \<equiv> ns_string_in_ns_string"

lemma id_to_string_in_ns_to_string: "\<And>x y. x \<in> string_identifier_domain d \<Longrightarrow> y \<in> string_namespace_domain d \<Longrightarrow> id_in_ns x y \<longleftrightarrow> id_string_in_ns_string d (id_to_string d x) (ns_to_string d y)"
proof-
  fix x y
  assume x_in_domain: "x \<in> string_identifier_domain d"
  assume y_in_domain: "y \<in> string_namespace_domain d"
  show "id_in_ns x y \<longleftrightarrow> id_string_in_ns_string d (id_to_string d x) (ns_to_string d y)"
    using id_in_ns_def id_string_in_ns_string_def id_to_string_def image_subset_iff ns_to_string_in_ns_to_string string_identifier_domain_subset x_in_domain y_in_domain
    by metis
qed

lemma string_to_id_in_string_to_ns: "\<And>x y. x \<in> string_identifier_range d \<Longrightarrow> y \<in> string_namespace_range d \<Longrightarrow> id_in_ns (string_to_id d x) (string_to_ns d y) \<longleftrightarrow> id_string_in_ns_string d x y"
  using bij_betwE id_to_string_in_ns_to_string string_to_id_bij string_to_id_inverse string_to_ns_bij string_to_ns_inverse
  by metis

end


theory Sunfold
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Stream"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy
primcorec sunfold :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b Stream" where
  "sunfold g f a = SCons (g a) (sunfold g f (f a))"

(*cohipster sunfold shd stl Fun.id*)
(* ca 30 sec *)
lemma lemma_a [thy_expl]: "sunfold id y (y z) = sunfold y y z"
 by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_aa [thy_expl]: "sunfold id id (y z) = sunfold y id z"
 by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_ab [thy_expl]: "SCons z (sunfold y y z) = sunfold id y z"
 by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_a)

lemma lemma_ac [thy_expl]: "SCons (y z) (sunfold y id z) = sunfold y id z"
 by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    simp
(*cohipster sunfold Fun.comp*)
(* ca 25 sec *)
(* Special case of fusion law *)
lemma lemma_ad [thy_expl]: "sunfold (z \<circ> x2) x2 x3 = sunfold z x2 (x2 x3)"
 by (coinduction arbitrary: x2 x3 z rule: Stream.Stream.coinduct_strong)
    auto
end


theory Nonpos_Ints
imports Main Real_Vector_Spaces "~~/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space"
begin

subsection \<open>Non-positive integers\<close>

definition nonpos_Ints ("\<int>\<^sub>\<le>\<^sub>0") where "\<int>\<^sub>\<le>\<^sub>0 = {of_int n |n. n \<le> 0}"

lemma zero_in_nonpos_Ints [simp,intro]: "0 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "0::int"])

lemma neg_one_in_nonpos_Ints [simp,intro]: "-1 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-1::int"])

lemma neg_numeral_in_nonpos_Ints [simp,intro]: "-numeral n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-numeral n::int"])

lemma one_notin_nonpos_Ints [simp]: "(1 :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma numeral_notin_nonpos_Ints [simp]: "(numeral n :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma minus_of_nat_in_nonpos_Ints [simp, intro]: "- of_nat n \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  have "- of_nat n = of_int (-int n)" by simp
  also have "-int n \<le> 0" by simp
  hence "of_int (-int n) \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
  finally show ?thesis .
qed

lemma of_nat_in_nonpos_Ints_iff: "(of_nat n :: 'a :: {ring_1,ring_char_0}) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n = 0"
proof
  assume "(of_nat n :: 'a) \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain m where "of_nat n = (of_int m :: 'a)" "m \<le> 0" by (auto simp: nonpos_Ints_def)
  hence "(of_int m :: 'a) = of_nat n" by simp
  also have "... = of_int (int n)" by simp
  finally have "m = int n" by (subst (asm) of_int_eq_iff)
  with `m \<le> 0` show "n = 0" by auto
qed simp

lemma nonpos_Ints_of_int: "n \<le> 0 \<Longrightarrow> of_int n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by blast

lemma nonpos_IntsI:
  "x \<in> \<int> \<Longrightarrow> x \<le> 0 \<Longrightarrow> (x :: 'a :: linordered_idom) \<in> \<int>\<^sub>\<le>\<^sub>0"
  using assms unfolding nonpos_Ints_def Ints_def by auto

lemma nonpos_Ints_subset_Ints: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_nonpos [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<le> (0 :: 'a :: linordered_idom)"
  unfolding nonpos_Ints_def by auto

lemma nonpos_Ints_Int [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_cases:
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = of_int n" "n \<le> 0"
  using assms unfolding nonpos_Ints_def by (auto elim!: Ints_cases)

lemma nonpos_Ints_cases':
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = -of_nat n"
proof -
  from assms obtain m where "x = of_int m" and m: "m \<le> 0" by (auto elim!: nonpos_Ints_cases)
  hence "x = - of_int (-m)" by auto
  also from m have "(of_int (-m) :: 'a) = of_nat (nat (-m))" by simp_all
  finally show ?thesis by (rule that)
qed

lemma of_real_in_nonpos_Ints_iff: "(of_real x :: 'a :: real_algebra_1) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "of_real x \<in> (\<int>\<^sub>\<le>\<^sub>0 :: 'a set)"
  then obtain n where "(of_real x :: 'a) = of_int n" "n \<le> 0" by (erule nonpos_Ints_cases)
  note `of_real x = of_int n`
  also have "of_int n = of_real (of_int n)" by (rule of_real_of_int_eq [symmetric])
  finally have "x = of_int n" by (subst (asm) of_real_eq_iff)
  with `n \<le> 0` show "x \<in> \<int>\<^sub>\<le>\<^sub>0" by (simp add: nonpos_Ints_of_int)
qed (auto elim!: nonpos_Ints_cases intro!: nonpos_Ints_of_int)

lemma nonpos_Ints_altdef: "\<int>\<^sub>\<le>\<^sub>0 = {n \<in> \<int>. (n :: 'a :: linordered_idom) \<le> 0}"
  by (auto intro!: nonpos_IntsI elim!: nonpos_Ints_cases)

lemma uminus_in_Nats_iff: "-x \<in> \<nat> \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "-x \<in> \<nat>"
  then obtain n where "n \<ge> 0" "-x = of_int n" by (auto simp: Nats_altdef1)
  hence "-n \<le> 0" "x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "x \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
next
  assume "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain n where "n \<le> 0" "x = of_int n" by (auto simp: nonpos_Ints_def)
  hence "-n \<ge> 0" "-x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "-x \<in> \<nat>" unfolding Nats_altdef1 by blast
qed

lemma uminus_in_nonpos_Ints_iff: "-x \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<nat>"
  using uminus_in_Nats_iff[of "-x"] by simp

lemma nonpos_Ints_mult: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<nat>"
  using Nats_mult[of "-x" "-y"] by (simp add: uminus_in_Nats_iff)

lemma Nats_mult_nonpos_Ints: "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of x "-y"] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_mult_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of "-x" y] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_add:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x + y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "-y"] uminus_in_Nats_iff[of "y+x", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma nonpos_Ints_diff_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x - y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "y"] uminus_in_Nats_iff[of "x-y", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma Nats_diff_nonpos_Ints:
  "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x - y \<in> \<nat>"
  using Nats_add[of "x" "-y"] by (simp add: uminus_in_Nats_iff add.commute)

lemma plus_of_nat_eq_0_imp: "z + of_nat n = 0 \<Longrightarrow> z \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  assume "z + of_nat n = 0"
  hence A: "z = - of_nat n" by (simp add: eq_neg_iff_add_eq_0)
  show "z \<in> \<int>\<^sub>\<le>\<^sub>0" by (subst A) simp
qed

lemma closed_nonpos_Ints [simp]: "closed (\<int>\<^sub>\<le>\<^sub>0 :: 'a :: real_normed_algebra_1 set)"
proof -
  have "\<int>\<^sub>\<le>\<^sub>0 = (of_int ` {n. n \<le> 0} :: 'a set)"
    by (auto elim!: nonpos_Ints_cases intro!: nonpos_Ints_of_int)
  also have "closed \<dots>" by (rule closed_of_int_image)
  finally show ?thesis .
qed

end


\<^marker>\<open>creator Florian Keßler\<close>

section "IMP- to IMP-- State Translations"

theory IMP_Minus_To_IMP_Minus_Minus_State_Translations
  imports "IMP_Minus.Small_StepT" Binary_Arithmetic
begin

text \<open> We define a translation between IMP- states, which map registers to natural numbers, and
       IMP-- state where a register can only hold a single bit. Fixing a number of bits n that
       are assumed to be sufficient to represent each natural number in the IMP- states, a register
       ''x'' in IMP- is represented by n registers in IMP--: ''#$x'', ''##$x'', ... ''#...#$x'',
        where the IMP-- register starting with k hashes represents the k- 1th bit of the
       IMP- register. Furthermore, the IMP-- states contain special registers ''carry'' and
        operands ''a'' and ''b'' with n bits respectively, which we will use when replacing
        arithmetic expressions by binary operations when translating IMP- to IMP-- programs. \<close>

type_synonym state = AExp.state
type_synonym bit_state = IMP_Minus_Minus_Small_StepT.state

definition var_to_var_bit:: "vname \<Rightarrow> (vname * nat) option" where
"var_to_var_bit v =
   (if length v > 0 then
      (if hd v = CHR ''#'' then
        (let t = dropWhile (\<lambda>i. i = CHR ''#'') v;
             l = length (takeWhile (\<lambda>i. i = CHR ''#'') v) - 1
         in
           (if length t > 0 \<and> hd t = CHR ''$'' then
              Some (tl t, l)
            else
              None))
       else
         None)
    else None)"

fun n_hashes:: "nat \<Rightarrow> string" where
"n_hashes 0 = []" |
"n_hashes (Suc n) = (CHR ''#'') # (n_hashes n)"

definition var_bit_to_var:: "(vname * nat) \<Rightarrow> vname" where
"var_bit_to_var vk = (n_hashes (snd vk + 1)) @ ''$''  @ (fst vk)"

lemma dropWhile_n_hashes[simp]: "dropWhile (\<lambda>i. i = CHR ''#'') (n_hashes x @ CHR ''$'' # y)
  = CHR ''$'' # y"
  apply(induction x)
  by(auto)

lemma length_takeWhile_n_hashes[simp]:
  "length (takeWhile (\<lambda>i. i = CHR ''#'') (n_hashes x @ CHR ''$'' # y)) = x"
  apply(induction x)
  by auto

lemma encoded_var_decomposition[simp]: "x \<noteq> [] \<Longrightarrow> hd x = CHR ''#''
  \<Longrightarrow> hd (dropWhile (\<lambda>i. i = CHR ''#'') x) = CHR ''$''
  \<Longrightarrow> c \<in> set x \<Longrightarrow> c \<noteq> CHR ''#''
  \<Longrightarrow> n_hashes (length (takeWhile (\<lambda>i. i = CHR ''#'') x))
    @ CHR ''$'' # tl (dropWhile (\<lambda>i. i = CHR ''#'') x) = x"
proof (induction x)
  case (Cons a x)
  hence *: "x \<noteq> []" by auto
  have "hd x = CHR ''#'' \<or> hd x \<noteq> CHR ''#''" by auto
  thus ?case
    apply(elim disjE)
    using Cons * apply(auto)
    by (smt hd_Cons_tl list.size(3) n_hashes.simps(1) self_append_conv2 takeWhile.simps(1)
        takeWhile_dropWhile_id takeWhile_tail)
qed auto

lemma var_to_var_bit_var_bit_to_var[simp]: "var_to_var_bit (var_bit_to_var x) = Some x"
  by (auto simp: var_to_var_bit_def var_bit_to_var_def Let_def)

lemma var_to_var_bit_eq_Some_iff: "var_to_var_bit x = Some y \<longleftrightarrow> x = var_bit_to_var y"
proof
  assume "var_to_var_bit x = Some y"
  thus "x = var_bit_to_var y"
    apply(auto simp: var_to_var_bit_def var_bit_to_var_def Let_def split: if_splits)
    using encoded_var_decomposition
    by (smt Nitpick.size_list_simp(2) One_nat_def char.inject length_tl list.expand list.sel(1)
        list.sel(3) list.simps(3) n_hashes.simps(2) self_append_conv2
        takeWhile_dropWhile_id tl_append2)
qed auto

lemma var_bit_to_var_eq_iff[simp]: "var_bit_to_var (a, b) = var_bit_to_var (c, d) \<longleftrightarrow> (a = c \<and> b = d)"
  apply(auto simp: var_bit_to_var_def)
   apply (metis dropWhile_n_hashes list.inject)
  by (metis length_takeWhile_n_hashes)

lemma var_to_var_bit_of_carry[simp]: "var_to_var_bit ''carry'' = None"
  by(auto simp: var_to_var_bit_def)

lemma var_bit_to_var_neq_carry[simp]: "''carry'' \<noteq> var_bit_to_var (x, y) "
  by(auto simp: var_bit_to_var_def)

lemma var_bit_to_var_neq_carry'[simp]: "var_bit_to_var (x, y) = ''carry'' \<longleftrightarrow> False"
  by(auto simp: var_bit_to_var_def)

(*
fun operand_bit_to_var:: "operand \<Rightarrow> vname" where
"operand_bit_to_var (a n) = replicate (n + 1) (CHR ''a'')" |
"operand_bit_to_var (b n) = replicate (n + 1) (CHR ''b'')"
*)
fun operand_bit_to_var:: "(char * nat) \<Rightarrow> vname" where
"operand_bit_to_var (c, 0) = [c]" |
"operand_bit_to_var (c, (Suc n)) = c # operand_bit_to_var (c, n)"

definition var_to_operand_bit:: "vname \<Rightarrow> (char * nat) option" where
"var_to_operand_bit v = (if v \<noteq> [] \<and> v = (operand_bit_to_var (hd v, length v - 1))
  then Some (hd v, length v - 1) else None)"

lemma hd_of_operand_bit_to_var[simp]:
  "hd (operand_bit_to_var (op, n)) = op" by (induction n) auto

lemma take_2_of_operand_bit_to_var[simp]:
  "take 2 (operand_bit_to_var (c, k)) = operand_bit_to_var (c, min k 1)"
  apply (cases k)
   apply(auto)
  using hd_of_operand_bit_to_var
  by (metis lessI less_Suc_eq_0_disj list.discI operand_bit_to_var.simps(1)
      operand_bit_to_var.simps(2) take0 take_Suc)

lemma length_of_operand_bit_to_var[simp]:
  "length (operand_bit_to_var (op, n)) = n + 1" by (induction n) auto

lemma var_to_operand_bit_of_operand_bit_to_var[simp]:
  "var_to_operand_bit (operand_bit_to_var (op, n)) = Some (op, n)"
  apply(induction n)
  by(auto simp: var_to_operand_bit_def)

lemma var_to_operand_bit_eq_Some_iff: "var_to_operand_bit x = Some (op, i)
  \<longleftrightarrow> x = operand_bit_to_var (op, i)"
  apply(auto simp: var_to_operand_bit_def)
  apply(cases i)
  by auto

lemma var_to_operand_bit_of_carry[simp]: "var_to_operand_bit ''carry'' = None"
  by(simp add: var_to_operand_bit_def)

lemma operand_bit_to_var_neq_carry[simp]: "operand_bit_to_var (op, k) = ''carry'' \<longleftrightarrow> False"
proof
  assume "operand_bit_to_var (op, k) = ''carry''"
  moreover hence "op = CHR ''c''" by (metis hd_of_operand_bit_to_var list.sel)
  ultimately show False
    by (metis option.simps var_to_operand_bit_of_carry var_to_operand_bit_of_operand_bit_to_var)
qed auto

lemma set_of_operand_bit_to_var[simp]: "set (operand_bit_to_var (op, b)) = { op }"
  by (induction b) auto

lemma var_to_operand_bit_var_bit_to_var[simp]: "var_to_operand_bit (var_bit_to_var (a, b)) = None"
  apply(simp add: var_to_operand_bit_def var_bit_to_var_def)
  apply(rule ccontr)
  apply simp
  apply(drule arg_cong[where ?f=set])
  by simp

lemma var_to_var_bit_operand_bit_to_var[simp]: "var_to_var_bit (operand_bit_to_var (c, k)) = None"
  by (simp add: var_to_var_bit_def)

lemma operand_bit_to_var_non_empty: "operand_bit_to_var (op, n) \<noteq> []"
  by (induction n) auto

lemma operand_bit_to_var_eq_operand_bit_to_var_iff[simp]:
  "operand_bit_to_var (op, a) = operand_bit_to_var (op', b)
  \<longleftrightarrow> (op = op' \<and> a = b)"
proof
  assume "operand_bit_to_var (op, a) = operand_bit_to_var (op', b)"
  hence "length (operand_bit_to_var (op, a)) = length (operand_bit_to_var (op', b))
    \<and> set (operand_bit_to_var (op, a)) = set (operand_bit_to_var (op', b))" by simp
  thus "op = op' \<and> a = b" by auto
qed auto

lemma operand_bit_to_var_eq_operand_bit_to_var_iff'[simp]:
  "op # operand_bit_to_var (op, i) = operand_bit_to_var (op', j)
    \<longleftrightarrow> (op = op' \<and> i + 1 = j)"
proof -
  have "op # operand_bit_to_var (op, i) =  operand_bit_to_var (op, i + 1)" by simp
  thus ?thesis using operand_bit_to_var_eq_operand_bit_to_var_iff by presburger
qed

lemma var_bit_to_var_neq_operand_bit_to_var[simp]:
  "var_bit_to_var (v, a) \<noteq> operand_bit_to_var (op, b)"
proof(rule ccontr)
  assume "\<not> (var_bit_to_var (v, a) \<noteq> operand_bit_to_var (op, b))"
  hence "set (var_bit_to_var (v, a)) = set (operand_bit_to_var (op, b))" by simp
  thus False using set_of_operand_bit_to_var by(auto simp: var_bit_to_var_def)
qed

definition IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b::
  "state \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bit_state" where
"IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n a b = (\<lambda>v.
  (case var_to_var_bit v of
     Some (v', k) \<Rightarrow> if k < n then Some (nth_bit (s v') k) else None |
     None \<Rightarrow>
       (case var_to_operand_bit v of
          Some (CHR ''a'', k) \<Rightarrow> if k < n then Some (nth_bit a k) else None |
          Some (CHR ''b'', k) \<Rightarrow> if k < n then Some (nth_bit b k) else None |
          _ \<Rightarrow> (if v = ''carry'' then Some Zero else None))))"

definition IMP_Minus_State_To_IMP_Minus_Minus:: "state \<Rightarrow> nat \<Rightarrow> bit_state" where
"IMP_Minus_State_To_IMP_Minus_Minus s n
  = IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n 0 0 "

definition IMP_Minus_State_To_IMP_Minus_Minus_partial::
  "(vname \<rightharpoonup> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bit_state" where
"IMP_Minus_State_To_IMP_Minus_Minus_partial s n r =
 (\<lambda>v. (case var_to_var_bit v of
         Some (v', k) \<Rightarrow>
           if k \<ge> n then
             None
           else
             (if k < r then
                ((\<lambda>x. Some (nth_bit x k)) \<circ>\<^sub>m s) v'
              else
                Some Zero)
        | None \<Rightarrow> (case var_to_operand_bit v of
            Some (CHR ''a'', k) \<Rightarrow>
              if k < n then
                Some Zero
              else
                None
          | Some (CHR ''b'', k) \<Rightarrow>
              if k < n then
                Some Zero
              else
                None
          |  _ \<Rightarrow>
              if v = ''carry'' then
                Some Zero
              else
                None)))"

lemma IMP_Minus_State_To_IMP_Minus_Minus_partial_of_operand_bit_to_var:
  "IMP_Minus_State_To_IMP_Minus_Minus_partial s n r (operand_bit_to_var (op, k)) =
    (if (op = CHR ''a'' \<or> op = CHR ''b'') \<and> k < n then Some Zero else None)"
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_partial_def split!: char.splits bool.splits)

lemma IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_carry[simp]:
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s k a b ''carry'' = Some Zero"
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)

lemma IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_operand_a[simp]:
  "j < k \<Longrightarrow> IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s k a b
  (operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit a j)"
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)

lemma IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_operand_a'[simp]:
  "j + 1 < k \<Longrightarrow> IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s k a b
  (CHR ''a'' # operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit a (j + 1))"
proof-
  assume "j + 1 < k"
  moreover have "CHR ''a'' # operand_bit_to_var (CHR ''a'', j) = operand_bit_to_var (CHR ''a'', j + 1)"
    by simp
  ultimately show ?thesis
    using IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_operand_a by presburger
qed

lemma IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_operand_b[simp]:
  "j < k \<Longrightarrow> IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s k a b
  (operand_bit_to_var (CHR ''b'', j)) = Some (nth_bit b j)"
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)

lemma IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_var_bit_to_var[simp]:
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n a b (var_bit_to_var (v, i))
    = (if i < n then Some (nth_bit (s v) i) else None)"
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)

lemma IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_changed_s_neq_iff:
  "IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n a b x \<noteq>
       IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b (s(v := y)) n a b x
  \<longleftrightarrow> (\<exists>i < n. var_to_var_bit x = Some (v, i) \<and> nth_bit(s v) i \<noteq> nth_bit y i)"
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def split: option.splits)

lemma dom_of_IMP_Minus_State_To_IMP_Minus_Minus: "dom (IMP_Minus_State_To_IMP_Minus_Minus s n) =
  { ''carry'' }
  \<union> { var_bit_to_var (w, i) | w i. i < n }
  \<union> { operand_bit_to_var (op, i) | op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }" for s n
  by (auto simp: IMP_Minus_State_To_IMP_Minus_Minus_def var_to_operand_bit_eq_Some_iff
                 var_to_var_bit_eq_Some_iff IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def
           split: char.splits option.splits bool.splits if_splits)

definition IMP_Minus_Minus_State_To_IMP_Minus:: "bit_state \<Rightarrow> nat \<Rightarrow> state" where
"IMP_Minus_Minus_State_To_IMP_Minus s n = (\<lambda>v.
  bit_list_to_nat (map (\<lambda>i. case s (var_bit_to_var (v, i)) of (Some b) \<Rightarrow>  b |
  None \<Rightarrow> Zero) [0..<n]))"

lemma nth_bit_of_IMP_Minus_Minus_State_To_IMP_Minus:
  "nth_bit (IMP_Minus_Minus_State_To_IMP_Minus s1 n v) k = (if k < n then
    (case s1 (var_bit_to_var (v, k)) of (Some b) \<Rightarrow> b |
                   None \<Rightarrow> Zero)
    else Zero)"
  by(auto simp: IMP_Minus_Minus_State_To_IMP_Minus_def split: option.splits)

lemma all_bits_geq_k_Zero_then_IMP_Minus_Minus_State_To_IMP_Minus_range_limited:
  assumes "\<forall>i v. i \<ge> k \<longrightarrow> s (var_bit_to_var (v, i)) \<noteq> Some One"
  shows "finite (range (IMP_Minus_Minus_State_To_IMP_Minus s n))"
    "Max (range (IMP_Minus_Minus_State_To_IMP_Minus s n)) < 2 ^ k"
proof -
  have "\<forall>v. (IMP_Minus_Minus_State_To_IMP_Minus s n) v < 2 ^ k"
  proof (rule ccontr)
    assume "\<not> (\<forall>v. IMP_Minus_Minus_State_To_IMP_Minus s n v < 2 ^ k)"
    then obtain v where "IMP_Minus_Minus_State_To_IMP_Minus s n v \<ge> 2 ^ k" using leI by blast
    hence "bit_list_to_nat (map (\<lambda>i. case s (var_bit_to_var (v, i)) of (Some b) \<Rightarrow> b |
      None \<Rightarrow> Zero) [0..<n]) \<ge> 2 ^ k" by (auto simp: IMP_Minus_Minus_State_To_IMP_Minus_def)
    then obtain i where "i \<ge> k \<and> i < n \<and>
      (map (\<lambda>i. case s (var_bit_to_var (v, i)) of (Some b) \<Rightarrow> b | None \<Rightarrow> Zero) [0..<n]) ! i = One"
      using bit_list_to_nat_geq_two_to_the_k_then by fastforce
    moreover hence "s (var_bit_to_var (v, i)) \<noteq> Some One"
      using \<open>\<forall>i v. i \<ge> k \<longrightarrow> s (var_bit_to_var (v, i)) \<noteq> Some One\<close> by simp
    ultimately show False apply(cases "s (var_bit_to_var (v, i))") by auto
  qed
  thus  "finite (range (IMP_Minus_Minus_State_To_IMP_Minus s n))"
    "Max (range (IMP_Minus_Minus_State_To_IMP_Minus s n)) < 2 ^ k"
    using bounded_nat_set_is_finite by auto
qed
end