(*
  File: AlgStructure.thy
  Author: Bohua Zhan

  Algebraic structures.
*)

theory AlgStructure
  imports Functions
begin

section \<open>Conversion from meta-function to set-theoretic functions\<close>

definition unary_fun :: "i \<Rightarrow> [i \<Rightarrow> i] \<Rightarrow> o" where [rewrite]:
  "unary_fun(S,f) \<longleftrightarrow> (\<forall>x\<in>S. f(x) \<in> S)"

lemma unary_funD [typing]: "unary_fun(S,f) \<Longrightarrow> x \<in> S \<Longrightarrow> f(x) \<in> S" by auto2
setup {* del_prfstep_thm_eqforward @{thm unary_fun_def} *}

definition binary_fun :: "i \<Rightarrow> [i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> o" where [rewrite]:
  "binary_fun(S,f) \<longleftrightarrow> (\<forall>x\<in>S. \<forall>y\<in>S. f(x,y) \<in> S)"

lemma binary_funD [typing]: "binary_fun(S,f) \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f(x,y) \<in> S" by auto2
setup {* del_prfstep_thm_eqforward @{thm binary_fun_def} *}

definition binary_fun_of :: "i \<Rightarrow> (i \<Rightarrow> i \<Rightarrow> i) \<Rightarrow> i" where [rewrite]:
  "binary_fun_of(S,f) = Fun(S\<times>S, S, \<lambda>p. f(fst(p),snd(p)))"
setup {* register_wellform_data ("binary_fun_of(S,f)", ["binary_fun(S,f)"]) *}

lemma binary_fun_of_mem [typing]: "binary_fun(S,f) \<Longrightarrow> binary_fun_of(S,f) \<in> S \<times> S \<rightarrow> S" by auto2
lemma binary_fun_eval [rewrite]:
  "F = binary_fun_of(S,f) \<Longrightarrow> F \<in> S \<times> S \<rightarrow> S \<Longrightarrow> \<langle>x,y\<rangle> \<in> source(F) \<Longrightarrow> F`\<langle>x,y\<rangle> = f(x,y)" by auto2
setup {* del_prfstep_thm @{thm binary_fun_of_def} *}

section \<open>Components of an algebraic structure\<close>

(* 0 and +, for additive structures. *)
definition "zero_name = succ(succ(succ(\<emptyset>)))"
definition "zero(S) = graph_eval(S, zero_name)"
definition "plus_fun_name = succ(succ(succ(succ(\<emptyset>))))"
definition "plus_fun(S) = graph_eval(S, plus_fun_name)"
notation zero ("\<zero>\<^sub>_" [96] 95)
setup {* add_field_data (@{term zero_name}, @{term zero}) *}
setup {* add_field_data (@{term plus_fun_name}, @{term plus_fun}) *}

(* 1 and *, for multiplicative structures. *)
definition "one_name = succ(succ(succ(succ(succ(\<emptyset>)))))"
definition "one(S) = graph_eval(S, one_name)"
definition "times_fun_name = succ(succ(succ(succ(succ(succ(\<emptyset>))))))"
definition "times_fun(S) = graph_eval(S, times_fun_name)"
notation one ("\<one>\<^sub>_" [96] 95)
setup {* add_field_data (@{term one_name}, @{term one}) *}
setup {* add_field_data (@{term times_fun_name}, @{term times_fun}) *}

section \<open>Notation for plus and times.\<close>

definition plus :: "[i, i, i] \<Rightarrow> i" where [rewrite_bidir]:
  "plus(G,x,y) = plus_fun(G)`\<langle>x,y\<rangle>"
abbreviation plus_notation ("(_/ +\<^sub>_ _)" [65,65,66] 65) where "x +\<^sub>G y \<equiv> plus(G,x,y)"
setup {* register_wellform_data ("x +\<^sub>G y", ["x \<in>. G", "y \<in>. G"]) *}

definition times :: "[i, i, i] \<Rightarrow> i" where [rewrite_bidir]:
  "times(G,x,y) = times_fun(G)`\<langle>x,y\<rangle>"
abbreviation times_notation ("(_/ *\<^sub>_ _)" [70,70,71] 70) where "x *\<^sub>G y \<equiv> times(G,x,y)"
setup {* register_wellform_data ("x *\<^sub>G y", ["x \<in>. G", "y \<in>. G"]) *}

section \<open>Abelian group structure\<close>

definition is_abgroup_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_abgroup_raw(G) \<longleftrightarrow> \<zero>\<^sub>G \<in>. G \<and> plus_fun(G) \<in> carrier(G) \<times> carrier(G) \<rightarrow> carrier(G)"

lemma is_abgroup_rawD [typing]:
  "is_abgroup_raw(G) \<Longrightarrow> \<zero>\<^sub>G \<in>. G"
  "is_abgroup_raw(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x +\<^sub>G y \<in>. G"
  "is_abgroup_raw(G) \<Longrightarrow> plus_fun(G) \<in> carrier(G) \<times> carrier(G) \<rightarrow> carrier(G)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_abgroup_raw_def} *}

(* General result on evaluation of plus. *)
lemma plus_eval_gen [rewrite]:
  "is_abgroup_raw(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow>
   plus_fun(R) = binary_fun_of(carrier(R),f) \<Longrightarrow> x +\<^sub>R y = f(x,y)" by auto2

definition abgroup_form :: "i \<Rightarrow> o" where [rewrite]:
  "abgroup_form(G) \<longleftrightarrow> is_abgroup_raw(G) \<and> is_func_graph(G,{carrier_name,zero_name,plus_fun_name})"

lemma abgroup_form_to_raw [forward]: "abgroup_form(G) \<Longrightarrow> is_abgroup_raw(G)" by auto2

definition AbGroup :: "[i, i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "AbGroup(S,z,f) = Struct({\<langle>carrier_name,S\<rangle>,\<langle>zero_name,z\<rangle>,\<langle>plus_fun_name, binary_fun_of(S,f)\<rangle>})"

lemma AbGroup_is_abgroup_raw [backward]:
  "z \<in> S \<Longrightarrow> binary_fun(S,f) \<Longrightarrow> abgroup_form(AbGroup(S,z,f))" by auto2

lemma abgroup_eval [rewrite]:
  "carrier(AbGroup(S,z,f)) = S"
  "zero(AbGroup(S,z,f)) = z"
  "G = AbGroup(S,z,f) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> is_abgroup_raw(G) \<Longrightarrow> x +\<^sub>G y = f(x,y)" by auto2+
setup {* del_prfstep_thm @{thm AbGroup_def} *}

(* Equality between abelian groups *)
definition eq_str_abgroup :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_abgroup(G,H) \<longleftrightarrow> carrier(G) = carrier(H) \<and> \<zero>\<^sub>G = \<zero>\<^sub>H \<and> plus_fun(G) = plus_fun(H)"

lemma eq_str_abgroupD [rewrite]:
  "eq_str_abgroup(G,H) \<Longrightarrow> carrier(G) = carrier(H)"
  "eq_str_abgroup(G,H) \<Longrightarrow> \<zero>\<^sub>G = \<zero>\<^sub>H"
  "x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> x +\<^sub>G y = x +\<^sub>H y"
  "eq_str_abgroup(G,H) \<Longrightarrow> plus_fun(G) = plus_fun(H)" by auto2+
lemma eq_str_abgroup_sym [forward]: "eq_str_abgroup(G,H) \<Longrightarrow> eq_str_abgroup(H,G)" by auto2

lemma eq_str_abgroupI [backward]:
  "is_abgroup_raw(G) \<Longrightarrow> is_abgroup_raw(H) \<Longrightarrow>
   carrier(G) = carrier(H) \<Longrightarrow> \<zero>\<^sub>G = \<zero>\<^sub>H \<Longrightarrow> \<forall>x\<in>.G. \<forall>y\<in>.G. x +\<^sub>G y = x +\<^sub>H y \<Longrightarrow> eq_str_abgroup(G,H)" by auto2
setup {* del_prfstep_thm @{thm eq_str_abgroup_def} *}

lemma abgroup_eq [backward]:
  "abgroup_form(G) \<Longrightarrow> abgroup_form(H) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> G = H" by auto2
setup {* del_prfstep_thm @{thm abgroup_form_def} *}
setup {* del_prfstep_thm @{thm plus_def} *}

section \<open>Group structure\<close>

definition is_group_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_group_raw(G) \<longleftrightarrow> \<one>\<^sub>G \<in>. G \<and> times_fun(G) \<in> carrier(G) \<times> carrier(G) \<rightarrow> carrier(G)"

lemma is_group_rawD [typing]:
  "is_group_raw(G) \<Longrightarrow> \<one>\<^sub>G \<in>. G"
  "is_group_raw(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x *\<^sub>G y \<in>. G"
  "is_group_raw(G) \<Longrightarrow> times_fun(G) \<in> carrier(G) \<times> carrier(G) \<rightarrow> carrier(G)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_group_raw_def} *}

(* General result on evaluation of times. *)
lemma times_eval_gen [rewrite]:
  "is_group_raw(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow>
   times_fun(R) = binary_fun_of(carrier(R),f) \<Longrightarrow> x *\<^sub>R y = f(x,y)" by auto2

definition group_form :: "i \<Rightarrow> o" where [rewrite]:
  "group_form(G) \<longleftrightarrow> is_group_raw(G) \<and> is_func_graph(G,{carrier_name,one_name,times_fun_name})"

lemma group_form_to_raw [forward]: "group_form(G) \<Longrightarrow> is_group_raw(G)" by auto2

definition Group :: "[i, i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "Group(S,u,f) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>one_name,u\<rangle>, \<langle>times_fun_name, binary_fun_of(S,f)\<rangle>})"

lemma Group_is_group_raw [backward]:
  "u \<in> S \<Longrightarrow> binary_fun(S,f) \<Longrightarrow> group_form(Group(S,u,f))" by auto2

lemma group_eval [rewrite]:
  "carrier(Group(S,u,f)) = S"
  "one(Group(S,u,f)) = u"
  "G = Group(S,u,f) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> is_group_raw(G) \<Longrightarrow> x *\<^sub>G y = f(x,y)" by auto2+
setup {* del_prfstep_thm @{thm Group_def} *}

(* Equality between groups *)
definition eq_str_group :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_group(G,H) \<longleftrightarrow> carrier(G) = carrier(H) \<and> \<one>\<^sub>G = \<one>\<^sub>H \<and> times_fun(G) = times_fun(H)"

lemma eq_str_groupD [rewrite]:
  "eq_str_group(G,H) \<Longrightarrow> carrier(G) = carrier(H)"
  "eq_str_group(G,H) \<Longrightarrow> \<one>\<^sub>G = \<one>\<^sub>H"
  "x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> x *\<^sub>G y = x *\<^sub>H y"
  "eq_str_group(G,H) \<Longrightarrow> times_fun(G) = times_fun(H)" by auto2+
lemma eq_str_group_sym [forward]: "eq_str_group(G,H) \<Longrightarrow> eq_str_group(H,G)" by auto2

lemma eq_str_groupI [backward]:
  "is_group_raw(G) \<Longrightarrow> is_group_raw(H) \<Longrightarrow> carrier(G) = carrier(H) \<Longrightarrow> \<one>\<^sub>G = \<one>\<^sub>H \<Longrightarrow>
   \<forall>x\<in>.G. \<forall>y\<in>.G. x *\<^sub>G y = x *\<^sub>H y \<Longrightarrow> eq_str_group(G,H)" by auto2
setup {* del_prfstep_thm @{thm eq_str_group_def} *}

lemma group_eq [backward]:
  "group_form(G) \<Longrightarrow> group_form(H) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> G = H" by auto2
setup {* del_prfstep_thm @{thm group_form_def} *}
setup {* del_prfstep_thm @{thm times_def} *}

section \<open>Ring structure\<close>

definition is_ring_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_ring_raw(R) \<longleftrightarrow> is_abgroup_raw(R) \<and> is_group_raw(R)"

lemma is_ring_raw_iff [forward]:
  "is_ring_raw(R) \<Longrightarrow> is_abgroup_raw(R)"
  "is_ring_raw(R) \<Longrightarrow> is_group_raw(R)"
  "is_abgroup_raw(R) \<Longrightarrow> is_group_raw(R) \<Longrightarrow> is_ring_raw(R)" by auto2+
setup {* del_prfstep_thm @{thm is_ring_raw_def} *}

definition ring_form :: "i \<Rightarrow> o" where [rewrite]:
  "ring_form(R) \<longleftrightarrow>
    is_ring_raw(R) \<and> is_func_graph(R,{carrier_name,zero_name,plus_fun_name,one_name,times_fun_name})"

lemma ring_form_to_raw [forward]: "ring_form(R) \<Longrightarrow> is_ring_raw(R)" by auto2

definition Ring :: "[i, i, i \<Rightarrow> i \<Rightarrow> i, i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "Ring(S,z,f,u,g) =
    Struct({\<langle>carrier_name,S\<rangle>, \<langle>zero_name,z\<rangle>, \<langle>plus_fun_name, binary_fun_of(S,f)\<rangle>,
            \<langle>one_name,u\<rangle>, \<langle>times_fun_name, binary_fun_of(S,g)\<rangle>})"

lemma Ring_is_ring_raw [backward]:
  "z \<in> S \<Longrightarrow> binary_fun(S,f) \<Longrightarrow> u \<in> S \<Longrightarrow> binary_fun(S,g) \<Longrightarrow> ring_form(Ring(S,z,f,u,g))"
@proof @have "is_abgroup_raw(Ring(S,z,f,u,g))" @have "is_group_raw(Ring(S,z,f,u,g))" @qed

lemma ring_eval [rewrite]:
  "carrier(Ring(S,z,f,u,g)) = S"
  "zero(Ring(S,z,f,u,g)) = z"
  "one(Ring(S,z,f,u,g)) = u"
  "R = Ring(S,z,f,u,g) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_abgroup_raw(R) \<Longrightarrow> x +\<^sub>R y = f(x,y)"
  "R = Ring(S,z,f,u,g) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_group_raw(R) \<Longrightarrow> x *\<^sub>R y = g(x,y)" by auto2+
setup {* del_prfstep_thm @{thm Ring_def} *}

definition eq_str_ring :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_ring(G,H) \<longleftrightarrow> eq_str_abgroup(G,H) \<and> eq_str_group(G,H)"

lemma eq_str_ring_sym [forward]: "eq_str_ring(G,H) \<Longrightarrow> eq_str_ring(H,G)" by auto2

lemma ring_eq [backward]:
  "ring_form(R) \<Longrightarrow> ring_form(S) \<Longrightarrow> eq_str_ring(R,S) \<Longrightarrow> R = S" by auto2
setup {* del_prfstep_thm @{thm ring_form_def} *}

section \<open>Ordered ring structure\<close>

definition is_ord_ring_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_ord_ring_raw(R) \<longleftrightarrow> is_ring_raw(R) \<and> raworder(R)"

lemma is_ord_ring_raw_iff [forward]:
  "is_ord_ring_raw(R) \<Longrightarrow> is_ring_raw(R)"
  "is_ord_ring_raw(R) \<Longrightarrow> raworder(R)"
  "is_ring_raw(R) \<Longrightarrow> raworder(R) \<Longrightarrow> is_ord_ring_raw(R)" by auto2+
setup {* del_prfstep_thm @{thm is_ord_ring_raw_def} *}

definition ord_ring_form :: "i \<Rightarrow> o" where [rewrite]:
  "ord_ring_form(R) \<longleftrightarrow> is_ord_ring_raw(R) \<and>
      is_func_graph(R,{carrier_name,order_graph_name,zero_name,plus_fun_name,one_name,times_fun_name})"

lemma ord_ring_form_to_raw [forward]: "ord_ring_form(R) \<Longrightarrow> is_ord_ring_raw(R)" by auto2

definition OrdRing :: "[i, i, i \<Rightarrow> i \<Rightarrow> i, i, i \<Rightarrow> i \<Rightarrow> i, i \<Rightarrow> i \<Rightarrow> o] \<Rightarrow> i" where [rewrite]:
  "OrdRing(S,z,f,u,g,r) = Struct({
      \<langle>carrier_name,S\<rangle>, \<langle>order_graph_name, rel_graph(S,r)\<rangle>,
      \<langle>zero_name,z\<rangle>, \<langle>plus_fun_name, binary_fun_of(S,f)\<rangle>,
      \<langle>one_name,u\<rangle>, \<langle>times_fun_name, binary_fun_of(S,g)\<rangle>})"

lemma OrdRing_is_ord_ring_raw [backward]:
  "z \<in> S \<Longrightarrow> binary_fun(S,f) \<Longrightarrow> u \<in> S \<Longrightarrow> binary_fun(S,g) \<Longrightarrow> R = OrdRing(S,z,f,u,g,r) \<Longrightarrow> ord_ring_form(R)"
@proof
  @have "is_abgroup_raw(R)"
  @have "is_group_raw(R)"
  @have "is_ring_raw(R)"
  @have "raworder(R)"
@qed

lemma ord_ring_eval [rewrite]:
  "carrier(OrdRing(S,z,f,u,g,r)) = S"
  "zero(OrdRing(S,z,f,u,g,r)) = z"
  "one(OrdRing(S,z,f,u,g,r)) = u"
  "R = OrdRing(S,z,f,u,g,r) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_ord_ring_raw(R) \<Longrightarrow> x +\<^sub>R y = f(x,y)"
  "R = OrdRing(S,z,f,u,g,r) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_ord_ring_raw(R) \<Longrightarrow> x *\<^sub>R y = g(x,y)"
  "R = OrdRing(S,z,f,u,g,r) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<le>\<^sub>R y \<longleftrightarrow> r(x,y)" by auto2+
setup {* del_prfstep_thm @{thm OrdRing_def} *}

definition eq_str_ord_ring :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_ord_ring(G,H) \<longleftrightarrow> eq_str_ring(G,H) \<and> eq_str_order(G,H)"

lemma eq_str_ord_ring_sym [forward]: "eq_str_ord_ring(G,H) \<Longrightarrow> eq_str_ord_ring(H,G)" by auto2

lemma ord_ring_eq [backward]:
  "ord_ring_form(R) \<Longrightarrow> ord_ring_form(S) \<Longrightarrow> eq_str_ord_ring(R,S) \<Longrightarrow> R = S" by auto2
setup {* del_prfstep_thm @{thm ord_ring_form_def} *}

section \<open>Predicates on additive structure\<close>

definition is_add_id :: "i \<Rightarrow> o" where [rewrite]:
  "is_add_id(G) \<longleftrightarrow> is_abgroup_raw(G) \<and> (\<forall>x\<in>.G. \<zero>\<^sub>G +\<^sub>G x = x)"

lemma is_add_idD [rewrite]: "is_add_id(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> \<zero>\<^sub>G +\<^sub>G x = x" by auto2
lemma is_add_id_abgroup_prop [forward]:
  "is_abgroup_raw(H) \<Longrightarrow> is_add_id(G) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> is_add_id(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_add_id_def} *}

definition is_plus_comm :: "i \<Rightarrow> o" where [rewrite]:
  "is_plus_comm(G) \<longleftrightarrow> (is_abgroup_raw(G) \<and> (\<forall>x\<in>.G. \<forall>y\<in>.G. x +\<^sub>G y = y +\<^sub>G x))"

lemma plus_commD: "is_plus_comm(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x +\<^sub>G y = y +\<^sub>G x" by auto2
lemma is_plus_comm_abgroup_prop [forward]:
  "is_abgroup_raw(H) \<Longrightarrow> is_plus_comm(G) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> is_plus_comm(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_plus_comm_def} *}

definition is_plus_assoc :: "i \<Rightarrow> o" where [rewrite]:
  "is_plus_assoc(G) \<longleftrightarrow> is_abgroup_raw(G) \<and> (\<forall>x\<in>.G. \<forall>y\<in>.G. \<forall>z\<in>.G. (x +\<^sub>G y) +\<^sub>G z = x +\<^sub>G (y +\<^sub>G z))"

lemma plus_assoc_right [rewrite]:
  "is_plus_assoc(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> (x +\<^sub>G y) +\<^sub>G z = x +\<^sub>G (y +\<^sub>G z) \<and> y +\<^sub>G z \<in>. G" by auto2

lemma plus_assoc_left:
  "is_plus_assoc(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> x +\<^sub>G (y +\<^sub>G z) = (x +\<^sub>G y) +\<^sub>G z \<and> x +\<^sub>G y \<in>. G" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_plus_assoc_def} *}

lemma is_plus_assoc_abgroup_prop [forward]:
  "is_abgroup_raw(H) \<Longrightarrow> is_plus_assoc(G) \<Longrightarrow> eq_str_abgroup(G,H) \<Longrightarrow> is_plus_assoc(H)" by auto2
setup {* del_prfstep_thm @{thm plus_assoc_right} *}

section \<open>Predicates on multiplicative structure\<close>

definition is_mult_id :: "i \<Rightarrow> o" where [rewrite]:
  "is_mult_id(G) \<longleftrightarrow> (\<forall>x\<in>.G. \<one>\<^sub>G *\<^sub>G x = x \<and> x *\<^sub>G \<one>\<^sub>G = x)"

lemma is_mult_id_left [rewrite]: "is_mult_id(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> \<one>\<^sub>G *\<^sub>G x = x" by auto2
lemma is_mult_id_right [rewrite]: "is_mult_id(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> x *\<^sub>G \<one>\<^sub>G = x" by auto2
lemma is_mult_id_group_prop [forward]:
  "is_group_raw(H) \<Longrightarrow> is_mult_id(G) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> is_mult_id(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_mult_id_def} *}

definition is_times_comm :: "i \<Rightarrow> o" where [rewrite]:
  "is_times_comm(G) \<longleftrightarrow> (is_group_raw(G) \<and> (\<forall>x\<in>.G. \<forall>y\<in>.G. x *\<^sub>G y = y *\<^sub>G x))"

lemma times_commD: "is_times_comm(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> x *\<^sub>G y = y *\<^sub>G x" by auto2
lemma is_times_comm_group_prop [forward]:
  "is_group_raw(H) \<Longrightarrow> is_times_comm(G) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> is_times_comm(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_times_comm_def} *}

definition is_times_assoc :: "i \<Rightarrow> o" where [rewrite]:
  "is_times_assoc(G) \<longleftrightarrow> is_group_raw(G) \<and> (\<forall>x\<in>.G. \<forall>y\<in>.G. \<forall>z\<in>.G. (x *\<^sub>G y) *\<^sub>G z = x *\<^sub>G (y *\<^sub>G z))"

lemma is_times_assocD [forward]:
  "is_times_assoc(G) \<Longrightarrow> is_group_raw(G)" by auto2

lemma times_assoc_right [rewrite]:
  "is_times_assoc(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> (x *\<^sub>G y) *\<^sub>G z = x *\<^sub>G (y *\<^sub>G z) \<and> y *\<^sub>G z \<in>. G" by auto2

lemma times_assoc_left:
  "is_times_assoc(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> x *\<^sub>G (y *\<^sub>G z) = (x *\<^sub>G y) *\<^sub>G z \<and> x *\<^sub>G y \<in>. G" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_times_assoc_def} *}

lemma is_times_assoc_group_prop [forward]:
  "is_group_raw(H) \<Longrightarrow> is_times_assoc(G) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> is_times_assoc(H)" by auto2
setup {* del_prfstep_thm @{thm times_assoc_right} *}

section \<open>Predicates on ring structure\<close>

definition is_left_distrib :: "i \<Rightarrow> o" where [rewrite]:
  "is_left_distrib(R) \<longleftrightarrow> is_ring_raw(R) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. \<forall>z\<in>.R. x *\<^sub>R (y +\<^sub>R z) = x *\<^sub>R y +\<^sub>R x *\<^sub>R z)"

lemma left_distribD [rewrite]:
  "is_left_distrib(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> z \<in>. R \<Longrightarrow>
   x *\<^sub>R (y +\<^sub>R z) = x *\<^sub>R y +\<^sub>R x *\<^sub>R z \<and> x *\<^sub>R y \<in>. R \<and> x *\<^sub>R z \<in>. R" by auto2

lemma left_distribD_back:
  "is_left_distrib(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> z \<in>. R \<Longrightarrow>
   x *\<^sub>R y +\<^sub>R x *\<^sub>R z = x *\<^sub>R (y +\<^sub>R z) \<and> y +\<^sub>R z \<in>. R" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_left_distrib_def} *}

lemma is_left_distrib_ring_prop [forward]:
  "is_ring_raw(H) \<Longrightarrow> is_left_distrib(G) \<Longrightarrow> eq_str_ring(G,H) \<Longrightarrow> is_left_distrib(H)" by auto2
setup {* del_prfstep_thm @{thm left_distribD} *}

definition is_right_distrib :: "i \<Rightarrow> o" where [rewrite]:
  "is_right_distrib(R) \<longleftrightarrow> is_ring_raw(R) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. \<forall>z\<in>.R. (y +\<^sub>R z) *\<^sub>R x = y *\<^sub>R x +\<^sub>R z *\<^sub>R x)"

lemma right_distribD [rewrite]:
  "is_right_distrib(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> z \<in>. R \<Longrightarrow>
   (y +\<^sub>R z) *\<^sub>R x = y *\<^sub>R x +\<^sub>R z *\<^sub>R x \<and> y *\<^sub>R x \<in>. R \<and> z *\<^sub>R x \<in>. R" by auto2

lemma right_distribD_back:
  "is_right_distrib(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> z \<in>. R \<Longrightarrow>
   y *\<^sub>R x +\<^sub>R z *\<^sub>R x = (y +\<^sub>R z) *\<^sub>R x \<and> y +\<^sub>R z \<in>. R" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_right_distrib_def} *}

lemma is_right_distrib_ring_prop [forward]:
  "is_ring_raw(H) \<Longrightarrow> is_right_distrib(G) \<Longrightarrow> eq_str_ring(G,H) \<Longrightarrow> is_right_distrib(H)" by auto2
setup {* del_prfstep_thm @{thm right_distribD} *}

section \<open>Predicates on ordered ring structure\<close>

definition ord_ring_add_left :: "i \<Rightarrow> o" where [rewrite]:
  "ord_ring_add_left(R) \<longleftrightarrow> (\<forall>a\<in>.R. \<forall>b c. b \<le>\<^sub>R c \<longrightarrow> a +\<^sub>R b \<le>\<^sub>R a +\<^sub>R c)"

lemma ord_ring_add_leftD [backward]:
  "ord_ring_add_left(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<le>\<^sub>R c \<Longrightarrow> a +\<^sub>R b \<le>\<^sub>R a +\<^sub>R c" by auto2
lemma ord_ring_add_ord_ring_prop [forward]:
  "is_ord_ring_raw(H) \<Longrightarrow> ord_ring_add_left(G) \<Longrightarrow> eq_str_ord_ring(G,H) \<Longrightarrow> ord_ring_add_left(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm ord_ring_add_left_def} *}

definition ord_ring_mult_pos :: "i \<Rightarrow> o" where [rewrite]:
  "ord_ring_mult_pos(R) \<longleftrightarrow> (\<forall>a b. a \<ge>\<^sub>R \<zero>\<^sub>R \<longrightarrow> b \<ge>\<^sub>R \<zero>\<^sub>R \<longrightarrow> a *\<^sub>R b \<ge>\<^sub>R \<zero>\<^sub>R)"

lemma ord_ring_mult_posD [backward1, backward2]:
  "ord_ring_mult_pos(R) \<Longrightarrow> a \<ge>\<^sub>R \<zero>\<^sub>R \<Longrightarrow> b \<ge>\<^sub>R \<zero>\<^sub>R \<Longrightarrow> a *\<^sub>R b \<ge>\<^sub>R \<zero>\<^sub>R" by auto2
setup {* add_forward_prfstep_cond @{thm ord_ring_mult_posD} [with_term "?a *\<^sub>?R ?b"] *}
lemma ord_ring_mult_pos_ord_ring_prop [forward]:
  "is_ord_ring_raw(H) \<Longrightarrow> ord_ring_mult_pos(G) \<Longrightarrow> eq_str_ord_ring(G,H) \<Longrightarrow> ord_ring_mult_pos(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm ord_ring_mult_pos_def} *}

definition ord_semiring_mult_left :: "i \<Rightarrow> o" where [rewrite]:
  "ord_semiring_mult_left(R) \<longleftrightarrow> (\<forall>a\<in>.R. \<forall>b c. b \<le>\<^sub>R c \<longrightarrow> a *\<^sub>R b \<le>\<^sub>R a *\<^sub>R c)"

lemma ord_semiring_mult_leftD [backward2]:
  "ord_semiring_mult_left(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<le>\<^sub>R c \<Longrightarrow> a *\<^sub>R b \<le>\<^sub>R a *\<^sub>R c" by auto2
lemma ord_semiring_mult_left_ord_ring_prop [forward]:
  "is_ord_ring_raw(H) \<Longrightarrow> ord_semiring_mult_left(G) \<Longrightarrow> eq_str_ord_ring(G,H) \<Longrightarrow> ord_semiring_mult_left(H)" by auto2
setup {* del_prfstep_thm_eqforward @{thm ord_semiring_mult_left_def} *}

ML_file "alg_fol.ML"

end


section {* Monoid variants and extra properties *}

theory Monoid_extra
  imports List_extra "~~/src/HOL/Library/Prefix_Order"
begin

class ordered_semigroup = semigroup_add + order +
  assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
  and add_right_mono: "a \<le> b \<Longrightarrow> a + c \<le> b + c"
begin

lemma add_mono:
  "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
  using local.add_left_mono local.add_right_mono local.order.trans by blast

end

class left_cancel_monoid = monoid_add +
  assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"

class right_cancel_monoid = monoid_add +
  assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"

class monoid_sum_0 = monoid_add +
  assumes zero_sum_left: "a + b = 0 \<Longrightarrow> a = 0"
begin

lemma zero_sum_right: "a + b = 0 \<Longrightarrow> b = 0"
  by (metis local.add_0_left local.zero_sum_left)

lemma zero_sum: "a + b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
  by (metis local.add_0_right zero_sum_right)

end

context monoid_add
begin

definition monoid_le (infix "\<le>\<^sub>m" 50)
where "a \<le>\<^sub>m b \<longleftrightarrow> (\<exists>c. b = a + c)"

definition monoid_subtract (infixl "-\<^sub>m" 65)
where "a -\<^sub>m b = (if (b \<le>\<^sub>m a) then THE c. a = b + c else 0)"

end

class pre_trace = left_cancel_monoid + monoid_sum_0 +
  assumes
  sum_eq_sum_conv: "(a + b) = (c + d) \<Longrightarrow> \<exists> e . a = c + e \<and> e + b = d \<or> a + e = c \<and> b = e + d"
begin

lemma monoid_le_least_zero: "0 \<le>\<^sub>m a"
  by (simp add: monoid_le_def)

lemma monoid_le_refl: "a \<le>\<^sub>m a"
  by (simp add: monoid_le_def, metis add.right_neutral)

lemma monoid_le_trans: "\<lbrakk> a \<le>\<^sub>m b; b \<le>\<^sub>m c \<rbrakk> \<Longrightarrow> a \<le>\<^sub>m c"
  by (metis add.assoc monoid_le_def)

lemma monoid_le_antisym:
  assumes "a \<le>\<^sub>m b" "b \<le>\<^sub>m a"
  shows "a = b"
proof -
  obtain a' where a': "b = a + a'"
    using assms(1) monoid_le_def by auto

  obtain b' where b': "a = b + b'"
    using assms(2) monoid_le_def by auto

  have "b' = (b' + a' + b')"
    by (metis a' add_assoc b' local.add_left_imp_eq)

  hence "a' + b' = 0"
    by (metis add_assoc local.add_0_right local.add_left_imp_eq)

  hence "a' = 0" "b' = 0"
    by (simp add: zero_sum)+

  with a' b' show ?thesis
    by simp
qed

lemma monoid_le_add: "a \<le>\<^sub>m a + b"
  by (auto simp add: monoid_le_def)

lemma monoid_le_add_left_mono: "a \<le>\<^sub>m b \<Longrightarrow> c + a \<le>\<^sub>m c + b"
  using add_assoc by (auto simp add: monoid_le_def)

lemma add_monoid_diff_cancel_left [simp]: "(a + b) -\<^sub>m a = b"
  apply (simp add: monoid_subtract_def monoid_le_add)
  apply (rule the_equality)
  apply (simp)
  using local.add_left_imp_eq apply blast
done

end

class trace = pre_trace + ord + minus +
  assumes le_is_monoid_le: "a \<le> b \<longleftrightarrow> (a \<le>\<^sub>m b)"
  and less_iff: "a < b \<longleftrightarrow> a \<le> b \<and> \<not> (b \<le> a)"
  and minus_def: "a - b = a -\<^sub>m b"
begin

  lemma le_iff_add: "a \<le> b \<longleftrightarrow> (\<exists> c. b = a + c)"
    by (simp add: local.le_is_monoid_le local.monoid_le_def)

  lemma least_zero [simp]: "0 \<le> a"
    by (simp add: local.le_is_monoid_le local.monoid_le_least_zero)

  lemma le_add [simp]: "a \<le> a + b"
    by (simp add: le_is_monoid_le local.monoid_le_add)

  lemma not_le_minus [simp]:  "\<not> (a \<le> b) \<Longrightarrow> b - a = 0"
    by (simp add: le_is_monoid_le local.minus_def local.monoid_subtract_def)

  lemma add_diff_cancel_left [simp]: "(a + b) - a = b"
    by (simp add: minus_def)

  lemma diff_zero [simp]: "a - 0 = a"
    by (metis local.add_0_left local.add_diff_cancel_left)

  lemma diff_cancel [simp]: "a - a = 0"
    by (metis local.add_0_right local.add_diff_cancel_left)

  lemma add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
    by (simp add: local.le_is_monoid_le local.monoid_le_add_left_mono)

  lemma add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
    by (auto simp add: le_iff_add, metis add_assoc local.add_diff_cancel_left)

  lemma add_diff_cancel_left' [simp]:  "(c + a) - (c + b) = a - b"
  proof (cases "b \<le> a")
    case True thus ?thesis
      by (metis add_assoc local.add_diff_cancel_left local.le_iff_add)
  next
    case False thus ?thesis
      using local.add_le_imp_le_left not_le_minus by blast
  qed

  lemma minus_zero_eq: "\<lbrakk> b \<le> a; a - b = 0 \<rbrakk> \<Longrightarrow> a = b"
    using local.le_iff_add local.monoid_le_def by auto

  lemma diff_add_cancel_left': "a \<le> b \<Longrightarrow> a + (b - a) = b"
    using local.le_iff_add local.monoid_le_def by auto

  lemma add_left_strict_mono: "\<lbrakk> a + b < a + c \<rbrakk> \<Longrightarrow> b < c"
    using local.add_le_imp_le_left local.add_left_mono local.less_iff by blast

  lemma sum_minus_left: "c \<le> a \<Longrightarrow> (a + b) - c = (a - c) + b"
    by (metis add_assoc diff_add_cancel_left' local.add_monoid_diff_cancel_left local.minus_def)

  lemma neq_zero_impl_greater:
    "x \<noteq> 0 \<Longrightarrow> 0 < x"
    using le_is_monoid_le less_iff monoid_le_antisym monoid_le_least_zero by auto

  lemma minus_cancel_le:
    "\<lbrakk> x \<le> y; y \<le> z \<rbrakk> \<Longrightarrow> y - x \<le> z - x"
    using add_assoc le_iff_add by auto

  text {* The set subtraces of a common trace $c$ is totally ordered *}
  lemma le_common_total: "\<lbrakk> a \<le> c; b \<le> c \<rbrakk> \<Longrightarrow> a \<le> b \<or> b \<le> a"
    by (metis diff_add_cancel_left' le_add local.sum_eq_sum_conv)

  lemma le_sum_cases: "a \<le> b + c \<Longrightarrow> a \<le> b \<or> b \<le> a"
    by (simp add: le_common_total)

  lemma le_sum_cases':
    "a \<le> b + c \<Longrightarrow> a \<le> b \<or> b \<le> a \<and> a - b \<le> c"
    by (auto, metis le_sum_cases, metis minus_def le_is_monoid_le add_monoid_diff_cancel_left monoid_le_def sum_eq_sum_conv)

  lemma le_sum_iff: "a \<le> b + c \<longleftrightarrow> a \<le> b \<or> b \<le> a \<and> a - b \<le> c"
    by (metis le_sum_cases' add_monoid_diff_cancel_left le_is_monoid_le minus_def monoid_le_add_left_mono monoid_le_def monoid_le_trans)

  lemma sum_minus_right: "c \<ge> a \<Longrightarrow> a + b - c = b - (c - a)"
    by (metis diff_add_cancel_left' local.add_diff_cancel_left')

  lemma minus_gr_zero_iff [simp]:
    "0 < x - y \<longleftrightarrow> y < x"
    by (metis diff_cancel le_is_monoid_le least_zero less_iff minus_zero_eq monoid_le_antisym not_le_minus)

  lemma le_zero_iff [simp]: "x \<le> 0 \<longleftrightarrow> x = 0"
    using local.le_iff_add local.zero_sum by auto

  lemma minus_assoc [simp]: "x - y - z = x - (y + z)"
    by (metis local.add_diff_cancel_left' local.diff_add_cancel_left' local.le_add local.le_sum_iff
        local.not_le_minus local.zero_sum_right)

end

instance trace \<subseteq> order
  apply (intro_classes)
  apply (simp_all add: less_iff le_is_monoid_le monoid_le_refl)
  using monoid_le_trans apply blast
  apply (simp add: monoid_le_antisym)
done

instantiation list :: (type) monoid_add
begin

  definition zero_list :: "'a list" where "zero_list = []"
  definition plus_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where "plus_list = op @"

instance
  by (intro_classes, simp_all add: zero_list_def plus_list_def)

end

lemma monoid_le_list:
  "(xs :: 'a list) \<le>\<^sub>m ys \<longleftrightarrow> xs \<le> ys"
  apply (simp add: monoid_le_def plus_list_def)
  using Prefix_Order.prefixE Prefix_Order.prefixI apply blast
done

lemma monoid_subtract_list:
  "(xs :: 'a list) -\<^sub>m ys = xs - ys"
  apply (auto simp add: monoid_subtract_def monoid_le_list minus_list_def less_eq_list_def)
  apply (rule the_equality)
  apply (simp_all add: zero_list_def plus_list_def prefix_drop)
done

instance list :: (type) trace
  apply (intro_classes, simp_all add: zero_list_def plus_list_def monoid_le_def monoid_subtract_list)
  apply (simp add: append_eq_append_conv2)
  using Prefix_Order.prefixE Prefix_Order.prefixI apply blast
  apply (simp add: less_list_def)
done

lemma monoid_le_nat:
  "(x :: nat) \<le>\<^sub>m y \<longleftrightarrow> x \<le> y"
  by (simp add: monoid_le_def nat_le_iff_add)

lemma monoid_subtract_nat:
  "(x :: nat) -\<^sub>m y = x - y"
  by (auto simp add: monoid_subtract_def monoid_le_nat)

instance nat :: trace
  apply (intro_classes, simp_all add: monoid_subtract_nat)
  apply (metis Nat.diff_add_assoc Nat.diff_add_assoc2 add_diff_cancel_right' add_le_cancel_left add_le_cancel_right add_less_mono cancel_ab_semigroup_add_class.add_diff_cancel_left' less_irrefl not_le)
  apply (simp add: nat_le_iff_add monoid_le_def)
  apply linarith+
done
end


theory auxiliary1
imports axioms_class_existence
begin

text{* Lemmas about unions, complements, and intersections. *}

lemma unionI1: "x \<in> X \<Longrightarrow> x \<in> X \<union> Y"
  by (metis Abs_Set_inverse CollectI Ex4_9_a set_predicate_def universe)

lemma Co_Eq: "\<lbrakk>\<And>x :: Set. x \<in> A \<longleftrightarrow> x \<notin> B\<rbrakk> \<Longrightarrow> A = Co(B)"
using set_extensionality B3 by blast

lemma V_Co_Empty: "\<V> = Co(\<emptyset>)"
using Ex4_9_b empty_set Co_Eq by simp

lemma notin_inter_mono: "x \<notin> X \<Longrightarrow> x \<notin> X \<inter> Y"
proof (cases "set(x)")
  assume "set(x)"
  assume "x \<notin> X"
  then have "\<not>(x \<in> X \<and> x \<in> Y)" by simp
  with B2 set_extensionality `set(x)` show "x \<notin> X \<inter> Y" by (metis Abs_Set_inverse CollectI universe)
  next
  assume "\<not> set x"
  show "x \<notin> X \<inter> Y"
  proof
    assume "x \<in> X \<inter> Y"
    then have "set x" using set_predicate_def by auto
    with `\<not> set x` show "False" ..
  qed
qed

lemma union_iff_or: "x \<in> X \<union> Y \<longleftrightarrow> x \<in> X \<or> x \<in> Y"
  by (metis Ex4_9_a Rep_Set_cases mem_Collect_eq set_predicate_def universe)

end


(*
  Title: Locale-Based Duality
  Author: Georg Struth
  Maintainer:Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Locale-Based Duality\<close>

theory Order_Lattice_Props_Loc
  imports Main
begin

unbundle lattice_syntax

text \<open>This section explores order and lattice duality based on locales. Used within the context of a class or locale,
this is very effective, though more opaque than the previous approach. Outside of such a context, however, it apparently
cannot be used for dualising theorems. Examples are properties of  functions between orderings or lattices.\<close>

definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set" where
  "Fix f = {x. f x = x}"

context ord
begin

definition min_set :: "'a set \<Rightarrow> 'a set" where
 "min_set X = {y \<in> X. \<forall>x \<in> X. x \<le> y \<longrightarrow> x = y}"

definition max_set :: "'a set \<Rightarrow> 'a set" where
 "max_set X = {x \<in> X. \<forall>y \<in> X. x \<le> y \<longrightarrow> x = y}"

definition directed :: "'a set \<Rightarrow> bool" where
 "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"

definition filtered :: "'a set \<Rightarrow> bool" where
 "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"

definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
  "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"

definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
 "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"

definition downset :: "'a \<Rightarrow> 'a set" ("\<down>") where
  "\<down> = \<Down> \<circ> (\<lambda>x. {x})"

definition upset :: "'a \<Rightarrow> 'a set" ("\<up>") where
  "\<up> = \<Up> \<circ> (\<lambda>x. {x})"

definition downsets :: "'a set set" where
  "downsets = Fix \<Down>"

definition upsets :: "'a set set" where
  "upsets = Fix \<Up>"

abbreviation "downset_setp X \<equiv> X \<in> downsets"

abbreviation "upset_setp X \<equiv> X \<in> upsets"

definition ideals :: "'a set set" where
  "ideals = {X. X \<noteq> {} \<and> downset_setp X \<and> directed X}"

definition filters :: "'a  set set" where
  "filters = {X. X \<noteq> {} \<and> upset_setp X \<and> filtered X}"

abbreviation "idealp X \<equiv> X \<in> ideals"

abbreviation "filterp X \<equiv> X \<in> filters"

end

abbreviation Sup_pres :: "('a::Sup \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
  "Sup_pres f \<equiv> f \<circ> Sup = Sup \<circ> (`) f"

abbreviation Inf_pres :: "('a::Inf \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
  "Inf_pres f \<equiv> f \<circ> Inf = Inf \<circ> (`) f"

abbreviation sup_pres :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
  "sup_pres f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y)"

abbreviation inf_pres :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
 "inf_pres f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<sqinter> f y)"

abbreviation bot_pres :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
  "bot_pres f \<equiv> f \<bottom> = \<bottom>"

abbreviation top_pres :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool" where
  "top_pres f \<equiv> f \<top> = \<top>"

abbreviation Sup_dual :: "('a::Sup \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
  "Sup_dual f \<equiv> f \<circ> Sup = Inf \<circ> (`) f"

abbreviation Inf_dual :: "('a::Inf \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
  "Inf_dual f \<equiv> f \<circ> Inf = Sup \<circ> (`) f"

abbreviation sup_dual :: "('a::sup \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
  "sup_dual f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<sqinter> f y)"

abbreviation inf_dual :: "('a::inf \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
 "inf_dual f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<squnion> f y)"

abbreviation bot_dual :: "('a::bot \<Rightarrow> 'b::top) \<Rightarrow> bool" where
 "bot_dual f \<equiv> f \<bottom> = \<top>"

abbreviation top_dual :: "('a::top \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
  "top_dual f \<equiv> f \<top> = \<bottom>"

subsection \<open>Duality via Locales\<close>

sublocale ord \<subseteq> dual_ord: ord "(\<ge>)" "(>)"
  rewrites dual_max_set: "max_set = dual_ord.min_set"
  and dual_filtered: "filtered = dual_ord.directed"
  and dual_upset_set: "upset_set = dual_ord.downset_set"
  and dual_upset: "upset = dual_ord.downset"
  and dual_upsets: "upsets = dual_ord.downsets"
  and dual_filters: "filters = dual_ord.ideals"
       apply unfold_locales
  unfolding max_set_def ord.min_set_def fun_eq_iff apply blast
  unfolding filtered_def ord.directed_def apply simp
  unfolding upset_set_def ord.downset_set_def apply simp
  apply (simp add: ord.downset_def ord.downset_set_def ord.upset_def ord.upset_set_def)
  unfolding upsets_def ord.downsets_def apply (metis ord.downset_set_def upset_set_def)
  unfolding filters_def ord.ideals_def Fix_def ord.downsets_def upsets_def ord.downset_set_def upset_set_def ord.directed_def filtered_def
  by simp

sublocale preorder \<subseteq> dual_preorder: preorder "(\<ge>)" "(>)"
  apply unfold_locales
  apply (simp add: less_le_not_le)
  apply simp
  using order_trans by blast

sublocale order \<subseteq> dual_order: order "(\<ge>)" "(>)"
  by (unfold_locales, simp)

sublocale lattice \<subseteq> dual_lattice: lattice sup "(\<ge>)" "(>)" inf
  by (unfold_locales, simp_all)

sublocale bounded_lattice \<subseteq> dual_bounded_lattice: bounded_lattice sup "(\<ge>)" "(>)" inf \<top> \<bottom>
  by (unfold_locales, simp_all)

sublocale boolean_algebra \<subseteq> dual_boolean_algebra: boolean_algebra "\<lambda>x y. x \<squnion> -y" uminus sup "(\<ge>)" "(>)" inf \<top> \<bottom>
  by (unfold_locales, simp_all add: inf_sup_distrib1)

sublocale complete_lattice \<subseteq> dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>
  rewrites dual_gfp: "gfp = dual_complete_lattice.lfp"
proof-
  show "class.complete_lattice Sup Inf sup (\<ge>) (>) inf \<top> \<bottom>"
    by (unfold_locales, simp_all add: Sup_upper Sup_least Inf_lower Inf_greatest)
  then interpret dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>.
  show "gfp = dual_complete_lattice.lfp"
    unfolding gfp_def dual_complete_lattice.lfp_def fun_eq_iff by simp
qed

context ord
begin

lemma dual_min_set: "min_set = dual_ord.max_set"
  by (simp add: dual_ord.dual_max_set)

lemma dual_directed: "directed = dual_ord.filtered"
  by (simp add:dual_ord.dual_filtered)

lemma dual_downset: "downset = dual_ord.upset"
  by (simp add: dual_ord.dual_upset)

lemma dual_downset_set: "downset_set = dual_ord.upset_set"
  by (simp add: dual_ord.dual_upset_set)

lemma dual_downsets: "downsets = dual_ord.upsets"
  by (simp add: dual_ord.dual_upsets)

lemma dual_ideals: "ideals = dual_ord.filters"
  by (simp add: dual_ord.dual_filters)

end

context complete_lattice
begin

lemma dual_lfp: "lfp = dual_complete_lattice.gfp"
  by (simp add: dual_complete_lattice.dual_gfp)

end

subsection \<open>Properties of Orderings, Again\<close>

context ord
begin

lemma directed_nonempty: "directed X \<Longrightarrow> X \<noteq> {}"
  unfolding directed_def by fastforce

lemma directed_ub: "directed X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z)"
  by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl)

lemma downset_set_prop: "\<Down> = Union \<circ> (`) \<down>"
  unfolding downset_set_def downset_def fun_eq_iff by fastforce

lemma downset_set_prop_var: "\<Down>X = (\<Union>x \<in> X. \<down>x)"
  by (simp add: downset_set_prop)

lemma downset_prop: "\<down>x = {y. y \<le> x}"
  unfolding downset_def downset_set_def fun_eq_iff comp_def by fastforce

end

context preorder
begin

lemma directed_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z) \<Longrightarrow> directed X"
proof-
  assume h1: "X \<noteq> {}"
  and h2: "\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z"
  {fix Y
  have "finite Y \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x)"
  proof (induct rule: finite_induct)
    case empty
    then show ?case
      using h1 by blast
  next
    case (insert x F)
    then show ?case
      by (metis h2 insert_iff insert_subset order_trans)
  qed}
  thus ?thesis
    by (simp add: directed_def)
qed

lemma directed_alt: "directed X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z))"
  by (metis directed_prop directed_nonempty directed_ub)

lemma downset_set_ext: "id \<le> \<Down>"
  unfolding le_fun_def id_def downset_set_def by auto

lemma downset_set_iso: "mono \<Down>"
  unfolding mono_def downset_set_def by blast

lemma downset_set_idem [simp]: "\<Down> \<circ> \<Down> = \<Down>"
  unfolding fun_eq_iff downset_set_def comp_def using order_trans by auto

lemma downset_faithful: "\<down>x \<subseteq> \<down>y \<Longrightarrow> x \<le> y"
  by (simp add: downset_prop subset_eq)

lemma downset_iso_iff: "(\<down>x \<subseteq> \<down>y) = (x \<le> y)"
  using atMost_iff downset_prop order_trans by blast

lemma downset_directed_downset_var [simp]: "directed (\<Down>X) = directed X"
proof
  assume h1: "directed X"
  {fix Y
  assume h2: "finite Y" and h3: "Y \<subseteq> \<Down>X"
  hence "\<forall>y. \<exists>x. y \<in> Y \<longrightarrow> x \<in> X \<and>  y \<le> x"
    by (force simp: downset_set_def)
  hence "\<exists>f. \<forall>y. y \<in> Y \<longrightarrow>  f y \<in> X \<and> y \<le> f y"
    by (rule choice)
  hence "\<exists>f. finite (f ` Y) \<and> f ` Y \<subseteq> X \<and> (\<forall>y \<in> Y. y \<le> f y)"
    by (metis finite_imageI h2 image_subsetI)
  hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z)"
    by fastforce
  hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z) \<and> (\<exists>x \<in> X. \<forall> z \<in> Z. z \<le> x)"
    by (metis directed_def h1)
  hence "\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x"
    by (meson order_trans)}
  thus "directed (\<Down>X)"
    unfolding directed_def downset_set_def by fastforce
next
  assume "directed (\<Down>X)"
  thus "directed X"
    unfolding directed_def downset_set_def
    apply clarsimp
    by (smt Ball_Collect order_refl order_trans subsetCE)
qed

lemma downset_directed_downset [simp]: "directed \<circ> \<Down> = directed"
  unfolding fun_eq_iff comp_def by simp

lemma directed_downset_ideals: "directed (\<Down>X) = (\<Down>X \<in> ideals)"
  by (metis (mono_tags, lifting) Fix_def comp_apply directed_alt downset_set_idem downsets_def ideals_def mem_Collect_eq)

end

lemma downset_iso: "mono (\<down>::'a::order \<Rightarrow> 'a set)"
  by (simp add: downset_iso_iff mono_def)

context order
begin

lemma downset_inj: "inj \<down>"
  by (metis injI downset_iso_iff order.eq_iff)

end

context lattice
begin

lemma lat_ideals: "X \<in> ideals = (X \<noteq> {} \<and> X \<in> downsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<squnion> y \<in> X))"
  unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def
  by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq)

end

context bounded_lattice
begin

lemma bot_ideal: "X \<in> ideals \<Longrightarrow> \<bottom> \<in> X"
  unfolding ideals_def downsets_def Fix_def downset_set_def by fastforce

end

context complete_lattice
begin

lemma Sup_downset_id [simp]: "Sup \<circ> \<down> = id"
  using Sup_atMost atMost_def downset_prop by fastforce

lemma downset_Sup_id: "id \<le> \<down> \<circ> Sup"
  by (simp add: Sup_upper downset_prop le_funI subsetI)

lemma Inf_Sup_var: "\<Squnion>(\<Inter>x \<in> X. \<down>x) = \<Sqinter>X"
  unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup)

lemma Inf_pres_downset_var: "(\<Inter>x \<in> X. \<down>x) = \<down>(\<Sqinter>X)"
  unfolding downset_prop by (safe, simp_all add: le_Inf_iff)

end

lemma lfp_in_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> lfp f \<in> Fix f"
  using Fix_def lfp_unfold by fastforce

lemma gfp_in_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> gfp f \<in> Fix f"
  using Fix_def gfp_unfold by fastforce

lemma nonempty_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> Fix f \<noteq> {}"
  using lfp_in_Fix by fastforce

subsection \<open>Dual Properties of Orderings from Locales\<close>

text \<open>These properties can be proved very smoothly overall. But only within the context of a class
or locale!\<close>

context ord
begin

lemma filtered_lb: "filtered X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y)"
  by (simp add: dual_filtered dual_ord.directed_ub)

lemma upset_set_prop: "\<Up> = Union \<circ> (`) \<up>"
  by (simp add: dual_ord.downset_set_prop dual_upset dual_upset_set)

lemma upset_set_prop_var: "\<Up>X = (\<Union>x \<in> X. \<up>x)"
  by (simp add: dual_ord.downset_set_prop_var dual_upset dual_upset_set)

lemma upset_prop: "\<up>x = {y. x \<le> y}"
  by (simp add: dual_ord.downset_prop dual_upset)

end

context preorder
begin

lemma filtered_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y) \<Longrightarrow> filtered X"
  by (simp add: dual_filtered dual_preorder.directed_prop)

lemma filtered_alt: "filtered X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y))"
  by (simp add: dual_filtered dual_preorder.directed_alt)

lemma upset_set_ext: "id \<le> \<Up>"
  by (simp add: dual_preorder.downset_set_ext dual_upset_set)

lemma upset_set_anti: "mono \<Up>"
  by (simp add: dual_preorder.downset_set_iso dual_upset_set)

lemma up_set_idem [simp]: "\<Up> \<circ> \<Up> = \<Up>"
  by (simp add: dual_upset_set)

lemma upset_faithful: "\<up>x \<subseteq> \<up>y \<Longrightarrow> y \<le> x"
  by (metis dual_preorder.downset_faithful dual_upset)

lemma upset_anti_iff: "(\<up>y \<subseteq> \<up>x) = (x \<le> y)"
  by (simp add: dual_preorder.downset_iso_iff dual_upset)

lemma upset_filtered_upset [simp]: "filtered \<circ> \<Up> = filtered"
  by (simp add: dual_filtered dual_upset_set)

lemma filtered_upset_filters: "filtered (\<Up>X) = (\<Up>X \<in> filters)"
  using dual_filtered dual_preorder.directed_downset_ideals dual_upset_set ord.dual_filters by fastforce

end

context order
begin

lemma upset_inj: "inj \<up>"
  by (simp add: dual_order.downset_inj dual_upset)

end

context lattice
begin

end

context bounded_lattice
begin

lemma top_filter: "X \<in> filters \<Longrightarrow> \<top> \<in> X"
  by (simp add: dual_bounded_lattice.bot_ideal dual_filters)

end

context complete_lattice
begin

lemma Inf_upset_id [simp]: "Inf \<circ> \<up> = id"
  by (simp add:  dual_upset)

lemma upset_Inf_id: "id \<le> \<up> \<circ> Inf"
  by (simp add: dual_complete_lattice.downset_Sup_id dual_upset)

lemma Sup_Inf_var: " \<Sqinter>(\<Inter>x \<in> X. \<up>x) = \<Squnion>X"
  by (simp add: dual_complete_lattice.Inf_Sup_var dual_upset)

lemma Sup_dual_upset_var: "(\<Inter>x \<in> X. \<up>x) = \<up>(\<Squnion>X)"
  by (simp add: dual_complete_lattice.Inf_pres_downset_var dual_upset)

end

subsection \<open>Examples that Do Not Dualise\<close>

lemma upset_anti: "antimono (\<up>::'a::order \<Rightarrow> 'a set)"
  by (simp add: antimono_def upset_anti_iff)

context complete_lattice
begin

lemma fSup_unfold: "(f::nat \<Rightarrow> 'a) 0 \<squnion> (\<Squnion>n. f (Suc n)) = (\<Squnion>n. f n)"
  apply (intro order.antisym sup_least)
    apply (rule Sup_upper, force)
   apply (rule Sup_mono, force)
  apply (safe intro!: Sup_least)
 by (case_tac n, simp_all add: Sup_upper le_supI2)

lemma fInf_unfold: "(f::nat \<Rightarrow> 'a) 0 \<sqinter> (\<Sqinter>n. f (Suc n)) = (\<Sqinter>n. f n)"
  apply (intro order.antisym inf_greatest)
  apply (rule Inf_greatest, safe)
  apply (case_tac n)
   apply simp_all
  using Inf_lower inf.coboundedI2 apply force
   apply (simp add: Inf_lower)
  by (auto intro: Inf_mono)

end

lemma fun_isol: "mono f \<Longrightarrow> mono ((\<circ>) f)"
  by (simp add: le_fun_def mono_def)

lemma fun_isor: "mono f \<Longrightarrow> mono (\<lambda>x. x \<circ> f)"
  by (simp add: le_fun_def mono_def)

lemma Sup_sup_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> sup_pres f"
  by (metis (no_types, opaque_lifting) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral)

lemma Inf_inf_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows"Inf_pres f \<Longrightarrow> inf_pres f"
  by (smt INF_insert comp_eq_elim dual_complete_lattice.Sup_empty dual_complete_lattice.Sup_insert inf_top.right_neutral)

lemma Sup_bot_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> bot_pres f"
  by (metis SUP_empty Sup_empty comp_eq_elim)

lemma Inf_top_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres f \<Longrightarrow> top_pres f"
  by (metis INF_empty comp_eq_elim dual_complete_lattice.Sup_empty)

context complete_lattice
begin

lemma iso_Inf_subdistl:
  assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
  shows "f \<circ> Inf \<le> Inf \<circ> (`) f"
  by (simp add: assms complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD)

lemma iso_Sup_supdistl:
  assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
  shows "Sup \<circ> (`) f \<le> f \<circ> Sup"
  by (simp add: assms complete_lattice_class.SUP_le_iff le_funI dual_complete_lattice.Inf_lower monoD)

lemma Inf_subdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "f \<circ> Inf \<le> Inf \<circ> (`) f \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff)

lemma Sup_supdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "Sup \<circ> (`) f \<le> f \<circ> Sup \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff)

lemma supdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "(Sup \<circ> (`) f \<le> f \<circ> Sup) = mono f"
  using Sup_supdistl_iso iso_Sup_supdistl by force

lemma subdistl_iso:
  fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
  shows "(f \<circ> Inf \<le> Inf \<circ> (`) f) = mono f"
  using Inf_subdistl_iso iso_Inf_subdistl by force

end

lemma fSup_distr: "Sup_pres (\<lambda>x. x \<circ> f)"
  unfolding fun_eq_iff comp_def
  by (smt Inf.INF_cong SUP_apply Sup_apply)

lemma fSup_distr_var: "\<Squnion>F \<circ> g = (\<Squnion>f \<in> F. f \<circ> g)"
  unfolding fun_eq_iff comp_def
  by (smt Inf.INF_cong SUP_apply Sup_apply)

lemma fInf_distr: "Inf_pres (\<lambda>x. x \<circ> f)"
  unfolding fun_eq_iff comp_def
  by (smt INF_apply Inf.INF_cong Inf_apply)

lemma fInf_distr_var: "\<Sqinter>F \<circ> g = (\<Sqinter>f \<in> F. f \<circ> g)"
  unfolding fun_eq_iff comp_def
  by (smt INF_apply Inf.INF_cong Inf_apply)

lemma fSup_subdistl:
  assumes "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattice)"
  shows "Sup \<circ> (`) ((\<circ>) f) \<le> (\<circ>) f \<circ> Sup"
  using assms by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)

lemma fSup_subdistl_var:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows  "mono f \<Longrightarrow> (\<Squnion>g \<in> G. f \<circ> g) \<le> f \<circ> \<Squnion>G"
  by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)

lemma fInf_subdistl:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows  "mono f \<Longrightarrow> (\<circ>) f \<circ> Inf \<le> Inf \<circ> (`) ((\<circ>) f)"
  by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)

lemma fInf_subdistl_var:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> f \<circ> \<Sqinter>G \<le> (\<Sqinter>g \<in> G. f \<circ> g)"
  by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)

lemma Inf_pres_downset: "Inf_pres (\<down>::'a::complete_lattice \<Rightarrow> 'a set)"
  unfolding downset_prop fun_eq_iff comp_def
  by (safe, simp_all add: le_Inf_iff)

text \<open>This approach could probably be combined with the explicit functor-based one. This may be good for proofs, but seems conceptually rather ugly.\<close>

end


theory Exe4p2
  imports Main
begin

lemma "\<not>surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a.{x. x\<notin>f x} = f a" by (auto simp: surj_def)
  thus "False" by blast
qed

lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
    \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)" (is "(\<exists>ys zs. ?P ys zs ?xs) \<or> (\<exists>ys zs. ?Q ys zs ?xs)")
proof cases
  assume "length xs mod 2 = 0"
  obtain ys where "ys = take (length xs div 2) xs" by auto
  obtain zs where "zs = drop (length xs div 2) xs" by auto
  show ?thesis by blast
next
  assume "length xs mod 2 \<noteq> 0"
  obtain ys where "ys = take (length xs div 2) xs" by auto
  obtain zs where "zs = drop (length xs div 2) xs" by auto
  show ?thesis by blast
qed

end


theory Star imports Main
begin

inductive
  star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

hide_fact (open) refl step  \<comment> \<open>names too generic\<close>

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
proof(induction rule: star.induct)
  case refl thus ?case .
next
  case step thus ?case by (metis star.step)
qed

lemmas star_induct =
  star.induct[of "r:: 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool", split_format(complete)]

declare star.refl[simp,intro]

lemma star_step1[simp, intro]: "r x y \<Longrightarrow> star r x y"
by(metis star.refl star.step)

code_pred star .

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_12
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map x (nil2) = nil2"
| "map x (cons2 z xs) = cons2 (x z) (map x xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

theorem property0 :
  "((drop n (map f xs)) = (map f (drop n xs)))"
  find_proof DInd
  apply (induct xs rule: TIP_prop_12.drop.induct)
    apply auto
  done

end


section \<open>Monoids\<close>

text \<open>
  We define monoids as a soft type class (though without tool support) and experiment with
  how it can interact with implicit arguments and type inference.

  Structures are modeled as sets that contain the operations, but are parametrized over
  the carrier sets.
\<close>

theory Monoid_Old
imports Structures_Old

begin

definition Monoid :: "set \<Rightarrow> set type"
  where [typeclass]: "Monoid A = Zero A \<bar> Plus A \<bar>
    \<lparr> (plus @plus) (zero @zero).
    (\<forall>x: element A. plus `zero `x = x) \<and>
    (\<forall>x: element A. plus `x `zero = x) \<and>
    (\<forall>x: element A. \<forall>y: element A. \<forall>z: element A.
      plus `(plus `x `y) `z = plus `x `(plus `y `z)) \<rparr>"

lemma Monoid_is_Zero [derive]: "M: Monoid A \<Longrightarrow> M: Zero A"
  sorry

lemma Monoid_is_Plus [derive]: "M: Monoid A \<Longrightarrow> M: Plus A"
  sorry

lemma Monoid_typeI:
  "\<lbrakk>str: Zero A; str: Plus A;
    \<forall>x: element A. str[@plus] `str[@zero] `x = x;
    \<forall>x: element A. str[@plus] `x `str[@zero] = x;
    \<forall>x: element A. \<forall>y: element A. \<forall>z: element A.
       str[@plus] `(str[@plus] `x `y) `z = str[@plus] `x `(str[@plus] `y `z)
    \<rbrakk> \<Longrightarrow> str: Monoid A"
  sorry

text \<open>
  Now we define the global operations as projections. Here, we also convert the set
  functions to meta functions. The axioms can then be derived.
\<close>

lemma
  assumes "M: Monoid A"
  shows
  monoid_left_neut [simp]: "x: element A \<Longrightarrow> plus M (zero M) x = x" and
  monoid_right_neut [simp]: "x: element A \<Longrightarrow> plus M x (zero M) = x" and
  monoid_assoc [simp]: "\<lbrakk>x: element A; y: element A; z: element A\<rbrakk>
     \<Longrightarrow> plus M (plus M x y) z = plus M x (plus M y z)"
  sorry

subsection \<open>Instance for pairs\<close>

definition
  "pair_plus A B p1 p2 \<equiv>
    \<lparr> @plus = \<lambda>\<langle>a1,b1\<rangle> \<langle>a2,b2\<rangle>\<in>A\<times>B. \<langle>plus p1 a1 a2, plus p2 b1 b2\<rangle> \<rparr>"

definition
  "pair_zero A B z1 z2 \<equiv>
    \<lparr> @zero = \<langle>zero z1, zero z2\<rangle> \<rparr>"

(* TODO: Need some form of structure composition: pair_monoid = pair_zero [+] pair_plus *)
definition
  "pair_monoid A B m1 m2 \<equiv>
    \<lparr> @zero = (pair_zero A B m1 m2)[@zero], @plus = (pair_plus A B m1 m2)[@plus] \<rparr>"

lemma pair_monoid_ZERO [simp]: "(pair_monoid A B m1 m2)[@zero] = (pair_zero A B m1 m2)[@zero]"
  unfolding pair_monoid_def by (simp add: object_simps)

lemma pair_monoid_PLUS [simp]: "(pair_monoid A B m1 m2)[@plus] = (pair_plus A B m1 m2)[@plus]"
  unfolding pair_monoid_def by (simp add: object_simps)

text \<open>
  The following proofs illustrate that reasoning with types is still very much pedestrian
  and needs better automated support.
\<close>

lemma pair_plus_PLUS:
  "(pair_plus A B p1 p2)[@plus] = \<lambda>\<langle>a1,b1\<rangle> \<langle>a2,b2\<rangle>\<in>A\<times>B. \<langle>plus p1 a1 a2, plus p2 b1 b2\<rangle>"
  unfolding pair_plus_def by (simp add: object_simps)

lemma pair_plus_type [type]:
  "pair_plus: (A: set) \<Rightarrow> (B: set) \<Rightarrow> Plus A \<Rightarrow> Plus B \<Rightarrow> Plus (A \<times> B)"
  apply discharge_types
  apply (intro Dep_fun_typeI Plus_typeI)
  apply (unfold pair_plus_PLUS split_def)
  oops

lemma pair_zero_type [type]:
  "pair_zero: (A: set) \<Rightarrow> (B: set) \<Rightarrow> Zero A \<Rightarrow> Zero B \<Rightarrow> Zero (A \<times> B)"
  unfolding Zero_def Pointed_def pair_zero_def zero_def
  by unfold_types (simp add: object_simps)

lemma pair_monoid_type [type]:
  "pair_monoid: (A: set) \<Rightarrow> (B: set) \<Rightarrow> Monoid A \<Rightarrow> Monoid B \<Rightarrow> Monoid (A \<times> B)"
  sorry

lemma [type_instance]:
  "m1: Plus A \<Longrightarrow> m2: Plus B \<Longrightarrow> pair_plus A B m1 m2: Plus (A \<times> B)"
  "m1: Zero A \<Longrightarrow> m2: Zero B \<Longrightarrow> pair_zero A B m1 m2: Zero (A \<times> B)"
  "m1: Monoid A \<Longrightarrow> m2: Monoid B \<Longrightarrow> pair_monoid A B m1 m2: Monoid (A \<times> B)"
  sorry

subsection \<open>Overloaded syntax\<close>

context
  notes [[auto_elaborate, trace_soft_types]]
begin

lemma "x + 0 = x"
  print_types
  oops

lemma "\<langle>x, y\<rangle> + 0 = \<langle>x, y\<rangle>"
  print_types
  oops

lemma "x + (y + z) = x + y + z"
  print_types
  oops

lemma "x + y = z + w \<and> u + v = 0"
  print_types
  oops

end

subsection \<open>Extension to groups\<close>

object Group "A :: set" is
  "Monoid A
  \<bar> \<lparr> (plus @plus) (zero @zero) (inv @inv).
    inv: element (A \<rightarrow> A) \<and>
    (\<forall>x\<in>A. plus `(inv `x) `x = zero) \<and>
    (\<forall>x\<in>A. plus `x `(inv `x) = zero) \<rparr>"

lemma group_is_monoid:  "G: Group A \<Longrightarrow> G: Monoid A"
  sorry

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_43
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x2) (Z) = False"
| "y (S x2) (S y22) = y x2 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun union :: "Nat list => Nat list => Nat list" where
  "union (nil2) y2 = y2"
| "union (cons2 z2 xs) y2 =
     (if elem z2 y2 then union xs y2 else cons2 z2 (union xs y2))"

theorem property0 :
  "((elem z y2) ==> (elem z (union z2 y2)))"
  oops

end


(*  Title:      Logical_Relations.thy
    Author:     Peter Gammie
*)

section \<open>Pitts's method for solving recursive domain predicates\<close>
(*<*)

theory Logical_Relations
imports
  Basis
begin

(*>*)
text\<open>

We adopt the general theory of \<^citet>\<open>"PittsAM:relpod"\<close> for solving
recursive domain predicates. This is based on the idea of
\emph{minimal invariants} that \<^citet>\<open>\<open>Def 2\<close> in "DBLP:conf/mfps/Pitts93"\<close>
ascribes ``essentially to D. Scott''.

Ideally we would like to do the proofs once and use Pitts's
\emph{relational structures}. Unfortunately it seems we need
higher-order polymorphism (type functions) to make this work (but see
\<^citet>\<open>"Huffman:MonadTransformers:2012"\<close>). Here we develop three
versions, one for each of our applications. The proofs are similar
(but not quite identical) in all cases.

We begin by defining an \emph{admissible} set (aka an \emph{inclusive
predicate}) to be one that contains @{term "\<bottom>"} and is closed under
countable chains:

\<close>

definition admS :: "'a::pcpo set set" where
  "admS \<equiv> { R :: 'a set. \<bottom> \<in> R \<and> adm (\<lambda>x. x \<in> R) }"

typedef ('a::pcpo) admS = "{ x::'a::pcpo set . x \<in> admS }"
  morphisms unlr mklr unfolding admS_def by fastforce

text\<open>

These sets form a complete lattice.

\<close>
(*<*)

lemma admSI [intro]:
  "\<lbrakk> \<bottom> \<in> R; adm (\<lambda>x. x \<in> R) \<rbrakk> \<Longrightarrow> R \<in> admS"
unfolding admS_def by simp

lemma bottom_in_unlr [simp]:
  "\<bottom> \<in> unlr R"
using admS.unlr [of R] by (simp add: admS_def)

lemma adm_unlr [simp]:
  "adm (\<lambda>x. x \<in> unlr R)"
using admS.unlr [of R] by (simp add: admS_def)

lemma adm_cont_unlr [intro, simp]:
  "cont f \<Longrightarrow> adm (\<lambda>x. f x \<in> unlr r)"
by (erule adm_subst) simp

declare admS.mklr_inverse[simp add]

instantiation admS :: (pcpo) order
begin

definition
  "x \<le> y \<equiv> unlr x \<subseteq> unlr y"

definition
  "x < y \<equiv> unlr x \<subset> unlr y"

instance
  by standard (auto simp add: less_eq_admS_def less_admS_def admS.unlr_inject)

end

lemma mklr_leq [iff]: "\<lbrakk> x \<in> admS; y \<in> admS \<rbrakk> \<Longrightarrow> (mklr x \<le> mklr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_admS_def by simp

lemma unlr_leq: "(unlr x \<le> unlr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_admS_def by simp

instantiation admS :: (pcpo) lattice
begin

definition
  "inf f g \<equiv> mklr (unlr f \<inter> unlr g)"

definition
  "sup f g = mklr (unlr f \<union> unlr g)"

lemma unlr_inf: "unlr (inf x y) = unlr x \<inter> unlr y"
  unfolding inf_admS_def by (simp add: admS_def)

lemma unlr_sup: "unlr (sup x y) = unlr x \<union> unlr y"
  unfolding sup_admS_def by (simp add: admS_def)

instance by intro_classes (auto simp: less_eq_admS_def unlr_inf unlr_sup)

end

instantiation admS :: (pcpo) bounded_lattice
begin

definition
  "bot_admS \<equiv> mklr {\<bottom>}"

lemma unlr_bot[simp]:
  "unlr bot = {\<bottom>}"
  by (simp add: admS_def bot_admS_def)

definition
  "top_admS \<equiv> mklr UNIV"

instance
proof
  fix x :: "'a admS"
  show "bot \<le> x" by (simp add: bot_admS_def less_eq_admS_def admS_def)
next
  fix x :: "'a admS"
  show "x \<le> top" by (simp add: top_admS_def less_eq_admS_def admS_def)
qed

end

instantiation admS :: (pcpo) complete_lattice
begin

definition
  "Inf A \<equiv> mklr (Inf (unlr ` A))"

definition
  "Sup (A::'a admS set) = Inf {y. \<forall>x\<in>A. x \<le> y}"

lemma mklr_Inf: "unlr (Inf A) = Inf (unlr ` A)"
  unfolding Inf_admS_def by (simp add: admS_def)

lemma INT_admS_bot [simp]:
  "(\<Inter>R. unlr R) = {\<bottom>}"
by (auto, metis singletonE unlr_bot)

instance
  by standard
    (auto simp add:
      less_eq_admS_def mklr_Inf Sup_admS_def
      Inf_admS_def bot_admS_def top_admS_def admS_def)

end
(*>*)

subsection\<open>Sets of vectors\<close>

text\<open>

The simplest case involves the recursive definition of a set of
vectors over a single domain. This involves taking the fixed point of
a functor where the \emph{positive} (covariant) occurrences of the
recursion variable are separated from the \emph{negative}
(contravariant) ones. (See \S\ref{sec:por} etc. for examples.)

By dually ordering the negative uses of the recursion variable the
functor is made monotonic with respect to the order on the domain
@{typ "'d"}. Here the type constructor @{typ "'a dual"} yields a type
with the same elements as @{typ "'a"} but with the reverse order. The
functions @{term "dual"} and @{term "undual"} mediate the isomorphism.

\<close>

type_synonym 'd lf_rep = "'d admS dual \<times> 'd admS \<Rightarrow> 'd set"
type_synonym 'd lf = "'d admS dual \<times> 'd admS \<Rightarrow> 'd admS"

text\<open>

The predicate @{term "eRSV"} encodes our notion of relation.  (This is
Pitts's \<open>e : R \<subset> S\<close>.) We model a vector as a function from
some index type @{typ "'i"} to the domain @{typ "'d"}. Note that the
minimal invariant is for the domain @{typ "'d"} only.

\<close>

abbreviation
  eRSV :: "('d::pcpo \<rightarrow> 'd) \<Rightarrow> ('i::type \<Rightarrow> 'd) admS dual \<Rightarrow> ('i \<Rightarrow> 'd) admS \<Rightarrow> bool"
where
  "eRSV e R S \<equiv> \<forall>d \<in> unlr (undual R). (\<lambda>x. e\<cdot>(d x)) \<in> unlr S"

text\<open>

In general we can also assume that @{term "e"} here is strict, but we
do not need to do so for our examples.

Our locale captures the key ingredients in Pitts's scheme:
\begin{itemize}

\item that the function @{term "\<delta>"} is a minimal invariant;

\item that the functor defining the relation is suitably monotonic; and

\item that the functor is closed with respect to the minimal invariant.

\end{itemize}

\<close>

locale DomSol =
  fixes F :: "'a::order dual \<times> 'a::order \<Rightarrow> 'a"
  assumes monoF: "mono F"
begin

definition sym_lr :: "'a dual \<times> 'a \<Rightarrow> 'a dual \<times> 'a"
where
  "sym_lr = (\<lambda>(rm, rp). (dual (F (dual rp, undual rm)), F (rm, rp)))"

lemma sym_lr_mono:
  "mono sym_lr"
proof
  fix x y :: "'a dual \<times> 'a"
  obtain x1 x2 y1 y2 where [simp]: "x = (x1, x2)" "y = (y1, y2)"
    by (cases x, cases y)
  assume "x \<le> y"
  with monoF have "F x \<le> F y" ..
  from \<open>x \<le> y\<close> have "(dual y2, undual y1) \<le> (dual x2, undual x1)"
    by (simp_all add: dual_less_eq_iff)
  with monoF have "F (dual y2, undual y1) \<le> F (dual x2, undual x1)" ..
  with \<open>F x \<le> F y\<close> show "sym_lr x \<le> sym_lr y"
    by (simp add: sym_lr_def)
qed

end

locale DomSolV = DomSol "F :: ('i::type \<Rightarrow> 'd::pcpo) lf" for F +
  fixes \<delta> :: "('d::pcpo \<rightarrow> 'd) \<rightarrow> 'd \<rightarrow> 'd"
  assumes min_inv_ID: "fix\<cdot>\<delta> = ID"
  assumes eRSV_deltaF:
      "\<And>(e :: 'd \<rightarrow> 'd) (R :: ('i \<Rightarrow> 'd) admS dual) (S :: ('i \<Rightarrow> 'd) admS).
          eRSV e R S \<Longrightarrow> eRSV (\<delta>\<cdot>e) (dual (F (dual S, undual R))) (F (R, S))"
(*<*)
context DomSolV
begin

abbreviation
  f_lim :: "('i \<Rightarrow> 'd) admS dual \<times> ('i \<Rightarrow> 'd) admS"
where
  "f_lim \<equiv> lfp sym_lr"

definition
  delta_neg :: "('i \<Rightarrow> 'd) admS dual"
where
  "delta_neg = fst f_lim"

definition
  delta_pos :: "('i \<Rightarrow> 'd) admS"
where
  "delta_pos = snd f_lim"

lemma delta:
  "(delta_neg, delta_pos) = f_lim"
by (simp add: delta_neg_def delta_pos_def)

lemma delta_neg_sol:
  "delta_neg = dual (F (dual delta_pos, undual delta_neg))"
by (metis (no_types, lifting) case_prod_unfold delta_neg_def delta_pos_def fst_conv lfp_unfold sym_lr_def sym_lr_mono)

lemma delta_pos_neg_least:
  assumes rm: "rm \<le> F (dual rp, rm)"
  assumes rp: "F (dual rm, rp) \<le> rp"
  shows "delta_neg \<le> dual rm"
    and "delta_pos \<le> rp"
proof -
  from rm rp
  have "(delta_neg, delta_pos) \<le> (dual rm, rp)"
    by (simp add: delta lfp_lowerbound sym_lr_def)
  then show "delta_neg \<le> dual rm" and "delta_pos \<le> rp"
    by simp_all
qed

lemma delta_eq:
  "undual delta_neg = delta_pos"
proof(rule antisym)
  show "delta_pos \<le> undual delta_neg"
    by (metis delta_neg_sol delta_pos_neg_least(2) delta_pos_sol order_refl undual_dual)
next
  let ?P = "\<lambda>x. eRSV x (delta_neg) (delta_pos)"
  have "?P (fix\<cdot>\<delta>)"
    by (rule fix_ind, simp_all add: inst_fun_pcpo[symmetric])
       (metis delta_neg_sol delta_pos_sol eRSV_deltaF)
  with min_inv_ID
  show "undual delta_neg \<le> delta_pos"
    by (fastforce simp: unlr_leq[symmetric])
qed
(*>*)
text\<open>

From these assumptions we can show that there is a unique object that
is a solution to the recursive equation specified by @{term "F"}.

\<close>

definition "delta \<equiv> delta_pos"

lemma delta_sol: "delta = F (dual delta, delta)"
(*<*)
unfolding delta_def
by (subst delta_eq[symmetric], simp, rule delta_pos_sol)
(*>*)

lemma delta_unique:
  assumes r: "F (dual r, r) = r"
  shows "r = delta"
(*<*)
unfolding delta_def
proof(rule antisym)
  show "delta_pos \<le> r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
next
  have "delta_neg \<le> dual r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
  then have "r \<le> undual delta_neg" by (simp add: less_eq_dual_def)
  then show "r \<le> delta_pos"
    using delta_eq by simp
qed
(*>*)

end

text\<open>

We use this to show certain functions are not PCF-definable in
\S\ref{sec:pcfdefinability}.

\<close>

subsection\<open>Relations between domains and syntax\<close>

text\<open>

\label{sec:synlr}

To show computational adequacy (\S\ref{sec:compad}) we need to relate
elements of a domain to their syntactic counterparts. An advantage of
Pitts's technique is that this is straightforward to do.

\<close>

definition synlr :: "('d::pcpo \<times> 'a::type) set set" where
  "synlr \<equiv> { R :: ('d \<times> 'a) set. \<forall>a. { d. (d, a) \<in> R } \<in> admS }"

typedef ('d::pcpo, 'a::type) synlr = "{ x::('d \<times> 'a) set. x \<in> synlr }"
  morphisms unsynlr mksynlr unfolding synlr_def by fastforce

text\<open>

An alternative representation (suggested by Brian Huffman) is to
directly use the type @{typ "'a \<Rightarrow> 'b admS"} as this is automatically
a complete lattice. However we end up fighting the automatic methods a
lot.

\<close>

(*<*)

lemma bottom_in_unsynlr [simp]:
  "(\<bottom>, a) \<in> unsynlr R"
  using synlr.unsynlr [of R] by (simp add: synlr_def admS_def)

lemma adm_unsynlr [simp]:
  "adm (\<lambda>x. (x, a) \<in> unsynlr R)"
  using synlr.unsynlr[of R] by (simp add: synlr_def admS_def)

lemma adm_cont_unsynlr [intro, simp]:
  "cont f \<Longrightarrow> adm (\<lambda>x. (f x, a) \<in> unsynlr r)"
  by (erule adm_subst) simp

declare synlr.mksynlr_inverse[simp add]

text\<open>Lattice machinery.\<close>

instantiation synlr :: (pcpo, type) order
begin

definition
  "x \<le> y \<equiv> unsynlr x \<le> unsynlr y"

definition
  "x < y \<equiv> unsynlr x < unsynlr y"

instance
  by standard (auto simp add: less_eq_synlr_def less_synlr_def synlr.unsynlr_inject)

end

lemma mksynlr_leq [iff]: "\<lbrakk> x \<in> synlr; y \<in> synlr \<rbrakk> \<Longrightarrow> (mksynlr x \<le> mksynlr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_synlr_def by simp

lemma unsynlr_leq: "(unsynlr x \<le> unsynlr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_synlr_def by simp

instantiation synlr :: (pcpo, type) lattice
begin

definition
  "inf f g \<equiv> mksynlr (unsynlr f \<inter> unsynlr g)"

definition
  "sup f g = mksynlr (unsynlr f \<union> unsynlr g)"

lemma unsynlr_inf: "unsynlr (inf x y) = unsynlr x \<inter> unsynlr y"
  unfolding inf_synlr_def by (simp add: admS_def synlr_def)

lemma unsynlr_sup: "unsynlr (sup x y) = unsynlr x \<union> unsynlr y"
  unfolding sup_synlr_def by (simp add: admS_def synlr_def)

instance by intro_classes (auto simp: less_eq_synlr_def unsynlr_inf unsynlr_sup)

end

instantiation synlr :: (pcpo, type) bounded_lattice
begin

definition
  "bot_synlr \<equiv> mksynlr ({\<bottom>} \<times> UNIV)"

lemma unsynlr_bot[simp]:
  "unsynlr bot = {\<bottom>} \<times> UNIV"
  by (simp add: admS_def synlr_def bot_synlr_def)

definition
  "top_synlr \<equiv> mksynlr UNIV"

instance
proof
  fix x :: "('a, 'b) synlr"
  show "bot \<le> x" by (auto simp: bot_synlr_def less_eq_synlr_def admS_def synlr_def)
next
  fix x :: "('a, 'b) synlr"
  show "x \<le> top" by (auto simp: top_synlr_def less_eq_synlr_def admS_def synlr_def)
qed

end

instantiation synlr :: (pcpo, type) complete_lattice
begin

definition
  "Inf A \<equiv> mksynlr (Inf (unsynlr ` A))"

definition
  "Sup (A::('a,'b) synlr set) = Inf {y. \<forall>x\<in>A. x \<le> y}"

lemma mksynlr_Inf: "unsynlr (Inf A) = Inf (unsynlr ` A)"
  unfolding Inf_synlr_def by (simp add: admS_def synlr_def)

lemma INT_synlr_bot [simp]:
  "(\<Inter>R. unsynlr R) = {\<bottom>} \<times> UNIV"
apply auto
apply (drule spec[of _ "mksynlr ({\<bottom>} \<times> UNIV)"])
apply (metis bot_synlr_def mem_Sigma_iff singletonE unsynlr_bot)
done

instance
apply standard
apply (auto simp add: less_eq_synlr_def mksynlr_Inf Sup_synlr_def)
apply (auto simp add: Inf_synlr_def bot_synlr_def top_synlr_def)
done

end

(*>*)
text\<open>

Again we define functors on @{typ "('d, 'a) synlr"}.

\<close>

type_synonym ('d, 'a) synlf_rep = "('d, 'a) synlr dual \<times> ('d, 'a) synlr \<Rightarrow> ('d \<times> 'a) set"
type_synonym ('d, 'a) synlf = "('d, 'a) synlr dual \<times> ('d, 'a) synlr \<Rightarrow> ('d, 'a) synlr"

text\<open>

We capture our relations as before. Note we need the inclusion @{term
"e"} to be strict for our example.

\<close>

abbreviation
  eRSS :: "('d::pcpo \<rightarrow> 'd) \<Rightarrow> ('d, 'a::type) synlr dual \<Rightarrow> ('d, 'a) synlr \<Rightarrow> bool"
where
  "eRSS e R S \<equiv> \<forall>(d, a) \<in> unsynlr (undual R). (e\<cdot>d, a) \<in> unsynlr S"

locale DomSolSyn =  DomSol "F :: ('d::pcpo, 'a::type) synlf" for F +
  fixes \<delta> :: "('d::pcpo \<rightarrow> 'd) \<rightarrow> 'd \<rightarrow> 'd"
  assumes min_inv_ID: "fix\<cdot>\<delta> = ID"
  assumes min_inv_strict: "\<And>r. \<delta>\<cdot>r\<cdot>\<bottom> = \<bottom>"
  assumes eRS_deltaF:
      "\<And>(e :: 'd \<rightarrow> 'd) (R :: ('d, 'a) synlr dual) (S :: ('d, 'a) synlr).
          \<lbrakk> e\<cdot>\<bottom> = \<bottom>; eRSS e R S \<rbrakk> \<Longrightarrow> eRSS (\<delta>\<cdot>e) (dual (F (dual S, undual R))) (F (R, S))"
(*<*)

context DomSolSyn
begin

abbreviation
  f_lim :: "('d, 'a) synlr dual \<times> ('d, 'a) synlr"
where
  "f_lim \<equiv> lfp sym_lr"

definition
  delta_neg :: "('d, 'a) synlr dual"
where
  "delta_neg = fst f_lim"

definition
  delta_pos :: "('d, 'a) synlr"
where
  "delta_pos = snd f_lim"

lemma delta:
  "(delta_neg, delta_pos) = f_lim"
by (simp add: delta_neg_def delta_pos_def)

lemma delta_neg_sol:
  "delta_neg = dual (F (dual delta_pos, undual delta_neg))"
by (metis (no_types, lifting) case_prod_unfold delta_neg_def delta_pos_def fst_conv lfp_unfold sym_lr_def sym_lr_mono)

lemma delta_pos_sol:
  "delta_pos = F (delta_neg, delta_pos)"
by (metis (no_types, lifting) case_prod_conv delta lfp_unfold snd_conv sym_lr_def sym_lr_mono)

lemma delta_pos_neg_least:
  assumes rm: "rm \<le> F (dual rp, rm)"
  assumes rp: "F (dual rm, rp) \<le> rp"
  shows "delta_neg \<le> dual rm"
    and "delta_pos \<le> rp"
proof -
  from rm rp
  have "(delta_neg, delta_pos) \<le> (dual rm, rp)"
    by (simp add: delta lfp_lowerbound sym_lr_def)
  then show "delta_neg \<le> dual rm" and "delta_pos \<le> rp"
    by simp_all
qed

lemma delta_eq:
  "undual delta_neg = delta_pos"
proof(rule antisym)
  show "delta_pos \<le> undual delta_neg"
    by (metis delta_neg_sol delta_pos_neg_least(2) delta_pos_sol order_refl undual_dual)
next
  let ?P = "\<lambda>x. x\<cdot>\<bottom> = \<bottom> \<and> eRSS x (delta_neg) (delta_pos)"
  have "?P (fix\<cdot>\<delta>)"
    by (rule fix_ind, simp_all)
       (metis delta_neg_sol delta_pos_sol eRS_deltaF min_inv_strict)
  with min_inv_ID
  show "undual delta_neg \<le> delta_pos"
    by (fastforce simp: unsynlr_leq[symmetric])
qed

definition
  "delta \<equiv> delta_pos"

lemma delta_sol:
  "delta = F (dual delta, delta)"
unfolding delta_def
by (subst delta_eq[symmetric], simp, rule delta_pos_sol)

lemma delta_unique:
  assumes r: "F (dual r, r) = r"
  shows "r = delta"
unfolding delta_def
proof(rule antisym)
  show "delta_pos \<le> r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
next
  have "delta_neg \<le> dual r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
  then have "r \<le> undual delta_neg" by (simp add: less_eq_dual_def)
  then show "r \<le> delta_pos"
    using delta_eq by simp
qed

end

(*>*)
text\<open>

Again, from these assumptions we can construct the unique solution to
the recursive equation specified by @{term "F"}.

\<close>

subsection\<open>Relations between pairs of domains\<close>

text\<open>

Following \<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close> and
\<^citet>\<open>"DBLP:journals/tcs/Filinski07"\<close>, we want to relate two pairs of
mutually-recursive domains. Each of the pairs represents a (monadic)
computation and value space.

\<close>

type_synonym ('am, 'bm, 'av, 'bv) lr_pair = "('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS"

type_synonym ('am, 'bm, 'av, 'bv) lf_pair_rep =
  "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair \<Rightarrow> (('am \<times> 'bm) set \<times> ('av \<times> 'bv) set)"

type_synonym ('am, 'bm, 'av, 'bv) lf_pair =
  "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair \<Rightarrow> (('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS)"

text\<open>

The inclusions need to be strict to get our example through.

\<close>

abbreviation
  eRSP :: "(('am::pcpo \<rightarrow> 'am) \<times> ('av::pcpo \<rightarrow> 'av))
       \<Rightarrow> (('bm::pcpo \<rightarrow> 'bm) \<times> ('bv::pcpo \<rightarrow> 'bv))
       \<Rightarrow> (('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS) dual
       \<Rightarrow> ('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS
       \<Rightarrow> bool"
where
  "eRSP ea eb R S \<equiv>
     (\<forall>(am, bm) \<in> unlr (fst (undual R)). (fst ea\<cdot>am, fst eb\<cdot>bm) \<in> unlr (fst S))
   \<and> (\<forall>(av, bv) \<in> unlr (snd (undual R)). (snd ea\<cdot>av, snd eb\<cdot>bv) \<in> unlr (snd S))"

locale DomSolP = DomSol "F :: ('am::pcpo, 'bm::pcpo, 'av::pcpo, 'bv::pcpo) lf_pair" for F +
  fixes ad :: "(('am \<rightarrow> 'am) \<times> ('av \<rightarrow> 'av)) \<rightarrow> (('am \<rightarrow> 'am) \<times> ('av \<rightarrow> 'av))"
  fixes bd :: "(('bm \<rightarrow> 'bm) \<times> ('bv \<rightarrow> 'bv)) \<rightarrow> (('bm \<rightarrow> 'bm) \<times> ('bv \<rightarrow> 'bv))"
  assumes ad_ID: "fix\<cdot>ad = (ID, ID)"
  assumes bd_ID: "fix\<cdot>bd = (ID, ID)"
  assumes ad_strict: "\<And>r. fst (ad\<cdot>r)\<cdot>\<bottom> = \<bottom>" "\<And>r. snd (ad\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  assumes bd_strict: "\<And>r. fst (bd\<cdot>r)\<cdot>\<bottom> = \<bottom>" "\<And>r. snd (bd\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  assumes eRSP_deltaF:
    "\<lbrakk> eRSP ea eb R S; fst ea\<cdot>\<bottom> = \<bottom>; snd ea\<cdot>\<bottom> = \<bottom>; fst eb\<cdot>\<bottom> = \<bottom>; snd ea\<cdot>\<bottom> = \<bottom> \<rbrakk>
      \<Longrightarrow> eRSP (ad\<cdot>ea) (bd\<cdot>eb) (dual (F (dual S, undual R))) (F (R, S))"
(*<*)

context DomSolP
begin

abbreviation
  f_lim :: "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair"
where
  "f_lim \<equiv> lfp sym_lr"

definition
  delta_neg :: "('am, 'bm, 'av, 'bv) lr_pair dual"
where
  "delta_neg = fst f_lim"

definition
  delta_pos :: "('am, 'bm, 'av, 'bv) lr_pair"
where
  "delta_pos = snd f_lim"

lemma delta:
  "(delta_neg, delta_pos) = f_lim"
by (simp add: delta_neg_def delta_pos_def)

lemma delta_neg_sol:
  "delta_neg = dual (F (dual delta_pos, undual delta_neg))"
by (metis (no_types, lifting) case_prod_unfold delta_neg_def delta_pos_def fst_conv lfp_unfold sym_lr_def sym_lr_mono)

lemma delta_pos_sol:
  "delta_pos = F (delta_neg, delta_pos)"
by (metis (no_types, lifting) case_prod_conv delta lfp_unfold snd_conv sym_lr_def sym_lr_mono)

lemma delta_pos_neg_least:
  assumes rm: "rm \<le> F (dual rp, rm)"
  assumes rp: "F (dual rm, rp) \<le> rp"
  shows "delta_neg \<le> dual rm"
    and "delta_pos \<le> rp"
proof -
  from rm rp
  have "(delta_neg, delta_pos) \<le> (dual rm, rp)"
    by (simp add: delta lfp_lowerbound sym_lr_def)
  then show "delta_neg \<le> dual rm" and "delta_pos \<le> rp"
    by simp_all
qed

lemma delta_eq:
  "undual delta_neg = delta_pos"
proof(rule antisym)
  show "delta_pos \<le> undual delta_neg"
    by (metis delta_neg_sol delta_pos_neg_least(2) delta_pos_sol order_refl undual_dual)
next
  let ?P = "\<lambda>(ea, eb). eRSP ea eb (delta_neg) (delta_pos) \<and> fst ea\<cdot>\<bottom> = \<bottom> \<and> snd ea\<cdot>\<bottom> = \<bottom> \<and> fst eb\<cdot>\<bottom> = \<bottom> \<and> snd eb\<cdot>\<bottom> = \<bottom>"
  have "?P (fix\<cdot>ad, fix\<cdot>bd)"
    apply (rule parallel_fix_ind)
    apply simp_all
    using ad_strict bd_strict
    apply clarsimp
    apply (cut_tac ea="(a, b)" and eb="(aa, ba)" in eRSP_deltaF[where R=delta_neg and S=delta_pos])
    apply (simp_all add: delta_pos_sol[symmetric])
    apply (subst delta_neg_sol)
    apply simp
    apply (subst delta_neg_sol)
    apply simp
    done
  then have "?P ((ID, ID), (ID, ID))" by (simp only: ad_ID bd_ID)
  then show "undual delta_neg \<le> delta_pos"
    by (fastforce simp: unlr_leq[symmetric] less_eq_prod_def)
qed

definition
  "delta \<equiv> delta_pos"

lemma delta_sol:
  "delta = F (dual delta, delta)"
unfolding delta_def
by (subst delta_eq[symmetric], simp, rule delta_pos_sol)

lemma delta_unique:
  assumes r: "F (dual r, r) = r"
  shows "r = delta"
unfolding delta_def
proof(rule antisym)
  show "delta_pos \<le> r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
next
  have "delta_neg \<le> dual r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
  then have "r \<le> undual delta_neg" by (simp add: less_eq_dual_def)
  then show "r \<le> delta_pos"
    using delta_eq by simp
qed

end
(*>*)

text\<open>

We use this solution to relate the direct and continuation semantics
for PCF in \S\ref{sec:continuations}.

\<close>
(*<*)

end
(*>*)