theory Galois_Connection
  imports Lattice
begin

section {* Galois connections *}

subsection {* Definition and basic properties *}

locale galois_connection =
  fixes orderA :: "('a, 'c) ord_scheme" ("\<alpha>")
  and orderB :: "('b, 'd) ord_scheme" ("\<beta>")
  and lower :: "'a \<Rightarrow> 'b" ("\<pi>\<^sup>*")
  and upper :: "'b \<Rightarrow> 'a" ("\<pi>\<^sub>*")
  assumes is_order_A: "order \<alpha>"
  and is_order_B: "order \<beta>"
  and lower_closure: "\<pi>\<^sup>* \<in> carrier \<alpha> \<rightarrow> carrier \<beta>"
  and upper_closure: "\<pi>\<^sub>* \<in> carrier \<beta> \<rightarrow> carrier \<alpha>"
  and galois_property: "\<lbrakk>\<pi>\<^sup>* x \<in> carrier \<beta>; x \<in> carrier \<alpha>; y \<in> carrier \<beta>; \<pi>\<^sub>* y \<in> carrier \<alpha>\<rbrakk> \<Longrightarrow> \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<beta>\<^esub> y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>\<alpha>\<^esub> \<pi>\<^sub>* y"

begin
  lemma right: "\<lbrakk>\<pi>\<^sup>* x \<in> carrier \<beta>; x \<in> carrier \<alpha>; y \<in> carrier \<beta>; \<pi>\<^sub>* y \<in> carrier \<alpha>; \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<beta>\<^esub> y\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^bsub>\<alpha>\<^esub> \<pi>\<^sub>* y"
    by (metis galois_property)

  lemma left: "\<lbrakk>\<pi>\<^sup>* x \<in> carrier \<beta>; x \<in> carrier \<alpha>; y \<in> carrier \<beta>; \<pi>\<^sub>* y \<in> carrier \<alpha>; x \<sqsubseteq>\<^bsub>\<alpha>\<^esub> \<pi>\<^sub>* y\<rbrakk> \<Longrightarrow> \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<beta>\<^esub> y"
    by (metis galois_property)

  lemma deflation: "y \<in> carrier \<beta> \<Longrightarrow> \<pi>\<^sup>* (\<pi>\<^sub>* y) \<sqsubseteq>\<^bsub>\<beta>\<^esub> y"
    by (metis typed_application is_order_A left lower_closure order.order_refl upper_closure)

  lemma inflation: "x \<in> carrier \<alpha> \<Longrightarrow> x \<sqsubseteq>\<^bsub>\<alpha>\<^esub> \<pi>\<^sub>* (\<pi>\<^sup>* x)"
    by (metis typed_application is_order_B lower_closure order.eq_refl right upper_closure)

  lemma lower_iso: "isotone \<alpha> \<beta> \<pi>\<^sup>*"
    by (smt typed_application inflation is_order_A is_order_B isotone_def left lower_closure order.order_trans upper_closure)

  lemma upper_iso: "isotone \<beta> \<alpha> \<pi>\<^sub>*"
    by (smt typed_application deflation is_order_A is_order_B isotone_def right lower_closure order.order_trans upper_closure)

  lemma lower_comp: "x \<in> carrier \<alpha> \<Longrightarrow> (\<pi>\<^sup>* \<circ> \<pi>\<^sub>* \<circ> \<pi>\<^sup>*) x = \<pi>\<^sup>* x"
    by (smt order.order_antisym typed_application deflation inflation isotone_def lower_closure lower_iso o_apply upper_closure)

  lemma upper_comp: "y \<in> carrier \<beta> \<Longrightarrow> (\<pi>\<^sub>* \<circ> \<pi>\<^sup>* \<circ> \<pi>\<^sub>*) y = \<pi>\<^sub>* y"
    by (smt order.order_antisym typed_application deflation is_order_A lower_closure lower_comp o_def right upper_closure)

  lemma adjoint_idem1: "idempotent (carrier \<beta>) (\<pi>\<^sup>* \<circ> \<pi>\<^sub>*)"
    by (smt idempotent_def o_apply o_assoc upper_comp)

  lemma adjoint_idem2: "idempotent (carrier \<alpha>) (\<pi>\<^sub>* \<circ> \<pi>\<^sup>*)"
    by (smt idempotent_def o_apply o_assoc lower_comp)

end

lemma fg_iso: "galois_connection A B f g \<Longrightarrow> isotone B B (f \<circ> g)"
  apply (simp add: isotone_def)
  by (metis (full_types) typed_application galois_connection.lower_iso galois_connection.upper_closure galois_connection.upper_iso isotone_def)

lemma gf_iso: "galois_connection A B f g \<Longrightarrow> isotone A A (g \<circ> f)"
  apply (simp add: isotone_def)
  by (metis (full_types) typed_application galois_connection.lower_closure galois_connection.lower_iso galois_connection.upper_iso isotone_def)

lemma galois_dual [simp]: "galois_connection (B\<sharp>) (A\<sharp>) g f = galois_connection A B f g"
  by (simp add: galois_connection_def, auto)

definition lower_adjoint :: "('a, 'c) ord_scheme \<Rightarrow> ('b, 'd) ord_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "lower_adjoint A B f \<equiv> \<exists>g. galois_connection A B f g"

definition upper_adjoint :: "('a, 'c) ord_scheme \<Rightarrow> ('b, 'd) ord_scheme \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "upper_adjoint A B g \<equiv> \<exists>f. galois_connection A B f g"

lemma lower_adjoint_dual [simp]: "lower_adjoint (A\<sharp>) (B\<sharp>) f = upper_adjoint B A f"
  by (simp add: lower_adjoint_def upper_adjoint_def)

lemma upper_adjoint_dual [simp]: "upper_adjoint (A\<sharp>) (B\<sharp>) f = lower_adjoint B A f"
  by (simp add: lower_adjoint_def upper_adjoint_def)

lemma lower_type: "lower_adjoint A B f \<Longrightarrow> f \<in> carrier A \<rightarrow> carrier B"
  by (metis galois_connection.lower_closure lower_adjoint_def)

lemma upper_type: "upper_adjoint A B g \<Longrightarrow> g \<in> carrier B \<rightarrow> carrier A"
  by (metis galois_connection.upper_closure upper_adjoint_def)

lemma id_galois: "order A \<Longrightarrow> galois_connection A A id id"
  by (unfold galois_connection_def, metis id_apply id_type)

lemma semi_inverse1: "\<lbrakk>x \<in> carrier A; galois_connection A B f g\<rbrakk> \<Longrightarrow> f x = f (g (f x))"
  by (metis galois_connection.lower_comp o_apply)

lemma semi_inverse2: "\<lbrakk>x \<in> carrier B; galois_connection A B f g\<rbrakk> \<Longrightarrow> g x = g (f (g x))"
  by (metis galois_connection.upper_comp o_def)

lemma galois_ump1: "galois_connection A B f g = (f \<in> carrier A \<rightarrow> carrier B \<and> g \<in> carrier B \<rightarrow> carrier A
                                                \<and> isotone A B f \<and> (\<forall>y\<in>carrier B. f (g y) \<sqsubseteq>\<^bsub>B\<^esub> y)
                                                \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier B. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<longrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> g y))"
proof
  assume "galois_connection A B f g"
  thus "f \<in> carrier A \<rightarrow> carrier B \<and> g \<in> carrier B \<rightarrow> carrier A \<and> isotone A B f
        \<and> (\<forall>y\<in>carrier B. f (g y) \<sqsubseteq>\<^bsub>B\<^esub> y) \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier B. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<longrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> g y)"
    by (smt typed_application galois_connection.deflation galois_connection.galois_property galois_connection.lower_closure galois_connection.lower_iso galois_connection.upper_closure)
next
  assume "f \<in> carrier A \<rightarrow> carrier B \<and> g \<in> carrier B \<rightarrow> carrier A \<and> isotone A B f
          \<and> (\<forall>y\<in>carrier B. f (g y) \<sqsubseteq>\<^bsub>B\<^esub> y) \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier B. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<longrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> g y)"
  thus "galois_connection A B f g"
    by (unfold galois_connection_def, safe, (smt typed_application isotone_def order.order_trans)+)
qed

lemma galois_ump2: "galois_connection A B f g = (f \<in> carrier A \<rightarrow> carrier B \<and> g \<in> carrier B \<rightarrow> carrier A
                                                \<and> isotone B A g \<and> (\<forall>x\<in>carrier A. x \<sqsubseteq>\<^bsub>A\<^esub> g (f x))
                                                \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier B. x \<sqsubseteq>\<^bsub>A\<^esub> g y \<longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> y))"
proof -
  have dual: "galois_connection (B\<sharp>) (A\<sharp>) g f = (g \<in> carrier (B\<sharp>) \<rightarrow> carrier (A\<sharp>) \<and> f \<in> carrier (A\<sharp>) \<rightarrow> carrier (B\<sharp>)
                                                \<and> isotone (B\<sharp>) (A\<sharp>) g \<and> (\<forall>y\<in>carrier (A\<sharp>). g (f y) \<sqsubseteq>\<^bsub>(A\<sharp>)\<^esub> y)
                                                \<and> (\<forall>x\<in>carrier (B\<sharp>). \<forall>y\<in>carrier (A\<sharp>). g x \<sqsubseteq>\<^bsub>(A\<sharp>)\<^esub> y \<longrightarrow> x \<sqsubseteq>\<^bsub>(B\<sharp>)\<^esub> f y))"
    by (metis (no_types) galois_ump1)
  thus ?thesis by (simp, auto)
qed

(* +------------------------------------------------------------------------+
   | Theorem 4.10(a)                                                        |
   +------------------------------------------------------------------------+ *)

lemma ore_galois:
  assumes fclosed: "f \<in> carrier A \<rightarrow> carrier B" and gclosed: "g \<in> carrier B \<rightarrow> carrier A"
  and a: "\<forall>x\<in>carrier A. x \<sqsubseteq>\<^bsub>A\<^esub> g (f x)" and b: "\<forall>y\<in>carrier B. f (g y) \<sqsubseteq>\<^bsub>B\<^esub> y"
  and c: "isotone A B f" and d: "isotone B A g"
  shows "galois_connection A B f g"
  by (unfold galois_connection_def, safe, (smt typed_application a b c d gclosed fclosed isotone_def order.order_trans)+)

(* +------------------------------------------------------------------------+
   | Theorems 4.20(a) and 4.20(b)                                           |
   +------------------------------------------------------------------------+ *)

(*
lemma perfect1: "\<lbrakk>galois_connection A B f g; x \<in> carrier A\<rbrakk> \<Longrightarrow> g (f x) = x \<longleftrightarrow> x \<in> range g"
  sledgehammer [timeout = 300]
  by (smt ftype_pred galois_connection.upper_closure image_iff range_eqI semi_inverse2)

lemma perfect2: "\<lbrakk>galois_connection A B f g; x \<in> carrier B\<rbrakk> \<Longrightarrow> f (g x) = x \<longleftrightarrow> x \<in> range f"
  by (metis galois_dual inv_carrier_id perfect1)
*)

(* +------------------------------------------------------------------------+
   | Theorems 4.20(a) and 4.20(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma galois_max:
  assumes conn: "galois_connection A B f g" and yc: "y \<in> carrier B"
  shows "order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
proof -
  have "order A" by (metis conn galois_connection.is_order_A)
  thus ?thesis
    apply (simp add: order.is_max_def order.is_lub_def order.is_ub_def)
    apply safe
    apply (metis conn galois_connection.deflation yc)
    apply (metis conn ftype_pred galois_ump1 yc)
    by (metis conn galois_ump1 yc)
qed

lemma galois_min:
  assumes conn: "galois_connection A B f g" and xc: "x \<in> carrier A"
  shows "order.is_min B (f x) {y. x \<sqsubseteq>\<^bsub>A \<^esub>g y \<and> y \<in> carrier B}"
proof -
  have dual: "\<And>z. \<lbrakk>galois_connection (B\<sharp>) (A\<sharp>) g f; z \<in> carrier (A\<sharp>)\<rbrakk>
              \<Longrightarrow> order.is_max (B\<sharp>) (f z) {y. g y \<sqsubseteq>\<^bsub>(A\<sharp>)\<^esub> z \<and> y \<in> carrier (B\<sharp>)}"
    by (rule galois_max, auto)
  moreover have "order B" by (metis conn galois_connection.is_order_B)
  ultimately show ?thesis
    by (smt Collect_cong conn dual_is_max galois_dual inv_carrier_id inv_flip xc)
qed

theorem max_galois: "galois_connection A B f g = (isotone A B f \<and> (\<forall>y\<in>carrier B. order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}) \<and> g \<in> carrier B \<rightarrow> carrier A \<and> f \<in> carrier A \<rightarrow> carrier B)"
proof
  assume conn: "galois_connection A B f g"
  have "isotone A B f" by (metis conn galois_connection.lower_iso)
  moreover have "\<forall>y\<in>carrier B. order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
    using galois_max conn by fast
  ultimately show "isotone A B f \<and> (\<forall>y\<in>carrier B. order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}) \<and> g \<in> carrier B \<rightarrow> carrier A \<and> f \<in> carrier A \<rightarrow> carrier B"
    by (metis (lifting) conn galois_connection.lower_closure galois_connection.upper_closure)
next
  assume "isotone A B f \<and> (\<forall>y\<in>carrier B. order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}) \<and> g \<in> carrier B \<rightarrow> carrier A \<and> f \<in> carrier A \<rightarrow> carrier B"
  hence f_iso: "isotone A B f"
    and max: "\<forall>y\<in>carrier B. order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
    and g_closed: "g \<in> carrier B \<rightarrow> carrier A"
    and f_closed: "f \<in> carrier A \<rightarrow> carrier B"
    by fast+
  show "galois_connection A B f g"
  proof (simp add: galois_ump1, safe, (smt g_closed f_closed)+)
    show "isotone A B f" by (metis f_iso)
  next
    fix y assume yc: "y \<in> carrier B"
    have "order A" and "order B" by (metis f_iso isotone_def)+
    hence "g y \<in> {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
      using max yc by (simp add: order.is_max_def)
    thus "f (g y) \<sqsubseteq>\<^bsub>B\<^esub> y" by (metis mem_Collect_eq)
  next
    fix x y assume xc: "x \<in> carrier A" and yc: "y \<in> carrier B" and lower: "f x \<sqsubseteq>\<^bsub>B\<^esub> y"
    have oa: "order A" and ob: "order B" by (metis f_iso isotone_def)+
    hence lub1: "order.is_lub A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
      using max yc by (metis (mono_tags) Collect_mem_eq Collect_mono order.is_max_equiv)
    thus "x \<sqsubseteq>\<^bsub>A\<^esub> g y" using oa by (simp add: order.is_lub_def order.is_ub_def, metis lower xc)
  qed
qed

(* +------------------------------------------------------------------------+
   | Lemma 4.24(a) and 4.24(b)                                              |
   +------------------------------------------------------------------------+ *)

lemma set_image_type: "\<lbrakk>X \<subseteq> A; f \<in> A \<rightarrow> B\<rbrakk> \<Longrightarrow> f ` X \<subseteq> B"
  by (metis typed_application image_subsetI set_rev_mp)

lemma lower_ub:
  assumes Xc: "X \<subseteq> carrier A" and xc: "x \<in> carrier A"
  and lub: "order.is_lub A x X" and lower: "lower_adjoint A B f"
  shows "order.is_ub B (f x) (f ` X)"
proof -
  have fxc: "f x \<in> carrier B"
    by (metis lower lower_type typed_application xc)

  have fXc: "f ` X \<subseteq> carrier B"
    by (metis Xc lower lower_type set_image_type)

  have ord_B: "order B" and ord_A: "order A"
    by (metis galois_connection.is_order_B galois_connection.is_order_A lower lower_adjoint_def)+

  hence "\<forall>y\<in>X. y \<sqsubseteq>\<^bsub>A\<^esub> x" using lub
    by (simp add: order.is_lub_simp)

  hence "\<forall>y\<in>X. f y \<sqsubseteq>\<^bsub>B\<^esub> f x"
    apply (clarify, rule_tac ?A = A in use_iso2, simp_all add: xc)
    by (metis galois_connection.lower_iso lower lower_adjoint_def, metis Xc set_mp)

  thus ?thesis using ord_A ord_B
    by (simp add: order.is_ub_def, intro conjI, simp_all add: fxc fXc)
qed

lemma lower_lub:
  assumes Xc: "X\<subseteq>carrier A" and xc: "x \<in> carrier A"
  and il: "order.is_lub A x X" and la: "lower_adjoint A B f"
  shows "order.is_lub B (f x) (f ` X)"
proof -
  have ord_B: "order B" and ord_A: "order A"
    by (metis galois_connection.is_order_B galois_connection.is_order_A la lower_adjoint_def)+
  thus ?thesis apply (simp add: order.is_lub_def)
  proof
    show "order.is_ub B (f x) (f ` X)"
      by (metis Xc il la lower_ub xc)

    obtain g where gc: "galois_connection A B f g"
      by (metis la lower_adjoint_def)

    thus "\<forall>y\<in>carrier B. (\<forall>z\<in>X. f z \<sqsubseteq>\<^bsub>B\<^esub> y) \<longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> y"
      by (smt typed_application Xc galois_ump1 gc galois_connection_def set_rev_mp xc il ord_A order.is_lub_def)
  qed
qed

lemma upper_glb:
  assumes Xc: "X\<subseteq>carrier B" and xc: "x \<in> carrier B"
  and il: "order.is_glb B x X" and la: "upper_adjoint A B g"
  shows "order.is_glb A (g x) (g ` X)"
proof -
  have ord_Bsh: "order (B\<sharp>)"
    by (metis galois_connection.is_order_B la ord_is_inv upper_adjoint_def)

  have ord_Ash: "order (A\<sharp>)"
    by (metis galois_connection.is_order_A la ord_is_inv upper_adjoint_def)

  have "order.is_lub (A\<sharp>) (g x) (g ` X)"
    apply (rule_tac ?A = "B\<sharp>" in lower_lub, simp_all add: Xc xc)
    using ord_Bsh ord_Ash by (simp_all add: il la)

  thus ?thesis using ord_Ash by simp
qed

lemma lower_preserves_ex_joins:
  assumes lower: "lower_adjoint A B f" shows "ex_join_preserving A B f"
proof (simp add: ex_join_preserving_def, safe)
  show "order A" and "order B"
    by (metis assms galois_connection.is_order_A galois_connection.is_order_B lower_adjoint_def)+
next
  fix X x assume Xc: "X \<subseteq> carrier A" and xc: "x \<in> carrier A" and il: "order.is_lub A x X"
  have "order B"
    by (metis assms galois_connection.is_order_B lower_adjoint_def)
  thus "order.lub B (f ` X) = f (order.lub A X)"
    by (metis order.lub_is_lub Xc assms galois_connection.is_order_A il lower_adjoint_def lower_lub xc)
qed

lemma upper_preserves_ex_meets:
  assumes upper: "upper_adjoint A B g" shows "ex_meet_preserving B A g"
proof -
  have "ex_join_preserving (B\<sharp>) (A\<sharp>) g"
    by (rule lower_preserves_ex_joins, simp add: upper)

  thus ?thesis by simp
qed

(* +------------------------------------------------------------------------+
   | Galois Connections for Complete Lattices                               |
   +------------------------------------------------------------------------+ *)

locale complete_lattice_connection = galois_connection +
  assumes is_cl_A: "complete_lattice \<alpha>"
  and is_cl_B: "complete_lattice \<beta>"

definition cl_lower_adjoint :: "('a, 'c) ord_scheme \<Rightarrow> ('b, 'd) ord_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "cl_lower_adjoint A B f \<equiv> \<exists>g. complete_lattice_connection A B f g"

definition cl_upper_adjoint :: "('a, 'c) ord_scheme \<Rightarrow> ('b, 'd) ord_scheme \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "cl_upper_adjoint A B g \<equiv> \<exists>f. complete_lattice_connection A B f g"

lemma cl_conn_dual [simp]: "complete_lattice_connection (B\<sharp>) (A\<sharp>) g f = complete_lattice_connection A B f g"
  by (simp add: complete_lattice_connection_def complete_lattice_connection_axioms_def, auto)

lemma cl_lower_dual [simp]: "cl_lower_adjoint (B\<sharp>) (A\<sharp>) f = cl_upper_adjoint A B f"
  by (simp add: cl_lower_adjoint_def cl_upper_adjoint_def)

lemma cl_upper_dual [simp]: "cl_upper_adjoint (B\<sharp>) (A\<sharp>) f = cl_lower_adjoint A B f"
  by (simp add: cl_lower_adjoint_def cl_upper_adjoint_def)

lemma cl_to_galois: "complete_lattice_connection A B f g \<Longrightarrow> galois_connection A B f g"
  by (simp add: complete_lattice_connection_def)

lemma cl_is_order: "complete_lattice A \<Longrightarrow> order A"
  by (simp add: complete_lattice_def complete_join_semilattice_def)

lemma z: "\<exists>z\<in>A. P(z) \<Longrightarrow> \<exists>z. P(z)" by auto

lemma suprema_galois_left:
  assumes cl_A: "complete_lattice A" and cl_B: "complete_lattice B"
  and ft: "f \<in> carrier A \<rightarrow> carrier B" and gt: "g \<in> carrier B \<rightarrow> carrier A"
  and ejp: "ex_join_preserving A B f"
  and lub_prop: "\<forall>y\<in>carrier B. order.is_lub A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
  shows "complete_lattice_connection A B f g"
proof -
  have oa: "order A" and ob: "order B"
    by (metis cl_A cl_B cl_to_order)+

  have left: "\<forall>x\<in>carrier A. \<forall>y\<in>carrier B. (f x \<sqsubseteq>\<^bsub>B\<^esub> y) \<longrightarrow> (x \<sqsubseteq>\<^bsub>A\<^esub> g y)"
  proof safe
    fix x y assume xc: "x \<in> carrier A" and yc: "y \<in> carrier B" and a: "f x \<sqsubseteq>\<^bsub>B\<^esub> y"
    hence "order.is_lub A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
      by (metis (full_types) lub_prop)
    thus "x \<sqsubseteq>\<^bsub>A\<^esub> g y" using oa
      apply (simp add: order.is_lub_def order.is_ub_def)
      by (metis a xc)
  qed

  have right: "\<forall>x\<in>carrier A. \<forall>y\<in>carrier B. (x \<sqsubseteq>\<^bsub>A\<^esub> g y) \<longrightarrow> (f x \<sqsubseteq>\<^bsub>B\<^esub> y)"
  proof safe
    fix x y assume xc: "x \<in> carrier A" and yc: "y \<in> carrier B" and a: "x \<sqsubseteq>\<^bsub>A\<^esub> g y"

    have lem: "\<Sigma>\<^bsub>B\<^esub>(f ` {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}) \<sqsubseteq>\<^bsub>B\<^esub> y"
      apply (rule order.the_lub_leq)
      apply (metis cl_B cl_to_order)
      apply (rule_tac ?A = "carrier B" in z)
      apply (rule complete_join_semilattice.lub_ex)
      apply (metis cl_B cl_to_cjs)
      apply (rule_tac ?A = "carrier A" in set_image_type)
      apply (metis (no_types) lub_prop order.is_lub_simp cl_A cl_to_order yc)
      apply (metis ft)
      using ob apply (simp add: order.is_lub_simp)
      apply safe
      by (metis yc)

    have "f x \<sqsubseteq>\<^bsub>B\<^esub> y \<Longrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> \<Sigma>\<^bsub>A\<^esub>{z. f z \<sqsubseteq>\<^bsub>B\<^esub> y \<and> z \<in> carrier A}"
      by (metis (full_types) a lub_prop oa order.lub_is_lub yc)
    moreover have "x \<sqsubseteq>\<^bsub>A\<^esub> \<Sigma>\<^bsub>A\<^esub>{z. f z \<sqsubseteq>\<^bsub>B\<^esub> y \<and> z \<in> carrier A} \<Longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> f (\<Sigma>\<^bsub>A\<^esub>{z. f z \<sqsubseteq>\<^bsub>B\<^esub> y \<and> z \<in> carrier A})"
      apply (rule_tac f = f and A = A in use_iso2)
      apply (rule ex_join_preserving_is_iso)
      apply (metis ft)
      apply (metis cl_A cl_to_js)
      apply (metis cl_B cl_to_js)
      apply (metis ejp)
      apply (metis xc)
      apply (metis (lifting) ftype_pred gt lub_prop oa order.lub_is_lub yc)
      by (metis)
    moreover have "(f x \<sqsubseteq>\<^bsub>B\<^esub> f (\<Sigma>\<^bsub>A\<^esub>{z. f z \<sqsubseteq>\<^bsub>B\<^esub> y \<and> z \<in> carrier A})) = (f x \<sqsubseteq>\<^bsub>B\<^esub> \<Sigma>\<^bsub>B\<^esub>(f ` {z. f z \<sqsubseteq>\<^bsub>B\<^esub> y \<and> z \<in> carrier A}))"
      by (smt Collect_cong ejp ex_join_preserving_def lub_prop order.is_lub_simp yc)
    moreover have "... \<Longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> y" using lem (* Should just be trans !?! *)
      by (smt Collect_cong ejp ex_join_preserving_def ft ftype_pred lub_prop order.is_lub_simp order.lub_is_lub order.order_trans xc yc)
    ultimately show "f x \<sqsubseteq>\<^bsub>B\<^esub> y"
      by (metis (full_types) a lub_prop oa order.lub_is_lub yc)
  qed

  have "galois_connection A B f g" unfolding galois_connection_def
    apply safe
    apply (metis oa)
    apply (metis cl_B cl_to_order)
    apply (metis ft)
    apply (metis gt)
    apply (metis left)
    by (metis right)
  thus ?thesis unfolding complete_lattice_connection_def complete_lattice_connection_axioms_def
    by (metis cl_A cl_B)
qed

(*
lemma suprema_galois_right:
  assumes conn: "complete_lattice_connection A B f g"
  shows "complete_lattice A" and "complete_lattice B"
  and "f \<in> carrier A \<rightarrow> carrier B" and "g \<in> carrier B \<rightarrow> carrier A"
  and "ex_join_preserving A B f"
  and "\<forall>y\<in>carrier B. order.is_lub A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
  apply safe
  apply (metis assms complete_lattice_connection.is_cl_A)
  apply (metis assms complete_lattice_connection.is_cl_B)
  apply (metis assms cl_to_galois galois_connection.lower_closure)
  apply (metis assms cl_to_galois galois_connection.upper_closure)

  apply (metis assms cl_to_galois lower_adjoint_def lower_preserves_ex_joins)
proof -
  fix y assume yc: "y \<in> carrier B"
  have ord_A: "order A"
    by (metis assms cl_to_order complete_lattice_connection.is_cl_A)
  have "galois_connection A B f g"
    by (metis (lifting) assms cl_to_galois)
  hence "order.is_max A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}"
    by (smt Collect_cong galois_max yc)
  thus "order.is_lub A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub>y \<and> x \<in> carrier A}"
    using ord_A by (simp add: order.is_max_def)
qed

lemma suprema_galois:
  "complete_lattice_connection A B f g = (complete_lattice A \<and> complete_lattice B
                                         \<and> f \<in> carrier A \<rightarrow> carrier B \<and> g \<in> carrier B \<rightarrow> carrier A
                                         \<and> ex_join_preserving A B f
                                         \<and> (\<forall>y\<in>carrier B. order.is_lub A (g y) {x. f x \<sqsubseteq>\<^bsub>B\<^esub> y \<and> x \<in> carrier A}))"
  by (smt Collect_cong suprema_galois_left suprema_galois_right(1) suprema_galois_right(2) suprema_galois_right(3) suprema_galois_right(4) suprema_galois_right(5) suprema_galois_right(6))
*)

lemma infima_galois_left:
  assumes cl_A: "complete_lattice A" and cl_B: "complete_lattice B"
  and ft: "f \<in> carrier A \<rightarrow> carrier B" and gt: "g \<in> carrier B \<rightarrow> carrier A"
  and emp: "ex_meet_preserving B A g"
  and lub_prop: "\<forall>y\<in>carrier A. order.is_glb B (f y) {x. y \<sqsubseteq>\<^bsub>A \<^esub>g x \<and> x \<in> carrier B}"
  shows "complete_lattice_connection A B f g"
proof -
  have "complete_lattice_connection (B\<sharp>) (A\<sharp>) g f"
  proof (rule suprema_galois_left, simp_all)
    show "complete_lattice B" by (metis cl_B)
    show "complete_lattice A" by (metis cl_A)
    show "g \<in> carrier B \<rightarrow> carrier A" by (metis gt)
    show "f \<in> carrier A \<rightarrow> carrier B" by (metis ft)
    show "ex_meet_preserving B A g" by (metis emp)
    show "\<forall>y\<in>carrier A. order.is_lub (B\<sharp>) (f y) {x. y \<sqsubseteq>\<^bsub>A \<^esub>g x \<and> x \<in> carrier B}"
      by (metis (lifting) dual_is_lub lub_prop cl_B cl_to_order)
  qed

  thus ?thesis by simp
qed

(*
lemma infima_galois_right:
  assumes conn: "complete_lattice_connection A B f g"
  shows"\<forall>y\<in>carrier A. order.is_glb B (f y) {x. y \<sqsubseteq>\<^bsub>A \<^esub>g x \<and> x \<in> carrier B}"
  sorry
  (* by (smt Collect_cong assms cl_conn_dual cl_to_galois dual_is_lub galois_connection.is_order_B inv_carrier_id inv_flip suprema_galois_right(6)) *)

(*
lemma infima_galois:
  "complete_lattice_connection A B f g = (complete_lattice A \<and> complete_lattice B
                                         \<and> f \<in> carrier A \<rightarrow> carrier B \<and> g \<in> carrier B \<rightarrow> carrier A
                                         \<and> ex_meet_preserving B A g
                                         \<and> (\<forall>y\<in>carrier A. order.is_glb B (f y) {x. y \<sqsubseteq>\<^bsub>A \<^esub>g x \<and> x \<in> carrier B}))"
  apply default
  apply safe
  apply (metis complete_lattice_connection.is_cl_A)
  apply (metis complete_lattice_connection.is_cl_B)
  apply (metis cl_to_galois galois_ump2)
  apply (metis cl_to_galois galois_ump2)
  apply (metis cl_conn_dual dual_ex_join_preserving suprema_galois_right(5))
  apply (simp add: infima_galois_right)
  by (simp add: infima_galois_left)
*)
*)

lemma cl_lower_join_preserving:
  assumes lower: "cl_lower_adjoint A B f" shows "join_preserving A B f"
proof -
  have "lower_adjoint A B f"
    by (metis assms cl_lower_adjoint_def cl_to_galois lower_adjoint_def)
  hence ejp: "ex_join_preserving A B f"
    by (metis lower_preserves_ex_joins)
  have "complete_lattice A"
    by (metis assms cl_lower_adjoint_def complete_lattice_connection.is_cl_A)
  hence "\<forall>X\<subseteq>carrier A. \<exists>x\<in>carrier A. order.is_lub A x X"
    by (simp add: complete_lattice_def complete_join_semilattice_def complete_join_semilattice_axioms_def)
  hence "\<forall>X\<subseteq>carrier A. order.lub B (f ` X) = f (order.lub A X)"
    by (metis ex_join_preserving_def ejp)
  thus ?thesis
    by (metis ejp ex_join_preserving_def join_preserving_def)
qed

lemma cl_upper_meet_preserving: "cl_upper_adjoint A B g \<Longrightarrow> meet_preserving B A g"
  by (metis cl_lower_dual cl_lower_join_preserving dual_join_preserving)

(* +------------------------------------------------------------------------+
   | Fixpoints and Galois connections                                       |
   +------------------------------------------------------------------------+ *)

lemma truncate_simp [simp]: "ord.truncate A = A"
  by (simp add: ord.truncate_def)

lemma least_fixpoint_closed:
  assumes cl: "complete_lattice A"
  and f_type: "f \<in> carrier A \<rightarrow> carrier A"
  and f_iso: "isotone A A f"
  shows "\<mu>\<^bsub>A\<^esub>f \<in> carrier A"
proof -
  have "\<exists>!x. is_lfp A x f" using cl f_type f_iso by (rule knaster_tarski)
  thus ?thesis by (metis least_fixpoint_set)
qed

lemma greatest_fixpoint_closed:
  assumes cl: "complete_lattice A"
  and f_type: "f \<in> carrier A \<rightarrow> carrier A"
  and f_iso: "isotone A A f"
  shows "\<mu>\<^bsub>A\<^esub>f \<in> carrier A"
  by (metis cl f_iso f_type least_fixpoint_closed)

lemma fixpoint_rolling: assumes conn: "complete_lattice_connection A B f g"
  shows "f (\<mu>\<^bsub>A\<^esub> (g \<circ> f)) = \<mu>\<^bsub>B\<^esub> (f \<circ> g)"
proof (rule lfp_equality_var)
  show "order B"
    by (metis assms cl_to_order complete_lattice_connection.is_cl_B)

  have cl_A: "complete_lattice A"
    by (metis assms complete_lattice_connection.is_cl_A)

  have cl_B: "complete_lattice B"
    by (metis assms complete_lattice_connection.is_cl_B)

  show closure1: "f \<circ> g \<in> carrier B \<rightarrow> carrier B"
    by (metis assms cl_to_galois typed_composition galois_connection.lower_closure galois_connection.upper_closure)

  have closure2: "g \<circ> f \<in> carrier A \<rightarrow> carrier A"
    by (metis assms cl_to_galois typed_composition galois_connection.lower_closure galois_connection.upper_closure)

  have closure3: "\<mu>\<^bsub>A \<^esub>(g \<circ> f) \<in> carrier A" using cl_A closure2
    by (rule least_fixpoint_closed, metis assms cl_to_galois gf_iso)

  thus closure4: "(f (\<mu>\<^bsub>A \<^esub>(g \<circ> f))) \<in> carrier B"
    by (metis assms cl_to_galois typed_application galois_connection.lower_closure)

  have "f (g (f (\<mu>\<^bsub>A\<^esub>(g \<circ> f)))) = f (\<mu>\<^bsub>A\<^esub>(g \<circ> f))"
    by (rule_tac f = f and A = A and B = B in semi_inverse1[symmetric], metis closure3, metis conn cl_to_galois)

  thus "(f \<circ> g) (f (\<mu>\<^bsub>A\<^esub>(g \<circ> f))) = f (\<mu>\<^bsub>A\<^esub>(g \<circ> f))"
    by (metis o_def)

  show "\<forall>y\<in>carrier B. (f \<circ> g) y = y \<longrightarrow> f (\<mu>\<^bsub>A\<^esub>(g \<circ> f)) \<sqsubseteq>\<^bsub>B\<^esub> y"
  proof safe
    fix y assume yc: "y \<in> carrier B" and fgy: "(f \<circ> g) y = y"
    have "complete_lattice A" by (metis cl_A)
    hence "\<mu>\<^bsub>A\<^esub>(g \<circ> f) \<sqsubseteq>\<^bsub>A\<^esub> g y"
      apply (rule fixpoint_induction)
      apply (metis closure2)
      apply (metis assms cl_to_galois typed_application upper_adjoint_def upper_type yc)
      apply (metis assms cl_to_galois gf_iso)
      by (metis assms cl_A cl_to_galois cl_to_order typed_application fgy galois_ump1 o_def order.eq_refl yc)
    thus "f (\<mu>\<^bsub>A\<^esub>(g \<circ> f)) \<sqsubseteq>\<^bsub>B\<^esub> y"
      by (metis assms cl_to_galois closure3 galois_ump2 yc)
  qed
qed

lemma greatest_fixpoint_rolling: assumes conn: "complete_lattice_connection A B f g"
  shows "g (\<nu>\<^bsub>B\<^esub> (f \<circ> g)) = \<nu>\<^bsub>A\<^esub> (g \<circ> f)"
proof -
  have "complete_lattice_connection (B\<sharp>) (A\<sharp>) g f \<Longrightarrow> g (\<mu>\<^bsub>(B\<sharp>)\<^esub>(f \<circ> g)) = \<mu>\<^bsub>(A\<sharp>)\<^esub>(g \<circ> f)"
    by (rule fixpoint_rolling, auto)
  thus ?thesis by (simp, metis conn)
qed

(* +------------------------------------------------------------------------+ *)
subsection {* Fixpoint fusion *}
(* +------------------------------------------------------------------------+ *)

theorem fixpoint_fusion [simp]:
  assumes upper_ex: "cl_lower_adjoint A B f"
  and ft: "f \<in> carrier A \<rightarrow> carrier B" and ht: "h \<in> carrier A \<rightarrow> carrier A" and kt: "k \<in> carrier B \<rightarrow> carrier B"
  and hiso: "isotone A A h" and kiso: "isotone B B k"
  and comm: "f\<circ>h = k\<circ>f"
  shows "f (\<mu>\<^bsub>A\<^esub> h) = \<mu>\<^bsub>B\<^esub> k"
proof (rule lfp_equality_var)
  obtain g where conn: "complete_lattice_connection A B f g"
    by (metis cl_lower_adjoint_def upper_ex)

  show "order B" by (metis isotone_def kiso)

  have cl_A: "complete_lattice A"
    by (metis cl_lower_adjoint_def complete_lattice_connection.is_cl_A upper_ex)

  have cl_B: "complete_lattice B"
    by (metis cl_lower_adjoint_def complete_lattice_connection.is_cl_B upper_ex)

  show "k \<in> carrier B \<rightarrow> carrier B" by (metis kt)

  have closure1: "\<mu>\<^bsub>A\<^esub>h \<in> carrier A" using cl_A ht hiso
    by (rule least_fixpoint_closed)

  thus closure2: "f (\<mu>\<^bsub>A\<^esub>h) \<in> carrier B"
    by (metis typed_application ft)

  have comm_var: "\<And>x. k (f x) = f (h x)"
    by (metis comm o_apply)

  show "k (f (\<mu>\<^bsub>A\<^esub>h)) = f (\<mu>\<^bsub>A\<^esub>h)"
    by (metis cl_A comm_var fixpoint_computation hiso ht)

  show "\<forall>y\<in>carrier B. k y = y \<longrightarrow> f (\<mu>\<^bsub>A\<^esub>h) \<sqsubseteq>\<^bsub>B\<^esub> y"
  proof clarify
    fix y assume yc: "y \<in> carrier B" and ky: "k y = y"

    have gy: "g y \<in> carrier A"
      by (metis cl_to_galois typed_application conn galois_ump2 yc)
    hence hgy: "h (g y) \<in> carrier A"
      by (metis typed_application ht)
    hence fhgy: "f (h (g y)) \<in> carrier B"
      by (metis typed_application ft)

    have "\<mu>\<^bsub>A\<^esub> h \<sqsubseteq>\<^bsub>A\<^esub> g y" using cl_A ht gy hiso
    proof (rule fixpoint_induction)
      have "f (g y) \<sqsubseteq>\<^bsub>B\<^esub> y"
        by (metis cl_to_galois conn galois_connection.deflation yc)
      hence "k (f (g y)) \<sqsubseteq>\<^bsub>B\<^esub> k y"
        by (metis typed_application ft gy kiso use_iso1 yc)
      hence "f (h (g y)) \<sqsubseteq>\<^bsub>B\<^esub> y"
        by (simp only: comm_var[symmetric] ky)
      thus "h (g y) \<sqsubseteq>\<^bsub>A\<^esub> g y" using gy hgy fhgy yc
        by (rule_tac lower = f and orderB = B in galois_connection.right, metis cl_to_galois conn, auto+)
    qed
    thus "f (\<mu>\<^bsub>A\<^esub> h) \<sqsubseteq>\<^bsub>B\<^esub> y"
      by (metis closure1 closure2 cl_to_galois conn galois_connection.left gy yc)
  qed
qed

theorem greatest_fixpoint_fusion [simp]:
  assumes lower_ex: "cl_upper_adjoint A B g"
  and ft: "f \<in> carrier A \<rightarrow> carrier B" and ht: "h \<in> carrier B \<rightarrow> carrier B" and kt: "k \<in> carrier A \<rightarrow> carrier A"
  and hiso: "isotone B B h" and kiso: "isotone A A k"
  and comm: "g\<circ>h = k\<circ>g"
  shows "g (\<nu>\<^bsub>B\<^esub> h) = \<nu>\<^bsub>A\<^esub> k"
proof -
  have gt: "g \<in> carrier B \<rightarrow> carrier A"
    by (metis cl_to_galois cl_upper_adjoint_def galois_ump2 lower_ex)
  have "g (\<mu>\<^bsub>B\<sharp>\<^esub>h) = \<mu>\<^bsub>A\<sharp>\<^esub>k"
    by (rule fixpoint_fusion, simp_all add: lower_ex ft ht kt gt hiso kiso comm)
  thus ?thesis by simp
qed

end


theory FW_Code
  imports
    Recursion_Combinators
    Floyd_Warshall
begin

section \<open>Refinement to Efficient Imperative Code\<close>

text \<open>
  We will now refine the recursive version of the \fw to an efficient imperative version.
  To this end, we use the Sepref framework, yielding an implementation in Imperative HOL.
\<close>

definition fw_upd' :: "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nres" where
  "fw_upd' m k i j =
  RETURN (
    op_mtx_set m (i, j) (min (op_mtx_get m (i, j)) (op_mtx_get m (i, k) + op_mtx_get m (k, j)))
  )"

lemma fw_upd'_alt_def:
  "fw_upd' m k i j =
  RETURN (
    let
      e = op_mtx_get m (i, k) + op_mtx_get m (k, j)
    in if e < op_mtx_get m (i, j) then op_mtx_set m (i, j) e else m
  )"
  unfolding fw_upd'_def min_def Let_def by auto

definition fwi' ::  "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nres"
where
  "fwi' m n k i j = RECT (\<lambda> fw (m, k, i, j).
      case (i, j) of
        (0, 0) \<Rightarrow> fw_upd' m k 0 0 |
        (Suc i, 0) \<Rightarrow> do {m' \<leftarrow> fw (m, k, i, n); fw_upd' m' k (Suc i) 0} |
        (i, Suc j) \<Rightarrow> do {m' \<leftarrow> fw (m, k, i, j); fw_upd' m' k i (Suc j)}
    ) (m, k, i, j)"

lemma fwi'_simps:
  "fwi' m n k 0       0        = fw_upd' m k 0 0"
  "fwi' m n k (Suc i) 0        = do {m' \<leftarrow> fwi' m n k i n; fw_upd' m' k (Suc i) 0}"
  "fwi' m n k i       (Suc j)  = do {m' \<leftarrow> fwi' m n k i j; fw_upd' m' k i (Suc j)}"
unfolding fwi'_def by (subst RECT_unfold, (refine_mono; fail), (auto split: nat.split; fail))+

lemma
  "fwi' m n k i j \<le> SPEC (\<lambda> r. r = uncurry (fwi (curry m) n k i j))"
by (induction "curry m" n k i j arbitrary: m rule: fwi.induct)
   (fastforce simp add: fw_upd'_def fw_upd_def upd_def fwi'_simps pw_le_iff refine_pw_simps)+

lemma fw_upd'_spec:
  "fw_upd' M k i j \<le> SPEC (\<lambda> M'. M' = uncurry (fw_upd (curry M) k i j))"
by (auto simp: fw_upd'_def fw_upd_def upd_def pw_le_iff refine_pw_simps)

lemma for_rec2_fwi:
  "for_rec2 (\<lambda> M. fw_upd' M k) M n i j \<le> SPEC (\<lambda> M'. M' = uncurry (fwi (curry M) n k i j))"
using fw_upd'_spec
by (induction "\<lambda> M. fw_upd' (M :: (nat \<times> nat \<Rightarrow> 'a)) k" M n i j rule: for_rec2.induct)
   (fastforce simp: pw_le_iff refine_pw_simps)+

definition fw' ::  "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nres" where
  "fw' m n k = nfoldli [0..<k + 1] (\<lambda> _. True) (\<lambda> k M. for_rec2 (\<lambda> M. fw_upd' M k) M n n n) m"

lemma fw'_spec:
  "fw' m n k \<le> SPEC (\<lambda> M'. M' = uncurry (fw (curry m) n k))"
  unfolding fw'_def
  apply (induction k)
  using for_rec2_fwi by (fastforce simp add: pw_le_iff refine_pw_simps curry_def)+

context
  fixes n :: nat
  fixes dummy :: "'a::{linordered_ab_monoid_add,zero,heap}"
begin

lemma [sepref_import_param]: "((+),(+)::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp
lemma [sepref_import_param]: "(min,min::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp

abbreviation "node_assn \<equiv> nat_assn"
abbreviation "mtx_assn \<equiv> asmtx_assn (Suc n) id_assn::('a mtx \<Rightarrow>_)"

sepref_definition fw_upd_impl1 is
  "uncurry2 (uncurry fw_upd')" ::
  "[\<lambda> (((_,k),i),j). k \<le> n \<and> i \<le> n \<and> j \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k
  \<rightarrow> mtx_assn"
  unfolding fw_upd'_def by sepref

sepref_definition fw_upd_impl is
  "uncurry2 (uncurry fw_upd')" ::
  "[\<lambda> (((_,k),i),j). k \<le> n \<and> i \<le> n \<and> j \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k
  \<rightarrow> mtx_assn"
  unfolding fw_upd'_alt_def by sepref

sepref_register fw_upd' :: "'a i_mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a i_mtx nres"

definition
  "fwi_impl' (M :: 'a mtx) k = for_rec2 (\<lambda> M. fw_upd' M k) M n n n"

definition
  "fw_impl' (M :: 'a mtx) = fw' M n n"

context
  notes [id_rules] = itypeI[of n "TYPE (nat)"]
    and [sepref_import_param] = IdI[of n]
begin

sepref_definition fw_impl is
  "fw_impl'" :: "mtx_assn\<^sup>d \<rightarrow>\<^sub>a mtx_assn"
  unfolding fw_impl'_def[abs_def] fw'_def for_rec2_eq
  supply [sepref_fr_rules] = fw_upd_impl.refine
  by sepref

sepref_definition fw_impl1 is
  "fw_impl'" :: "mtx_assn\<^sup>d \<rightarrow>\<^sub>a mtx_assn"
  unfolding fw_impl'_def[abs_def] fw'_def for_rec2_eq
  supply [sepref_fr_rules] = fw_upd_impl1.refine
  by sepref

sepref_definition fwi_impl is
  "uncurry fwi_impl'" :: "[\<lambda> (_,k). k \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k \<rightarrow> mtx_assn"
  unfolding fwi_impl'_def[abs_def] for_rec2_eq
  supply [sepref_fr_rules] = fw_upd_impl.refine
  by sepref

sepref_definition fwi_impl1 is
  "uncurry fwi_impl'" :: "[\<lambda> (_,k). k \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k \<rightarrow> mtx_assn"
  supply [sepref_fr_rules] = fw_upd_impl1.refine
  unfolding fwi_impl'_def[abs_def] for_rec2_eq by sepref

end (* End of sepref setup *)

end (* End of n *)

export_code fw_impl in SML_imp

text \<open>
  A compact specification for the characteristic property of the \fw.
\<close>
definition fw_spec where
  "fw_spec n M \<equiv> SPEC (\<lambda> M'.
    if (\<exists> i \<le> n. M' i i < 0)
    then \<not> cyc_free M n
    else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n)"

lemma D_diag_nonnegI:
  assumes "cycle_free M n" "i \<le> n"
  shows "D M i i n \<ge> 0"
  using assms D_dest''[OF refl, of M i i n] unfolding cycle_free_def by auto

lemma fw_fw_spec:
  "RETURN (FW M n) \<le> fw_spec n M"
unfolding fw_spec_def cycle_free_diag_equiv
proof (simp, safe, goal_cases)
  case prems: (1 i)
  with fw_shortest_path[unfolded cycle_free_diag_equiv, OF prems(3)] D_diag_nonnegI show ?case
    by fastforce
next
  case 2 then show ?case using FW_neg_cycle_detect[unfolded cycle_free_diag_equiv]
    by (force intro: fw_shortest_path[symmetric, unfolded cycle_free_diag_equiv])
next
  case 3 then show ?case using FW_neg_cycle_detect[unfolded cycle_free_diag_equiv] by blast
qed

definition
  "mat_curry_rel = {(Mu, Mc). curry Mu = Mc}"

definition
  "mtx_curry_assn n = hr_comp (mtx_assn n) (br curry (\<lambda>_. True))"

declare mtx_curry_assn_def[symmetric, fcomp_norm_unfold]

lemma fw_impl'_correct:
  "(fw_impl', fw_spec) \<in> Id \<rightarrow> br curry (\<lambda> _. True) \<rightarrow> \<langle>br curry (\<lambda> _. True)\<rangle> nres_rel"
  unfolding fw_impl'_def[abs_def] using fw'_spec fw_fw_spec
  by (fastforce simp: in_br_conv pw_le_iff refine_pw_simps intro!: nres_relI)

subsection \<open>Main Result\<close>

text \<open>This is one way to state that the \<open>fw_impl\<close> fulfills the specification \<open>fw_spec\<close>.\<close>
theorem fw_impl_correct:
  "(fw_impl n, fw_spec n) \<in> (mtx_curry_assn n)\<^sup>d \<rightarrow>\<^sub>a mtx_curry_assn n"
  using fw_impl.refine[FCOMP fw_impl'_correct[THEN fun_relD, OF IdI]] .

text \<open>An alternative version: a Hoare triple for total correctness.\<close>
corollary
  "<mtx_curry_assn n M Mi> fw_impl n Mi <\<lambda> Mi'. \<exists>\<^sub>A M'. mtx_curry_assn n M' Mi' * \<up>
    (if (\<exists> i \<le> n. M' i i < 0)
    then \<not> cyc_free M n
    else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n)>\<^sub>t"
  unfolding cycle_free_diag_equiv
  by (rule cons_rule[OF _ _ fw_impl_correct[THEN hfrefD, THEN hn_refineD]])
     (sep_auto simp: fw_spec_def[unfolded cycle_free_diag_equiv])+

subsection \<open>Alternative versions for Uncurried Matrices.\<close>

definition "FWI' = uncurry ooo FWI o curry"

lemma fwi_impl'_refine_FWI':
  "(fwi_impl' n, RETURN oo PR_CONST (\<lambda> M. FWI' M n)) \<in> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
  unfolding fwi_impl'_def[abs_def] FWI_def[abs_def] FWI'_def using for_rec2_fwi
  by (force simp: pw_le_iff pw_nres_rel_iff refine_pw_simps)

lemmas fwi_impl_refine_FWI' = fwi_impl.refine[FCOMP fwi_impl'_refine_FWI']

definition "FW' = uncurry oo FW o curry"

definition "FW'' n M = FW' M n"

lemma fw_impl'_refine_FW'':
  "(fw_impl' n, RETURN o PR_CONST (FW'' n)) \<in> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
  unfolding fw_impl'_def[abs_def] FW''_def[abs_def] FW'_def using fw'_spec
  by (force simp: pw_le_iff pw_nres_rel_iff refine_pw_simps)

lemmas fw_impl_refine_FW'' = fw_impl.refine[FCOMP fw_impl'_refine_FW'']
lemmas fw_impl1_refine_FW'' = fw_impl1.refine[FCOMP fw_impl'_refine_FW'']

end


theory topo_negation_conditions
  imports topo_frontier_algebra sse_operation_negative_quantification
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Frontier-based negation - Semantic conditions\<close>

text\<open>\noindent{We define a paracomplete and a paraconsistent negation employing the interior and closure operation resp.
We take the frontier operator as primitive and explore which semantic conditions are minimally required
to obtain some relevant properties of negation.}\<close>

definition neg_I::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>\<^sup>I")  where  "\<^bold>\<not>\<^sup>I A \<equiv> \<I>(\<^bold>\<midarrow>A)"
definition neg_C::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>\<^sup>C")  where  "\<^bold>\<not>\<^sup>C A \<equiv> \<C>(\<^bold>\<midarrow>A)"
declare neg_I_def[conn] neg_C_def[conn]

text\<open>\noindent{(We rename the meta-logical HOL negation to avoid terminological confusion)}\<close>
abbreviation cneg::"bool\<Rightarrow>bool" ("\<sim>_" [40]40) where "\<sim>\<phi> \<equiv> \<not>\<phi>"

subsection \<open>'Explosion' (ECQ), non-contradiction (LNC) and excluded middle (TND)\<close>

text\<open>\noindent{TND}\<close>
lemma "\<FF> \<F> \<Longrightarrow> TNDm \<^bold>\<not>\<^sup>I" nitpick oops (*minimally weak TND not valid*)
lemma TND_C: "TND \<^bold>\<not>\<^sup>C" by (simp add: pC2 Defs conn) (*TND valid in general*)

text\<open>\noindent{ECQ}\<close>
lemma ECQ_I: "ECQ \<^bold>\<not>\<^sup>I" by (simp add: pI2 Defs conn) (*ECQ valid in general*)
lemma "\<FF> \<F> \<Longrightarrow> ECQm \<^bold>\<not>\<^sup>C" nitpick oops (*minimally weak ECQ not valid*)

text\<open>\noindent{LNC}\<close>
lemma "LNC \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma LNC_I: "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow>  LNC \<^bold>\<not>\<^sup>I" using ECQ_I ECQ_def IF3 LNC_def dNOR_def unfolding conn by auto
lemma "LNC \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma LNC_C: "Fr_6 \<F> \<Longrightarrow> LNC \<^bold>\<not>\<^sup>C" unfolding Defs by (smt Cl_fr_def MONO_def compl_def join_def meet_def monC neg_C_def top_def)

text\<open>\noindent{Relations between LNC and different ECQ variants (only relevant for paraconsistent negation).}\<close>
lemma "ECQ \<^bold>\<not>\<^sup>C \<longrightarrow>  LNC \<^bold>\<not>\<^sup>C" by (simp add: pC2 Defs conn)
lemma ECQw_LNC: "ECQw \<^bold>\<not>\<^sup>C \<longrightarrow>  LNC \<^bold>\<not>\<^sup>C" by (smt ECQw_def LNC_def pC2 conn)
lemma ECQm_LNC: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> ECQm \<^bold>\<not>\<^sup>C \<longrightarrow> LNC \<^bold>\<not>\<^sup>C" using Cl_fr_def Fr_1_def pF2 unfolding Defs conn by metis
lemma "\<FF> \<F> \<Longrightarrow> LNC \<^bold>\<not>\<^sup>C \<longrightarrow>  ECQm \<^bold>\<not>\<^sup>C" nitpick oops  (*countermodel*)

text\<open>\noindent{Below we show that enforcing all conditions on the frontier operator still leaves room
for both boldly paraconsistent and paracomplete models. We use Nitpick to generate a non-trivial
model (here a set algebra with 8 elements).}\<close>
lemma "\<FF> \<F> \<and> \<sim>ECQm \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops (*boldly paraconsistent model found*)
lemma "\<FF> \<F> \<and> \<sim>TNDm \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops (*boldly paracomplete model found*)

subsection \<open>Modus tollens (MT)\<close>

text\<open>\noindent{MT-I}\<close>
lemma MT0_I: "Fr_1b \<F> \<Longrightarrow> MT0 \<^bold>\<not>\<^sup>I"  unfolding Defs by (smt MONO_def compl_def monI neg_I_def top_def)
lemma MT1_I: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> MT1 \<^bold>\<not>\<^sup>I" unfolding Defs by (metis MONO_def monI IF3 Int_fr_def compl_def dNOR_def diff_def neg_I_def top_def)
lemma "\<FF> \<F> \<Longrightarrow> MT2 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> MT2 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_1a \<F> \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> MT2 \<^bold>\<not>\<^sup>I" nitpick[satisfy] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> MT2 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> MT2 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<FF> \<F> \<Longrightarrow> MT3 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_1a \<F> \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> MT3 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> MT0 \<^bold>\<not>\<^sup>I \<and> MT1 \<^bold>\<not>\<^sup>I \<and> MT2 \<^bold>\<not>\<^sup>I \<and> MT3 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
text\<open>\noindent{MT-C}\<close>
lemma "Fr_2 \<F> \<Longrightarrow> MT0 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma MT0_C: "Fr_6 \<F> \<Longrightarrow> MT0 \<^bold>\<not>\<^sup>C" unfolding Defs by (smt ICdual MONO_def compl_def monC neg_C_def top_def)
lemma MT1_C: "Fr_6 \<F> \<Longrightarrow> MT1 \<^bold>\<not>\<^sup>C" unfolding Defs by (smt Cl_fr_def Fr_6_def conn)
lemma "\<FF> \<F> \<Longrightarrow> MT2 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> \<FF> \<F> \<and> MT2 \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops (*model found*)
lemma MT3_C: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> MT3 \<^bold>\<not>\<^sup>C" unfolding Defs using MONO_def monI by (metis ClOpdual IF3 compl_def dNOR_def diff_def neg_C_def pA2 top_def)
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> MT0 \<^bold>\<not>\<^sup>C \<and> MT1 \<^bold>\<not>\<^sup>C \<and> MT2 \<^bold>\<not>\<^sup>C \<and> MT3 \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

subsection \<open>Contraposition rules (CoP)\<close>

text\<open>\noindent{CoPw-I}\<close>
lemma "CoPw \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma CoPw_I: "Fr_1b \<F> \<Longrightarrow> CoPw \<^bold>\<not>\<^sup>I" unfolding Defs conn by (metis (no_types, lifting) MONO_def monI)
text\<open>\noindent{CoPw-C}\<close>
lemma "CoPw \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma CoPw_C: "Fr_6 \<F> \<Longrightarrow> CoPw \<^bold>\<not>\<^sup>C" by (smt CoPw_def MONO_def monC conn)

text\<open>\noindent{We can indeed prove that XCoP is entailed by CoP1 (CoP2) in the particular case of a closure- (interior-)based negation.}\<close>
lemma CoP1_XCoP: "CoP1 \<^bold>\<not>\<^sup>C \<longrightarrow>  XCoP \<^bold>\<not>\<^sup>C" by (metis XCoP_def2 CoP1_def CoP1_def2 DM2_CoPw DM2_def ECQw_def TND_C TND_def TNDw_def top_def)
lemma CoP2_XCoP: "CoP2 \<^bold>\<not>\<^sup>I \<longrightarrow>  XCoP \<^bold>\<not>\<^sup>I" by (smt XCoP_def2 CoP2_DM3 CoP2_def2 CoPw_def DM3_def DNE_def ECQ_I ECQ_def ECQw_def TNDw_def bottom_def join_def)

text\<open>\noindent{CoP1-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> CoP1 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> \<FF> \<F> \<and> CoP1 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
text\<open>\noindent{CoP1-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> CoP1 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> CoP1 \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "CoP1 \<^bold>\<not>\<^sup>C \<longrightarrow> ECQm \<^bold>\<not>\<^sup>C" using XCoP_def2 CoP1_XCoP ECQm_def ECQw_def by blast

text\<open>\noindent{CoP2-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> CoP2 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> CoP2 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> CoP2 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "CoP2 \<^bold>\<not>\<^sup>I \<longrightarrow> TNDm \<^bold>\<not>\<^sup>I" using XCoP_def2 CoP2_XCoP TNDm_def TNDw_def by auto
text\<open>\noindent{CoP2-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> CoP2 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> \<FF> \<F> \<and> CoP2 \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

text\<open>\noindent{CoP3-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> CoP3 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> CoP3 \<^bold>\<not>\<^sup>I" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)
text\<open>\noindent{CoP3-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> CoP3 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> CoP3 \<^bold>\<not>\<^sup>C" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)

text\<open>\noindent{XCoP-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> XCoP \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> XCoP \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> XCoP \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "XCoP \<^bold>\<not>\<^sup>I \<longrightarrow> TNDm \<^bold>\<not>\<^sup>I" by (simp add: XCoP_def2 TNDm_def TNDw_def)
text\<open>\noindent{XCoP-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> XCoP \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> XCoP \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "XCoP \<^bold>\<not>\<^sup>C \<longrightarrow> ECQm \<^bold>\<not>\<^sup>C" by (simp add: XCoP_def2 ECQm_def ECQw_def)

subsection \<open>Normality (negative) and its dual (nNor/nDNor)\<close>

text\<open>\noindent{nNor-I}\<close>
lemma "nNor \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma nNor_I: "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> nNor \<^bold>\<not>\<^sup>I"  using IF3 dNOR_def unfolding Defs conn by auto
text\<open>\noindent{nNor-C}\<close>
lemma nNor_C: "nNor \<^bold>\<not>\<^sup>C" unfolding Cl_fr_def Defs conn by simp

text\<open>\noindent{nDNor-I}\<close>
lemma nDNor_I: "nDNor \<^bold>\<not>\<^sup>I" unfolding Int_fr_def Defs conn by simp
text\<open>\noindent{nDNor-C}\<close>
lemma "nDNor \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma nDNor_C: "Fr_3 \<F> \<Longrightarrow> nDNor \<^bold>\<not>\<^sup>C" using pC2 NOR_def unfolding Defs conn by simp

subsection \<open>Double negation introduction/elimination (DNI/DNE)\<close>

text\<open>\noindent{DNI-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DNI \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> \<FF> \<F> \<and> DNI \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
text\<open>\noindent{DNI-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DNI \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> DNI \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> DNI \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> DNI \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

text\<open>\noindent{DNE-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DNE \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> DNE \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> DNE \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> DNE \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I  \<and> DNE \<^bold>\<not>\<^sup>I \<and> DNI \<^bold>\<not>\<^sup>I" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)
text\<open>\noindent{DNE-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DNE \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> \<FF> \<F> \<and> DNE \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C  \<and> DNE \<^bold>\<not>\<^sup>C \<and> DNI \<^bold>\<not>\<^sup>C" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)

text\<open>\noindent{rDNI-I}\<close>
lemma "Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> rDNI \<^bold>\<not>\<^sup>I" using nNor_I nDNor_I nDNor_rDNI by simp
text\<open>\noindent{rDNI-C}\<close>
lemma "Fr_3 \<F> \<Longrightarrow> rDNI \<^bold>\<not>\<^sup>C" using nNor_C nDNor_C nDNor_rDNI by simp

text\<open>\noindent{rDNE-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> rDNE \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> rDNE \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> rDNE \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> rDNE \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
text\<open>\noindent{rDNE-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> rDNE \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> \<FF> \<F> \<and> rDNE \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C  \<and> rDNE \<^bold>\<not>\<^sup>C \<and> rDNI \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

subsection \<open>De Morgan laws\<close>

text\<open>\noindent{DM1/2 (see CoPw)}\<close>

text\<open>\noindent{DM3-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DM3 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> DM3 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> DM3 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> DM3 \<^bold>\<not>\<^sup>I" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)
text\<open>\noindent{DM3-C}\<close>
lemma "DM3 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma DM3_C: "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> DM3 \<^bold>\<not>\<^sup>C" using  DM3_def Fr_1a_def pA2 pF2 unfolding conn by smt
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> \<FF> \<F> \<and> DM3 \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops

text\<open>\noindent{DM4-I}\<close>
lemma "DM4 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma DM4_I: "Fr_1a \<F> \<Longrightarrow> DM4 \<^bold>\<not>\<^sup>I" using ADDI_a_def Cl_fr_def DM4_def IC1b IF1b dual_def unfolding conn by smt
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> \<FF> \<F> \<and> DM4 \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
text\<open>\noindent{DM4-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DM4 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> DM4 \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> DM4 \<^bold>\<not>\<^sup>C" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)

text\<open>\noindent{iDM1/2 (see CoPw)}\<close>

text\<open>\noindent{iDM3-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> Fr_inf \<F> \<Longrightarrow> iDM3 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> iDM3 \<^bold>\<not>\<^sup>I" nitpick[satisfy] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> iDM3 \<^bold>\<not>\<^sup>I" nitpick[satisfy] oops
lemma "\<sim>TNDm \<^bold>\<not>\<^sup>I \<and> iDM3 \<^bold>\<not>\<^sup>I" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)
text\<open>\noindent{iDM3-C}\<close>
lemma "iDM3 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma iDM3_C: "Fr_2 \<F> \<Longrightarrow> Fr_inf \<F> \<Longrightarrow> iDM3 \<^bold>\<not>\<^sup>C" unfolding Defs by (metis (full_types) CF_inf Ra_restr_ex dom_compl_def iADDI_a_def iDM_a neg_C_def)
text\<open>\noindent{iDM4-I}\<close>
lemma "iDM4 \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma iDM4_I: "Fr_inf \<F> \<Longrightarrow> iDM4 \<^bold>\<not>\<^sup>I" unfolding Defs by (metis IF_inf Ra_restr_all dom_compl_def iDM_b iMULT_b_def neg_I_def)
text\<open>\noindent{iDM4-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> Fr_inf \<F> \<Longrightarrow> iDM4 \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> iDM4 \<^bold>\<not>\<^sup>C" nitpick[satisfy] oops
lemma "\<sim>ECQm \<^bold>\<not>\<^sup>C \<and> iDM4 \<^bold>\<not>\<^sup>C" (*nitpick[satisfy]*) oops (*cannot find (finite) models*)

subsection \<open>Local contraposition axioms (lCoP)\<close>

text\<open>\noindent{lCoPw-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I \<longrightarrow> TNDm \<^bold>\<not>\<^sup>I" by (simp add: XCoP_def2 TNDm_def TNDw_def lCoPw_XCoP)
text\<open>\noindent{lCoPw-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C \<longrightarrow> ECQm \<^bold>\<not>\<^sup>C" by (simp add: XCoP_def2 ECQm_def ECQw_def lCoPw_XCoP)

text\<open>\noindent{lCoP1-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I \<longrightarrow> TND \<^bold>\<not>\<^sup>I" by (simp add: lCoP1_TND)
text\<open>\noindent{lCoP1-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "\<sim>ECQ \<^bold>\<not>\<^sup>C \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick[satisfy,card w=3] oops
lemma "lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C \<longrightarrow> ECQm \<^bold>\<not>\<^sup>C" by (simp add: XCoP_def2 ECQm_def ECQw_def lCoP1_def2 lCoPw_XCoP)

text\<open>\noindent{lCoP2-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_4 \<F> \<and> lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "\<sim>TND \<^bold>\<not>\<^sup>I \<and> Fr_1 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F> \<and> lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick[satisfy,card w=3] oops
lemma "lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I \<longrightarrow> TNDm \<^bold>\<not>\<^sup>I" by (simp add: XCoP_def2 TNDm_def TNDw_def lCoP2_def2 lCoPw_XCoP)
text\<open>\noindent{lCoP2-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C \<longrightarrow> ECQ \<^bold>\<not>\<^sup>C" by (simp add: lCoP2_ECQ)

text\<open>\noindent{lCoP3-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "lCoP3(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I \<longrightarrow> TND \<^bold>\<not>\<^sup>I" unfolding Defs conn by metis
text\<open>\noindent{lCoP3-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "lCoP3(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C \<longrightarrow> ECQ \<^bold>\<not>\<^sup>C" unfolding Defs conn by metis

subsection \<open>Disjunctive syllogism\<close>

text\<open>\noindent{DS1-I}\<close>
lemma "DS1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" using DS1_def ECQ_I ECQ_def unfolding conn by auto
text\<open>\noindent{DS1-C}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" nitpick oops (*countermodel*)
lemma "DS1(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C \<longrightarrow> ECQ \<^bold>\<not>\<^sup>C" unfolding Defs conn by metis

text\<open>\noindent{DS2-I}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I" nitpick oops (*countermodel*)
lemma "DS2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>I \<longrightarrow> TND \<^bold>\<not>\<^sup>I" by (simp add: Defs conn)
text\<open>\noindent{DS2-C}\<close>
lemma "DS2(\<^bold>\<rightarrow>) \<^bold>\<not>\<^sup>C" using TND_C unfolding Defs conn by auto

end