section \<open> Healthiness Conditions \<close>

theory utp_healthy
  imports utp_pred_laws utp_recursion
begin

subsection \<open> Main Definitions \<close>

text \<open> We collect closure laws for healthiness conditions in the following theorem attribute. \<close>

named_theorems closure

type_synonym 'a health = "'a pred \<Rightarrow> 'a pred"

text \<open> A predicate $P$ is healthy, under healthiness function $H$, if $P$ is a fixed-point of $H$. \<close>

definition Healthy :: "'\<alpha> pred \<Rightarrow> '\<alpha> health \<Rightarrow> bool" (infix "is" 30)
  where [pred]: "P is H \<equiv> (H P = P)"

lemma Healthy_def': "P is H \<longleftrightarrow> (H P = P)"
  unfolding Healthy_def by auto

lemma Healthy_if: "P is H \<Longrightarrow> (H P = P)"
  unfolding Healthy_def by auto

lemma Healthy_intro: "H(P) = P \<Longrightarrow> P is H"
  by (simp add: Healthy_def)

abbreviation Healthy_carrier :: "'\<alpha> health \<Rightarrow> '\<alpha> pred set" ("\<lbrakk>_\<rbrakk>\<^sub>H")
where "\<lbrakk>H\<rbrakk>\<^sub>H \<equiv> {P. P is H}"

lemma Healthy_carrier_image:
  "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<Longrightarrow> \<H> ` A = A"
    by (auto simp add: image_def, (metis Healthy_if mem_Collect_eq subsetCE)+)

lemma Healthy_carrier_Collect: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> A = {H(P) | P. P \<in> A}"
  by (simp add: Healthy_carrier_image Setcompr_eq_image)

lemma Healthy_func:
  "\<lbrakk> F \<in> \<lbrakk>\<H>\<^sub>1\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<^sub>2\<rbrakk>\<^sub>H; P is \<H>\<^sub>1 \<rbrakk> \<Longrightarrow> F(P) = \<H>\<^sub>2(F(P))"
  by (metis Healthy_if PiE mem_Collect_eq)

lemma Healthy_comp:
  "\<lbrakk> P is \<H>\<^sub>1; P is \<H>\<^sub>2 \<rbrakk> \<Longrightarrow> P is \<H>\<^sub>1 \<circ> \<H>\<^sub>2"
  by (simp add: Healthy_def)

lemma Healthy_apply_closed:
  assumes "F \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H" "P is H"
  shows "F(P) is H"
  using assms by auto

lemma Healthy_set_image_member:
  "\<lbrakk> P \<in> F ` A; \<And> x. F x is H \<rbrakk> \<Longrightarrow> P is H"
  by blast

lemma Healthy_case_prod:
  "\<lbrakk> \<And> x y. P x y is H \<rbrakk> \<Longrightarrow> case_prod P v is H"
  by (simp add: prod.case_eq_if)

lemma Healthy_SUPREMUM:
  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> Sup (H ` A) = \<Sqinter> A"
  by (drule Healthy_carrier_image, presburger)

lemma Healthy_INFIMUM:
  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> Inf (H ` A) = \<Squnion> A"
  by (drule Healthy_carrier_image, presburger)

lemma Healthy_nu [closure]:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
  shows "\<nu> F is H"
  by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff lfp_unfold)

lemma Healthy_mu [closure]:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
  shows "\<mu> F is H"
  by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff gfp_unfold)

lemma Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> H(P) = P"
  using Healthy_if by blast

lemma is_Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> P is H"
  by blast

subsection \<open> Properties of Healthiness Conditions \<close>

definition Idempotent :: "'\<alpha> health \<Rightarrow> bool" where
  "Idempotent(H) \<longleftrightarrow> (\<forall> P. H(H(P)) = H(P))"

abbreviation Monotonic :: "'\<alpha> health \<Rightarrow> bool" where
  "Monotonic(H) \<equiv> mono H"

definition IMH :: "'\<alpha> health \<Rightarrow> bool" where
  "IMH(H) \<longleftrightarrow> Idempotent(H) \<and> Monotonic(H)"

definition Antitone :: "'\<alpha> health \<Rightarrow> bool" where
  "Antitone(H) \<longleftrightarrow> (\<forall> P Q. Q \<sqsubseteq> P \<longrightarrow> (H(P) \<sqsubseteq> H(Q)))"

definition Conjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "Conjunctive(H) \<longleftrightarrow> (\<exists> Q. \<forall> P. H(P) = (P \<and> Q))"

definition FunctionalConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "FunctionalConjunctive(H) \<longleftrightarrow> (\<exists> F. \<forall> P. H(P) = (P \<and> F(P)) \<and> Monotonic(F))"

definition WeakConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "WeakConjunctive(H) \<longleftrightarrow> (\<forall> P. \<exists> Q. H(P) = (P \<and> Q))"

definition Disjunctuous :: "'\<alpha> health \<Rightarrow> bool" where
  [pred]: "Disjunctuous H = (\<forall> P Q. H(P \<or> Q) = (H(P) \<or> H(Q)))"

definition Continuous :: "'\<alpha> health \<Rightarrow> bool" where
  [pred]: "Continuous H = (\<forall> A. A \<noteq> {} \<longrightarrow> H (\<Sqinter> A) = \<Sqinter> (H ` A))"

lemma Healthy_Idempotent:
  "Idempotent H \<Longrightarrow> H(P) is H"
  by (simp add: Healthy_def Idempotent_def)

lemma Healthy_range: "Idempotent H \<Longrightarrow> range H = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (auto simp add: image_def Healthy_if Healthy_Idempotent, metis Healthy_if)

lemma Idempotent_id [simp]: "Idempotent id"
  by (simp add: Idempotent_def)

lemma Idempotent_comp [intro]:
  "\<lbrakk> Idempotent f; Idempotent g; f \<circ> g = g \<circ> f \<rbrakk> \<Longrightarrow> Idempotent (f \<circ> g)"
  by (auto simp add: Idempotent_def comp_def, metis+)

lemma Idempotent_image: "Idempotent f \<Longrightarrow> f ` (f ` A) = (f ` A)"
  by (metis (mono_tags, lifting) Idempotent_def image_cong image_image)

named_theorems mono

lemma Monotonic_refine: "Monotonic F \<longleftrightarrow> (\<forall> P Q. P \<sqsubseteq> Q \<longrightarrow> F(P) \<sqsubseteq> F(Q))"
  by (metis monoE monoI pred_ref_iff_le)

lemma Monotonic_id [simp]: "Monotonic id"
  by (simp add: monoI)

lemma Monotonic_id' [mono]:
  "mono (\<lambda> X. X)"
  by (simp add: monoI)

lemma Monotonic_const [mono]:
  "Monotonic (\<lambda> x. c)"
  by (simp add: mono_def)

lemma Monotonic_comp [intro, mono]:
  "\<lbrakk> Monotonic f; Monotonic g \<rbrakk> \<Longrightarrow> Monotonic (f \<circ> g)"
  by (simp add: mono_def)

lemma Monotonic_sup [mono]:
  assumes "Monotonic P" "Monotonic Q"
  shows "Monotonic (\<lambda> X. P X \<sqinter> Q X)"
  using assms unfolding mono_def by (meson sup_mono)

lemma Monotonic_disj [mono]:
  assumes "Monotonic P" "Monotonic Q"
  shows "Monotonic (\<lambda> X. P(X) \<or> Q(X))"
  by (insert assms, simp add: disj_pred_def Monotonic_sup)

lemma Monotonic_cond:
  assumes "Monotonic P" "Monotonic Q"
  shows "Monotonic (\<lambda> X. P(X) \<triangleleft> b \<triangleright> Q(X))"
  by (insert assms, simp add: mono_def pred le_fun_def)

lemma Conjuctive_Idempotent:
  "Conjunctive(H) \<Longrightarrow> Idempotent(H)"
  by (auto simp add: Conjunctive_def Idempotent_def conj_pred_def)

lemma Conjunctive_Monotonic:
  "Conjunctive(H) \<Longrightarrow> Monotonic(H)"
  unfolding Conjunctive_def mono_def
  by (metis (no_types, opaque_lifting) conj_pred_def le_inf_iff order.trans order_refl)

lemma Conjunctive_conj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<and> Q) = (HC(P) \<and> Q)"
  using assms unfolding Conjunctive_def
  by (metis conj_pred_def inf.commute inf_sup_aci(2))

lemma Conjunctive_distr_conj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<and> Q) = (HC(P) \<and> HC(Q))"
  using assms unfolding Conjunctive_def
  by (metis Conjunctive_conj assms conj_pred_def inf.right_idem inf_sup_aci(2))

lemma Conjunctive_distr_disj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<or> Q) = (HC(P) \<or> HC(Q))"
  using assms unfolding Conjunctive_def
  by (metis conj_pred_def disj_pred_def inf_sup_distrib2)

lemma Conjunctive_distr_cond:
  assumes "Conjunctive(HC)"
  shows "HC(P \<triangleleft> b \<triangleright> Q) = (HC(P) \<triangleleft> b \<triangleright> HC(Q))"
  using assms unfolding Conjunctive_def
  apply pred_simp
  by force

lemma FunctionalConjunctive_Monotonic:
  "FunctionalConjunctive(H) \<Longrightarrow> Monotonic(H)"
  unfolding FunctionalConjunctive_def
  by (smt (verit, del_insts) conj_pred_def dual_order.trans le_inf_iff mono_def order_refl)

lemma WeakConjunctive_Refinement:
  assumes "WeakConjunctive(HC)"
  shows "P \<sqsubseteq> HC(P)"
  using assms unfolding WeakConjunctive_def
  by (metis conj_pred_def inf1D1 pred_refine_iff)

lemma WeakCojunctive_Healthy_Refinement:
  assumes "WeakConjunctive(HC)" and "P is HC"
  shows "HC(P) \<sqsubseteq> P"
  using assms unfolding WeakConjunctive_def Healthy_def by simp

lemma WeakConjunctive_implies_WeakConjunctive:
  "Conjunctive(H) \<Longrightarrow> WeakConjunctive(H)"
  unfolding WeakConjunctive_def Conjunctive_def by pred_auto

lemma Disjunctuous_Monotonic: "Disjunctuous H \<Longrightarrow> Monotonic H"
  by (metis (no_types, lifting) Disjunctuous_def disj_pred_def le_iff_sup mono_def)

lemma ContinuousD [dest]: "\<lbrakk> Continuous H; A \<noteq> {} \<rbrakk> \<Longrightarrow> H (\<Sqinter> A) = (\<Sqinter> P\<in>A. H(P))"
  by (simp add: Continuous_def)

lemma Continuous_Disjunctous: "Continuous H \<Longrightarrow> Disjunctuous H"
  apply (auto simp add: Continuous_def Disjunctuous_def)
  by (metis SUP_insert Sup_insert cSup_singleton disj_pred_def insert_not_empty)

lemma Continuous_choice_dist: "Continuous H \<Longrightarrow> H(P \<sqinter> Q) = H(P) \<sqinter> H(Q)"
  using Continuous_Disjunctous Disjunctuous_def
  by (metis disj_pred_def)

lemma Continuous_Monotonic [closure]: "Continuous H \<Longrightarrow> Monotonic H"
  by (simp add: Continuous_Disjunctous Disjunctuous_Monotonic)

lemma Continuous_comp [intro]:
  "\<lbrakk> Continuous f; Continuous g \<rbrakk> \<Longrightarrow> Continuous (f \<circ> g)"
  unfolding Continuous_def by (simp, blast)

lemma Continuous_const [closure]: "Continuous (\<lambda> X. P)"
  by pred_auto

text \<open> Closure laws derived from continuity \<close>

lemma Sup_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A. P(i)) is H"
  by (drule ContinuousD[of H "P ` A"], auto) (metis (no_types, lifting) Healthy_def' SUP_cong image_image)

(*
lemma UINF_mem_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Union> i\<in>A. P(i)) is H"
  by (simp add: Sup_Continuous_closed UINF_as_Sup_collect)
*)

lemma Sup_mem_Continuous_closed_pair [closure]:
  assumes "Continuous H" "\<And> i j. (i, j) \<in> A \<Longrightarrow> P i j is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j)\<in>A. P i j) is H"
  by (simp add: Sup_Continuous_closed assms split_beta)

lemma Sup_mem_Continuous_closed_triple:
  assumes "Continuous H" "\<And> i j k. (i, j, k) \<in> A \<Longrightarrow> P i j k is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k)\<in>A. P i j k) is H"
  by (simp add: Sup_Continuous_closed assms split_beta)

lemma Sup_mem_Continuous_closed_quad:
  assumes "Continuous H" "\<And> i j k l. (i, j, k, l) \<in> A \<Longrightarrow> P i j k l is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k,l)\<in>A. P i j k l) is H"
  by (simp add: Sup_Continuous_closed assms split_beta)

lemma Sup_mem_Continuous_closed_quint:
  assumes "Continuous H" "\<And> i j k l m. (i, j, k, l, m) \<in> A \<Longrightarrow> P i j k l m is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k,l,m)\<in>A. P i j k l m) is H"
  by (simp add: Sup_Continuous_closed assms split_beta)

text \<open> All continuous functions are also Scott-continuous \<close>

lemma sup_continuous_Continuous [closure]: "Continuous F \<Longrightarrow> sup_continuous F"
  by (auto simp add: Continuous_def sup_continuous_def)

lemma Inf_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Squnion> P\<in>A. F(P)) = (\<Squnion> P\<in>A. F(H(P)))"
  by (rule INF_cong, auto simp add: Healthy_subset_member)

lemma Sup_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Sqinter> P\<in>A. F(P)) = (\<Sqinter> P\<in>A. F(H(P)))"
  by (rule SUP_cong, auto simp add: Healthy_subset_member)

end


(*  Title:      HOL/Library/Lub_Glb.thy
    Author:     Jacques D. Fleuriot, University of Cambridge
    Author:     Amine Chaieb, University of Cambridge *)

section \<open>Definitions of Least Upper Bounds and Greatest Lower Bounds\<close>

theory Lub_Glb
imports Complex_MainRLT
begin

text \<open>Thanks to suggestions by James Margetson\<close>

definition setle :: "'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"  (infixl \<open>*<=\<close> 70)
  where "S *<= x = (\<forall>y\<in>S. y \<le> x)"

definition setge :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool"  (infixl \<open><=*\<close> 70)
  where "x <=* S = (\<forall>y\<in>S. x \<le> y)"

subsection \<open>Rules for the Relations \<open>*<=\<close> and \<open><=*\<close>\<close>

lemma setleI: "\<forall>y\<in>S. y \<le> x \<Longrightarrow> S *<= x"
  by (simp add: setle_def)

lemma setleD: "S *<= x \<Longrightarrow> y\<in>S \<Longrightarrow> y \<le> x"
  by (simp add: setle_def)

lemma setgeI: "\<forall>y\<in>S. x \<le> y \<Longrightarrow> x <=* S"
  by (simp add: setge_def)

lemma setgeD: "x <=* S \<Longrightarrow> y\<in>S \<Longrightarrow> x \<le> y"
  by (simp add: setge_def)

definition leastP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "leastP P x = (P x \<and> x <=* Collect P)"

definition isUb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isUb R S x = (S *<= x \<and> x \<in> R)"

definition isLub :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isLub R S x = leastP (isUb R S) x"

definition ubs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
  where "ubs R S = Collect (isUb R S)"

subsection \<open>Rules about the Operators \<^term>\<open>leastP\<close>, \<^term>\<open>ub\<close> and \<^term>\<open>lub\<close>\<close>

lemma leastPD1: "leastP P x \<Longrightarrow> P x"
  by (simp add: leastP_def)

lemma leastPD2: "leastP P x \<Longrightarrow> x <=* Collect P"
  by (simp add: leastP_def)

lemma leastPD3: "leastP P x \<Longrightarrow> y \<in> Collect P \<Longrightarrow> x \<le> y"
  by (blast dest!: leastPD2 setgeD)

lemma isLubD1: "isLub R S x \<Longrightarrow> S *<= x"
  by (simp add: isLub_def isUb_def leastP_def)

lemma isLubD1a: "isLub R S x \<Longrightarrow> x \<in> R"
  by (simp add: isLub_def isUb_def leastP_def)

lemma isLub_isUb: "isLub R S x \<Longrightarrow> isUb R S x"
  unfolding isUb_def by (blast dest: isLubD1 isLubD1a)

lemma isLubD2: "isLub R S x \<Longrightarrow> y \<in> S \<Longrightarrow> y \<le> x"
  by (blast dest!: isLubD1 setleD)

lemma isLubD3: "isLub R S x \<Longrightarrow> leastP (isUb R S) x"
  by (simp add: isLub_def)

lemma isLubI1: "leastP(isUb R S) x \<Longrightarrow> isLub R S x"
  by (simp add: isLub_def)

lemma isLubI2: "isUb R S x \<Longrightarrow> x <=* Collect (isUb R S) \<Longrightarrow> isLub R S x"
  by (simp add: isLub_def leastP_def)

lemma isUbD: "isUb R S x \<Longrightarrow> y \<in> S \<Longrightarrow> y \<le> x"
  by (simp add: isUb_def setle_def)

lemma isUbD2: "isUb R S x \<Longrightarrow> S *<= x"
  by (simp add: isUb_def)

lemma isUbD2a: "isUb R S x \<Longrightarrow> x \<in> R"
  by (simp add: isUb_def)

lemma isUbI: "S *<= x \<Longrightarrow> x \<in> R \<Longrightarrow> isUb R S x"
  by (simp add: isUb_def)

lemma isLub_le_isUb: "isLub R S x \<Longrightarrow> isUb R S y \<Longrightarrow> x \<le> y"
  unfolding isLub_def by (blast intro!: leastPD3)

lemma isLub_ubs: "isLub R S x \<Longrightarrow> x <=* ubs R S"
  unfolding ubs_def isLub_def by (rule leastPD2)

lemma isLub_unique: "[| isLub R S x; isLub R S y |] ==> x = (y::'a::linorder)"
  apply (frule isLub_isUb)
  apply (frule_tac x = y in isLub_isUb)
  apply (blast intro!: order_antisym dest!: isLub_le_isUb)
  done

lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
  by (simp add: isUbI setleI)

definition greatestP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "greatestP P x = (P x \<and> Collect P *<=  x)"

definition isLb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isLb R S x = (x <=* S \<and> x \<in> R)"

definition isGlb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
  where "isGlb R S x = greatestP (isLb R S) x"

definition lbs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
  where "lbs R S = Collect (isLb R S)"

subsection \<open>Rules about the Operators \<^term>\<open>greatestP\<close>, \<^term>\<open>isLb\<close> and \<^term>\<open>isGlb\<close>\<close>

lemma greatestPD1: "greatestP P x \<Longrightarrow> P x"
  by (simp add: greatestP_def)

lemma greatestPD2: "greatestP P x \<Longrightarrow> Collect P *<= x"
  by (simp add: greatestP_def)

lemma greatestPD3: "greatestP P x \<Longrightarrow> y \<in> Collect P \<Longrightarrow> x \<ge> y"
  by (blast dest!: greatestPD2 setleD)

lemma isGlbD1: "isGlb R S x \<Longrightarrow> x <=* S"
  by (simp add: isGlb_def isLb_def greatestP_def)

lemma isGlbD1a: "isGlb R S x \<Longrightarrow> x \<in> R"
  by (simp add: isGlb_def isLb_def greatestP_def)

lemma isGlb_isLb: "isGlb R S x \<Longrightarrow> isLb R S x"
  unfolding isLb_def by (blast dest: isGlbD1 isGlbD1a)

lemma isGlbD2: "isGlb R S x \<Longrightarrow> y \<in> S \<Longrightarrow> y \<ge> x"
  by (blast dest!: isGlbD1 setgeD)

lemma isGlbD3: "isGlb R S x \<Longrightarrow> greatestP (isLb R S) x"
  by (simp add: isGlb_def)

lemma isGlbI1: "greatestP (isLb R S) x \<Longrightarrow> isGlb R S x"
  by (simp add: isGlb_def)

lemma isGlbI2: "isLb R S x \<Longrightarrow> Collect (isLb R S) *<= x \<Longrightarrow> isGlb R S x"
  by (simp add: isGlb_def greatestP_def)

lemma isLbD: "isLb R S x \<Longrightarrow> y \<in> S \<Longrightarrow> y \<ge> x"
  by (simp add: isLb_def setge_def)

lemma isLbD2: "isLb R S x \<Longrightarrow> x <=* S "
  by (simp add: isLb_def)

lemma isLbD2a: "isLb R S x \<Longrightarrow> x \<in> R"
  by (simp add: isLb_def)

lemma isLbI: "x <=* S \<Longrightarrow> x \<in> R \<Longrightarrow> isLb R S x"
  by (simp add: isLb_def)

lemma isGlb_le_isLb: "isGlb R S x \<Longrightarrow> isLb R S y \<Longrightarrow> x \<ge> y"
  unfolding isGlb_def by (blast intro!: greatestPD3)

lemma isGlb_ubs: "isGlb R S x \<Longrightarrow> lbs R S *<= x"
  unfolding lbs_def isGlb_def by (rule greatestPD2)

lemma isGlb_unique: "[| isGlb R S x; isGlb R S y |] ==> x = (y::'a::linorder)"
  apply (frule isGlb_isLb)
  apply (frule_tac x = y in isGlb_isLb)
  apply (blast intro!: order_antisym dest!: isGlb_le_isLb)
  done

lemma bdd_above_setle: "bdd_above A \<longleftrightarrow> (\<exists>a. A *<= a)"
  by (auto simp: bdd_above_def setle_def)

lemma bdd_below_setge: "bdd_below A \<longleftrightarrow> (\<exists>a. a <=* A)"
  by (auto simp: bdd_below_def setge_def)

lemma isLub_cSup:
  "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. S *<= b) \<Longrightarrow> isLub UNIV S (Sup S)"
  by  (auto simp add: isLub_def setle_def leastP_def isUb_def
            intro!: setgeI cSup_upper cSup_least)

lemma isGlb_cInf:
  "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. b <=* S) \<Longrightarrow> isGlb UNIV S (Inf S)"
  by  (auto simp add: isGlb_def setge_def greatestP_def isLb_def
            intro!: setleI cInf_lower cInf_greatest)

lemma cSup_le: "(S::'a::conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> S *<= b \<Longrightarrow> Sup S \<le> b"
  by (metis cSup_least setle_def)

lemma cInf_ge: "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> b <=* S \<Longrightarrow> Inf S \<ge> b"
  by (metis cInf_greatest setge_def)

lemma cSup_bounds:
  fixes S :: "'a :: conditionally_complete_lattice set"
  shows "S \<noteq> {} \<Longrightarrow> a <=* S \<Longrightarrow> S *<= b \<Longrightarrow> a \<le> Sup S \<and> Sup S \<le> b"
  using cSup_least[of S b] cSup_upper2[of _ S a]
  by (auto simp: bdd_above_setle setge_def setle_def)

lemma cSup_unique: "(S::'a :: {conditionally_complete_linorder, no_bot} set) *<= b \<Longrightarrow> (\<forall>b'<b. \<exists>x\<in>S. b' < x) \<Longrightarrow> Sup S = b"
  by (rule cSup_eq) (auto simp: not_le[symmetric] setle_def)

lemma cInf_unique: "b <=* (S::'a :: {conditionally_complete_linorder, no_top} set) \<Longrightarrow> (\<forall>b'>b. \<exists>x\<in>S. b' > x) \<Longrightarrow> Inf S = b"
  by (rule cInf_eq) (auto simp: not_le[symmetric] setge_def)

text\<open>Use completeness of reals (supremum property) to show that any bounded sequence has a least upper bound\<close>

lemma reals_complete: "\<exists>X. X \<in> S \<Longrightarrow> \<exists>Y. isUb (UNIV::real set) S Y \<Longrightarrow> \<exists>t. isLub (UNIV :: real set) S t"
  by (intro exI[of _ "Sup S"] isLub_cSup) (auto simp: setle_def isUb_def intro!: cSup_upper)

lemma Bseq_isUb: "\<And>X :: nat \<Rightarrow> real. Bseq X \<Longrightarrow> \<exists>U. isUb (UNIV::real set) {x. \<exists>n. X n = x} U"
  by (auto intro: isUbI setleI simp add: Bseq_def abs_le_iff)

lemma Bseq_isLub: "\<And>X :: nat \<Rightarrow> real. Bseq X \<Longrightarrow> \<exists>U. isLub (UNIV::real set) {x. \<exists>n. X n = x} U"
  by (blast intro: reals_complete Bseq_isUb)

lemma isLub_mono_imp_LIMSEQ:
  fixes X :: "nat \<Rightarrow> real"
  assumes u: "isLub UNIV {x. \<exists>n. X n = x} u" (* FIXME: use \<open>range X\<close> *)
  assumes X: "\<forall>m n. m \<le> n \<longrightarrow> X m \<le> X n"
  shows "X \<longlonglongrightarrow> u"
proof -
  have "X \<longlonglongrightarrow> (SUP i. X i)"
    using u[THEN isLubD1] X
    by (intro LIMSEQ_incseq_SUP) (auto simp: incseq_def image_def eq_commute bdd_above_setle)
  also have "(SUP i. X i) = u"
    using isLub_cSup[of "range X"] u[THEN isLubD1]
    by (intro isLub_unique[OF _ u]) (auto simp add: image_def eq_commute)
  finally show ?thesis .
qed

lemmas real_isGlb_unique = isGlb_unique[where 'a=real]

lemma real_le_inf_subset: "t \<noteq> {} \<Longrightarrow> t \<subseteq> s \<Longrightarrow> \<exists>b. b <=* s \<Longrightarrow> Inf s \<le> Inf (t::real set)"
  by (rule cInf_superset_mono) (auto simp: bdd_below_setge)

lemma real_ge_sup_subset: "t \<noteq> {} \<Longrightarrow> t \<subseteq> s \<Longrightarrow> \<exists>b. s *<= b \<Longrightarrow> Sup s \<ge> Sup (t::real set)"
  by (rule cSup_subset_mono) (auto simp: bdd_above_setle)

end


(*
    Title:      Echelon_Form_Det_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Determinant of matrices computed using immutable arrays\<close>

theory Echelon_Form_Det_IArrays
imports
  Echelon_Form_Det
  Echelon_Form_IArrays
begin

subsection\<open>Definitions\<close>

definition echelon_form_of_column_k_det_iarrays ::
          "'a::{bezout_ring} \<times> 'a iarray iarray \<times> nat \<times> ('a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a)
          \<Rightarrow> nat
          \<Rightarrow> 'a \<times> 'a iarray iarray \<times> nat \<times> ('a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a)"
 where
 "echelon_form_of_column_k_det_iarrays A' k =
    (let (det_P, A, i, bezout) = A'
      in if ((i \<noteq> nrows_iarray A) \<and> (A !! i !! k = 0)
            \<and> (\<not> vector_all_zero_from_index (i + 1, (column_iarray k A))))
         then (-1 * det_P, echelon_form_of_column_k_iarrays (A, i, bezout) k)
         else (det_P,echelon_form_of_column_k_iarrays (A,i,bezout) k))"

definition "echelon_form_of_upt_k_det_iarrays A' k bezout =
      (let A = snd A';
           f = foldl echelon_form_of_column_k_det_iarrays (1, A, 0, bezout) [0..<Suc k]
       in (fst f, fst (snd f)))"

definition echelon_form_of_det_iarrays ::
  "'a::{bezout_ring} iarray iarray
    \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a)
    \<Rightarrow> ('a \<times> ('a iarray iarray))"
  where
  "echelon_form_of_det_iarrays A bezout =
      echelon_form_of_upt_k_det_iarrays (1::'a, A) (ncols_iarray A - 1) bezout"

definition "det_iarrays_rings A =
    (let A' = echelon_form_of_det_iarrays A euclid_ext2
     in 1 div (fst A') * prod_list (map (\<lambda>i. (snd A') !! i !! i) [0..<nrows_iarray A]))"

subsection\<open>Properties\<close>

subsubsection\<open>Echelon Form of column k\<close>

lemma vector_all_zero_from_index3:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
  shows "(\<exists>m>i. A $ m $ k \<noteq> 0)
  = (\<not> vector_all_zero_from_index (to_nat i + 1, vec_to_iarray (column k A)))"
  using matrix_vector_all_zero_from_index2
proof -
  have "(\<forall>m>i. A $ m $ k = 0) = (vector_all_zero_from_index (to_nat i + 1, vec_to_iarray (column k A)))"
    using matrix_vector_all_zero_from_index2[of i A k] by auto
  hence "(\<not> (\<forall>m>i. A $ m $ k = 0))
    = (\<not>(vector_all_zero_from_index (to_nat i + 1, vec_to_iarray (column k A))))"
    by auto
  thus ?thesis by auto
qed

lemma fst_matrix_to_iarray_echelon_form_of_column_k_det:
  assumes k: "k<ncols A" and i: "i\<le>nrows A"
  shows "fst ((echelon_form_of_column_k_det bezout) (det_P, A, i) k)
  = fst (echelon_form_of_column_k_det_iarrays (det_P, matrix_to_iarray A, i, bezout) k)"
proof (cases "i<nrows A")
  case True
  have ex_rw: "(\<exists>m>from_nat i. A $ m $ from_nat k \<noteq> 0)
    = (\<not> vector_all_zero_from_index (i + 1, column_iarray k (matrix_to_iarray A)))"
    using vector_all_zero_from_index3[of "from_nat i" A "from_nat k"]
    unfolding vec_to_iarray_column
    unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]] .
  have Aik: "matrix_to_iarray A !! i !! k = A $ (from_nat i) $ (from_nat k)"
    by (metis True k matrix_to_iarray_nth ncols_def nrows_def to_nat_from_nat_id)
  show ?thesis
    unfolding echelon_form_of_column_k_det_iarrays_def echelon_form_of_column_k_det_def
    unfolding Let_def
    unfolding split_beta
    unfolding fst_conv snd_conv
    unfolding matrix_to_iarray_nrows
    unfolding ex_rw Aik by auto
next
  case False
  hence i2: "i=nrows A" using i by simp
  thus ?thesis
    unfolding echelon_form_of_column_k_det_iarrays_def echelon_form_of_column_k_det_def
    unfolding Let_def fst_conv snd_conv
    unfolding matrix_to_iarray_nrows
    unfolding i2 unfolding matrix_to_iarray_nrows by auto
qed

lemma snd_echelon_form_of_column_k_det:
  shows "(snd (echelon_form_of_column_k_det_iarrays (det_P, A, i, bezout) k))
  = echelon_form_of_column_k_iarrays (A,i,bezout) k"
  unfolding echelon_form_of_column_k_det_iarrays_def Let_def by auto

lemma fst_snd_echelon_form_of_column_k_le_nrows:
  assumes "i\<le>nrows A"
  shows "snd ((echelon_form_of_column_k bezout) (A, i) k) \<le> nrows A"
  using assms
  unfolding echelon_form_of_column_k_def Let_def fst_conv snd_conv
  unfolding nrows_def by auto

lemma fst_snd_snd_echelon_form_of_column_k_det_le_nrows:
  assumes "i\<le>nrows A"
  shows "snd (snd ((echelon_form_of_column_k_det bezout) (n, A, i) k)) \<le> nrows A"
  unfolding echelon_form_of_column_k_det_def Let_def fst_conv snd_conv
  by (simp add: assms fst_snd_echelon_form_of_column_k_le_nrows)

subsubsection\<open>Echelon Form up to column k\<close>

lemma snd_snd_snd_foldl_echelon_form_of_column_k_det_iarrays:
  "snd (snd (snd (foldl echelon_form_of_column_k_det_iarrays (n, A, 0, bezout) [0..<k]))) = bezout"
proof (induct k)
  case 0
  show ?case by auto
next
  case (Suc k)
  show ?case
    apply auto
    apply (simp only: echelon_form_of_column_k_det_iarrays_def Let_def)
    apply (auto simp add: split_beta echelon_form_of_column_k_iarrays_def Let_def Suc.hyps)
    done
qed

(*lemma snd_snd_snd_echelon_form_of_column_k_det:
  "snd (snd (snd (foldl echelon_form_of_column_k_det (n, A, 0, bezout) [0..<k]))) = bezout"
  by (metis snd_foldl_ef_det_eq snd_snd_foldl_echelon_form_of_column_k)*)

lemma matrix_to_iarray_echelon_form_of_column_k_det:
  assumes "k<ncols A" and "i\<le>nrows A"
  shows "matrix_to_iarray (fst (snd ((echelon_form_of_column_k_det bezout) (n, A, i) k)))
  = (fst (snd (echelon_form_of_column_k_det_iarrays (n, matrix_to_iarray A, i, bezout) k)))"
  unfolding snd_echelon_form_of_column_k_det
  unfolding echelon_form_of_column_k_det_def Let_def fst_conv snd_conv
  using assms matrix_to_iarray_echelon_form_of_column_k by auto

lemma fst_snd_snd_echelon_form_of_column_k_det:
  assumes "k < ncols A"
  and "i \<le> nrows A"
  shows "snd (snd ((echelon_form_of_column_k_det bezout) (n,A,i) k))
  = fst (snd (snd (echelon_form_of_column_k_det_iarrays (n,matrix_to_iarray A, i, bezout) k)))"
  unfolding snd_echelon_form_of_column_k_det_eq
  unfolding snd_echelon_form_of_column_k_det
  by (rule fst_snd_matrix_to_iarray_echelon_form_of_column_k[OF assms])

lemma
  fixes A::"'a::{bezout_domain}^'cols::{mod_type}^'rows::{mod_type}"
  assumes "k<ncols A"
  shows matrix_to_iarray_fst_echelon_form_of_upt_k_det:
  "fst ((echelon_form_of_upt_k_det bezout) (1::'a,A) k)
  = fst (echelon_form_of_upt_k_det_iarrays (1::'a,matrix_to_iarray A) k bezout)"
  and matrix_to_iarray_snd_echelon_form_of_upt_k_det:
  "matrix_to_iarray ((snd ((echelon_form_of_upt_k_det bezout) (1::'a,A) k)))
  = (snd (echelon_form_of_upt_k_det_iarrays (1::'a, matrix_to_iarray A) k bezout))"
  and "snd (snd (foldl (echelon_form_of_column_k_det bezout) (1::'a,A,0) [0..<Suc k])) \<le> nrows A"
  and "fst (snd (snd (foldl echelon_form_of_column_k_det_iarrays
  (1::'a,matrix_to_iarray A,0,bezout) [0..<Suc k]))) = snd (snd
  (foldl (echelon_form_of_column_k_det bezout) (1::'a,A,0) [0..<Suc k]))"
  using assms
proof (induct k)
  show "fst ((echelon_form_of_upt_k_det bezout) (1, A) 0)
    = fst (echelon_form_of_upt_k_det_iarrays (1, matrix_to_iarray A) 0 bezout)"
    unfolding echelon_form_of_upt_k_det_def echelon_form_of_upt_k_det_iarrays_def Let_def
    by (auto, metis fst_matrix_to_iarray_echelon_form_of_column_k_det le0 ncols_not_0 neq0_conv)
  show "matrix_to_iarray (snd ((echelon_form_of_upt_k_det bezout) (1, A) 0)) =
    snd (echelon_form_of_upt_k_det_iarrays (1, matrix_to_iarray A) 0 bezout)"
    unfolding echelon_form_of_upt_k_det_def echelon_form_of_upt_k_det_iarrays_def Let_def
    by (auto, metis le0 matrix_to_iarray_echelon_form_of_column_k ncols_not_0 neq0_conv
      snd_echelon_form_of_column_k_det snd_echelon_form_of_column_k_det_eq)
  show "snd (snd (foldl (echelon_form_of_column_k_det bezout)(1, A, 0) [0..<Suc 0])) \<le> nrows A"
    by (simp add: fst_snd_snd_echelon_form_of_column_k_det_le_nrows)
  show "fst (snd (snd (foldl echelon_form_of_column_k_det_iarrays (1, matrix_to_iarray A, 0, bezout) [0..<Suc 0]))) =
    snd (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc 0]))"
    by (auto, metis fst_snd_matrix_to_iarray_echelon_form_of_column_k le0 ncols_not_0 neq0_conv
      snd_echelon_form_of_column_k_det snd_echelon_form_of_column_k_det_eq)
next
  fix k
  assume "(k < ncols A \<Longrightarrow> fst ((echelon_form_of_upt_k_det bezout) (1::'a, A) k)
    = fst (echelon_form_of_upt_k_det_iarrays (1::'a, matrix_to_iarray A) k bezout))"
    and "(k < ncols A \<Longrightarrow>
    matrix_to_iarray (snd ((echelon_form_of_upt_k_det bezout) (1::'a, A) k))
    = snd (echelon_form_of_upt_k_det_iarrays (1::'a, matrix_to_iarray A) k bezout))"
    and "(k < ncols A \<Longrightarrow>
    snd (snd (foldl (echelon_form_of_column_k_det bezout) (1::'a, A, 0) [0..<Suc k])) \<le> nrows A)"
    and "(k < ncols A \<Longrightarrow>
    fst (snd (snd (foldl echelon_form_of_column_k_det_iarrays (1::'a, matrix_to_iarray A, 0, bezout) [0..<Suc k]))) =
    snd (snd (foldl (echelon_form_of_column_k_det bezout) (1::'a, A, 0) [0..<Suc k])))"
    and S: "Suc k < ncols A"
  hence hyp1: "fst ((echelon_form_of_upt_k_det bezout) (1::'a, A) k)
    = fst (echelon_form_of_upt_k_det_iarrays (1::'a, matrix_to_iarray A) k bezout)"
    and hyp2: "matrix_to_iarray (snd ((echelon_form_of_upt_k_det bezout) (1::'a, A) k))
    = snd (echelon_form_of_upt_k_det_iarrays (1::'a, matrix_to_iarray A) k bezout)"
    and hyp3: "snd (snd (foldl (echelon_form_of_column_k_det bezout) (1::'a, A, 0) [0..<Suc k]))
    \<le> nrows A"
    and hyp4: "fst (snd (snd (foldl echelon_form_of_column_k_det_iarrays
    (1::'a, matrix_to_iarray A, 0, bezout) [0..<Suc k])))
    = snd (snd (foldl (echelon_form_of_column_k_det bezout) (1::'a, A, 0) [0..<Suc k]))"
    by auto
  have list_rw: "[0..<Suc (Suc k)] = [0..<(Suc k)] @ [Suc k]" by simp
  let ?f = "foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k]"
  have f_rw: "?f= (fst ?f, fst (snd ?f), snd (snd ?f))" by simp
  let ?g="(foldl echelon_form_of_column_k_det_iarrays (1, matrix_to_iarray A, 0, bezout) [0..<Suc k])"
  have g_rw: "?g = (fst ?g, fst (snd ?g), fst (snd (snd ?g)), snd (snd (snd ?g)))" by simp
  have rw1: "fst ?g = fst ?f"
    using hyp1[unfolded echelon_form_of_upt_k_det_def echelon_form_of_upt_k_det_iarrays_def Let_def
      fst_conv snd_conv] ..
  have rw2: "fst (snd ?g) = matrix_to_iarray (fst (snd ?f))"
    using hyp2[unfolded echelon_form_of_upt_k_det_def
      echelon_form_of_upt_k_det_iarrays_def Let_def snd_conv] ..
  have rw3: "fst (snd (snd ?g)) = snd (snd ?f)"
    using hyp4 .
  (*have rw4: "snd (snd (snd ?g)) = snd (snd (snd ?f))"
    unfolding snd_snd_snd_foldl_echelon_form_of_column_k_det_iarrays
    unfolding snd_snd_snd_echelon_form_of_column_k_det ..*)
  show "fst ((echelon_form_of_upt_k_det bezout) (1, A) (Suc k))
    = fst (echelon_form_of_upt_k_det_iarrays (1, matrix_to_iarray A) (Suc k) bezout)"
    unfolding echelon_form_of_upt_k_det_iarrays_def echelon_form_of_upt_k_det_def Let_def fst_conv snd_conv
    unfolding list_rw foldl_append
    unfolding List.foldl.simps
    apply (subst f_rw)
    apply (subst g_rw)
    unfolding rw1[symmetric] rw2 rw3
    unfolding snd_snd_snd_foldl_echelon_form_of_column_k_det_iarrays
  proof (rule fst_matrix_to_iarray_echelon_form_of_column_k_det)
    show "Suc k < ncols (fst (snd ?f))" using S unfolding ncols_def .
    show " snd (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k]))
    \<le> nrows (fst (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k])))"
    by (metis hyp3 nrows_def)
  qed
  show "matrix_to_iarray (snd ((echelon_form_of_upt_k_det bezout) (1, A) (Suc k))) =
    snd (echelon_form_of_upt_k_det_iarrays (1, matrix_to_iarray A) (Suc k) bezout)"
    unfolding echelon_form_of_upt_k_det_iarrays_def echelon_form_of_upt_k_det_def Let_def fst_conv snd_conv
    unfolding list_rw foldl_append
    unfolding List.foldl.simps
    apply (subst f_rw)
    apply (subst g_rw)
    unfolding rw1[symmetric] rw2 rw3 unfolding snd_snd_snd_foldl_echelon_form_of_column_k_det_iarrays
  proof (rule matrix_to_iarray_echelon_form_of_column_k_det)
    show "Suc k < ncols (fst (snd ?f))" using S unfolding ncols_def .
    show "snd (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k]))
    \<le> nrows (fst (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k])))"
    by (metis hyp3 nrows_def)
  qed
  show "snd (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc (Suc k)])) \<le> nrows A"
    unfolding list_rw foldl_append List.foldl.simps
    apply (subst f_rw)
    using fst_snd_snd_echelon_form_of_column_k_det_le_nrows
    by (metis hyp3 nrows_def)
  show "fst (snd (snd (foldl echelon_form_of_column_k_det_iarrays
    (1, matrix_to_iarray A, 0, bezout) [0..<Suc (Suc k)])))
    = snd (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc (Suc k)]))"
    unfolding echelon_form_of_upt_k_det_iarrays_def echelon_form_of_upt_k_det_def Let_def fst_conv snd_conv
    unfolding list_rw foldl_append
    unfolding List.foldl.simps
    apply (subst f_rw)
    apply (subst g_rw)
    unfolding rw1[symmetric] rw2 rw3
     unfolding snd_snd_snd_foldl_echelon_form_of_column_k_det_iarrays
  proof (rule fst_snd_snd_echelon_form_of_column_k_det[symmetric])
    show "Suc k < ncols (fst (snd ?f))" using S unfolding ncols_def .
    show "snd (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k]))
    \<le> nrows (fst (snd (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k])))"
    by (metis hyp3 nrows_def)
  qed
qed

subsubsection\<open>Echelon Form\<close>

lemma matrix_to_iarray_echelon_form_of_det[code_unfold]:
  "matrix_to_iarray (snd (echelon_form_of_det A bezout))
  = snd (echelon_form_of_det_iarrays (matrix_to_iarray A) bezout)"
  unfolding echelon_form_of_det_def echelon_form_of_det_iarrays_def
  unfolding matrix_to_iarray_ncols[symmetric]
  by (rule matrix_to_iarray_snd_echelon_form_of_upt_k_det, simp add: ncols_def)

lemma fst_echelon_form_of_det[code_unfold]:
  "(fst (echelon_form_of_det A bezout))
  = fst (echelon_form_of_det_iarrays (matrix_to_iarray A) bezout)"
  unfolding echelon_form_of_det_def echelon_form_of_det_iarrays_def
  unfolding matrix_to_iarray_ncols[symmetric]
  by (rule matrix_to_iarray_fst_echelon_form_of_upt_k_det, simp add: ncols_def)

subsubsection\<open>Computing the determinant\<close>

lemma det_echelon_form_of_euclidean_iarrays[code]:
  fixes A::"'a::{euclidean_ring_gcd}^'n::{mod_type}^'n::{mod_type}"
  shows "det A = (let A' = echelon_form_of_det_iarrays (matrix_to_iarray A) euclid_ext2
  in 1 div (fst A')
  * prod_list (map (\<lambda>i. (snd A') !! i !! i) [0..<nrows_iarray (matrix_to_iarray A)]))"
proof -
  let ?f="(\<lambda>i. snd (echelon_form_of_det_iarrays (matrix_to_iarray A) euclid_ext2) !! i !! i)"
  have "prod_list (map ?f [0..<nrows_iarray (matrix_to_iarray A)])
    = prod ?f (set [0..<nrows_iarray (matrix_to_iarray A)])"
    by (metis (mono_tags, lifting) distinct_upt prod.distinct_set_conv_list)
  also have "... = prod (\<lambda>i. snd (echelon_form_of_det A euclid_ext2) $ i $ i) (UNIV:: 'n set)"
  proof (rule prod.reindex_cong[of "to_nat::('n=>nat)"])
    show "inj (to_nat::('n=>nat))" by (metis strict_mono_imp_inj_on strict_mono_to_nat)
    show "set [0..<nrows_iarray (matrix_to_iarray A)] = range (to_nat::'n=>nat)"
      unfolding nrows_eq_card_rows using bij_to_nat[where ?'a='n]
      unfolding bij_betw_def
      unfolding atLeast0LessThan atLeast_upt  by auto
    fix x
    show "snd (echelon_form_of_det_iarrays (matrix_to_iarray A) euclid_ext2) !! to_nat x !! to_nat x
      = snd (echelon_form_of_det A euclid_ext2) $ x $ x"
      unfolding matrix_to_iarray_echelon_form_of_det[symmetric]
      unfolding matrix_to_iarray_nth ..
  qed
  finally have *:"prod_list (map (\<lambda>i. snd (echelon_form_of_det_iarrays
    (matrix_to_iarray A) euclid_ext2) !! i !! i) [0..<nrows_iarray (matrix_to_iarray A)]) =
    (\<Prod>i\<in>UNIV. snd (echelon_form_of_det A euclid_ext2) $ i $ i)" .
  have "det A = 1 div (fst (echelon_form_of_det A euclid_ext2))
    * prod (\<lambda>i. snd (echelon_form_of_det A euclid_ext2) $ i $ i) (UNIV:: 'n set)"
    unfolding det_echelon_form_of_euclidean ..
  also have "... = (let A' = echelon_form_of_det_iarrays (matrix_to_iarray A) euclid_ext2
    in 1 div (fst A')
    * prod_list (map (\<lambda>i. (snd A') !! i !! i) [0..<nrows_iarray (matrix_to_iarray A)]))"
    unfolding Let_def unfolding * fst_echelon_form_of_det ..
  finally show ?thesis .
qed

corollary matrix_to_iarray_det_euclidean_ring:
  fixes A::"'a::{euclidean_ring_gcd}^'n::{mod_type}^'n::{mod_type}"
  shows "det A = det_iarrays_rings (matrix_to_iarray A)"
  unfolding det_echelon_form_of_euclidean_iarrays det_iarrays_rings_def ..

subsubsection\<open>Computing the characteristic polynomial of a matrix\<close>

definition "mat2matofpoly_iarrays A
  = tabulate2 (nrows_iarray A) (ncols_iarray A)  (\<lambda>i j. [:A !! i !! j:])"

lemma matrix_to_iarray_mat2matofpoly[code_unfold]:
  "matrix_to_iarray (mat2matofpoly A) = mat2matofpoly_iarrays (matrix_to_iarray A)"
  unfolding mat2matofpoly_def mat2matofpoly_iarrays_def tabulate2_def
proof (rule matrix_to_iarray_eq_of_fun, auto)
  show "nrows_iarray (matrix_to_iarray A) = length (IArray.list_of (matrix_to_iarray (\<chi> i j. [:A $ i $ j:])))"
    unfolding nrows_iarray_def matrix_to_iarray_def by simp
  fix i
  show "vec_to_iarray (\<chi> j. [:A $ i $ j:]) =
    IArray (map (\<lambda>j. [:IArray.list_of (IArray.list_of (matrix_to_iarray A) ! mod_type_class.to_nat i) ! j:])
    [0..<ncols_iarray (matrix_to_iarray A)])"
    unfolding vec_to_iarray_def
    unfolding matrix_to_iarray_ncols[symmetric] unfolding ncols_def
    by (auto, metis IArray.sub_def vec_matrix vec_to_iarray_nth)
qed

text\<open>The following two lemmas must be added to the file \<open>Matrix_To_IArray\<close>
  of the AFP Gauss-Jordan development.\<close>

lemma vec_to_iarray_minus[code_unfold]: "vec_to_iarray (a - b)
  = (vec_to_iarray a) - (vec_to_iarray b)"
  unfolding vec_to_iarray_def
  unfolding minus_iarray_def by auto

lemma matrix_to_iarray_minus[code_unfold]: "matrix_to_iarray (A - B)
  = (matrix_to_iarray A) - (matrix_to_iarray B)"
  unfolding matrix_to_iarray_def o_def
  by (simp add: minus_iarray_def Let_def vec_to_iarray_minus)

definition "charpoly_iarrays A
  = det_iarrays_rings (mat_iarray (monom 1 (Suc 0)) (nrows_iarray A) - mat2matofpoly_iarrays A)"

lemma matrix_to_iarray_charpoly[code]: "charpoly A = charpoly_iarrays (matrix_to_iarray A)"
  unfolding charpoly_def charpoly_iarrays_def
  unfolding matrix_to_iarray_mat2matofpoly[symmetric]
  unfolding matrix_to_iarray_nrows[symmetric] nrows_def
  unfolding matrix_to_iarray_mat[symmetric]
  unfolding matrix_to_iarray_minus[symmetric]
  unfolding det_iarrays_rings_def
  unfolding det_echelon_form_of_euclidean_iarrays ..

end


theory Sorting_Quicksort_Scheme
imports Sorting_Setup Sorting_Partially_Sorted
begin

  abbreviation "is_threshold \<equiv> 16::nat"

  context weak_ordering begin

    definition "partition1_spec xs \<equiv> doN {
      ASSERT (length xs \<ge> 4);
      SPEC (\<lambda>(xs1,xs2). mset xs = mset xs1 + mset xs2 \<and> xs1\<noteq>[] \<and> xs2\<noteq>[] \<and> slice_LT (\<^bold>\<le>) xs1 xs2)
    }"
    definition introsort_aux1 :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list nres" where "introsort_aux1 xs d \<equiv> RECT (\<lambda>introsort_aux1 (xs,d). doN {
      if length xs > is_threshold then doN {
        if d=0 then
          SPEC (sort_spec (\<^bold><) xs)
        else doN {
          (xs1,xs2)\<leftarrow>partition1_spec xs;
          xs1 \<leftarrow> introsort_aux1 (xs1,d-1);
          xs2 \<leftarrow> introsort_aux1 (xs2,d-1);
          RETURN (xs1@xs2)
        }
      }
      else
        RETURN xs
    }) (xs,d)"

    lemma slice_strict_LT_imp_LE: "slice_LT (\<^bold><) xs ys \<Longrightarrow> slice_LT (le_by_lt (\<^bold><)) xs ys"
      apply (erule slice_LT_mono)
      by (meson le_by_lt_def wo_less_asym)

    lemma introsort_aux1_correct: "introsort_aux1 xs d \<le> SPEC (\<lambda>xs'. mset xs' = mset xs \<and> part_sorted_wrt (le_by_lt (\<^bold><)) is_threshold xs')"

      unfolding introsort_aux1_def partition1_spec_def sort_spec_def

      apply (refine_vcg RECT_rule_arb[where V="measure (\<lambda>(xs,d). d+1)" and pre="\<lambda>xss (xs',d). xss=xs'"])
      apply (all \<open>(auto intro: sorted_wrt_imp_part_sorted part_sorted_wrt_init; fail)?\<close>)
      apply (rule order_trans)
      apply rprems
      applyS (simp)
      subgoal by auto
      apply refine_vcg
      subgoal
        apply (rule order_trans)
        apply rprems
        applyS simp
        subgoal by auto
        apply refine_vcg
        subgoal by auto
        subgoal
          apply clarsimp
          apply (rule part_sorted_concatI; assumption?)
          apply (subst slice_LT_mset_eq1, assumption)
          apply (subst slice_LT_mset_eq2, assumption)
          using le_by_lt by blast
        done
      done

    definition "partition2_spec xs \<equiv> doN {
      ASSERT (length xs \<ge> 4);
      SPEC (\<lambda>(xs',i). mset xs' = mset xs \<and> 0<i \<and> i<length xs \<and> slice_LT (\<^bold>\<le>) (take i xs') (drop i xs'))
    }"

    lemma partition2_spec_refine: "(xs,xs')\<in>Id \<Longrightarrow> partition2_spec xs \<le>\<Down>(br (\<lambda>(xs,i). (take i xs, drop i xs)) (\<lambda>(xs,i). 0<i \<and> i<length xs)) (partition1_spec xs')"
      unfolding partition1_spec_def partition2_spec_def
      apply (refine_vcg RES_refine)
      by (auto dest: mset_eq_length simp: in_br_conv simp flip: mset_append)

    definition introsort_aux2 :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list nres" where "introsort_aux2 xs d \<equiv> RECT (\<lambda>introsort_aux (xs,d). doN {
      if length xs > is_threshold then doN {
        if d=0 then
          SPEC (sort_spec (\<^bold><) xs)
        else doN {
          (xs,m)\<leftarrow>partition2_spec xs;
          ASSERT (m\<le>length xs);
          xs1 \<leftarrow> introsort_aux (take m xs,d-1);
          xs2 \<leftarrow> introsort_aux (drop m xs,d-1);
          RETURN (xs1@xs2)
        }
      }
      else
        RETURN xs
    }) (xs,d)"

    lemma introsort_aux2_refine: "introsort_aux2 xs d \<le>\<Down>Id (introsort_aux1 xs d)"
      unfolding introsort_aux2_def introsort_aux1_def
      apply (refine_rcg partition2_spec_refine)
      apply refine_dref_type
      apply (auto simp: in_br_conv)
      done

    definition "partition3_spec xs l h \<equiv> doN {
      ASSERT (h-l\<ge>4 \<and> h\<le>length xs);
      SPEC (\<lambda>(xs',i). slice_eq_mset l h xs' xs \<and> l<i \<and> i<h \<and> slice_LT (\<^bold>\<le>) (slice l i xs') (slice i h xs'))
    }"

    lemma partition3_spec_refine: "(xsi,xs) \<in> slice_rel xs\<^sub>0 l h \<Longrightarrow> partition3_spec xsi l h  \<le>\<Down>(slice_rel xs\<^sub>0 l h \<times>\<^sub>r idx_shift_rel l) (partition2_spec xs)"
      unfolding partition3_spec_def partition2_spec_def
      apply (refine_vcg RES_refine)
      apply (auto simp: slice_rel_def in_br_conv) [2]
      apply (clarsimp simp: slice_rel_def in_br_conv)
      subgoal for xs'i ii
        apply (rule exI[where x="slice l h xs'i"])
        apply (rule conjI)
        subgoal by (auto simp: slice_eq_mset_def)
        apply (simp add: idx_shift_rel_alt)
        by (auto simp: slice_eq_mset_def take_slice drop_slice)
      done

    lemma partition3_spec_refine': "\<lbrakk>(xsi,xs) \<in> slicep_rel l h; xsi'=xsi; l'=l; h'=h\<rbrakk>
      \<Longrightarrow> partition3_spec xsi l h  \<le>\<Down>(slice_rel xsi' l' h' \<times>\<^sub>r idx_shift_rel l') (partition2_spec xs)"
      unfolding partition3_spec_def partition2_spec_def
      apply (refine_vcg RES_refine)
      apply (auto simp: slicep_rel_def in_br_conv) [2]
      apply (clarsimp simp: slice_rel_def slicep_rel_def in_br_conv)
      subgoal for xs'i ii
        apply (rule exI[where x="slice l h xs'i"])
        apply (rule conjI)
        subgoal by (auto simp: slice_eq_mset_def)
        apply (simp add: idx_shift_rel_alt)
        by (auto simp: slice_eq_mset_def take_slice drop_slice)
      done

    definition introsort_aux3 :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list nres" where "introsort_aux3 xs l h d
    \<equiv> RECT (\<lambda>introsort_aux (xs,l,h,d). doN {
        ASSERT (l\<le>h);
        if h-l > is_threshold then doN {
          if d=0 then
            slice_sort_spec (\<^bold><) xs l h
          else doN {
            (xs,m)\<leftarrow>partition3_spec xs l h;
            xs \<leftarrow> introsort_aux (xs,l,m,d-1);
            xs \<leftarrow> introsort_aux (xs,m,h,d-1);
            RETURN xs
          }
        }
        else
          RETURN xs
      }) (xs,l,h,d)"

    lemma introsort_aux3_refine: "(xsi,xs)\<in>slicep_rel l h \<Longrightarrow> introsort_aux3 xsi l h d \<le> \<Down>(slice_rel xsi l h) (introsort_aux2 xs d)"
      unfolding introsort_aux3_def introsort_aux2_def

      supply recref = RECT_dep_refine[where
          R="\<lambda>_. {((xsi::'a list, l, h, di::nat), (xs, d)). (xsi, xs) \<in> slicep_rel l h \<and> di=d}" and
          S="\<lambda>_ (xsi::'a list, l, h, di::nat). slice_rel xsi l h" and
          arb\<^sub>0 = "()"
          ]

      apply (refine_rcg
        recref
        partition3_spec_refine'
        slice_sort_spec_refine_sort'
        ; (rule refl)?
        )

      subgoal by auto
      subgoal by auto
      subgoal by (auto simp: slicep_rel_def)
      subgoal by (auto simp: slicep_rel_def)
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      apply (rprems)
      subgoal by (auto simp: slice_rel_alt idx_shift_rel_def slicep_rel_take)
      apply rprems
      subgoal by (auto simp: slice_rel_alt idx_shift_rel_def slicep_rel_eq_outside_range slicep_rel_drop)
      subgoal
        apply (clarsimp simp: slice_rel_alt idx_shift_rel_def)
        apply (rule conjI)
        subgoal
          apply (rule slicep_rel_append)
          apply (subst slicep_rel_eq_outside_range; assumption?)
          by auto
        subgoal
          apply (drule (1) eq_outside_range_gen_trans[OF _ _ refl refl])
          apply (erule (1) eq_outside_range_gen_trans)
          apply (auto simp: max_def algebra_simps slicep_rel_def split: if_splits)
          done
        done
      subgoal by (auto simp: slice_rel_alt eq_outside_range_triv slicep_rel_def)
      done

    definition "slice_part_sorted_spec xsi l h \<equiv> doN { ASSERT (l\<le>h \<and> h\<le>length xsi); SPEC (\<lambda>xsi'.
        eq_outside_range xsi' xsi l h
      \<and> mset (slice l h xsi') = mset (slice l h xsi)
      \<and> part_sorted_wrt (le_by_lt (\<^bold><)) is_threshold (slice l h xsi'))}"

    lemma introsort_aux3_correct: "introsort_aux3 xsi l h d \<le> slice_part_sorted_spec xsi l h"
    proof -

(*      have "(xsi, slice l h xsi) \<in> slicep_rel l h"
        unfolding slicep_rel_def apply auto
        *)

      have A: "\<Down> (slice_rel xsi l h) (SPEC (\<lambda>xs'. mset xs' = mset (slice l h xsi) \<and> part_sorted_wrt (le_by_lt (\<^bold><)) 16 xs'))
        \<le> slice_part_sorted_spec xsi l h"
        apply (clarsimp simp: slice_part_sorted_spec_def pw_le_iff refine_pw_simps)
        apply (auto simp: slice_rel_alt  slicep_rel_def)
        done

      note introsort_aux3_refine[of xsi "slice l h xsi" l h d]
      also note introsort_aux2_refine
      also note introsort_aux1_correct
      also note A
      finally show ?thesis
        apply (clarsimp simp: slicep_rel_def slice_part_sorted_spec_def)
        by (auto simp: pw_le_iff refine_pw_simps)

    qed

    text \<open>In the paper, we summarized steps 2 and 3. Here are the relevant lemmas: \<close>
    lemma partition3_spec_alt: "partition3_spec xs l h = \<Down>(slice_rel xs l h \<times>\<^sub>r Id) (doN { ASSERT (l\<le>h \<and> h\<le>length xs); (xs\<^sub>1,xs\<^sub>2) \<leftarrow> partition1_spec (slice l h xs); RETURN (xs\<^sub>1@xs\<^sub>2, l+length xs\<^sub>1) })"
      unfolding partition3_spec_def partition1_spec_def
      apply (auto simp: pw_eq_iff refine_pw_simps)
      apply (auto simp: slice_eq_mset_def slice_rel_def in_br_conv)
      subgoal
        by (smt Sorting_Misc.slice_len diff_is_0_eq leD le_add_diff_inverse less_imp_le_nat less_le_trans list.size(3) mset_append slice_append)
      subgoal by (metis mset_append)
      subgoal
        by (metis Misc.slice_len add_le_cancel_left drop_all drop_append_miracle leI le_add_diff_inverse)
      subgoal
        by (metis Misc.slice_def add_diff_cancel_left' append_assoc append_eq_conv_conj drop_slice drop_take drop_take_drop_unsplit)
      done

    corollary partition3_spec_alt': "partition3_spec xs l h = \<Down>({((xsi',m),(xs\<^sub>1,xs\<^sub>2)). (xsi',xs\<^sub>1@xs\<^sub>2)\<in>slice_rel xs l h \<and> m=l + length xs\<^sub>1 }) (doN { ASSERT (l\<le>h \<and> h\<le>length xs); partition1_spec (slice l h xs)})"
      unfolding partition3_spec_alt
      apply (auto simp: pw_eq_iff refine_pw_simps)
      done

    corollary partition3_spec_direct_refine: "\<lbrakk> h-l\<ge>4; (xsi,xs)\<in>slicep_rel l h \<rbrakk> \<Longrightarrow> partition3_spec xsi l h \<le> \<Down>({((xsi',m),(xs\<^sub>1,xs\<^sub>2)). (xsi',xs\<^sub>1@xs\<^sub>2)\<in>slice_rel xsi l h \<and> m=l + length xs\<^sub>1 }) (partition1_spec xs)"
      unfolding partition3_spec_alt'
      apply (auto simp: pw_le_iff refine_pw_simps)
      apply (auto simp: slicep_rel_def)
      done

    lemma slice_part_sorted_spec_alt: "slice_part_sorted_spec xsi l h = \<Down> (slice_rel xsi l h) (doN { ASSERT(l\<le>h \<and> h\<le>length xsi); SPEC (\<lambda>xs'. mset xs' = mset (slice l h xsi) \<and> part_sorted_wrt (le_by_lt (\<^bold><)) 16 xs') })"
      apply (clarsimp simp: slice_part_sorted_spec_def pw_eq_iff refine_pw_simps)
      apply (auto simp: slice_rel_alt  slicep_rel_def eq_outside_rane_lenD)
      done

    (* Extracted this subgoal to present it in paper *)
    lemma introsort_aux3_direct_refine_aux1': "(xs', xs\<^sub>1 @ xs\<^sub>2) \<in> slice_rel xs l h \<Longrightarrow> xs\<^sub>1 = slice l (l + length xs\<^sub>1) xs'"
      apply (clarsimp simp: slice_rel_def in_br_conv)
      by (metis Misc.slice_def add_diff_cancel_left' append.assoc append_eq_conv_conj append_take_drop_id)

    lemma introsort_aux3_direct_refine_aux1: "\<lbrakk>(xsi', xs\<^sub>1 @ xs\<^sub>2) \<in> slice_rel xsi l' h'\<rbrakk> \<Longrightarrow> (xsi', xs\<^sub>1) \<in> slicep_rel l' (l' + length xs\<^sub>1)"
      apply (simp add: slicep_rel_def introsort_aux3_direct_refine_aux1')
      apply (auto simp: slice_rel_alt slicep_rel_def)
      by (metis Misc.slice_len ab_semigroup_add_class.add_ac(1) le_add1 length_append ordered_cancel_comm_monoid_diff_class.add_diff_inverse)

    lemma introsort_aux3_direct_refine: "(xsi,xs)\<in>slicep_rel l h \<Longrightarrow> introsort_aux3 xsi l h d \<le> \<Down>(slice_rel xsi l h) (introsort_aux1 xs d)"
      unfolding introsort_aux3_def introsort_aux1_def

      supply [refine del] = RECT_refine

      supply recref = RECT_dep_refine[where
          R="\<lambda>_. {((xsi::'a list, l, h, di::nat), (xs, d)). (xsi, xs) \<in> slicep_rel l h \<and> di=d}" and
          S="\<lambda>_ (xsi::'a list, l, h, di::nat). slice_rel xsi l h" and
          arb\<^sub>0 = "()"
          ]

      apply (refine_rcg
        recref
        slice_sort_spec_refine_sort'
        partition3_spec_direct_refine
        ; (rule refl)?
        )

      subgoal by auto
      subgoal by auto
      subgoal by (auto simp: slicep_rel_def)
      subgoal by (auto simp: slicep_rel_def)
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      subgoal by auto
      apply (rprems)
      subgoal by (clarsimp simp: introsort_aux3_direct_refine_aux1)
      apply rprems
      subgoal
        apply (auto simp: slice_rel_alt slicep_rel_def)
        subgoal by (metis Misc.slice_def drop_append_miracle drop_slice eq_outside_range_def)
        subgoal by (metis Nat.add_diff_assoc Sorting_Misc.slice_len add_diff_cancel_left' add_le_cancel_left diff_add_zero diff_is_0_eq length_append)
        subgoal by (simp add: eq_outside_rane_lenD)
        done
      subgoal
        apply (clarsimp simp: slice_rel_alt idx_shift_rel_def)
        apply (rule conjI)
        subgoal
          apply (rule slicep_rel_append)
          apply (subst slicep_rel_eq_outside_range; assumption?)
          by auto
        subgoal
          apply (drule (1) eq_outside_range_gen_trans[OF _ _ refl refl])
          apply (erule (1) eq_outside_range_gen_trans)
          apply (auto simp: max_def algebra_simps slicep_rel_def split: if_splits)
          done
        done
      subgoal by (auto simp: slice_rel_alt eq_outside_range_triv slicep_rel_def)
      done

    definition "final_sort_spec xs l h \<equiv> doN {
      ASSERT (h-l>1 \<and> part_sorted_wrt (le_by_lt (\<^bold><)) is_threshold (slice l h xs));
      slice_sort_spec (\<^bold><) xs l h
      }"

    definition "introsort3 xs l h \<equiv> doN {
      ASSERT(l\<le>h);
      if h-l>1 then doN {
        xs \<leftarrow> slice_part_sorted_spec xs l h;
        xs \<leftarrow> final_sort_spec xs l h;
        RETURN xs
      } else RETURN xs
    }"

    lemma introsort3_correct: "introsort3 xs l h \<le> slice_sort_spec (\<^bold><) xs l h"
      apply (cases "l\<le>h \<and> h\<le>length xs")
      subgoal
        apply (cases "1<h-l")
        subgoal
          unfolding introsort3_def slice_part_sorted_spec_def final_sort_spec_def slice_sort_spec_alt
          by (auto simp: pw_le_iff refine_pw_simps eq_outside_rane_lenD elim: eq_outside_range_gen_trans[of _ _ l h _ l h l h, simplified])
        subgoal
          unfolding introsort3_def slice_sort_spec_alt slice_part_sorted_spec_def final_sort_spec_def
          by (simp add: eq_outside_range_triv sorted_wrt01)
        done
      subgoal
        unfolding slice_sort_spec_alt
        apply refine_vcg
        by simp
      done

  end

end


section \<open>Stamps: Type and Range Information\<close>

theory StampLattice
imports
  Values
  HOL.Lattices
begin

subsection \<open>Void Stamp\<close>
text \<open>
The VoidStamp represents a type with no associated values.
The VoidStamp lattice is therefore a simple single element lattice.
\<close>
datatype void =
  VoidStamp

instantiation void :: order
begin

definition less_eq_void :: "void \<Rightarrow> void \<Rightarrow> bool" where
  "less_eq_void a b = True"

definition less_void :: "void \<Rightarrow> void \<Rightarrow> bool" where
  "less_void a b = False"

instance
  apply standard
     apply (simp add: less_eq_void_def less_void_def)
    apply (simp add: less_eq_void_def)
   apply (simp add: less_eq_void_def)
  by (metis (full_types) void.exhaust)

end

instantiation void :: semilattice_inf
begin

definition inf_void :: "void \<Rightarrow> void \<Rightarrow> void" where
  "inf_void a b = VoidStamp"

instance
  apply standard
    apply (simp add: less_eq_void_def)
   apply (simp add: less_eq_void_def)
  by (metis (mono_tags) void.exhaust)

end

instantiation void :: semilattice_sup
begin

definition sup_void :: "void \<Rightarrow> void \<Rightarrow> void" where
  "sup_void a b = VoidStamp"

instance
  apply standard
    apply (simp add: less_eq_void_def)
   apply (simp add: less_eq_void_def)
  by (metis (mono_tags) void.exhaust)

end

instantiation void :: bounded_lattice
begin

definition bot_void :: "void" where
  "bot_void = VoidStamp"

definition top_void :: "void" where
  "top_void = VoidStamp"

instance
  apply standard
   apply (simp add: less_eq_void_def)
  by (simp add: less_eq_void_def)

end

text \<open>Definition of the stamp type\<close>
datatype stamp =
  intstamp int64 int64 \<comment>\<open>Type: Integer; Range: Lower Bound \& Upper Bound\<close>
(*
  | floatstamp \<comment>\<open>Type: Float; Range: Lower Bound \& Upper Bound\<close>
  | objectstamp classname \<comment>\<open>Type: Object Instance; Range: Upper Bound Superclass\<close>
*)

subsection \<open>Stamp Lattice\<close>

text_raw \<open>\input{lattice}\\\<close>

subsubsection \<open>Stamp Order\<close>
text \<open>
Defines an ordering on the stamp type.

One stamp is less than another if the valid values
for the stamp are a strict subset of the other stamp.
\<close>
instantiation stamp :: order
begin

fun less_eq_stamp :: "stamp \<Rightarrow> stamp \<Rightarrow> bool" where
  "less_eq_stamp (intstamp l1 u1) (intstamp l2 u2) = ({l1..u1} \<subseteq> {l2..u2})"

fun less_stamp :: "stamp \<Rightarrow> stamp \<Rightarrow> bool" where
  "less_stamp (intstamp l1 u1) (intstamp l2 u2) = ({l1..u1} \<subset> {l2..u2})"

lemma less_le_not_le:
  fixes x y :: stamp
  shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
  using less_eq_stamp.simps less_stamp.simps
  using stamp.exhaust subset_not_subset_eq by metis

lemma order_refl:
  fixes x :: stamp
  shows "x \<le> x"
  using less_eq_stamp.simps less_stamp.simps
  using dual_order.refl stamp.exhaust by metis

lemma order_trans:
  fixes x y z :: stamp
  shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
proof -
  fix x :: stamp and y :: stamp and z :: stamp
  assume "x \<le> y"
  assume "y \<le> z"
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust
    by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust
    by blast
  obtain l3 u3 where zdef: "z = intstamp l3 u3"
    using stamp.exhaust
    by blast
  have s1: "{l1..u1} \<le> {l2..u2}"
    using \<open>x \<le> y\<close> less_eq_stamp.simps xdef ydef by blast
  have s2: "{l2..u2} \<le> {l3..u3}"
    using \<open>y \<le> z\<close> less_eq_stamp.simps ydef zdef by blast
  from s1 s2 have "{l1..u1} \<le> {l3..u3}"
    by (meson dual_order.trans)
  then show "x \<le> z"
    using less_eq_stamp.simps
    using xdef zdef by presburger
qed

lemma antisym:
  fixes x y :: stamp
  shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
proof -
  fix x :: stamp
  fix y :: stamp
  assume xlessy: "x \<le> y"
  assume ylessx: "y \<le> x"
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast

  from xlessy have s1: "{l1..u1} \<subseteq> {l2..u2}"
    using less_eq_stamp.simps
    using xdef ydef by blast
  from ylessx have s2: "{l2..u2} \<subseteq> {l1..u1}"
    using less_eq_stamp.simps
    using xdef ydef by blast
  have "{l1..u1} \<subseteq> {l2..u2} \<Longrightarrow> {l2..u2} \<subseteq> {l1..u1} \<Longrightarrow> {l1..u1} = {l2..u2}"
    by fastforce
  then have s3: "{l1..u1} = {l2..u2} \<Longrightarrow> (l1 = l2) \<and> (u1 = u2)"
    (* not true *)
    (* consider:
       {1..0} = {-1..-1}
    *)
    sorry
  then have "(l1 = l2) \<and> (u1 = u2) \<Longrightarrow> x = y"
    using xdef ydef by fastforce
  then show "x = y"
    using s1 s2 s3 by fastforce
qed

instance
  apply standard
  using less_le_not_le apply simp
  using order_refl apply simp
  using order_trans apply simp
  using antisym by simp
end

subsubsection \<open>Stamp Join\<close>
text \<open>
Defines the @{emph \<open>join\<close>} operation for stamps.

For any two stamps, the @{emph \<open>join\<close>} is defined as the intersection
of the valid values for the stamp.
\<close>
instantiation stamp :: semilattice_inf
begin

notation inf (infix "\<sqinter>" 65)

fun inf_stamp :: "stamp \<Rightarrow> stamp \<Rightarrow> stamp" where
  "inf_stamp (intstamp l1 u1) (intstamp l2 u2) = intstamp (max l1 l2) (min u1 u2)"

lemma inf_le1:
  fixes x y :: stamp
  shows "(x \<sqinter> y) \<le> x"
proof -
  fix x :: stamp
  fix y :: stamp
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast
  have joindef: "x \<sqinter> y = intstamp (max l1 l2) (min u1 u2)"
    (is "?join = intstamp ?l3 ?u3")
    using inf_stamp.simps xdef ydef
    by force
  have leq: "{?l3..?u3} \<subseteq> {l1..u1}"
    by force
  have "(x \<sqinter> y) \<le> x = ({?l3..?u3} \<subseteq> {l1..u1})"
    using xdef joindef inf_stamp.simps
    by force
  then show "(x \<sqinter> y) \<le> x"
    using leq
    by fastforce
qed

lemma inf_le2:
  fixes x y :: stamp
  shows "(x \<sqinter> y) \<le> y"
proof -
  fix x :: stamp
  fix y :: stamp
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast
  have joindef: "x \<sqinter> y = intstamp (max l1 l2) (min u1 u2)"
    (is "?join = intstamp ?l3 ?u3")
    using inf_stamp.simps xdef ydef
    by force
  have leq: "{?l3..?u3} \<subseteq> {l2..u2}"
    by force
  have "(x \<sqinter> y) \<le> y = ({?l3..?u3} \<subseteq> {l2..u2})"
    using ydef joindef
    by force
  then show "(x \<sqinter> y) \<le> y"
    using leq
    by fastforce
qed

lemma inf_greatest:
  fixes x y z :: stamp
  shows "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> (y \<sqinter> z)"
proof -
  fix x y z :: stamp
  assume xlessy: "x \<le> y"
  assume xlessz: "x \<le> z"
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast
  obtain l3 u3 where zdef: "z = intstamp l3 u3"
    using stamp.exhaust by blast
  obtain l4 u4 where yzdef: "y \<sqinter> z = intstamp l4 u4"
    by (meson inf_stamp.elims)
  have max4: "l4 = max l2 l3"
    using yzdef ydef zdef inf_stamp.simps by simp
  have min4: "u4 = min u2 u3"
    using yzdef ydef zdef inf_stamp.simps by simp
  have "{l1..u1} \<subseteq> {l2..u2}"
    using xlessy xdef ydef
    using less_eq_stamp.simps by blast
  have "{l1..u1} \<subseteq> {l3..u3}"
    using xlessz xdef zdef
    using less_eq_stamp.simps by blast
  have leq: "{l1..u1} \<subseteq> {l4..u4}"
    using \<open>{l1..u1} \<subseteq> {l2..u2}\<close> \<open>{l1..u1} \<subseteq> {l3..u3}\<close> max4 min4 by auto
  have "x \<le> (y \<sqinter> z) = ({l1..u1} \<subseteq> {l4..u4})"
    by (simp add: xdef yzdef)
  then show "x \<le> (y \<sqinter> z)"
    using leq
    by fastforce
qed

instance
  apply standard
  using inf_le1 apply simp
  using inf_le2 apply simp
  using inf_greatest by simp
end

subsubsection \<open>Stamp Meet\<close>
text \<open>
Defines the @{emph \<open>meet\<close>} operation for stamps.

For any two stamps, the @{emph \<open>meet\<close>} is defined as the union
of the valid values for the stamp.
\<close>
instantiation stamp :: semilattice_sup
begin

notation sup (infix "\<squnion>" 65)

fun sup_stamp :: "stamp \<Rightarrow> stamp \<Rightarrow> stamp" where
  "sup_stamp (intstamp l1 u1) (intstamp l2 u2) = intstamp (min l1 l2) (max u1 u2)"

lemma sup_ge1:
  fixes x y :: stamp
  shows "x \<le> x \<squnion> y"
proof -
  fix x :: stamp
  fix y :: stamp
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast
  have joindef: "x \<squnion> y = intstamp (min l1 l2) (max u1 u2)"
    (is "?join = intstamp ?l3 ?u3")
    using inf_stamp.simps xdef ydef
    by force
  have leq: "{l1..u1} \<subseteq> {?l3..?u3}"
    by simp
  have "x \<le> x \<squnion> y = ({l1..u1} \<subseteq> {?l3..?u3})"
    using xdef joindef inf_stamp.simps
    by force
  then show "x \<le> x \<squnion> y"
    using leq
    by fastforce
qed

lemma sup_ge2:
  fixes x y :: stamp
  shows "y \<le> x \<squnion> y"
proof -
  fix x :: stamp
  fix y :: stamp
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast
  have joindef: "x \<squnion> y = intstamp (min l1 l2) (max u1 u2)"
    (is "?join = intstamp ?l3 ?u3")
    using inf_stamp.simps xdef ydef
    by force
  have leq: "{l2..u2} \<subseteq> {?l3..?u3}" (is "?subset_thesis")
    by simp
  have "?thesis = (?subset_thesis)"
    using ydef joindef sup_stamp.simps less_eq_stamp.simps
    by (metis StampLattice.sup_ge1 max.commute min.commute sup_stamp.elims)
  then show "?thesis"
    using leq
    by fastforce
qed

lemma sup_least:
  fixes x y z :: stamp
  shows "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> ((y \<squnion> z) \<le> x)"
proof -
  fix x y z :: stamp
  assume xlessy: "y \<le> x"
  assume xlessz: "z \<le> x"
  obtain l1 u1 where xdef: "x = intstamp l1 u1"
    using stamp.exhaust by blast
  obtain l2 u2 where ydef: "y = intstamp l2 u2"
    using stamp.exhaust by blast
  obtain l3 u3 where zdef: "z = intstamp l3 u3"
    using stamp.exhaust by blast
  have yzdef: "y \<squnion> z = intstamp (min l2 l3) (max u2 u3)"
    (is "?meet = intstamp ?l4 ?u4")
    using sup_stamp.simps
    by (simp add: ydef zdef)
  have s1: "{l2..u2} \<subseteq> {l1..u1}"
    using xlessy xdef ydef
    using less_eq_stamp.simps by blast
  have s2: "{l3..u3} \<subseteq> {l1..u1}"
    using xlessz xdef zdef
    using less_eq_stamp.simps by blast
  have leq: "{?l4..?u4} \<subseteq> {l1..u1}" (is ?subset_thesis)
    using s1 s2 unfolding atLeastatMost_subset_iff
    (* why is this such a hard proof? *)
    by (metis (no_types, opaque_lifting) inf.orderE inf_stamp.simps max.bounded_iff max.cobounded2 min.bounded_iff min.cobounded2 stamp.inject xdef xlessy xlessz ydef zdef)
  have "(y \<squnion> z \<le> x) = ?subset_thesis"
    using yzdef xdef less_eq_stamp.simps
    by simp
  then show "(y \<squnion> z \<le> x)"
    using leq by fastforce
qed

instance
  apply standard
  using sup_ge1 apply simp
  using sup_ge2 apply simp
  using sup_least by simp
end

subsubsection \<open>Stamp Bounds\<close>
text \<open>
Defines the top and bottom elements of the stamp lattice.

This poses an interesting question as our stamp type is a
union of the various @{emph \<open>Stamp\<close>} subclasses, e.g.
@{emph \<open>IntegerStamp\<close>}, @{emph \<open>ObjectStamp\<close>}, etc.

Each subclass should preferably have its own unique
top and bottom element, i.e. An @{emph \<open>IntegerStamp\<close>}
would have the top element of the full range of integers
allowed by the bit width and a bottom of a range with no integers.
While the @{emph \<open>ObjectStamp\<close>} should have @{emph \<open>Object\<close>}
as the top and @{emph \<open>Void\<close>} as the bottom element.
\<close>
instantiation stamp :: bounded_lattice
begin

notation bot ("\<bottom>" 50)
notation top ("\<top>" 50)

definition width_min :: "nat \<Rightarrow> int64" where
  "width_min bits = -(2^(bits-1))"

definition width_max :: "nat \<Rightarrow> int64" where
  "width_max bits = (2^(bits-1)) - 1"

value "(sint (width_min 64), sint (width_max 64))"
value "max_word::int64"

lemma
  assumes "x = width_min 64"
  assumes "y = width_max 64"
  shows "sint x < sint y"
  using assms unfolding width_min_def width_max_def by simp

text \<open>
Note that this definition is valid for unsigned integers only.

The bottom and top element for signed integers would be
(- 9223372036854775808, 9223372036854775807).

For unsigned we have
(0, 18446744073709551615).

For Java we are likely to be more concerned with signed integers.
To use the appropriate bottom and top for signed integers we
would need to change our definition of less\_eq from
{l1..u1} <= {l2..u2}
to
{sint l1..sint u1} <= {sint l2..sint u2}

We may still find an unsigned integer stamp useful.
I plan to investigate the Java code to see if this is useful
and then apply the changes to switch to signed integers.
\<close>
definition "bot_stamp = intstamp (-1) 0"
definition "top_stamp = intstamp 0 (-1)"

lemma bot_least:
  fixes a :: stamp
  shows "(\<bottom>) \<le> a"
proof -
  obtain min max where bot_def:"\<bottom> = intstamp max min"
    using bot_stamp_def
    by force
  have "min < max"
    using bot_def
    unfolding bot_stamp_def width_min_def width_max_def
    using word_gt_0 by fastforce
  then have "{max..min} = {}"
    using bot_def
    unfolding bot_stamp_def width_min_def width_max_def
    by auto
  then show ?thesis
    unfolding bot_stamp_def
    using less_eq_stamp.simps
    by (simp add: stamp.induct)
qed

lemma top_greatest:
  fixes a :: stamp
  shows "a \<le> (\<top>)"
proof -
  obtain min max where top_def:"\<top> = intstamp min max"
    using top_stamp_def
    by force
  have max_is_max: "\<not>(\<exists> n. n > max)"
    by (metis stamp.inject top_def top_stamp_def word_order.extremum_strict)
  have min_is_min: "\<not>(\<exists> n. n < min)"
    by (metis not_less_iff_gr_or_eq stamp.inject top_def top_stamp_def word_coorder.not_eq_extremum)
  have "\<not>(\<exists> l u. {min..max} < {l..u})"
    using max_is_max min_is_min
    by (metis atLeastatMost_psubset_iff not_less)
  then show ?thesis
    unfolding top_stamp_def
    using less_eq_stamp.simps
    using less_eq_stamp.elims(3) by fastforce
qed

instance
  apply standard
  using bot_least apply simp
  using top_greatest by simp
end

subsection \<open>Java Stamp Methods\<close>
text \<open>
The following are methods from the Java Stamp class,
they are the methods primarily used for optimizations.
\<close>
definition is_unrestricted :: "stamp \<Rightarrow> bool" where
  "is_unrestricted s = (\<top> = s)"

fun is_empty :: "stamp \<Rightarrow> bool" where
  "is_empty s = (\<bottom> = s)"

fun as_constant :: "stamp \<Rightarrow> Value option" where
  "as_constant (intstamp l u) = (if (card {l..u}) = 1
    then Some (IntVal 64 (SOME x. x \<in> {l..u}))
    else None)"

definition always_distinct :: "stamp \<Rightarrow> stamp \<Rightarrow> bool" where
  "always_distinct stamp1 stamp2 = (\<bottom> = (stamp1 \<sqinter> stamp2))"

definition never_distinct :: "stamp \<Rightarrow> stamp \<Rightarrow> bool" where
  "never_distinct stamp1 stamp2 =
    (as_constant stamp1 = as_constant stamp2 \<and> as_constant stamp1 \<noteq> None)"

subsection \<open>Mapping to Values\<close>
fun valid_value :: "stamp => Value => bool" where
  "valid_value (intstamp l u) (IntVal b v) = (v \<in> {l..u})" |
  "valid_value (intstamp l u) _ = False"

text \<open>
The @{const valid_value} function is used to map a stamp instance
to the values that are allowed by the stamp.

It would be nice if there was a slightly more integrated way
to perform this mapping as it requires some infrastructure
to prove some fairly simple properties.
\<close>
lemma bottom_range_empty:
  "\<not>(valid_value (\<bottom>) v)"
  unfolding bot_stamp_def
  using valid_value.elims(2) by fastforce

lemma join_values:
  assumes "joined = x_stamp \<sqinter> y_stamp"
  shows "valid_value joined x \<longleftrightarrow> (valid_value x_stamp x \<and> valid_value y_stamp x)"
proof (cases x)
  case UndefVal
  then show ?thesis
    using valid_value.elims(2) by blast
(* WAS:
next
  case (IntVal32 x2)
  then show ?thesis
    using valid_value.elims(2) by blast
*)
next
  case (IntVal b x3)
  obtain lx ux where xdef: "x_stamp = intstamp lx ux"
    using stamp.exhaust by blast
  obtain ly uy where ydef: "y_stamp = intstamp ly uy"
    using stamp.exhaust by blast
  obtain v where "x = IntVal b v"
    using IntVal by blast
  have "joined = intstamp (max lx ly) (min ux uy)"
    (is "joined = intstamp ?lj ?uj")
    by (simp add: xdef ydef assms)
  then have "valid_value joined (IntVal b v) = (v \<in> {?lj..?uj})"
    by simp
  then show ?thesis
    using \<open>x = IntVal b v\<close> xdef ydef by force
next
  case (ObjRef x5)
  then show ?thesis
    using valid_value.elims(2) by blast
next
  case (ObjStr x6)
  then show ?thesis
    using valid_value.elims(2) by blast
qed

lemma disjoint_empty:
  fixes x_stamp y_stamp :: stamp
  assumes "\<bottom> = x_stamp \<sqinter> y_stamp"
  shows "\<not>(valid_value x_stamp x \<and> valid_value y_stamp x)"
  using assms bottom_range_empty join_values
  by blast

experiment begin
text \<open>A possible equivalent alternative to the definition of less\_eq\<close>
fun less_eq_alt :: "'a::ord \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where
  "less_eq_alt (l1, u1) (l2, u2) = ((\<not> l1 \<le> u1) \<or> l2 \<le> l1 \<and> u1 \<le> u2)"

text \<open>Proof equivalence\<close>
lemma
  fixes l1 l2 u1 u2 :: int
  assumes "l1 \<le> u1 \<and> l2 \<le> u2"
  shows "{l1..u1} \<subseteq> {l2..u2} = ((l1 \<ge> l2) \<and> (u1 \<le> u2))"
  by (simp add: assms)

lemma
  fixes l1 l2 u1 u2 :: int
  shows "{l1..u1} \<subseteq> {l2..u2} = less_eq_alt (l1, u1) (l2, u2)"
  by simp
end

subsection \<open>Generic Integer Stamp\<close>

text \<open>
Experimental definition of integer stamps generically,
restricting the datatype to only allow valid ranges and
the bottom integer element (max\_int..min\_int).
\<close>

lemma
  assumes "(x::int) > 0"
  shows "(2 ^ x)/2 = (2 ^ (x - 1))"
  sorry

definition max_signed_int :: "'a::len word" where
  "max_signed_int = (2 ^ (LENGTH('a) - 1)) - 1"

definition min_signed_int :: "'a::len word" where
  "min_signed_int = -(2 ^ (LENGTH('a) - 1))"

definition int_bottom :: "'a::len word \<times> 'a word" where
  "int_bottom = (max_signed_int, min_signed_int)"

definition int_top :: "'a::len word \<times> 'a word" where
  "int_top = (min_signed_int, max_signed_int)"

(*
definition signed_gt_eq :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> bool" where
  "signed_gt_eq a b = (sint a \<ge> sint a)"

definition signed_gt :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> bool" where
  "signed_gt a b = (sint a > sint a)"

interpretation wor: ordering_top \<open>signed_gt_eq\<close> \<open>signed_gt\<close> \<open>max_signed_int :: 'a::len word\<close>
  apply (standard) sledgehammer
*)

lemma
  fixes x :: "'a::len word"
  shows "sint x \<le> sint (((2 ^ (LENGTH('a) - 1)) - 1)::'a word)"
  using sint_greater_eq sorry (*
  by (smt (z3) Euclidean_Division.pos_mod_bound int_word_sint sint_0 sint_lt two_less_eq_exp_length word_of_int_2p_len)
  *)

(* helpful: sint_greater_eq *)
value "sint (0::1 word)"
value "sint (1::1 word)"
value "sint (((2 ^ 0) - 1)::1 word)"

value "sint (((2 ^ 31) - 1)::32 word)"

lemma max_signed:
  fixes a :: "'a::len word"
  shows "sint a \<le> sint (max_signed_int::'a word)"
proof (cases "sint a = sint (max_signed_int::'a word)")
  case True
  then show ?thesis by simp
next
  case False
  have "sint a < sint (max_signed_int::'a word)"
    using False unfolding max_signed_int_def sorry
  then show ?thesis by simp
qed

lemma min_signed:
  fixes a :: "'a::len word"
  shows "sint a \<ge> sint (min_signed_int::'a word)"
  sorry

value "max_signed_int :: 32 word"
value "int_bottom::(32 word \<times> 32 word)"
value "sint (2147483647::32 word)"
value "sint (2147483648::32 word)"

typedef (overloaded) ('a::len) intstamp =
  "{bounds :: ('a word, 'a word) prod . ((fst bounds) \<le>s (snd bounds) \<or> bounds = int_bottom)}"
proof -
  show ?thesis
    by (smt (z3) mem_Collect_eq prod.sel(1) prod.sel(2) signed_minus_1 sint_0)
qed

setup_lifting type_definition_intstamp

lift_definition lower :: "('a::len) intstamp \<Rightarrow> 'a word"
  is "prod.fst \<circ> Rep_intstamp" .

lift_definition upper :: "('a::len) intstamp \<Rightarrow> 'a word"
  is "prod.snd \<circ> Rep_intstamp" .

lift_definition lower_int :: "('a::len) intstamp \<Rightarrow> int"
  is "sint \<circ> prod.fst" .

lift_definition upper_int :: "('a::len) intstamp \<Rightarrow> int"
  is "sint \<circ> prod.snd" .

lift_definition range :: "('a::len) intstamp \<Rightarrow> int set"
  is "\<lambda> (l, u). {sint l..sint u}" .

lift_definition bounds :: "('a::len) intstamp \<Rightarrow> ('a word \<times> 'a word)"
  is Rep_intstamp .

lift_definition is_bottom :: "('a::len) intstamp \<Rightarrow> bool"
  is "\<lambda> x. x = int_bottom" .

lift_definition from_bounds :: "('a::len word \<times> 'a word) \<Rightarrow> 'a intstamp"
  is "Abs_intstamp" .

instantiation intstamp :: (len) order
begin

definition less_eq_intstamp :: "'a intstamp \<Rightarrow> 'a intstamp \<Rightarrow> bool" where
  "less_eq_intstamp s1 s2 = (range s1 \<subseteq> range s2)"

definition less_intstamp :: "'a intstamp \<Rightarrow> 'a intstamp \<Rightarrow> bool" where
  "less_intstamp s1 s2 = (range s1 \<subset> range s2)"

value "int_bottom::(1 word \<times> 1 word)"
value "sint (0::1 word)"
value "sint (1::1 word)"

value "int_bottom::(2 word \<times> 2 word)"
value "sint (1::2 word)"
value "sint (2::2 word)"
value "sint ((2 ^ (LENGTH(32) - 1) - 1)::32 word) > sint ((- (2 ^ (LENGTH(32) - 1)))::32 word)"

lemma bottom_is_bottom:
  assumes "is_bottom s"
  shows "s \<le> a"
proof -
  have boundsdef: "bounds s = int_bottom"
    by (metis assms bounds.transfer is_bottom.rep_eq)
  obtain min max where "bounds s = (max, min)"
    by fastforce
  then have "max \<noteq> min"
    by (metis boundsdef dual_order.eq_iff fst_conv int_bottom_def less_minus_one_simps(1) max_signed min_signed not_less sint_0 sint_n1 snd_conv)
  then have "sint min < sint max"
    unfolding boundsdef int_bottom_def
    using max_signed
    by (metis \<open>bounds s = (max, min)\<close> boundsdef int_bottom_def order.not_eq_order_implies_strict prod.sel(1) signed_word_eqI)
  then have "range s = {}"
    unfolding range_def bounds_def
    by (simp add: \<open>bounds s = (max, min)\<close> bounds.transfer)
  then show ?thesis
    by (simp add: StampLattice.less_eq_intstamp_def)
qed

lemma bounds_has_value:
  fixes x y :: int
  assumes "x < y"
  shows "card {x..y} > 0"
  using assms by auto

lemma bounds_has_no_value:
  fixes x y :: int
  assumes "x < y"
  shows "card {y..x} = 0"
  using assms by auto

lemma bottom_unique:
  fixes a s :: "'a intstamp"
  assumes "is_bottom s"
  shows "a \<le> s \<longleftrightarrow> is_bottom a"
proof -
  have "\<forall>x. sint (fst (bounds x)) \<le> sint (snd (bounds x)) \<or> is_bottom x"
    unfolding bounds_def is_bottom_def
    using Rep_intstamp
    using word_sle_eq by auto
  then have "\<forall>x. (card (range x)) > 0 \<or> is_bottom x"
    unfolding range_def using bounds_has_value
    by (simp add: bounds.transfer case_prod_beta)
  obtain min max where boundsdef: "bounds s = (max, min)"
    by fastforce
  have nooverlap: "sint min < sint max"
    using max_signed
    by (metis assms bounds.transfer boundsdef fst_conv int_bottom_def is_bottom.rep_eq min_signed order.not_eq_order_implies_strict signed_word_eqI sint_0 snd_conv verit_la_disequality zero_neq_one)
  have "range s = {sint max..sint min}"
    by (simp add: bounds.transfer boundsdef range.rep_eq)
  then have "card (range s) = 0"
    using nooverlap bounds_has_no_value by simp
  then have "\<forall>x. (card (range x)) > 0 \<longrightarrow> s < x"
    using \<open>StampLattice.range s = {sint max..sint min}\<close> atLeastatMost_empty less_intstamp_def by auto
  then show ?thesis
    by (meson \<open>\<forall>x. 0 < card (StampLattice.range x) \<or> is_bottom x\<close> bottom_is_bottom leD less_eq_intstamp_def less_intstamp_def)
qed

lemma bottom_antisym:
  assumes "is_bottom x"
  shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  using assms proof (cases "is_bottom y")
case True
  then show ?thesis
    by (metis Rep_intstamp_inverse assms is_bottom.rep_eq)
next
  case False
  assume "y \<le> x"
  have "\<not>(y \<le> x)"
    using bottom_unique False assms
    by simp
  then show ?thesis
    using \<open>y \<le> x\<close> by auto
qed

lemma int_antisym:
  fixes x y :: "'a intstamp"
  shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
proof -
  fix x :: "'a intstamp"
  fix y :: "'a intstamp"
  assume xlessy: "x \<le> y"
  assume ylessx: "y \<le> x"
  obtain l1 u1 where xdef: "bounds x = (l1, u1)"
    by fastforce
  obtain l2 u2 where ydef: "bounds y = (l2, u2)"
    by fastforce

  from xlessy have s1: "{sint l1..sint u1} \<subseteq> {sint l2..sint u2}" (is "?xlessy")
    using xdef ydef unfolding bounds_def range_def less_eq_intstamp_def
    by simp
  from ylessx have s2: "{sint l2..sint u2} \<subseteq> {sint l1..sint u1}" (is "?ylessx")
    using xdef ydef unfolding bounds_def range_def less_eq_intstamp_def
    by simp
  show "x = y" proof (cases "is_bottom x")
    case True
    then show ?thesis using bottom_antisym xlessy ylessx
      by simp
  next
    case False
    then show ?thesis sorry
  qed
qed

instance
  apply standard
     apply (simp add: less_eq_intstamp_def less_intstamp_def less_le_not_le)
  apply blast
  using less_eq_intstamp_def apply force
  using less_eq_intstamp_def apply force
  by (simp add: int_antisym)
end

value "take_bit LENGTH(63) 20::int"
value "take_bit LENGTH(63) ((-20)::int)"
value "bit (20::int64) (63::nat)"
value "bit ((-20)::int64) (63::nat)"

value "((-20)::int64) < (20::int64)"

value "take_bit LENGTH(63) ((-20)::int)"

lift_definition smax :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda> a b. (if (sint a) \<le> (sint b) then b else a)" .

lift_definition smin :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda> a b. (if (sint a) \<le> (sint b) then a else b)" .

instantiation intstamp :: (len) semilattice_inf
begin

notation inf (infix "\<sqinter>" 65)

definition join_bounds :: "'a intstamp \<Rightarrow> 'a intstamp \<Rightarrow> ('a word \<times> 'a word)" where
  "join_bounds s1 s2 = (smax (lower s1) (lower s2), smin (upper s1) (upper s2))"

definition join_or_bottom :: "'a intstamp \<Rightarrow> 'a intstamp \<Rightarrow> ('a word \<times> 'a word)" where
  "join_or_bottom s1 s2 = (let bound = (join_bounds s1 s2) in
    if sint (fst bound) \<ge> sint (snd bound) then int_bottom else bound)"

definition inf_intstamp :: "'a intstamp \<Rightarrow> 'a intstamp \<Rightarrow> 'a intstamp" where
  "inf_intstamp s1 s2 = from_bounds (join_or_bottom s1 s2)"

lemma always_valid:
  fixes s1 s2 :: "'a intstamp"
  shows "Rep_intstamp (from_bounds (join_or_bottom s1 s2)) = join_or_bottom s1 s2"
  unfolding join_or_bottom_def join_bounds_def from_bounds_def
  using Abs_intstamp_inverse
  by (smt (z3) from_bounds.transfer from_bounds_def mem_Collect_eq word_sle_eq)

lemma invalid_join:
  fixes s1 s2 :: "'a intstamp"
  assumes "bound = join_bounds s1 s2"
  assumes "sint (fst bound) \<ge> sint (snd bound)"
  shows "from_bounds int_bottom = s1 \<sqinter> s2"
  using assms(1) assms(2) inf_intstamp_def join_or_bottom_def by presburger

lemma unfold_bounds:
  "bounds x = (lower x, upper x)"
  by (simp add: bounds.transfer lower.rep_eq upper.rep_eq)

lemma int_inf_le1:
  fixes x y :: "'a intstamp"
  shows "(x \<sqinter> y) \<le> x"
proof (cases "is_bottom (x \<sqinter> y)")
  case True
  then show ?thesis
    by (simp add: bottom_is_bottom)
next
  case False
  then show ?thesis
  using False proof -
  obtain l1 u1 where xdef: "lower x = l1 \<and> upper x = u1"
    by fastforce
  obtain l2 u2 where ydef: "lower y = l2 \<and> upper y = u2"
    by fastforce
  have joindef: "x \<sqinter> y = from_bounds ((smax l1 l2, smin u1 u2))"
    (is "x \<sqinter> y = from_bounds (?l3, ?u3)")
    using False
    by (smt (z3) StampLattice.inf_intstamp_def StampLattice.join_bounds_def always_valid is_bottom.rep_eq join_or_bottom_def xdef ydef)
  have leq: "{sint ?l3..sint ?u3} \<subseteq> {sint l1..sint u1}"
    by (smt (z3) atLeastatMost_subset_iff smax.transfer smin.transfer)
  have "(x \<sqinter> y) \<le> x = ({sint ?l3..sint ?u3} \<subseteq> {sint l1..sint u1})"
    using xdef joindef range_def less_eq_intstamp_def
    by (smt (z3) False StampLattice.always_valid StampLattice.join_or_bottom_def bounds.abs_eq case_prod_conv inf_intstamp_def is_bottom.rep_eq join_bounds_def range.rep_eq unfold_bounds ydef)
  then show "(x \<sqinter> y) \<le> x"
    using leq
    by fastforce
qed
qed

lemma int_inf_le2:
  fixes x y :: "'a intstamp"
  shows "(x \<sqinter> y) \<le> y"
proof (cases "is_bottom (x \<sqinter> y)")
  case True
  then show ?thesis
    by (simp add: bottom_is_bottom)
next
  case False
  then show ?thesis
  using False proof -
  obtain l1 u1 where xdef: "lower x = l1 \<and> upper x = u1"
    by fastforce
  obtain l2 u2 where ydef: "lower y = l2 \<and> upper y = u2"
    by fastforce
  have joindef: "x \<sqinter> y = from_bounds ((smax l1 l2, smin u1 u2))"
    (is "x \<sqinter> y = from_bounds (?l3, ?u3)")
    using False
    by (smt (z3) StampLattice.inf_intstamp_def StampLattice.join_bounds_def always_valid is_bottom.rep_eq join_or_bottom_def xdef ydef)
  have leq: "{sint ?l3..sint ?u3} \<subseteq> {sint l1..sint u1}"
    by (smt (z3) atLeastatMost_subset_iff smax.transfer smin.transfer)
  have "(x \<sqinter> y) \<le> y = ({sint ?l3..sint ?u3} \<subseteq> {sint l2..sint u2})"
    using xdef joindef range_def less_eq_intstamp_def
    by (smt (z3) False StampLattice.always_valid StampLattice.join_or_bottom_def bounds.abs_eq case_prod_conv inf_intstamp_def is_bottom.rep_eq join_bounds_def range.rep_eq unfold_bounds ydef)
  then show "(x \<sqinter> y) \<le> y"
    using leq
    by (smt (z3) atLeastatMost_subset_iff smax.transfer smin.transfer)
qed
qed

lemma
  assumes "x \<le> y"
  assumes "is_bottom y"
  shows "is_bottom x"
  using bottom_is_bottom assms
  using bottom_unique by auto

lemma int_inf_greatest:
  fixes x y :: "'a intstamp"
  shows "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
  sorry

instance
  apply standard
    apply (simp add: local.int_inf_le1)
   apply (simp add: local.int_inf_le2)
  by (simp add: local.int_inf_greatest)

end

instantiation intstamp :: (len) semilattice_sup
begin

notation sup (infix "\<squnion>" 65)

instance sorry

end

instantiation intstamp :: (len) bounded_lattice
begin

notation bot ("\<bottom>" 50)
notation top ("\<top>" 50)

definition "bot_intstamp = int_bottom"
definition "top_intstamp = int_top"

instance sorry

end

value "sint (0::1 word)"
value "sint (1::1 word)"

datatype Stamp =
  BottomStamp |
  TopStamp |
  VoidStamp |
  (*Int1Stamp "1 uintstamp" |*)
  Int8Stamp "8 intstamp" |
  Int16Stamp "16 intstamp" |
  Int32Stamp "32 intstamp" |
  Int64Stamp "64 intstamp"

instantiation Stamp :: order
begin

fun less_eq_Stamp :: "Stamp \<Rightarrow> Stamp \<Rightarrow> bool" where
  "less_eq_Stamp BottomStamp _ = True" |
  "less_eq_Stamp _ TopStamp = True" |
  "less_eq_Stamp VoidStamp VoidStamp = True" |
  "less_eq_Stamp (Int8Stamp v1) (Int8Stamp v2) = (v1 \<le> v2)" |
  "less_eq_Stamp (Int16Stamp v1) (Int16Stamp v2) = (v1 \<le> v2)" |
  "less_eq_Stamp (Int32Stamp v1) (Int32Stamp v2) = (v1 \<le> v2)" |
  "less_eq_Stamp (Int64Stamp v1) (Int64Stamp v2) = (v1 \<le> v2)" |
  "less_eq_Stamp _ _ = False"

fun less_Stamp :: "Stamp \<Rightarrow> Stamp \<Rightarrow> bool" where
  "less_Stamp BottomStamp BottomStamp = False" |
  "less_Stamp BottomStamp _ = True" |
  "less_Stamp TopStamp TopStamp = False" |
  "less_Stamp _ TopStamp = True" |
  "less_Stamp VoidStamp VoidStamp = False" |
  "less_Stamp (Int8Stamp v1) (Int8Stamp v2) = (v1 < v2)" |
  "less_Stamp (Int16Stamp v1) (Int16Stamp v2) = (v1 < v2)" |
  "less_Stamp (Int32Stamp v1) (Int32Stamp v2) = (v1 < v2)" |
  "less_Stamp (Int64Stamp v1) (Int64Stamp v2) = (v1 < v2)" |
  "less_Stamp _ _ = False"

instance
  apply standard sorry
end

instantiation Stamp :: semilattice_inf
begin

notation inf (infix "\<sqinter>" 65)

fun inf_Stamp :: "Stamp \<Rightarrow> Stamp \<Rightarrow> Stamp" where
  "inf_Stamp BottomStamp _ = BottomStamp" |
  "inf_Stamp _ BottomStamp = BottomStamp" |
  "inf_Stamp TopStamp _ = TopStamp" |
  "inf_Stamp _ TopStamp = TopStamp" |
  "inf_Stamp VoidStamp VoidStamp = VoidStamp" |
  "inf_Stamp (Int8Stamp v1) (Int8Stamp v2) = Int8Stamp (v1 \<sqinter> v2)" |
  "inf_Stamp (Int16Stamp v1) (Int16Stamp v2) = Int16Stamp (v1 \<sqinter> v2)" |
  "inf_Stamp (Int32Stamp v1) (Int32Stamp v2) = Int32Stamp (v1 \<sqinter> v2)" |
  "inf_Stamp (Int64Stamp v1) (Int64Stamp v2) = Int64Stamp (v1 \<sqinter> v2)"

instance
  apply standard sorry
end

instantiation Stamp :: semilattice_sup
begin

notation sup (infix "\<squnion>" 65)

fun sup_Stamp :: "Stamp \<Rightarrow> Stamp \<Rightarrow> Stamp" where
  "sup_Stamp BottomStamp _ = BottomStamp" |
  "sup_Stamp _ BottomStamp = BottomStamp" |
  "sup_Stamp TopStamp _ = TopStamp" |
  "sup_Stamp _ TopStamp = TopStamp" |
  "sup_Stamp VoidStamp VoidStamp = VoidStamp" |
  "sup_Stamp (Int8Stamp v1) (Int8Stamp v2) = Int8Stamp (v1 \<squnion> v2)" |
  "sup_Stamp (Int16Stamp v1) (Int16Stamp v2) = Int16Stamp (v1 \<squnion> v2)" |
  "sup_Stamp (Int32Stamp v1) (Int32Stamp v2) = Int32Stamp (v1 \<squnion> v2)" |
  "sup_Stamp (Int64Stamp v1) (Int64Stamp v2) = Int64Stamp (v1 \<squnion> v2)"

instance
  apply standard sorry
end

instantiation Stamp :: bounded_lattice
begin

notation bot ("\<bottom>" 50)
notation top ("\<top>" 50)

definition top_Stamp :: "Stamp" where
  "top_Stamp = TopStamp"
definition bot_Stamp :: "Stamp" where
  "bot_Stamp = BottomStamp"

instance
  apply standard sorry
end

code_datatype Abs_intstamp
(*
value "Int32Stamp (from_bounds (2::32 word, 5::32 word)) \<sqinter> Int32Stamp (from_bounds (2::32 word, 5::32 word))"
*)
end