(* Title: Examples/TTS_Foundations/Orders/Type_Simple_Orders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Abstract orders on types\<close>
theory Type_Simple_Orders
  imports
    "../Foundations/FNDS_Definite_Description"
    FNDS_Auxiliary
begin

subsection\<open>Background\<close>

text\<open>
The results presented in this section were ported
(with amendments and additions) from the theories \<^text>\<open>Orderings\<close>
and \<^text>\<open>Set_Interval\<close> in the main library of Isabelle/HOL.
\<close>

subsection\<open>Order operations\<close>

text\<open>Abstract order operations.\<close>

locale ord =
  fixes le ls :: "['a, 'a] \<Rightarrow> bool"

locale ord_syntax = ord le ls for le ls :: "['a, 'a] \<Rightarrow> bool"
begin

notation
  le ("'(\<le>\<^sub>a')") and
  le (infix "\<le>\<^sub>a" 50) and
  ls ("'(<\<^sub>a')") and
  ls (infix "<\<^sub>a" 50)

abbreviation (input) ge (infix "\<ge>\<^sub>a" 50)
  where "x \<ge>\<^sub>a y \<equiv> y \<le>\<^sub>a x"
abbreviation (input) gt (infix ">\<^sub>a" 50)
  where "x >\<^sub>a y \<equiv> y <\<^sub>a x"

notation
  ge ("'(\<ge>\<^sub>a')") and
  ge (infix "\<ge>\<^sub>a" 50) and
  gt ("'(>\<^sub>a')") and
  gt (infix ">\<^sub>a" 50)

end

locale ord_dual = ord le ls for le ls :: "['a, 'a] \<Rightarrow> bool"
begin

interpretation ord_syntax .
sublocale dual: ord ge gt .

end

text\<open>Pairs.\<close>

locale ord_pair = ord\<^sub>a: ord le\<^sub>a ls\<^sub>a + ord\<^sub>b: ord le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

sublocale rev: ord_pair le\<^sub>b ls\<^sub>b le\<^sub>a ls\<^sub>a .

end

locale ord_pair_syntax = ord_pair le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

sublocale ord\<^sub>a: ord_syntax le\<^sub>a ls\<^sub>a + ord\<^sub>b: ord_syntax le\<^sub>b ls\<^sub>b .

notation le\<^sub>a (\<open>'(\<le>\<^sub>a')\<close>)
  and le\<^sub>a (infix \<open>\<le>\<^sub>a\<close> 50)
  and ls\<^sub>a (\<open>'(<\<^sub>a')\<close>)
  and ls\<^sub>a (infix \<open><\<^sub>a\<close> 50)
  and le\<^sub>b (\<open>'(\<le>\<^sub>b')\<close>)
  and le\<^sub>b (infix \<open>\<le>\<^sub>b\<close> 50)
  and ls\<^sub>b (\<open>'(<\<^sub>b')\<close>)
  and ls\<^sub>b (infix \<open><\<^sub>b\<close> 50)

notation ord\<^sub>a.ge (\<open>'(\<ge>\<^sub>a')\<close>)
  and ord\<^sub>a.ge (infix \<open>\<ge>\<^sub>a\<close> 50)
  and ord\<^sub>a.gt (\<open>'(>\<^sub>a')\<close>)
  and ord\<^sub>a.gt (infix \<open>>\<^sub>a\<close> 50)
  and ord\<^sub>b.ge (\<open>'(\<ge>\<^sub>b')\<close>)
  and ord\<^sub>b.ge (infix \<open>\<ge>\<^sub>b\<close> 50)
  and ord\<^sub>b.gt (\<open>'(>\<^sub>b')\<close>)
  and ord\<^sub>b.gt (infix \<open>>\<^sub>b\<close> 50)

end

locale ord_pair_dual = ord_pair le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_dual: ord_pair \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> .
sublocale dual_ord: ord_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> .
sublocale dual_dual: ord_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> .

end

subsection\<open>Preorders\<close>

subsubsection\<open>Definitions\<close>

text\<open>Abstract preorders.\<close>

locale preorder = ord le ls for le ls :: "['a, 'a] \<Rightarrow> bool" +
  assumes less_le_not_le: "ls x y \<longleftrightarrow> le x y \<and> \<not> (le y x)"
    and order_refl[iff]: "le x x"
    and order_trans: "le x y \<Longrightarrow> le y z \<Longrightarrow> le x z"

locale preorder_dual = preorder le ls for le ls :: "['a, 'a] \<Rightarrow> bool"
begin

interpretation ord_syntax .

sublocale ord_dual .

sublocale dual: preorder ge gt
  by standard (auto simp: less_le_not_le intro: order_trans)

end

text\<open>Pairs.\<close>

locale ord_preorder = ord_pair le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>b: preorder le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"

locale ord_preorder_dual = ord_preorder le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_pair_dual .
sublocale ord_dual: ord_preorder \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by unfold_locales (auto simp: ord\<^sub>b.less_le_not_le intro: ord\<^sub>b.order_trans)
sublocale dual_ord: ord_preorder \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by (rule ord_preorder_axioms)
sublocale dual_dual: ord_preorder \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by (rule ord_dual.ord_preorder_axioms)

end

locale preorder_pair = ord_preorder le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>a: preorder le\<^sub>a ls\<^sub>a
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

sublocale rev: preorder_pair le\<^sub>b ls\<^sub>b le\<^sub>a ls\<^sub>a ..

end

locale preorder_pair_dual = preorder_pair le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_preorder_dual ..
sublocale ord_dual: preorder_pair \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: preorder_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by unfold_locales (auto intro: ord\<^sub>a.order_trans simp: ord\<^sub>a.less_le_not_le)
sublocale dual_dual: preorder_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

subsubsection\<open>Results\<close>

context preorder
begin

interpretation ord_syntax .

text\<open>Reflexivity.\<close>

lemma eq_refl:
  assumes "x = y"
  shows "x \<le>\<^sub>a y"
  using assms by (rule ssubst) (rule order_refl)

lemma less_irrefl[iff]: "\<not> x <\<^sub>a x" by (simp add: less_le_not_le)

lemma less_imp_le:
  assumes "x <\<^sub>a y"
  shows "x \<le>\<^sub>a y"
  using assms by (simp add: less_le_not_le)

lemma strict_implies_not_eq:
  assumes "a <\<^sub>a b"
  shows "a \<noteq> b"
  using assms by blast

text\<open>Asymmetry.\<close>

lemma less_not_sym:
  assumes "x <\<^sub>a y"
  shows "\<not> (y <\<^sub>a x)"
  using assms by (simp add: less_le_not_le)

lemma asym:
  assumes "a <\<^sub>a b" and "b <\<^sub>a a"
  shows False
  using assms by (simp add: less_not_sym)

lemma less_asym:
  assumes "x <\<^sub>a y" and "(\<not> P \<Longrightarrow> y <\<^sub>a x)"
  shows P
  using assms by (auto dest: asym)

text\<open>Transitivity.\<close>

lemma less_trans:
  assumes "x <\<^sub>a y" and "y <\<^sub>a z"
  shows "x <\<^sub>a z"
  using assms by (auto simp: less_le_not_le intro: order_trans)

lemma le_less_trans:
  assumes "x \<le>\<^sub>a y" and "y <\<^sub>a z"
  shows "x <\<^sub>a z"
  using assms by (auto simp: less_le_not_le intro: order_trans)

lemma less_le_trans:
  assumes "x <\<^sub>a y" and "y \<le>\<^sub>a z"
  shows "x <\<^sub>a z"
  using assms by (auto simp: less_le_not_le intro: order_trans)

lemma less_imp_not_less:
  assumes "x <\<^sub>a y"
  shows "(\<not> y <\<^sub>a x) \<longleftrightarrow> True"
  using assms by (elim less_asym) simp

lemma less_imp_triv:
  assumes "x <\<^sub>a y"
  shows "(y <\<^sub>a x \<longrightarrow> P) \<longleftrightarrow> True"
  using assms by (elim less_asym) simp

lemma less_asym':
  assumes "a <\<^sub>a b" and "b <\<^sub>a a"
  shows P
  using assms by (rule less_asym)

end

subsection\<open>Partial orders\<close>

subsubsection\<open>Definitions\<close>

text\<open>Abstract partial orders.\<close>

locale order = preorder le ls for le ls :: "['a, 'a] \<Rightarrow> bool" +
  assumes antisym: "le x y \<Longrightarrow> le y x \<Longrightarrow> x = y"

locale order_dual = order le ls for le ls :: "['a, 'a] \<Rightarrow> bool"
begin

interpretation ord_syntax .

sublocale preorder_dual ..

sublocale dual: order ge gt
  unfolding order_def order_axioms_def
  apply unfold_locales
  apply(rule conjI)
  subgoal by (rule dual.preorder_axioms)
  subgoal by (simp add: antisym)
  done

end

text\<open>Pairs.\<close>

locale ord_order = ord_preorder le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>b: order le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"

locale ord_order_dual = ord_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_preorder_dual ..
sublocale ord_dual: ord_order \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by unfold_locales (simp add: ord\<^sub>b.antisym)
sublocale dual_ord: ord_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by (rule ord_order_axioms)
sublocale dual_dual: ord_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by (rule ord_dual.ord_order_axioms)

end

locale preorder_order = ord_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>a: preorder le\<^sub>a ls\<^sub>a
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

sublocale preorder_pair ..

end

locale preorder_order_dual = preorder_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_order_dual ..
sublocale preorder_pair_dual ..
sublocale ord_dual: preorder_order \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: preorder_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> ..
sublocale dual_dual: preorder_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

locale order_pair = preorder_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>a: order le\<^sub>a ls\<^sub>a
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

sublocale rev: order_pair le\<^sub>b ls\<^sub>b le\<^sub>a ls\<^sub>a ..

end

locale order_pair_dual = order_pair le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "['a, 'a] \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "['b, 'b] \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale preorder_order_dual ..
sublocale ord_dual: order_pair \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: order_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by unfold_locales (simp add: ord\<^sub>a.antisym)
sublocale dual_dual: order_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

subsubsection\<open>Results\<close>

context order
begin

interpretation ord_syntax .

text\<open>Reflexivity.\<close>

lemma less_le: "x <\<^sub>a y \<longleftrightarrow> x \<le>\<^sub>a y \<and> x \<noteq> y"
  by (auto simp: less_le_not_le intro: antisym)

lemma le_less: "x \<le>\<^sub>a y \<longleftrightarrow> x <\<^sub>a y \<or> x = y" by (auto simp: less_le)

lemma le_imp_less_or_eq:
  assumes "x \<le>\<^sub>a y"
  shows "x <\<^sub>a y \<or> x = y"
  using assms by (simp add: le_less)

lemma less_imp_not_eq:
  assumes "x <\<^sub>a y"
  shows "(x = y) \<longleftrightarrow> False"
  using assms by auto

lemma less_imp_not_eq2:
  assumes "x <\<^sub>a y"
  shows "(y = x) \<longleftrightarrow> False"
  using assms by auto

text\<open>Transitivity.\<close>

lemma neq_le_trans:
  assumes "a \<noteq> b" and "a \<le>\<^sub>a b"
  shows "a <\<^sub>a b"
  using assms by (simp add: less_le)

lemma le_neq_trans:
  assumes "a \<le>\<^sub>a b" and "a \<noteq> b"
  shows "a <\<^sub>a b"
  using assms by (simp add: less_le)

text\<open>Asymmetry.\<close>

lemma eq_iff: "x = y \<longleftrightarrow> x \<le>\<^sub>a y \<and> y \<le>\<^sub>a x" by (blast intro: antisym)

lemma antisym_conv:
  assumes "y \<le>\<^sub>a x"
  shows "x \<le>\<^sub>a y \<longleftrightarrow> x = y"
  using assms by (blast intro: antisym)

text\<open>Other results.\<close>

lemma antisym_conv1:
  assumes "\<not> x <\<^sub>a y"
  shows "x \<le>\<^sub>a y \<longleftrightarrow> x = y"
  using assms by (simp add: le_less)

lemma antisym_conv2:
  assumes "x \<le>\<^sub>a y"
  shows "\<not> x <\<^sub>a y \<longleftrightarrow> x = y"
  using assms le_less by auto

lemma leD:
  assumes "y \<le>\<^sub>a x"
  shows "\<not> x <\<^sub>a y"
  using assms by (simp add: less_le_not_le)

end

subsection\<open>Dense orders\<close>

text\<open>Abstract dense orders.\<close>

locale dense_order = order le ls for le ls :: "['a, 'a] \<Rightarrow> bool" +
  assumes dense: "ls x y \<Longrightarrow> (\<exists>z. ls x z \<and> ls z y)"

locale dense_order_dual = dense_order le ls for le ls :: "['a, 'a] \<Rightarrow> bool"
begin

interpretation ord_syntax .

sublocale order_dual ..

sublocale dual: dense_order ge gt
  using dense by unfold_locales auto

end

text\<open>Pairs.\<close>

locale ord_dense_order = ord_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>b: dense_order le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"

locale ord_dense_order_dual = ord_dense_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_order_dual ..
sublocale ord_dual: ord_dense_order \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  using ord\<^sub>b.dense by unfold_locales blast
sublocale dual_ord: ord_dense_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by (rule ord_dense_order_axioms)
sublocale dual_dual: ord_dense_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by (rule ord_dual.ord_dense_order_axioms)

end

locale preorder_dense_order =
  ord_dense_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>a: preorder le\<^sub>a ls\<^sub>a
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

sublocale preorder_order ..

end

locale preorder_dense_order_dual = preorder_dense_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale ord_dense_order_dual ..
sublocale preorder_order_dual ..
sublocale ord_dual: preorder_dense_order \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: preorder_dense_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> ..
sublocale dual_dual: preorder_dense_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

locale order_dense_order =
  preorder_dense_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>a: order le\<^sub>a ls\<^sub>a
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

sublocale order_pair ..

end

locale order_dense_order_dual = order_dense_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale preorder_dense_order_dual ..
sublocale order_pair_dual ..
sublocale ord_dual: order_dense_order \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: order_dense_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> ..
sublocale dual_dual: order_dense_order \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

locale dense_order_pair =
  order_dense_order le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b + ord\<^sub>a: dense_order le\<^sub>a ls\<^sub>a
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"

locale dense_order_pair_dual = dense_order_pair le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b
  for le\<^sub>a ls\<^sub>a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and le\<^sub>b ls\<^sub>b :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

interpretation ord_pair_syntax .

sublocale order_dense_order_dual ..
sublocale ord_dual: dense_order_pair \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: dense_order_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  using ord\<^sub>a.dense by unfold_locales auto
sublocale dual_dual: dense_order_pair \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

subsection\<open>(Unique) top and bottom elements\<close>

text\<open>Abstract extremum.\<close>

locale extremum =
  fixes extremum :: 'a

locale ord_extremum = ord le ls + extremum extremum
  for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and extremum :: 'a

text\<open>Concrete syntax.\<close>

locale bot = extremum bot for bot :: 'a
begin

notation bot ("\<bottom>")

end

locale top = extremum top for top :: 'a
begin

notation top ("\<top>")

end

subsection\<open>(Unique) top and bottom elements for partial orders\<close>

subsubsection\<open>Definitions\<close>

text\<open>Abstract partial order with extremum.\<close>

locale order_extremum = ord_extremum le ls extremum + order le ls
  for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and extremum :: 'a  +
  assumes extremum[simp]: "le a extremum"

text\<open>Concrete syntax.\<close>

locale order_bot =
  order_dual le ls +
  dual: order_extremum \<open>\<lambda>x y. le y x\<close> \<open>\<lambda>x y. ls y x\<close> bot +
  bot bot
  for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and bot :: 'a

locale order_top = order_dual le ls + order_extremum le ls top + top top
  for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and top :: 'a

subsubsection\<open>Results\<close>

context order_extremum
begin

interpretation ord_syntax .

lemma extremum_uniqueI:
  assumes "extremum \<le>\<^sub>a a"
  shows "a = extremum"
  using assms by (simp add: antisym)

lemma extremum_unique: "extremum \<le>\<^sub>a a \<longleftrightarrow> a = extremum"
  by (auto intro: antisym)

lemma extremum_strict[simp]: "\<not> (extremum <\<^sub>a a)"
  by (fastforce simp: less_le_not_le)

lemma not_eq_extremum: "a \<noteq> extremum \<longleftrightarrow> a <\<^sub>a extremum"
  using le_imp_less_or_eq by (auto intro: extremum)

end

subsection\<open>Partial orders without top or bottom elements\<close>

text\<open>Abstract partial orders without top or bottom elements.\<close>

locale no_extremum = order le ls for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool" +
  assumes gt_ex: "\<exists>y. ls x y"

text\<open>Concrete syntax.\<close>

locale no_top = order_dual le ls + no_extremum le ls
  for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

locale no_bot =
  order_dual le ls +
  dual: no_extremum \<open>\<lambda>x y. le y x\<close> \<open>\<lambda>x y. ls y x\<close>
  for le ls :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

subsection\<open>Least and greatest operators\<close>

definition Least :: "['a set, ['a, 'a] \<Rightarrow> bool, 'a \<Rightarrow> bool] \<Rightarrow> 'a option"
  (\<open>(on _ with _ : \<guillemotleft>Least\<guillemotright> _)\<close> [1000, 1000, 1000] 10)
  where
    "on U with op : \<guillemotleft>Least\<guillemotright> P \<equiv> (THE x on U. P x \<and> (\<forall>y\<in>U. P y \<longrightarrow> op x y))"

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
    and [transfer_rule]: "bi_unique A" "right_total A"
  trp (?'a A)
  in Least_def

context ord_syntax
begin

abbreviation Least where "Least \<equiv> Type_Simple_Orders.Least UNIV (\<le>\<^sub>a)"
abbreviation Greatest where "Greatest \<equiv> Type_Simple_Orders.Least UNIV (\<ge>\<^sub>a)"

lemmas Least_def = Least_def[of UNIV \<open>(\<le>\<^sub>a)\<close>]

end

context order
begin

interpretation ord_syntax .

lemma Least_equality:
  assumes "P x" and "\<And>y. P y \<Longrightarrow> x \<le>\<^sub>a y"
  shows "Least P = Some x"
  unfolding Least_def by (rule The_on_Some_equality) (auto simp: assms antisym)

lemma LeastI2_order:
  assumes "P x"
    and "\<And>y. P y \<Longrightarrow> x \<le>\<^sub>a y"
    and "\<And>x. P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le>\<^sub>a y \<Longrightarrow> Q x"
  obtains z where "Least P = Some z" and "Q z"
  unfolding Least_def using assms by (clarsimp simp: that Least_equality)

lemma Least_ex1:
  assumes "\<exists>!x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le>\<^sub>a y)"
  obtains x where "Least P = Some x" and "P x" and "P z \<Longrightarrow> x \<le>\<^sub>a z"
  using assms unfolding Least_def by (clarsimp simp: that Least_equality)

end

subsection\<open>min and max\<close>

definition min :: "[['a, 'a] \<Rightarrow> bool, 'a, 'a] \<Rightarrow> 'a" where
  "min le a b = (if le a b then a else b)"

ctr parametricity
  in min_def

context ord_syntax
begin

abbreviation min where "min \<equiv> Type_Simple_Orders.min (\<le>\<^sub>a)"
abbreviation max where "max \<equiv> Type_Simple_Orders.min (\<ge>\<^sub>a)"

end

context ord
begin

interpretation ord_syntax .

lemma min_absorb1: "x \<le>\<^sub>a y \<Longrightarrow> min x y = x"
  unfolding min_def by simp

end

context order
begin

interpretation ord_syntax .

lemma min_absorb2:
  assumes "y \<le>\<^sub>a x"
  shows "min x y = y"
  using assms unfolding min_def by (simp add: eq_iff)

end

context order_extremum
begin

interpretation ord_syntax .

lemma max_top[simp]: "max extremum x = extremum"
  by (simp add: ord.min_absorb1)

lemma max_top2[simp]: "max x extremum = extremum"
  unfolding min_def by (simp add: extremum_uniqueI)

lemma min_top[simp]: "min extremum x = x" by (simp add: min_absorb2)

lemma min_top2[simp]: "min x extremum = x"  by (simp add: min_def top_unique)

end

subsection\<open>Monotonicity\<close>

definition mono ::
  "['a set, ['a, 'a] \<Rightarrow> bool, ['b, 'b] \<Rightarrow> bool, 'a \<Rightarrow> 'b] \<Rightarrow> bool"
  (\<open>(on _ with _ _ : \<guillemotleft>mono\<guillemotright> _)\<close> [1000, 1000, 999, 1000] 10)
  where
    "on U\<^sub>a with op\<^sub>1 op\<^sub>2 : \<guillemotleft>mono\<guillemotright> f \<equiv> \<forall>x\<in>U\<^sub>a. \<forall>y\<in>U\<^sub>a. op\<^sub>1 x y \<longrightarrow> op\<^sub>2 (f x) (f y)"

ctr parametricity
  in mono_def

context ord_pair_syntax
begin

abbreviation mono\<^sub>a\<^sub>b
  where "mono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono UNIV (\<le>\<^sub>a) (\<le>\<^sub>b)"
abbreviation mono\<^sub>b\<^sub>a
  where "mono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono UNIV (\<le>\<^sub>b) (\<le>\<^sub>a)"
abbreviation antimono\<^sub>a\<^sub>b
  where "antimono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono UNIV (\<le>\<^sub>a) (\<ge>\<^sub>b)"
abbreviation antimono\<^sub>b\<^sub>a
  where "antimono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono UNIV (\<le>\<^sub>b) (\<ge>\<^sub>a)"
abbreviation strict_mono\<^sub>a\<^sub>b
  where "strict_mono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono UNIV (<\<^sub>a) (<\<^sub>b)"
abbreviation strict_mono\<^sub>b\<^sub>a
  where "strict_mono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono UNIV (<\<^sub>b) (<\<^sub>a)"
abbreviation strict_antimono\<^sub>a\<^sub>b
  where "strict_antimono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono UNIV (<\<^sub>a) (>\<^sub>b)"
abbreviation strict_antimono\<^sub>b\<^sub>a
  where "strict_antimono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono UNIV (<\<^sub>b) (>\<^sub>a)"

end

context ord_pair
begin

interpretation ord_pair_syntax .

lemma monoI[intro?]:
  assumes "\<And>x y. x \<le>\<^sub>a y \<Longrightarrow> f x \<le>\<^sub>b f y"
  shows "mono\<^sub>a\<^sub>b f"
  unfolding mono_def using assms by simp

lemma monoD[dest?]:
  assumes "mono\<^sub>a\<^sub>b f" and "x \<le>\<^sub>a y"
  shows "f x \<le>\<^sub>b f y"
  using assms unfolding mono_def by simp

lemma monoE:
  assumes "mono\<^sub>a\<^sub>b f" and "x \<le>\<^sub>a y"
  obtains "f x \<le>\<^sub>b f y"
  using assms unfolding mono_def by simp

lemma strict_monoI[intro?]:
  assumes "\<And>x y. x <\<^sub>a y \<Longrightarrow> f x <\<^sub>b f y"
  shows "strict_mono\<^sub>a\<^sub>b f"
  unfolding mono_def using assms by simp

lemma strict_monoD[dest?]:
  assumes "strict_mono\<^sub>a\<^sub>b f" and "x <\<^sub>a y"
  shows "f x <\<^sub>b f y"
  using assms unfolding mono_def by simp

lemma strict_monoE:
  assumes "strict_mono\<^sub>a\<^sub>b f" and "x <\<^sub>a y"
  obtains "f x <\<^sub>b f y"
  using assms unfolding mono_def by simp

end

context order_pair
begin

interpretation ord_pair_syntax .

lemma strict_mono_mono[dest?]:
  assumes "strict_mono\<^sub>a\<^sub>b f"
  shows "mono\<^sub>a\<^sub>b f"
proof(rule monoI)
  fix x y
  assume "x \<le>\<^sub>a y"
  show "f x \<le>\<^sub>b f y"
  proof (cases "x = y")
    case True then show ?thesis by simp
  next
    case False with \<open>x \<le>\<^sub>a y\<close> have "x <\<^sub>a y" by (simp add: ord\<^sub>a.neq_le_trans)
    with assms strict_monoD have "f x <\<^sub>b f y" by simp
    then show ?thesis by (simp add: ord\<^sub>b.le_less)
  qed
qed

end

subsection\<open>Set intervals\<close>

definition ray :: "['a set, ['a, 'a] \<Rightarrow> bool, 'a] \<Rightarrow> 'a set"
  (\<open>(on _ with _ : {..\<sqsubset>_})\<close> [1000, 1000, 1000] 10)
  where "on U with op : {..\<sqsubset>u} \<equiv> {x \<in> U. op x u}"
definition interval ::
  "['a set, ['a, 'a] \<Rightarrow> bool, ['a, 'a] \<Rightarrow> bool, 'a, 'a] \<Rightarrow> 'a set"
  (\<open>(on _ with _ _ : {_\<sqsubset>..\<sqsubset>_})\<close> [1000, 1000, 999, 1000, 1000] 10)
  where "on U with op\<^sub>1 op\<^sub>2 : {l\<sqsubset>..\<sqsubset>u} \<equiv>
    (on U with (\<lambda>x y. op\<^sub>1 y x) : {..\<sqsubset>l}) \<inter> (on U with op\<^sub>2 : {..\<sqsubset>u})"

lemma ray_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "(rel_set A ===> (A ===> A ===> (=)) ===> A ===> rel_set A) ray ray"
  unfolding ray_def
proof(intro rel_funI)
  fix S :: "'a set" and S' :: "'b set"
    and le :: "['a, 'a] \<Rightarrow> bool" and le' :: "['b, 'b] \<Rightarrow> bool"
    and u u'
  assume [transfer_rule]: "rel_set A S S'"
    and [transfer_rule]: "(A ===> A ===> (=)) le le'"
    and [transfer_rule]: "A u u'"
  show "rel_set A {xc \<in> S. le xc u} {x \<in> S'. le' x u'}"
  proof(intro rel_setI)
    show "x \<in> {xc \<in> S. le xc u} \<Longrightarrow> \<exists>x'\<in>{x \<in> S'. le' x u'}. A x x'" for x
    proof-
      assume x: "x \<in> {xc \<in> S. le xc u}"
      then obtain x' where [transfer_rule]: "A x x'"
        using \<open>rel_set A S S'\<close> rel_setD1 by fastforce
      from x have "x' \<in> {x \<in> S'. le' x u'}"
        apply transfer using \<open>A x x'\<close> by auto
      then show ?thesis by (auto simp: \<open>A x x'\<close>)
    qed
    show "x' \<in> {x \<in> S'. le' x u'} \<Longrightarrow> \<exists>x\<in>{xc \<in> S. le xc u}. A x x'" for x'
    proof-
      assume x': "x' \<in> {x \<in> S'. le' x u'}"
      then obtain x where [transfer_rule]: "A x x'"
        using assms(2) by (auto elim: right_totalE)
      from x' have "x \<in> {xc \<in> S. le xc u}" by transfer auto
      then show ?thesis by (auto simp: \<open>A x x'\<close>)
    qed
  qed
qed

ctr relativization
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  trp (?'a A)
  in interval_def

lemma interval_ge_le:
  "(on UNIV with (\<lambda>x y. le\<^sub>a y x) (\<lambda>x y. le\<^sub>b y x) : {l\<sqsubset>..\<sqsubset>h}) =
    (on UNIV with le\<^sub>b le\<^sub>a : {h\<sqsubset>..\<sqsubset>l})"
  unfolding interval_def by auto

context ord_syntax
begin

abbreviation lessThan (\<open>{..<\<^sub>a_}\<close>)
  where "{..<\<^sub>au} \<equiv> on UNIV with (<\<^sub>a) : {..\<sqsubset>u}"
abbreviation atMost (\<open>{..\<le>\<^sub>a_}\<close>)
  where "{..\<le>\<^sub>au} \<equiv> on UNIV with (\<le>\<^sub>a) : {..\<sqsubset>u}"
abbreviation greaterThan (\<open>{_<\<^sub>a..}\<close>)
  where "{l<\<^sub>a..} \<equiv> on UNIV with (>\<^sub>a) : {..\<sqsubset>l}"
abbreviation atLeast (\<open>{_\<le>\<^sub>a..}\<close>)
  where "{l\<le>\<^sub>a..} \<equiv> on UNIV with (\<ge>\<^sub>a) : {..\<sqsubset>l}"
abbreviation greaterThanLessThan (\<open>{_<\<^sub>a..<\<^sub>a_}\<close>)
  where "{l<\<^sub>a..<\<^sub>au} \<equiv> on UNIV with (<\<^sub>a) (<\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atLeastLessThan (\<open>{_\<le>\<^sub>a..<\<^sub>a_}\<close>)
  where "{l\<le>\<^sub>a..<\<^sub>au} \<equiv> on UNIV with (\<le>\<^sub>a) (<\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation greaterThanAtMost (\<open>{_<\<^sub>a..\<le>\<^sub>a_}\<close>)
  where "{l<\<^sub>a..\<le>\<^sub>au} \<equiv> on UNIV with (<\<^sub>a) (\<le>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atLeastAtMost (\<open>{_\<le>\<^sub>a..\<le>\<^sub>a_}\<close>)
  where "{l\<le>\<^sub>a..\<le>\<^sub>au} \<equiv> on UNIV with (\<le>\<^sub>a) (\<le>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation lessThanGreaterThan (\<open>{_>\<^sub>a..>\<^sub>a_}\<close>)
  where "{l>\<^sub>a..>\<^sub>au} \<equiv> on UNIV with (>\<^sub>a) (>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation lessThanAtLeast (\<open>{_\<ge>\<^sub>a..>\<^sub>a_}\<close>)
  where "{l\<ge>\<^sub>a..>\<^sub>au} \<equiv> on UNIV with (\<ge>\<^sub>a) (>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atMostGreaterThan (\<open>{_>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  where "{l>\<^sub>a..\<ge>\<^sub>au} \<equiv> on UNIV with (>\<^sub>a) (\<ge>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atMostAtLeast (\<open>{_\<ge>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  where "{l\<ge>\<^sub>a..\<ge>\<^sub>au} \<equiv> on UNIV with (\<ge>\<^sub>a) (\<ge>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"

end

context ord
begin

interpretation ord_syntax .

lemma lessThan_iff[iff]: "(i \<in> {..<\<^sub>ak}) = (i <\<^sub>a k)"
  unfolding ray_def by simp

lemma atLeast_iff[iff]: "(i \<in> {k\<le>\<^sub>a..}) = (k \<le>\<^sub>a i)"
  unfolding ray_def by simp

lemma greaterThanLessThan_iff[simp]: "(i \<in> {l<\<^sub>a..<\<^sub>au}) = (l <\<^sub>a i \<and> i <\<^sub>a u)"
  unfolding interval_def ray_def by simp

lemma atLeastLessThan_iff[simp]: "(i \<in> {l\<le>\<^sub>a..<\<^sub>au}) = (l \<le>\<^sub>a i \<and> i <\<^sub>a u)"
  unfolding interval_def ray_def by simp

lemma greaterThanAtMost_iff[simp]: "(i \<in> {l<\<^sub>a..\<le>\<^sub>au}) = (l <\<^sub>a i \<and> i \<le>\<^sub>a u)"
  unfolding interval_def ray_def by simp

lemma atLeastAtMost_iff[simp]: "(i \<in> {l\<le>\<^sub>a..\<le>\<^sub>au}) = (l \<le>\<^sub>a i \<and> i \<le>\<^sub>a u)"
  unfolding interval_def ray_def by simp

lemma greaterThanLessThan_eq: "{a<\<^sub>a..<\<^sub>ab} = {a<\<^sub>a..} \<inter> {..<\<^sub>ab}"
  unfolding interval_def ray_def by simp

end

context ord_pair_syntax
begin

notation ord\<^sub>a.lessThan (\<open>{..<\<^sub>a_}\<close>)
  and ord\<^sub>a.atMost (\<open>{..\<le>\<^sub>a_}\<close>)
  and ord\<^sub>a.greaterThan (\<open>{_<\<^sub>a..}\<close>)
  and ord\<^sub>a.atLeast (\<open>{_\<le>\<^sub>a..}\<close>)
  and ord\<^sub>a.greaterThanLessThan (\<open>{_<\<^sub>a..<\<^sub>a_}\<close>)
  and ord\<^sub>a.atLeastLessThan (\<open>{_\<le>\<^sub>a..<\<^sub>a_}\<close>)
  and ord\<^sub>a.greaterThanAtMost (\<open>{_<\<^sub>a..\<le>\<^sub>a_}\<close>)
  and ord\<^sub>a.atLeastAtMost (\<open>{_\<le>\<^sub>a..\<le>\<^sub>a_}\<close>)
  and ord\<^sub>a.lessThanGreaterThan (\<open>{_>\<^sub>a..>\<^sub>a_}\<close>)
  and ord\<^sub>a.lessThanAtLeast (\<open>{_\<ge>\<^sub>a..>\<^sub>a_}\<close>)
  and ord\<^sub>a.atMostGreaterThan (\<open>{_>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  and ord\<^sub>a.atMostAtLeast (\<open>{_\<ge>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  and ord\<^sub>b.lessThan (\<open>{..<\<^sub>b_}\<close>)
  and ord\<^sub>b.atMost (\<open>{..\<le>\<^sub>b_}\<close>)
  and ord\<^sub>b.greaterThan (\<open>{_<\<^sub>b..}\<close>)
  and ord\<^sub>b.atLeast (\<open>{_\<le>\<^sub>b..}\<close>)
  and ord\<^sub>b.greaterThanLessThan (\<open>{_<\<^sub>b..<\<^sub>b_}\<close>)
  and ord\<^sub>b.atLeastLessThan (\<open>{_\<le>\<^sub>b..<\<^sub>b_}\<close>)
  and ord\<^sub>b.greaterThanAtMost (\<open>{_<\<^sub>b..\<le>\<^sub>b_}\<close>)
  and ord\<^sub>b.atLeastAtMost (\<open>{_\<le>\<^sub>b..\<le>\<^sub>b_}\<close>)
  and ord\<^sub>b.lessThanGreaterThan (\<open>{_>\<^sub>b..>\<^sub>b_}\<close>)
  and ord\<^sub>b.lessThanAtLeast (\<open>{_\<ge>\<^sub>b..>\<^sub>b_}\<close>)
  and ord\<^sub>b.atMostGreaterThan (\<open>{_>\<^sub>b..\<ge>\<^sub>b_}\<close>)
  and ord\<^sub>b.atMostAtLeast (\<open>{_\<ge>\<^sub>b..\<ge>\<^sub>b_}\<close>)

end

context preorder
begin

interpretation ord_syntax .

lemma Ioi_le_Ico: "{a<\<^sub>a..} \<subseteq> {a\<le>\<^sub>a..}"
  unfolding ray_def by (fastforce simp: less_le_not_le)

end

context preorder
begin

interpretation ord_syntax .

interpretation preorder_dual le ls
  by (rule preorder_dual.intro[OF preorder_axioms])

lemma single_Diff_lessThan[simp]: "{k} - {..<\<^sub>ak} = {k}" by auto

lemma atLeast_subset_iff[iff]: "({x\<le>\<^sub>a..} \<subseteq> {y\<le>\<^sub>a..}) = (y \<le>\<^sub>a x)"
  by (auto intro: order_trans)

lemma atLeastatMost_empty[simp]:
  assumes "b <\<^sub>a a"
  shows "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {}"
  unfolding interval_def
  using less_le_not_le assms
  by (metis Int_emptyI ord.lessThan_iff atLeast_iff order_trans)

lemma atLeastatMost_empty_iff[simp]: "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {} \<longleftrightarrow> (\<not> a \<le>\<^sub>a b)"
  by auto (blast intro: order_trans)

lemma atLeastatMost_empty_iff2[simp]: "{} = {a\<le>\<^sub>a..\<le>\<^sub>ab} \<longleftrightarrow> (\<not> a \<le>\<^sub>a b)"
  by auto (blast intro: order_trans)

lemma atLeastLessThan_empty[simp]:
  assumes "b \<le>\<^sub>a a"
  shows "{a\<le>\<^sub>a..<\<^sub>ab} = {}"
  unfolding interval_def
  using assms less_le_not_le
  by (blast intro: order_trans)

lemma atLeastLessThan_empty_iff[simp]: "{a\<le>\<^sub>a..<\<^sub>ab} = {} \<longleftrightarrow> (\<not> a <\<^sub>a b)"
  unfolding interval_def by (auto simp: le_less_trans ord.lessThan_iff)

lemma atLeastLessThan_empty_iff2[simp]: "{} = {a\<le>\<^sub>a..<\<^sub>ab} \<longleftrightarrow> (\<not> a <\<^sub>a b)"
  unfolding interval_def by (auto simp: le_less_trans ord.lessThan_iff)

lemma greaterThanAtMost_empty[simp]:
  assumes "l \<le>\<^sub>a k"
  shows "{k<\<^sub>a..\<le>\<^sub>al} = {}"
  using assms atLeastLessThan_empty[OF assms]
  unfolding
    greaterThanAtMost_eq_atLeastAtMost_diff
    atLeastLessThan_eq_atLeastAtMost_diff
  using le_less_trans by auto blast

lemma greaterThanAtMost_empty_iff[simp]: "{k<\<^sub>a..\<le>\<^sub>al} = {} \<longleftrightarrow> \<not> k <\<^sub>a l"
  by (auto simp: dual.le_less_trans)

lemma greaterThanAtMost_empty_iff2[simp]: "{} = {k<\<^sub>a..\<le>\<^sub>al} \<longleftrightarrow> \<not> k <\<^sub>a l"
  unfolding interval_def ray_def by (blast intro: less_le_trans)

lemma greaterThanLessThan_empty[simp]:
  assumes "l \<le>\<^sub>a k"
  shows "{k<\<^sub>a..<\<^sub>al} = {}"
  using assms by auto (blast intro: le_less_trans asym equals0I)

lemma atLeastatMost_subset_iff[simp]:
  "{a\<le>\<^sub>a..\<le>\<^sub>ab} \<le> {c\<le>\<^sub>a..\<le>\<^sub>ad} \<longleftrightarrow> (\<not> a \<le>\<^sub>a b) \<or> c \<le>\<^sub>a a \<and> b \<le>\<^sub>a d"
  by auto (blast intro: order_trans)+

lemma atLeastatMost_psubset_iff:
  "{a\<le>\<^sub>a..\<le>\<^sub>ab} < {c\<le>\<^sub>a..\<le>\<^sub>ad} \<longleftrightarrow>
    ((\<not> a \<le>\<^sub>a b) \<or> c \<le>\<^sub>a a \<and> b \<le>\<^sub>a d \<and> (c <\<^sub>a a \<or> b <\<^sub>a d)) \<and> c \<le>\<^sub>a d"
  by (simp add: psubset_eq set_eq_iff less_le_not_le)
    (blast intro: order_trans)

lemma Icc_subset_Ici_iff[simp]:
  "{l\<le>\<^sub>a..\<le>\<^sub>ah} \<subseteq> {l'\<le>\<^sub>a..} = (\<not> l \<le>\<^sub>a h \<or> l \<ge>\<^sub>a l')"
  by (auto simp: subset_eq intro: order_trans)

lemma Icc_subset_Iic_iff[simp]:
  "{l\<le>\<^sub>a..\<le>\<^sub>ah} \<subseteq> {..\<le>\<^sub>ah'} = (\<not> l \<le>\<^sub>a h \<or> h \<le>\<^sub>a h')"
  unfolding interval_def ray_def by (blast intro: order_trans)+

lemma not_Ici_eq_empty[simp]: "{l\<le>\<^sub>a..} \<noteq> {}" by (auto simp: set_eq_iff)

lemmas not_empty_eq_Ici_eq_empty[simp] = not_Ici_eq_empty[symmetric]

lemma Iio_Int_singleton: "{..<\<^sub>ak} \<inter> {x} = (if x <\<^sub>a k then {x} else {})" by simp

lemma ivl_disj_int_one:
  "{..\<le>\<^sub>al} \<inter> {l<\<^sub>a..<\<^sub>au} = {}"
  "{..<\<^sub>al} \<inter> {l\<le>\<^sub>a..<\<^sub>au} = {}"
  "{..\<le>\<^sub>al} \<inter> {l<\<^sub>a..\<le>\<^sub>au} = {}"
  "{..<\<^sub>al} \<inter> {l\<le>\<^sub>a..\<le>\<^sub>au} = {}"
  "{l<\<^sub>a..\<le>\<^sub>au} \<inter> {u<\<^sub>a..} = {}"
  "{l<\<^sub>a..<\<^sub>au} \<inter> {u\<le>\<^sub>a..} = {}"
  "{l\<le>\<^sub>a..\<le>\<^sub>au} \<inter> {u<\<^sub>a..} = {}"
  "{l\<le>\<^sub>a..<\<^sub>au} \<inter> {u\<le>\<^sub>a..} = {}"
  using lessThan_iff dual.lessThan_iff by (auto simp: less_le_not_le)

lemma ivl_disj_int_two:
  "{l<\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..<\<^sub>au} = {}"
  "{l<\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..<\<^sub>au} = {}"
  "{l\<le>\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..<\<^sub>au} = {}"
  "{l\<le>\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..<\<^sub>au} = {}"
  "{l<\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..\<le>\<^sub>au} = {}"
  "{l<\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..\<le>\<^sub>au} = {}"
  "{l\<le>\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..\<le>\<^sub>au} = {}"
  "{l\<le>\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..\<le>\<^sub>au} = {}"
  using lessThan_iff by (auto simp: less_le_not_le)

end

context order
begin

interpretation ord_syntax .

interpretation order_dual le ls
  by (rule order_dual.intro[OF order_axioms])

lemma atMost_Int_atLeast: "{..\<le>\<^sub>an} \<inter> {n\<le>\<^sub>a..} = {n}"
  unfolding ray_def by (auto simp: eq_iff)

lemma atLeast_eq_iff[iff]: "({x\<le>\<^sub>a..} = {y\<le>\<^sub>a..}) = (x = y)"
  unfolding ray_def using antisym by auto

lemma atLeastLessThan_eq_atLeastAtMost_diff: "{a\<le>\<^sub>a..<\<^sub>ab} = {a\<le>\<^sub>a..\<le>\<^sub>ab} - {b}"
  unfolding interval_def ray_def by (auto simp: less_imp_le le_less)

lemma greaterThanAtMost_eq_atLeastAtMost_diff: "{a<\<^sub>a..\<le>\<^sub>ab} = {a\<le>\<^sub>a..\<le>\<^sub>ab} - {a}"
  unfolding interval_def ray_def by (auto simp: less_imp_le le_less)

lemma atLeastAtMost_singleton[simp]: "{a\<le>\<^sub>a..\<le>\<^sub>aa} = {a}"
  using atMost_Int_atLeast by (fastforce simp: ray_def)

lemma atLeastAtMost_singleton':
  assumes "a = b"
  shows "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {a}"
  using assms by simp

lemma Icc_eq_Icc[simp]:
  "{l\<le>\<^sub>a..\<le>\<^sub>ah} = {l'\<le>\<^sub>a..\<le>\<^sub>ah'} = (l = l' \<and> h = h' \<or> \<not> l \<le>\<^sub>a h \<and> \<not> l' \<le>\<^sub>a h')"
  apply(rule iffI)
  subgoal by (metis antisym atLeastatMost_subset_iff eq_refl)
  subgoal using atLeastatMost_empty_iff by blast
  done

lemma atLeastAtMost_singleton_iff[simp]: "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {c} \<longleftrightarrow> a = b \<and> b = c"
proof
  assume "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {c}"
  hence *: "\<not> (\<not> a \<le>\<^sub>a b)" unfolding atLeastatMost_empty_iff[symmetric] by simp
  with \<open>{a\<le>\<^sub>a..\<le>\<^sub>ab} = {c}\<close> have "c \<le>\<^sub>a a \<and> b \<le>\<^sub>a c" by auto
  with * show "a = b \<and> b = c" by (auto intro: antisym order_trans)
qed simp

end

context order_extremum
begin

interpretation ord_syntax .

lemma atMost_eq_UNIV_iff: "{..\<le>\<^sub>ax} = UNIV \<longleftrightarrow> x = extremum"
  by (metis ord.lessThan_iff eq_iff UNIV_I UNIV_eq_I extremum)

end

context no_extremum
begin

interpretation ord_syntax .

interpretation order_dual le ls
  by (rule order_dual.intro[OF order_axioms])

lemma not_UNIV_le_Icc[simp]: "\<not> UNIV \<subseteq> {l\<le>\<^sub>a..\<le>\<^sub>ah}"
  using gt_ex[of h] by (auto simp: subset_eq less_le_not_le)

lemma not_UNIV_le_Iic[simp]: "\<not> UNIV \<subseteq> {..\<le>\<^sub>ah}"
  using gt_ex[of h] by (auto simp: less_le_not_le)

lemma not_Ici_le_Icc[simp]: "\<not> {l\<le>\<^sub>a..} \<subseteq> {l'\<le>\<^sub>a..\<le>\<^sub>ah'}"
  using gt_ex[of h']
  by (auto simp: subset_eq less_le)
    (blast dest: antisym_conv intro: order_trans)

lemma not_Ici_le_Iic[simp]: "\<not> {l\<le>\<^sub>a..} \<subseteq> {..\<le>\<^sub>ah'}"
proof
  assume "{l\<le>\<^sub>a..} \<subseteq> {..\<le>\<^sub>ah'}"
  then have x: "l \<le>\<^sub>a x \<Longrightarrow> x \<le>\<^sub>a h'" for x by auto
  from gt_ex obtain x where "h' <\<^sub>a x" by auto
  show False
  proof(cases \<open>l \<le>\<^sub>a x\<close>)
    case True show ?thesis
      using x[OF True] less_le_not_le by (force simp: \<open>h' <\<^sub>a x\<close>)
  next
    case False
    obtain y where "x \<le>\<^sub>a y" and "y <\<^sub>a l"
      using \<open>h' <\<^sub>a x\<close> dual.less_le_trans by (blast intro: x less_imp_le)
    then have "x <\<^sub>a l" by (rule le_less_trans)
    then show ?thesis
      using \<open>h' <\<^sub>a x\<close> less_le_not_le by (blast intro: x dual.less_trans)
  qed
qed

lemma not_UNIV_eq_Icc[simp]: "UNIV \<noteq> {l'\<le>\<^sub>a..\<le>\<^sub>ah'}"
  using gt_ex by (auto simp: set_eq_iff less_le_not_le)

lemmas not_Icc_eq_UNIV[simp] = not_UNIV_eq_Icc[symmetric]

lemma not_UNIV_eq_Iic[simp]: "UNIV \<noteq> {..\<le>\<^sub>ah'}"
  using gt_ex[of h'] not_UNIV_le_Iic by blast

lemmas not_Iic_eq_UNIV[simp] = not_UNIV_eq_Iic[symmetric]

lemma not_Icc_eq_Ici[simp]: "{l\<le>\<^sub>a..\<le>\<^sub>ah} \<noteq> {l'\<le>\<^sub>a..}"
  using not_Ici_le_Icc by blast

lemmas not_Ici_eq_Icc[simp] = not_Icc_eq_Ici[symmetric]

lemma not_Iic_eq_Ici[simp]: "{..\<le>\<^sub>ah} \<noteq> {l'\<le>\<^sub>a..}"
  using not_Ici_le_Iic[of l' h] by blast

lemmas not_Ici_eq_Iic[simp] = not_Iic_eq_Ici[symmetric]

lemma greaterThan_non_empty[simp]: "{x<\<^sub>a..} \<noteq> {}"
  using gt_ex[of x] unfolding ray_def by simp

end

context order
begin

interpretation ord_syntax .
interpretation order_pair le ls le ls ..
interpretation ord_pair_syntax le ls le ls .

lemma mono_image_least:
  assumes f_mono: "mono\<^sub>a\<^sub>b f"
    and f_img: "f ` {m\<le>\<^sub>a..<\<^sub>an} = {m'\<le>\<^sub>a..<\<^sub>an'}"
    and "m <\<^sub>a n"
  shows "f m = m'"
proof -
  from f_img have "{m'\<le>\<^sub>a..<\<^sub>an'} \<noteq> {}" by (force simp: assms(3))
  with f_img have "m' \<in> f ` {m\<le>\<^sub>a..<\<^sub>an}" by auto
  then obtain k where "f k = m'" "m \<le>\<^sub>a k" by auto
  moreover have "m' \<le>\<^sub>a f m"
    unfolding interval_def using f_img by (auto simp: assms(3))
  ultimately show "f m = m'"
    using f_mono by (auto dest: monoD intro: antisym)
qed

end

subsection\<open>Bounded sets\<close>

definition bdd :: "['a set, ['a, 'a] \<Rightarrow> bool, 'a set] \<Rightarrow> bool"
  (\<open>(on _ with _ : \<guillemotleft>bdd\<guillemotright> _)\<close> [1000, 1000, 1000] 10)
  where "bdd U op A \<longleftrightarrow> (\<exists>M\<in>U. \<forall>x \<in> A. op x M)"

ctr parametricity
  in bdd_def

context ord_syntax
begin

abbreviation bdd_above where "bdd_above \<equiv> bdd UNIV (\<le>\<^sub>a)"
abbreviation bdd_below where "bdd_below \<equiv> bdd UNIV (\<ge>\<^sub>a)"

end

context preorder
begin

interpretation ord_syntax .

interpretation preorder_dual ..

lemma bdd_aboveI[intro]:
  assumes "\<And>x. x \<in> A \<Longrightarrow> x \<le>\<^sub>a M"
  shows "bdd_above A"
  using assms unfolding bdd_def by auto

lemma bdd_belowI[intro]:
  assumes "\<And>x. x \<in> A \<Longrightarrow> m \<le>\<^sub>a x"
  shows "bdd_below A"
  using assms unfolding bdd_def by auto

lemma bdd_aboveI2:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<le>\<^sub>a M"
  shows "bdd_above (f ` A)"
  using assms by force

lemma bdd_belowI2:
  assumes "\<And>x. x \<in> A \<Longrightarrow> m \<le>\<^sub>a f x"
  shows "bdd_below (f ` A)"
  using assms by force

lemma bdd_above_empty[simp, intro]: "bdd_above {}"
  unfolding bdd_above_def by auto

lemma bdd_below_empty[simp, intro]: "bdd_below {}"
  unfolding bdd_below_def by auto

lemma bdd_above_mono:
  assumes "bdd_above B" and "A \<subseteq> B"
  shows "bdd_above A"
  using assms unfolding bdd_def by auto

lemma bdd_below_mono:
  assumes "bdd_below B" and "A \<subseteq> B"
  shows "bdd_below A"
  using assms unfolding bdd_def by auto

lemma bdd_above_Int1[simp]:
  assumes "bdd_above A"
  shows "bdd_above (A \<inter> B)"
  using assms by (auto simp: bdd_above_mono)

lemma bdd_above_Int2[simp]:
  assumes "bdd_above B"
  shows "bdd_above (A \<inter> B)"
  using assms by (auto simp: bdd_above_mono)

lemma bdd_below_Int1[simp]:
  assumes "bdd_below A"
  shows "bdd_below (A \<inter> B)"
  using assms by (auto simp: bdd_below_mono)

lemma bdd_below_Int2[simp]:
  assumes "bdd_below B"
  shows "bdd_below (A \<inter> B)"
  using assms by (auto simp: bdd_below_mono)

lemma bdd_above_Ioo[simp, intro]: "bdd_above {a<\<^sub>a..<\<^sub>ab}"
  by (auto intro!: less_imp_le)

lemma bdd_above_Ico[simp, intro]: "bdd_above {a\<le>\<^sub>a..<\<^sub>ab}"
  by (auto intro!: less_imp_le)

lemma bdd_above_Iio[simp, intro]: "bdd_above {..<\<^sub>ab}"
  by (auto intro: less_imp_le)

lemma bdd_above_Ioc[simp, intro]: "bdd_above {a<\<^sub>a..\<le>\<^sub>ab}" by auto

lemma bdd_above_Icc[simp, intro]: "bdd_above {a\<le>\<^sub>a..\<le>\<^sub>ab}"
  by (auto intro: less_imp_le)

lemma bdd_above_Iic[simp, intro]: "bdd_above {..\<le>\<^sub>ab}"
  by (auto intro: less_imp_le)

lemma bdd_below_Ioo[simp, intro]: "bdd_below {a<\<^sub>a..<\<^sub>ab}"
  by (auto intro!: less_imp_le)

lemma bdd_below_Ioc[simp, intro]: "bdd_below {a<\<^sub>a..\<le>\<^sub>ab}"
  by (auto intro!: less_imp_le)

lemma bdd_below_Ioi[simp, intro]: "bdd_below {a<\<^sub>a..}"
  by (auto intro: less_imp_le)

lemma bdd_below_Ico[simp, intro]: "bdd_below {a\<le>\<^sub>a..<\<^sub>ab}" by auto

lemma bdd_below_Icc[simp, intro]: "bdd_below {a\<le>\<^sub>a..\<le>\<^sub>ab}" by auto

lemma bdd_below_Ici[simp, intro]: "bdd_below {a\<le>\<^sub>a..}"
  by (auto intro: less_imp_le)

end

context order_pair
begin

interpretation ord_pair_syntax .

lemma bdd_above_image_mono:
  assumes "mono\<^sub>a\<^sub>b f" and "ord\<^sub>a.bdd_above A"
  shows "ord\<^sub>b.bdd_above (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

lemma bdd_below_image_mono:
  assumes "mono\<^sub>a\<^sub>b f" and "ord\<^sub>a.bdd_below A"
  shows "ord\<^sub>b.bdd_below (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

lemma bdd_above_image_antimono:
  assumes "antimono\<^sub>a\<^sub>b f" and "ord\<^sub>a.bdd_below A"
  shows "ord\<^sub>b.bdd_above (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

lemma bdd_below_image_antimono:
  assumes "antimono\<^sub>a\<^sub>b f" and "ord\<^sub>a.bdd_above A"
  shows "ord\<^sub>b.bdd_below (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

end

context order_extremum
begin

interpretation ord_syntax .
interpretation order_dual ..

lemma bdd_above_top[simp, intro!]: "bdd_above A"
  by (rule bdd_aboveI[of _ extremum]) simp

end

text\<open>\newpage\<close>

end


header {* Circular Singly Linked Lists *}
theory Circ_List
imports List_Seg Imp_List_Spec
begin

text {*
  Example of circular lists, with efficient append, prepend, pop, and rotate
  operations.
*}

subsection {* Datatype Definition *}

type_synonym 'a cs_list = "'a node ref option"

text {* A circular list is described by a list segment, with special
  cases for the empty list: *}
fun cs_list :: "'a::heap list \<Rightarrow> 'a node ref option \<Rightarrow> assn" where
  "cs_list [] None = emp"
| "cs_list (x#l) (Some p) = lseg (x#l) (Some p) (Some p)"
| "cs_list _ _ = false"

lemma [simp]:
  "cs_list l (Some p)
  = (\<exists>\<^sub>Ax ls. \<up>(l=x#ls) * lseg (x#ls) (Some p) (Some p))"
  apply (rule ent_iffI)
  apply (cases l)
  apply simp
  apply sep_auto
  apply (cases l)
  apply simp
  apply sep_auto
  done

subsection {* Precision *}
lemma cs_prec:
  "precise cs_list"
  apply rule
  apply (case_tac p)
  apply clarsimp

  apply clarsimp
  apply (subgoal_tac "x=xa \<and> n=na", simp)

  apply (erule prec_frame_expl[OF lseg_prec1])
  apply frame_inference
  apply frame_inference

  apply (drule prec_frame[OF sngr_prec])
  apply frame_inference
  apply frame_inference
  apply simp
  done

lemma cs_imp_list_impl: "imp_list cs_list"
  apply unfold_locales
  apply (rule cs_prec)
  done
interpretation cs!: imp_list cs_list by (rule cs_imp_list_impl)

subsection {* Operations *}
subsubsection {* Allocate Empty List *}
definition cs_empty :: "'a::heap cs_list Heap" where
  "cs_empty \<equiv> return None"

lemma cs_empty_rule: "<emp> cs_empty <cs_list []>"
  unfolding cs_empty_def
  by sep_auto

lemma cs_empty_impl: "imp_list_empty cs_list cs_empty"
  by unfold_locales (sep_auto heap: cs_empty_rule)
interpretation cs!: imp_list_empty cs_list cs_empty by (rule cs_empty_impl)

subsubsection {* Prepend Element *}
fun cs_prepend :: "'a \<Rightarrow> 'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
  "cs_prepend x None = do {
    p \<leftarrow> ref (Node x None);
    p:=Node x (Some p);
    return (Some p)
  }"
| "cs_prepend x (Some p) = do {
    n \<leftarrow> !p;
    q \<leftarrow> ref (Node (val n) (next n));
    p := Node x (Some q);
    return (Some p)
  }"

declare cs_prepend.simps [simp del]

lemma cs_prepend_rule:
  "<cs_list l p> cs_prepend x p <cs_list (x#l)>"
  apply (cases p)
  apply simp_all
  apply (sep_auto simp: cs_prepend.simps)

  apply (sep_auto simp: cs_prepend.simps)
  done

lemma cs_prepend_impl: "imp_list_prepend cs_list cs_prepend"
  by unfold_locales (sep_auto heap: cs_prepend_rule)
interpretation cs!: imp_list_prepend cs_list cs_prepend
  by (rule cs_prepend_impl)

subsubsection {* Append Element *}
fun cs_append :: "'a \<Rightarrow> 'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
  "cs_append x None = do {
    p \<leftarrow> ref (Node x None);
    p:=Node x (Some p);
    return (Some p) }"
| "cs_append x (Some p) = do {
    n \<leftarrow> !p;
    q \<leftarrow> ref (Node (val n) (next n));
    p := Node x (Some q);
    return (Some q)
  }"

declare cs_append.simps [simp del]

lemma cs_append_rule:
  "<cs_list l p> cs_append x p <cs_list (l@[x])>"
  apply (cases p)
  apply simp_all
  apply (sep_auto simp: cs_append.simps)

  apply (sep_auto simp: cs_append.simps)
  apply (rule ent_frame_fwd)
  apply (rule_tac s=pp in lseg_append) (* frame_inference does no backtracking
    on instantiating schematics, hence we have to give it some help here. *)
  apply frame_inference
  apply (sep_auto)
  done

lemma cs_append_impl: "imp_list_append cs_list cs_append"
  by unfold_locales (sep_auto heap: cs_append_rule)
interpretation cs!: imp_list_append cs_list cs_append
  by (rule cs_append_impl)

subsubsection {* Pop First Element *}
fun cs_pop :: "'a::heap cs_list \<Rightarrow> ('a\<times>'a cs_list) Heap" where
  "cs_pop None = raise ''Pop from empty list''"
| "cs_pop (Some p) = do {
    n1 \<leftarrow> !p;
    if next n1 = Some p then
      return (val n1,None) (* Singleton list becomes empty list *)
    else do {
      let p2 = the (next n1);
      n2 \<leftarrow> !p2;
      p := Node (val n2) (next n2);
      return (val n1,Some p)
    }
  }"

declare cs_pop.simps[simp del]

lemma cs_pop_rule:
  "<cs_list (x#l) p> cs_pop p <\<lambda>(y,p'). cs_list l p' * true * \<up>(y=x)>"
  apply (cases p)
  apply (sep_auto simp: cs_pop.simps)

  apply (cases l)
  apply (sep_auto simp: cs_pop.simps dflt_simps: option.sel)

  apply (sep_auto
    simp: cs_pop.simps
    dflt_simps: option.sel
    eintros del: exI)
  (* Some unfortunate quantifier fiddling :( *)
  apply (rule_tac x=aa in exI)
  apply (rule_tac x=list in exI)
  apply (rule_tac x=pp in exI)
  apply clarsimp
  apply (rule exI)
  apply sep_auto
  done

lemma cs_pop_impl: "imp_list_pop cs_list cs_pop"
  apply unfold_locales
  apply (sep_auto heap: cs_pop_rule elim!: list_not_emptyE)
  done
interpretation cs!: imp_list_pop cs_list cs_pop by (rule cs_pop_impl)

subsubsection {* Rotate *}
fun cs_rotate :: "'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
  "cs_rotate None = return None"
| "cs_rotate (Some p) = do {
    n \<leftarrow> !p;
    return (next n)
  }"

declare cs_rotate.simps [simp del]

lemma cs_rotate_rule:
  "<cs_list l p> cs_rotate p <cs_list (rotate1 l)>"
  apply (cases p)
  apply (sep_auto simp: cs_rotate.simps)

  apply (cases l)
  apply simp

  apply (case_tac list)
  apply simp
  apply (sep_auto simp: cs_rotate.simps)

  apply (sep_auto simp: cs_rotate.simps)
  apply (rule ent_frame_fwd)
  apply (rule_tac s="pp" in lseg_append)
  apply frame_inference
  apply sep_auto
  done

lemma cs_rotate_impl: "imp_list_rotate cs_list cs_rotate"
  apply unfold_locales
  apply (sep_auto heap: cs_rotate_rule)
  done
interpretation cs!: imp_list_rotate cs_list cs_rotate by (rule cs_rotate_impl)

subsection {* Test *}
definition "test \<equiv> do {
  l \<leftarrow> cs_empty;
  l \<leftarrow> cs_append ''a'' l;
  l \<leftarrow> cs_append ''b'' l;
  l \<leftarrow> cs_append ''c'' l;
  l \<leftarrow> cs_prepend ''0'' l;
  l \<leftarrow> cs_rotate l;
  (v1,l)\<leftarrow>cs_pop l;
  (v2,l)\<leftarrow>cs_pop l;
  (v3,l)\<leftarrow>cs_pop l;
  (v4,l)\<leftarrow>cs_pop l;
  return [v1,v2,v3,v4]
}"

definition "test_result \<equiv> [''a'', ''b'', ''c'', ''0'']"

lemma "<emp> test <\<lambda>r. \<up>(r=test_result) * true>"
  unfolding test_def test_result_def
  apply (sep_auto)
  done

export_code test checking SML_imp

ML_val {*
  val res = @{code test} ();
  if res = @{code test_result} then () else raise Match;
*}

hide_const (open) test test_result

end


section \<open>Finding a Path between Nodes\<close>
theory Find_Tour
imports
  CAVA_Automata.Digraph
  Specification
  DFS_Framework.DFS_Framework
begin
text \<open>
  We instantiate the DFS framework to find a path to some reachable node
  that satisfies a given predicate. We present four variants of the algorithm:
  Finding any path, and finding path of at least length one, combined with
  searching the whole graph, and searching the graph restricted to a given set
  of nodes. The restricted variants are efficiently implemented by
  pre-initializing the visited set (cf. @{theory DFS_Framework.Restr_Impl}).

  The restricted variants can be used for incremental search, ignoring already
  searched nodes in further searches. This is required, e.g., for the inner
  search of nested DFS (Buchi automaton emptiness check).
\<close>

subsection \<open>Including empty Path\<close>
record 'v fp0_state = "'v state" +
  tour_list :: "'v list"

type_synonym 'v fp0_param = "('v, ('v,unit) fp0_state_ext) parameterization"

definition fp0_params :: "'v fp0_param" where
"fp0_params \<equiv> dflt_parametrization state.more
  (RETURN \<lparr> tour_list = [] \<rparr>)
  \<lparr> on_discover := \<lambda>_ n s. RETURN \<lparr>tour_list = tour_list s @ [n]\<rparr> \<rparr>"

lemmas fp0_params_simp[simp] =
  gen_parameterization.simps[mk_record_simp, OF fp0_params_def[simplified]]

locale node_and_MST_in_graph =
  complete_finite_metric_graph G +
  T: tree T
  for G::\<open>('v::metric_space,real) graph\<close>
  and T::\<open>('v,real) graph\<close> +
  fixes v\<^sub>0::\<open>'v\<close>
  assumes v_in_V: \<open>v\<^sub>0 \<in> V\<close>
  and mst: \<open>minimum_spanning_tree T G\<close>
begin

lemma n_in_TV_iff: \<open>n \<in> T.V \<longleftrightarrow> n \<in> V\<close>
  using mst[unfolded minimum_spanning_tree_def spanning_tree_def]
  by (meson subgraph_node)

lemma v_in_TV: \<open>v\<^sub>0 \<in> T.V\<close>
  using n_in_TV_iff v_in_V by blast

lemma subgraphTG: \<open>subgraph T G\<close>
  using minimum_spanning_tree_def mst spanning_tree_def by blast

lemma finiteTE: \<open>finite T.E\<close>
  using finite_E finite_subset subgraphTG subgraph_def by blast

lemma finiteTV: \<open>finite T.V\<close>
  by (metis s.finiteV subgraphTG subgraph_def)

lemma finite01: \<open>finite {(va,w,v'). (va, w, v') \<in> T.E}\<close>
  using finiteTE by force

lemma finite02: \<open>finite {(w,v'). (v, w, v') \<in> T.E}\<close>
  using finiteTE by (metis succ_def succ_finite)

lemma finite03: \<open>finite {(w,v')| w v'. (v, w, v') \<in> T.E}\<close>
  using finite02 by auto

lemma finite04: \<open>{v'. \<exists>w. (v, w, v') \<in> T.E} \<subseteq> T.V\<close>
  using T.E_validD(2) by blast

lemma finite04': \<open>{v'. \<exists>w. (v', w, v) \<in> T.E} \<subseteq> T.V\<close>
  using T.E_validD(1) by blast

lemma finite05: \<open>finite {v'. \<exists>w. (v, w, v') \<in> T.E}\<close>
  using finite04 finiteTV infinite_super by blast

lemma finite05': \<open>finite {v'. \<exists>w. (v', w, v) \<in> T.E}\<close>
  using finite04' finiteTV finite_subset by blast

definition T' where
  \<open>T' = \<lparr>g_V = V, g_E = {(v,v'). (\<exists>w.(v,w,v')\<in>T.E) \<or> (\<exists>w.(v',w,v)\<in>T.E)}, g_V0 = {v\<^sub>0}\<rparr>\<close>
sublocale dfs: DFS T' fp0_params \<comment> \<open>to-do: try without qualifier\<close>
  apply unfold_locales
  apply (auto simp: T'_def E_validD v_in_TV v_in_V)
  using T.E_validD(1) n_in_TV_iff apply blast
  using T.E_validD(2) n_in_TV_iff apply blast
  using T.E_validD(2) n_in_TV_iff apply blast
  using T.E_validD(1) n_in_TV_iff apply blast
  by (simp_all add: finite05 finite05' T.E_valid)

lemma dfsV_V[simp]: \<open>dfs.V = V\<close>
  by (simp add: T'_def)

lemma start_nodes_are_nodes[simp]: "v \<in> dfs.V0 \<Longrightarrow> v \<in> V"
  by (simp add: T'_def v_in_V)

lemma finite_dfsgraph_reachable: \<open>finite dfs.reachable\<close>
  using dfs.finite_E by (simp add: T'_def)

  lemma [simp]:
    "tour_list (dfs.empty_state \<lparr>tour_list = e\<rparr>) = e"
    by (simp add: dfs.empty_state_def)

  lemma [simp]:
    "tour_list (s\<lparr>state.more := state.more s'\<rparr>) = tour_list s'"
    by (cases s, cases s') auto

(* This was above the simp lemmas, but isn't it superseded anyway by the sublocale statement?
locale fp0 = param_DFS
  where G = G and param = "fp0_params"
  for G
begin
*)(*
  sublocale DFS where param = "fp0_params"
    by unfold_locales simp_all*)

end

lemma dfsI:
  assumes \<open>node_and_MST_in_graph G T v\<^sub>0\<close>
  shows \<open>DFS (node_and_MST_in_graph.T' G T v\<^sub>0) fp0_params\<close>
proof - interpret node_and_MST_in_graph G T v\<^sub>0 by fact show ?thesis by unfold_locales qed

locale fp0_invar = node_and_MST_in_graph +
  DFS_invar where G = T' and param = "fp0_params"

lemma fp0_invar_intro[intro]:
  assumes "DFS_invar (node_and_MST_in_graph.T' G T v\<^sub>0) fp0_params s"
    and "node_and_MST_in_graph G T v\<^sub>0"
  shows "fp0_invar G T v\<^sub>0 s"
  using assms
proof -
  assume "DFS_invar (node_and_MST_in_graph.T' G T v\<^sub>0) fp0_params s"
  interpret DFS_invar \<open>node_and_MST_in_graph.T' G T v\<^sub>0\<close> "fp0_params" s by fact
  assume \<open>node_and_MST_in_graph G T v\<^sub>0\<close>
  interpret tmp: node_and_MST_in_graph G T v\<^sub>0 by fact
  show ?thesis by unfold_locales
qed

lemma fp0_invar_2_DFS:
  \<open>fp0_invar G T v\<^sub>0 s \<Longrightarrow> DFS_invar (node_and_MST_in_graph.T' G T v\<^sub>0) fp0_params s\<close>
proof -
  fix s
  assume "fp0_invar G T v\<^sub>0 s"
  interpret fp0_invar G T v\<^sub>0 s by fact
  show "DFS_invar (node_and_MST_in_graph.T' G T v\<^sub>0) fp0_params s" by unfold_locales
qed

abbreviation (in valid_graph) \<open>ind' V' \<equiv> \<lparr>nodes=V', edges = E \<inter> V'\<times>UNIV\<times>V'\<rparr>\<close>

lemma (in valid_graph) valid_graph_ind': \<open>valid_graph (ind' V')\<close>
  by unfold_locales auto

lemma (in complete_finite_weighted_graph) subgraph_complete:
  \<open>V' \<subseteq> V \<Longrightarrow> complete_finite_weighted_graph (ind' V') weight\<close>
proof unfold_locales
  assume \<open>V' \<subseteq> V\<close>
  then show "finite (nodes \<lparr>nodes = V', edges = E \<inter> V' \<times> UNIV \<times> V'\<rparr>)"
    by (simp add: finite_subset)
  fix v w v'
  assume \<open>(v, w, v') \<in> edges \<lparr>nodes = V', edges = E \<inter> V' \<times> UNIV \<times> V'\<rparr>\<close>
  then show "weight v v' = w"
    using edge_unique by auto
qed (auto simp: edge_exists subsetD)

lemma (in complete_finite_metric_graph) subgraph_complete_metric:
  \<open>V' \<subseteq> V \<Longrightarrow> complete_finite_metric_graph (ind' V')\<close>
  unfolding complete_finite_metric_graph_def by (simp add: subgraph_complete)

context node_and_MST_in_graph begin

lemma i_snd_pending_sane: \<open>dfs.is_invar (\<lambda>s. snd ` (pending s) \<subseteq> V)\<close>
  by (induction rule: dfs.establish_invarI) (use dfs.E_ss in auto)
lemmas (in fp0_invar) snd_pending_sane = i_snd_pending_sane[THEN make_invar_thm, rule_format]

lemma i_stack_sane: \<open>dfs.is_invar (\<lambda>s. set (stack s) \<subseteq> V)\<close>
proof (induction rule: dfs.establish_invarI)
  case (finish s s' u)
  then show ?case
    by auto (meson in_hd_or_tl_conv subset_iff)
next
  case (discover s s' u v)
  then show ?case unfolding dfs.discover_def
    by auto (use i_snd_pending_sane in \<open>meson DFS_invar.make_invar_thm img_snd subset_iff\<close>)
qed auto
lemmas (in fp0_invar) stack_sane = i_stack_sane[THEN make_invar_thm, rule_format]

lemma i_discovered_sane: \<open>dfs.is_invar (\<lambda>s. dom (discovered s) \<subseteq> V)\<close>
proof (induction rule: dfs.establish_invarI)
  case (discover s s' u v) then interpret fp0_invar where s=s
    using node_and_MST_in_graph_axioms by blast
  show ?case using discover unfolding dfs.discover_def
    by (auto simp: T'_def) (use snd_pending_sane in blast)
qed auto
lemmas (in fp0_invar) discovered_sane = i_discovered_sane[THEN make_invar_thm, rule_format]

lemma \<open>dfs.is_invar (\<lambda>s. valid_graph.tour (ind' (dom (discovered s))) (tour_list s))\<close>
proof (induction rule: dfs.establish_invarI)
  case (discover s s' u v) then interpret fp0_invar where s=s
    using node_and_MST_in_graph_axioms by blast
  interpret s: complete_finite_metric_graph \<open>ind' (dom (discovered s))\<close>
    by (fact subgraph_complete_metric[OF discovered_sane])
  from discover have ne: "stack s \<noteq> []" by simp
  from discover have vnis: "v\<notin>set (stack s)" using stack_discovered by auto
  have discovered'[simp]: \<open>dom (discovered s') = insert v (dom (discovered s))\<close>
    using discover[unfolded dfs.discover_def] by auto
  interpret s': complete_finite_metric_graph \<open>ind' (insert v (dom (discovered s)))\<close>
    using discover snd_pending_sane discovered_sane by (auto intro!: subgraph_complete_metric)
  have tour_list': \<open>tour_list s' = tour_list s\<close>
    using discover[unfolded dfs.discover_def] by auto
  have a: \<open>on_discover fp0_params u v s' \<le> SPEC (\<lambda>r. r = \<lparr>tour_list = tour_list s' @ [v]\<rparr>)\<close>
    by simp
  then have b: \<open>on_discover fp0_params u v s' \<le>\<^sub>n SPEC (\<lambda>r. r = \<lparr>tour_list = tour_list s' @ [v]\<rparr>)\<close>
    using leof_lift by blast
  have c: \<open>on_discover fp0_params u v s' \<le> SPEC (\<lambda>r. r = \<lparr>tour_list = tour_list s @ [v]\<rparr>)\<close>
    by (simp add: tour_list')
  then have d: \<open>on_discover fp0_params u v s' \<le>\<^sub>n SPEC (\<lambda>r. r = \<lparr>tour_list = tour_list s @ [v]\<rparr>)\<close>
    using leof_lift by blast
  have \<open>s'.tour (tour_list s @ [v])\<close>
  proof (cases \<open>tour_list s\<close>)
    case (Cons p ps)
    show ?thesis
    proof (cases ps)
      case Nil
      then have s_tour: \<open>s.tour [p]\<close>
        using discover(2) Cons by argo
      then have s'V: \<open>s'.V = {p,v}\<close> \<open>insert v (dom (discovered s)) = {p, v}\<close>
        by force+
      have pv: \<open>p \<in> V\<close> \<open>v \<in> V\<close> \<open>v \<noteq> p\<close>
        using s.tour_set_V[OF s_tour] discovered_sane apply fastforce
        using discover snd_pending_sane apply fast
        by (metis Un_empty discover(6,9) discovered_eq_finished_un_stack insert_absorb insert_absorb2 insert_ident insert_not_empty s'V(2) set_empty2)
      have \<open>s'.the_path [p, v] p = [(p,dist p v,v),(v,dist v p,p)]\<close>
        oops

end

end


section "Stack Machine and Compilation"

theory ASM imports "~~/src/HOL/IMP/AExp" begin

subsection "Stack Machine"

text_raw\<open>\snip{ASMinstrdef}{0}{1}{%\<close>
datatype instr = LOADI val | LOAD vname | ADD
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{ASMstackdef}{1}{2}{%\<close>
type_synonym stack = "val list"
text_raw\<open>}%endsnip\<close>

text\<open>\noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.\<close>

text_raw\<open>\snip{ASMexeconedef}{0}{1}{%\<close>
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk  =  Some (n # stk)" |
"exec1 (LOAD x) s stk  =  Some (s(x) # stk)" |
"exec1  ADD _ (j # i # stk)  =  Some ((i + j) # stk)" |
"exec1 _ _ _ = None"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{ASMexecdef}{1}{2}{%\<close>
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk = (
  case exec1 i s stk of
  Some stk' \<Rightarrow> exec is s stk' |
  None \<Rightarrow> None
)"
text_raw\<open>}%endsnip\<close>

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1@is2) s stk = (
    case exec is1 s stk of
    Some stk' \<Rightarrow> exec is2 s stk' |
    None \<Rightarrow> None
  )"
apply(induction is1 arbitrary: stk)
apply (auto split: option.split)
done

subsection "Compilation"

text_raw\<open>\snip{ASMcompdef}{0}{2}{%\<close>
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw\<open>}%endsnip\<close>

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
apply(induction a arbitrary: stk)
apply (auto)
done

end


section \<open>State for SM\<close>
theory SM_State
imports SM_Syntax "HOL-Word.Word" "HOL-Library.Multiset"
begin

section \<open>Values\<close>
  text \<open>The primitive values are fixed-size signed integers\<close>
  type_synonym word_size = 32   \<comment> \<open>Word size\<close>
  type_synonym signed = "word_size Word.word"  \<comment> \<open>Signed integer\<close>

  text \<open>Currently, we only have signed integer values.
    This may change if we extend the language, and allow,
    i.e., channel pointers, pids or process references\<close>
  type_synonym val = signed  \<comment> \<open>Value type\<close>

section \<open>Configurations\<close>
  type_synonym valuation = "ident \<rightharpoonup> val"

  record local_state =
    variables :: valuation

  record global_state =
    variables :: valuation

  text \<open>The effect of actions is on focused states\<close>
  type_synonym focused_state = "local_state \<times> global_state"

section \<open>Utilities\<close>
  abbreviation "word_len \<equiv> LENGTH(word_size)"
  abbreviation "signeds \<equiv> sints (LENGTH(word_size))"

  definition min_signed :: int where "min_signed \<equiv> -(2^(word_len - 1))"
  definition max_signed :: int where "max_signed \<equiv> 2^(word_len - 1) - 1"

  definition signed_of_int :: "int \<Rightarrow> signed"
    where "signed_of_int i \<equiv> word_of_int i"

  definition int_of_signed :: "signed \<Rightarrow> int"
    where "int_of_signed i == sint i"

  lemma si_inv[simp]: "signed_of_int (int_of_signed i) = i"
    unfolding signed_of_int_def int_of_signed_def
    by simp

  lemma int_of_signed_in_range[simp]:
    "int_of_signed i \<ge> min_signed"
    "int_of_signed i \<le> max_signed"
    unfolding int_of_signed_def min_signed_def max_signed_def
    apply -
    apply (rule sint_ge)
    using sint_lt[of i]
    by simp

  lemma is_inv[simp]:
    "\<lbrakk> i\<ge>min_signed; i\<le>max_signed \<rbrakk> \<Longrightarrow> (int_of_signed (signed_of_int i)) = i"
    unfolding int_of_signed_def signed_of_int_def min_signed_def max_signed_def
    by (simp add: sints_num word_sint.Abs_inverse)

  primrec val_of_bool :: "bool \<Rightarrow> val" where
    "val_of_bool False = 0" | "val_of_bool True = 1"

  definition bool_of_val :: "val \<Rightarrow> bool" where
    "bool_of_val v \<equiv> v\<noteq>0"

  lemma bool_of_val_invs[simp]:
    "bool_of_val (val_of_bool b) = b"
    "val_of_bool (bool_of_val v) = (if v=0 then 0 else 1)"
    unfolding bool_of_val_def
    by (cases b) auto

end


theory "Static_Semantics"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "./Lib"
  "./Syntax"
  "./Denotational_Semantics"
  "./Frechet_Correctness"
begin
section \<open>Static Semantics\<close>
text \<open>This section introduces functions for computing properties of the static semantics, specifically
 the following dependencies:
  \begin{itemize}
    \item Signatures: Symbols (from the interpretation) which influence the result of a term, ode, formula, program
    \item Free variables: Variables (from the state) which influence the result of a term, ode, formula, program
    \item Bound variables: Variables (from the state) that *might* be influenced by a program
    \item Must-bound variables: Variables (from the state) that are *always* influenced by a program (i.e.
  will never depend on anything other than the free variables of that program)
  \end{itemize}

  We also prove basic lemmas about these definitions, but their overall correctness is proved elsewhere
  in the Bound Effect and Coincidence theorems.
  \<close>

subsection \<open>Signature Definitions\<close>
primrec SIGT :: "trm \<Rightarrow> ident set"
where
  "SIGT (Var var) = {}"
| "SIGT (Const r) = {}"
| "SIGT (Function var f) = {var} \<union> (\<Union>i. SIGT (f i))"
| "SIGT (Functional var) = {var}"
| "SIGT (Neg t1) = SIGT t1"
| "SIGT (Plus t1 t2) = SIGT t1 \<union> SIGT t2"
| "SIGT (Times t1 t2) = SIGT t1 \<union> SIGT t2"
| "SIGT (Div t1 t2) = SIGT t1 \<union> SIGT t2"
| "SIGT (Max t1 t2) = SIGT t1 \<union> SIGT t2"
| "SIGT (Min t1 t2) = SIGT t1 \<union> SIGT t2"
| "SIGT (Abs t1) = SIGT t1"
| "SIGT (DiffVar x) = {}"
| "SIGT (Differential t) = SIGT t"

primrec SIGO   :: "ODE \<Rightarrow> (ident + ident) set"
where
  "SIGO (OVar c _) = {Inr c}"
| "SIGO (OSing x \<theta>) =  {Inl x| x. x \<in> SIGT \<theta>}"
| "SIGO (OProd ODE1 ODE2) = SIGO ODE1 \<union> SIGO ODE2"

lemma SIGO_assoc:"SIGO (oprod ODE1 ODE2) = SIGO (OProd ODE1 ODE2)"
  apply(induction ODE1 arbitrary:ODE2)
  by( auto)

primrec SIGP   :: "hp      \<Rightarrow> (ident + ident + ident) set"
and     SIGF   :: "formula \<Rightarrow> (ident + ident + ident) set"
where
  "SIGP (Pvar var) = {Inr (Inr var)}"
| "SIGP (Assign var t) = {Inl x | x. x \<in> SIGT t}"
| "SIGP (AssignAny var) = {}"
| "SIGP (DiffAssign var t) = {Inl x | x. x \<in> SIGT t}"
| "SIGP (Test p) = SIGF p"
| "SIGP (EvolveODE ODE p) = SIGF p \<union> {Inl x | x. Inl x \<in> SIGO ODE} \<union> {Inr (Inr x) | x. Inr x \<in> SIGO ODE}"
| "SIGP (Choice a b) = SIGP a \<union> SIGP b"
| "SIGP (Sequence a b) = SIGP a \<union> SIGP b"
| "SIGP (Loop a) = SIGP a"
| "SIGF (Geq t1 t2) = {Inl x | x. x \<in> SIGT t1 \<union> SIGT t2}"
| "SIGF (Prop var args) = {Inr (Inr var)} \<union> {Inl x | x. x \<in> (\<Union>i. SIGT (args i))}"
| "SIGF (Not p) = SIGF p"
| "SIGF (And pp p2) = SIGF pp \<union> SIGF p2"
| "SIGF (Exists var p) = SIGF p"
| "SIGF (Diamond a p) = SIGP a \<union> SIGF p"
| "SIGF (InContext var p) = {Inr (Inl var)} \<union> SIGF p"

fun primify :: "(ident + ident) \<Rightarrow> (ident + ident) set"
where
  "primify (Inl x) = {Inl x, Inr x}"
| "primify (Inr x) = {Inl x, Inr x}"

subsection \<open>Variable Binding Definitions\<close>
text\<open>
  We represent the (free or bound or must-bound) variables of a term as an (id + id) set,
  where all the (Inl x) elements are unprimed variables x and all the (Inr x) elements are
  primed variables x'.
  \<close>
text\<open>Free variables of a term \<close>
primrec FVT::"trm \<Rightarrow> (ident + ident) set"
where
  FVT_Var:"FVT (Var x) = {Inl x}"
| FVT_Const:"FVT (Const x) = {}"
| FVT_Fun:"FVT (Function f args) = (\<Union>i. FVT (args i))"
| FVT_Funl:"FVT (Functional f) = UNIV"
| FVT_Neg:"FVT (Neg f) = FVT f"
| FVT_Plus:"FVT (Plus f g) = FVT f \<union> FVT g"
| FVT_Times:"FVT (Times f g) = FVT f \<union> FVT g"
| FVT_Div:"FVT (Div f g) = FVT f \<union> FVT g"
| FVT_Max:"FVT (Max f g) = FVT f \<union> FVT g"
| FVT_Min:"FVT (Min f g) = FVT f \<union> FVT g"
| FVT_Abs:"FVT (Abs f) = FVT f"
| FVT_Diff:"FVT (Differential f) =
   (\<Union>x \<in> {x. Inl x \<in> (FVT f)}. {Inl x, Inr x})
  \<union>(\<Union>x \<in> {x. Inr x \<in> (FVT f)}. {Inl x, Inr x})"

| FVT_DiffVar:"FVT (DiffVar x) = {Inr x}"

lemma FVT_Zero[simp]: "FVT \<^bold>0 = {}"
  by (auto simp: Zero_def)

lemma FVT_One[simp]: "FVT \<^bold>1 = {}"
  by (simp add: One_def)

fun FVDiff :: "trm \<Rightarrow> (ident + ident) set"
where "FVDiff f = (\<Union>x \<in> (FVT f). primify x)"

text\<open> Free variables of an ODE includes both the bound variables and the terms \<close>
fun FVO :: "ODE \<Rightarrow> ident set"
where
  "FVO (OVar c (Some x)) = UNIV"
| "FVO (OVar c None) = UNIV"
| "FVO (OSing x \<theta>) = {x} \<union> {x . Inl x \<in> FVT \<theta>}"
| "FVO (OProd ODE1 ODE2) = FVO ODE1 \<union> FVO ODE2"

(* lemma oprod_induct:
  assumes BC1:"(\<And>x t ODE2. P (OSing x t) ODE2)"
  assumes BC2:"(\<And>c ODE2. (P (OVar c) ODE2))"
  assumes  IH:"\<And>l1 l2 x. (\<And>x. P l1 x) \<Longrightarrow> (\<And>x. P l2 x) \<Longrightarrow> P (OProd l1 l2) x"
*)
lemma FVO_assoc:"FVO (oprod ODE1 ODE2) = FVO (OProd ODE1 ODE2)"
  apply(induction ODE1 arbitrary:ODE2)
  by(auto)

text\<open> Bound variables of ODEs, formulas, programs \<close>
fun BVO :: "ODE \<Rightarrow> (ident + ident) set"
where
  "BVO (OVar c (Some x)) = -{Inl x, Inr x}"
| "BVO (OVar c None) = UNIV"
| "BVO (OSing x \<theta>) = {Inl x, Inr x}"
| "BVO (OProd ODE1 ODE2) = BVO ODE1 \<union> BVO ODE2"

lemma BVO_assoc:"BVO (oprod ODE1 ODE2) = BVO (OProd ODE1 ODE2)"
  apply(induction ODE1 arbitrary:ODE2)
  by(auto)

lemma BVO_lr:"(Inl x \<in> BVO ODE) = (Inr x \<in> BVO ODE)"
  apply(induction ODE,auto)
  subgoal for x1 x2 by(cases x2,auto)
  subgoal for x1 x2 by(cases x2,auto) done

fun BVF :: "formula \<Rightarrow> (ident + ident) set"
and BVP :: "hp \<Rightarrow> (ident + ident) set"
where
  "BVF (Geq f g) = {}"
| "BVF (Prop p dfun_args) = {}"
| "BVF (Not p) = BVF p"
| "BVF (And p q) = BVF p \<union> BVF q"
| "BVF (Exists x p) = {Inl x} \<union> BVF p"
| "BVF (Diamond \<alpha> p) = BVP \<alpha> \<union> BVF p"
| "BVF (InContext C p) = UNIV"

| "BVP (Pvar a) = UNIV"
| "BVP (Assign x \<theta>) = {Inl x}"
| "BVP (AssignAny x) = {Inl x}"
| "BVP (DiffAssign x \<theta>) = {Inr x}"
| "BVP (Test \<phi>) = {}"
| "BVP (EvolveODE ODE \<phi>) = BVO ODE"
| "BVP (Choice \<alpha> \<beta>) = BVP \<alpha> \<union> BVP \<beta>"
| "BVP (Sequence \<alpha> \<beta>) = BVP \<alpha> \<union> BVP \<beta>"
| "BVP (Loop \<alpha>) = BVP \<alpha>"

text\<open> Must-bound variables (of a program)\<close>
fun MBV :: "hp \<Rightarrow> (ident + ident) set"
where
  "MBV (Pvar a) = {}"
| "MBV (Choice \<alpha> \<beta>) = MBV \<alpha> \<inter> MBV \<beta>"
| "MBV (Sequence \<alpha> \<beta>) = MBV \<alpha> \<union> MBV \<beta>"
| "MBV (Loop \<alpha>) = {}"
| "MBV (EvolveODE ODE _) = (Inl ` (ODE_dom ODE)) \<union> (Inr ` (ODE_dom ODE))"
| "MBV \<alpha> = BVP \<alpha>"

text\<open>Free variables of a formula,
 free variables of a program \<close>
fun FVF :: "formula \<Rightarrow> (ident + ident) set"
and FVP :: "hp \<Rightarrow> (ident + ident) set"
where
  "FVF (Geq f g) = FVT f \<union> FVT g"
| "FVF (Prop p args) = (\<Union>i. FVT (args i))"
| "FVF (Not p) = FVF p"
| "FVF (And p q) = FVF p \<union> FVF q"
| "FVF (Exists x p) = FVF p - {Inl x}"
| "FVF (Diamond \<alpha> p) =   FVP \<alpha> \<union> (FVF p - MBV \<alpha>)"
| "FVF (InContext C p) = UNIV"
| "FVP (Pvar a) = UNIV"
| "FVP (Assign x \<theta>) = FVT \<theta>"
| "FVP (AssignAny x)  = {}"
| "FVP (DiffAssign x \<theta>) = FVT \<theta>"
| "FVP (Test \<phi>) = FVF \<phi>"
| "FVP (EvolveODE ODE \<phi>) = ((Inl ` FVO ODE) \<union> FVF \<phi>)"
| "FVP (Choice \<alpha> \<beta>) = FVP \<alpha> \<union> FVP \<beta>"
| "FVP (Sequence \<alpha> \<beta>) = FVP \<alpha> \<union> (FVP \<beta> - MBV \<alpha>)"
| "FVP (Loop \<alpha>) = FVP \<alpha>"

lemma FVF_FF[simp]: "FVF FF = {}"
  by (simp add: FF_def)

lemma FVF_TT[simp]: "FVF TT = {}"
  by (auto simp: TT_def)

lemma FVF_Or[simp]: "FVF (a || b) = FVF a \<union> FVF b"
  by (auto simp: Or_def)

lemma FVF_Implies[simp]: "FVF (a \<rightarrow> b) = FVF a \<union> FVF b"
  by (auto simp: Implies_def)

fun FVSeq :: "sequent \<Rightarrow> (ident + ident) set"
  where "FVSeq (A,S) = (List.foldr (\<lambda> x acc.  (acc \<union> (FVF x))) A {}) \<union> (List.foldr (\<lambda> x acc.  (acc \<union> (FVF x))) S {})"

subsection \<open>Lemmas for reasoning about static semantics\<close>

lemma primify_contains:"x \<in> primify x"
  by (cases "x") auto

lemma FVDiff_sub:"FVT f \<subseteq> FVDiff f"
  by (auto simp add:  primify_contains)

lemma fvdiff_plus1:"FVDiff (Plus t1 t2) = FVDiff t1 \<union> FVDiff t2"
  by (auto)

lemma agree_func_fvt:"Vagree \<nu> \<nu>' (FVT (Function f args)) \<Longrightarrow> Vagree \<nu> \<nu>' (FVT (args i))"
  by (auto simp add: Set.Un_upper1 agree_supset Vagree_def)

lemma agree_neg:"Vagree \<nu> \<nu>' (FVDiff (Neg t1 )) \<Longrightarrow> Vagree \<nu> \<nu>' (FVDiff t1)"
proof -
  assume agree:"Vagree \<nu> \<nu>' (FVDiff (Neg t1))"
  have agree':"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i) )"
    using  FVDiff.simps agree by (auto)
  have agreeL:"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i))"
    using agree' agree_supset Set.Un_upper1 by (blast)
  show "Vagree \<nu> \<nu>' (FVDiff t1)" using agreeL by (auto)
qed

lemma agree_plus1:"Vagree \<nu> \<nu>' (FVDiff (Plus t1 t2)) \<Longrightarrow> Vagree \<nu> \<nu>' (FVDiff t1)"
proof -
  assume agree:"Vagree \<nu> \<nu>' (FVDiff (Plus t1 t2))"
  have agree':"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i) \<union> (\<Union>i\<in>FVT t2. primify i))"
    using fvdiff_plus1 FVDiff.simps agree by (auto)
  have agreeL:"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i))"
    using agree' agree_supset Set.Un_upper1 by (blast)
  show "Vagree \<nu> \<nu>' (FVDiff t1)" using agreeL by (auto)
qed

lemma agree_plus2:"Vagree \<nu> \<nu>' (FVDiff (Plus t1 t2)) \<Longrightarrow> Vagree \<nu> \<nu>' (FVDiff t2)"
proof -
  assume agree:"Vagree \<nu> \<nu>' (FVDiff (Plus t1 t2))"
  have agree':"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i) \<union> (\<Union>i\<in>FVT t2. primify i))"
    using fvdiff_plus1 FVDiff.simps agree by (auto)
  have agreeR:"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t2. primify i))"
    using agree' agree_supset Set.Un_upper1 by (blast)
  show "Vagree \<nu> \<nu>' (FVDiff t2)" using agreeR by (auto)
qed

lemma agree_times1:"Vagree \<nu> \<nu>' (FVDiff (Times t1 t2)) \<Longrightarrow> Vagree \<nu> \<nu>' (FVDiff t1)"
proof -
  assume agree:"Vagree \<nu> \<nu>' (FVDiff (Times t1 t2))"
  have agree':"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i) \<union> (\<Union>i\<in>FVT t2. primify i))"
    using fvdiff_plus1 FVDiff.simps agree by (auto)
  have agreeL:"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i))"
    using agree' agree_supset Set.Un_upper1 by (blast)
  show "Vagree \<nu> \<nu>' (FVDiff t1)" using agreeL by (auto)
qed

lemma agree_times2:"Vagree \<nu> \<nu>' (FVDiff (Times t1 t2)) \<Longrightarrow> Vagree \<nu> \<nu>' (FVDiff t2)"
proof -
  assume agree:"Vagree \<nu> \<nu>' (FVDiff (Times t1 t2))"
  have agree':"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t1. primify i) \<union> (\<Union>i\<in>FVT t2. primify i))"
    using fvdiff_plus1 FVDiff.simps agree by (auto)
  have agreeR:"Vagree \<nu> \<nu>' ((\<Union>i\<in>FVT t2. primify i))"
    using agree' agree_supset Set.Un_upper1 by (blast)
  show "Vagree \<nu> \<nu>' (FVDiff t2)" using agreeR by (auto)
qed

lemma agree_func:"Vagree \<nu> \<nu>' (FVDiff ($f var args)) \<Longrightarrow> (\<And>i. Vagree \<nu> \<nu>' (FVDiff (args i)))"
proof -
  assume agree:"Vagree \<nu> \<nu>' (FVDiff ($f var args))"
  have agree':"Vagree \<nu> \<nu>' ((\<Union>i. (\<Union>j \<in>(FVT (args i)). primify j)))"
    using fvdiff_plus1 FVDiff.simps agree by (auto)
  fix i :: ident
  have "\<And>S. \<not> S \<subseteq> (\<Union>f. (\<Union>x\<in>(FVT (args f)). primify x)) \<or> Vagree \<nu> \<nu>' S"
    using agree' agree_supset by blast
  then have "\<And>f. f \<notin> UNIV \<or> Vagree \<nu> \<nu>' (\<Union>x \<in>(FVT (args f)). primify x)"
    by blast
  then show "Vagree \<nu> \<nu>' (FVDiff (args i))"
    by simp
qed

end


text\<open>
Formal Languages and Automata Theory (FLAT)
according to the book with same name (2nd version) by Zongli Jiang
created by Yongwang Zhao (zhaoyw@buaa.edu.cn)
School of Computer Science and Engineering, Beihang University, Beijing, China
\<close>

section\<open>3. Finite Automaton\<close>

subsection\<open>3.2: finite automaton\<close>

theory DFA
imports AutoProj
begin

subsubsection\<open>definition 3-1 finite automaton\<close>

text\<open>
M = <Q,\<Sigma>,\<delta>,q0,F>
Q: states, represented as 's
\<Sigma>: input alphabet, represented as 'a
\<delta>: transition function
q0: initial state
F: final states
dfa defined as below is a triple <q0,\<delta>,F>
\<close>
type_synonym ('a,'s)dfa = "'s \<times> ('a \<Rightarrow> 's \<Rightarrow> 's) \<times> ('s set)"

abbreviation "q0 \<equiv> start"
abbreviation "\<delta> \<equiv> next"
abbreviation "F \<equiv> fin"

definition
 foldl2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
"foldl2 f xs a = foldl (\<lambda>a b. f b a) a xs"

text\<open>
extend the \<delta>: \<Sigma> \<times> Q \<times> Q to \<delta>': \<Sigma>* \<times> Q \<times> Q
\<close>
definition
 \<delta>' :: "('a,'s)dfa \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 's" where
"\<delta>' A = foldl2 (\<delta> A)"

subsubsection\<open>definition 3-2: accepted language\<close>

definition
 accepts :: "('a,'s)dfa \<Rightarrow> 'a list \<Rightarrow> bool" where
"accepts A w \<equiv> (\<delta>' A w (q0 A)) \<in> F A"

type_synonym 'a lang = "'a list set"

definition DFALang :: "('a,'s)dfa \<Rightarrow> 'a lang"
  where "DFALang m \<equiv> {x. accepts m x}"

lemma delta_Nil[simp]: "\<delta>' A [] s = s"
by(simp add:\<delta>'_def)

lemma delta_Cons[simp]: "\<delta>' A (a#w) s = \<delta>' A w (\<delta> A a s)"
by(simp add:\<delta>'_def)

lemma delta_append[simp]:
 "\<And>q ys. \<delta>' A (xs@ys) q = \<delta>' A ys (\<delta>' A xs q)"
by(induct xs) simp_all

subsubsection\<open>definition 3-3: FA equivalence\<close>
definition DFAEquiv :: "('a,'s)dfa \<Rightarrow> ('a,'s)dfa \<Rightarrow> bool"
  where "DFAEquiv m1 m2 \<equiv> DFALang m1 = DFALang m2"

subsubsection\<open>definition 3-5: instantaneous description (ID)\<close>

type_synonym ('a,'s) IDType = "'a list \<times> 's \<times> 'a list"

fun ID :: "('a,'s)dfa \<Rightarrow> ('a,'s) IDType \<Rightarrow> bool"
  where "ID m (x,q,y) = (\<delta>' m x (q0 m) = q)"

inductive_set IDtran_set :: "('a,'s)dfa \<Rightarrow> (('a,'s) IDType \<times> ('a,'s) IDType) set"
and IDtran :: "('a,'s)dfa \<Rightarrow> ('a,'s) IDType \<Rightarrow> ('a,'s) IDType \<Rightarrow> bool" ("_ \<turnstile> _ \<leadsto> _" [80,80,80] 81)
  for M :: "('a,'s)dfa"
  where "M \<turnstile> x \<leadsto> y \<equiv> (x,y) \<in> IDtran_set M"
  | "\<lbrakk>ID M (x,q,a#y); (\<delta> M) a q = p \<rbrakk> \<Longrightarrow> ((x,q,a#y),(x@[a],p,y)) \<in> IDtran_set M"

text\<open>
a transition from an ID, the target is an ID too.
\<close>
lemma id_tran2_id: "\<lbrakk> ID M (x,q,y); M \<turnstile> (x,q,y) \<leadsto> (x',q',y') \<rbrakk> \<Longrightarrow> ID M (x',q',y')"
  apply(rule IDtran_set.cases) apply fast
  by auto

inductive nIDtrans :: "('a,'s)dfa \<Rightarrow> ('a,'s) IDType \<Rightarrow> nat \<Rightarrow> ('a,'s) IDType \<Rightarrow> bool"
("_ \<turnstile> _ \<midarrow>_\<leadsto> _" [80,80,80,80] 81)
  where tran0: "g \<turnstile> x \<midarrow>0\<leadsto> x" |
        trann: "\<exists>r. g \<turnstile> x \<midarrow>n\<leadsto> r \<and> g \<turnstile> r \<leadsto> y \<Longrightarrow> g \<turnstile> x \<midarrow>(n+1)\<leadsto> y"

definition IDtrans :: "('a,'s)dfa \<Rightarrow> ('a,'s) IDType \<Rightarrow> ('a,'s) IDType \<Rightarrow> bool" ("_ \<turnstile> _ \<midarrow>*\<leadsto> _" [80,80,80] 81)
  where "IDtrans g x y \<equiv> (\<exists>n. g \<turnstile> x \<midarrow>n\<leadsto> y)"

definition IDtrans1 :: "('a,'s)dfa \<Rightarrow> ('a,'s) IDType \<Rightarrow> ('a,'s) IDType \<Rightarrow> bool" ("_ \<turnstile> _ \<midarrow>+\<leadsto> _" [80,80,80] 81)
  where "IDtrans1 g x y \<equiv> (\<exists>n>0. g \<turnstile> x \<midarrow>n\<leadsto> y)"

lemma id_trans2_id: "\<lbrakk> ID M (x,q,y); M \<turnstile> (x,q,y) \<midarrow>n\<leadsto> (x',q',y') \<rbrakk> \<Longrightarrow> ID M (x',q',y')"
  apply(induct n arbitrary: x q y x' q' y') using nIDtrans.cases
  apply (metis add.commute less_one not_add_less1)
  apply(rule nIDtrans.cases) apply blast+
  using id_tran2_id
  by (metis Suc_eq_plus1 Suc_inject prod_cases3)

subsubsection\<open>definition 3-6\<close>

definition aset :: "('a,'s)dfa \<Rightarrow> 's \<Rightarrow> 'a list set"
  where "aset M q \<equiv> {x. \<delta>' M x (q0 M) = q}"

end