theory Framed_Links
imports Links
begin

(*Defining- Framed Link Relations*)
definition framed_linkrel::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel x y = ((framed_linkrel_uncross x y) ∨ (linkrel_pull x y) ∨ (linkrel_straighten x y)
∨(linkrel_swing x y)∨(linkrel_rotate x y) ∨ (linkrel_compress x y) ∨ (linkrel_slide x y)
∨  (framed_linkrel_uncross y x) ∨ (linkrel_pull y x) ∨ (linkrel_straighten y x)
∨(linkrel_swing y x)∨(linkrel_rotate y x) ∨ (linkrel_compress y x) ∨ (linkrel_slide y x))"

text{*Following lemma tells us that framed Link relations implies Link relation*}

lemma framed_linkrel_implies_linkrel: "(framed_linkrel x y) ⟹ (linkrel x y)"
using framed_uncross_implies_uncross framed_linkrel_def linkrel_def by auto

text{*Following lemma tells us that framed Link relation is Symmetric*}

lemma framed_linkrel_symp: "symp framed_linkrel" unfolding framed_linkrel_def symp_def by auto

text{*Following lemma construct equivalence among Links*}

definition framed_linkrel_diagram_left::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_left x y ≡ ∃A.∃B.∃C.((x =  ((A::walls) ⊗ B))∧ (y = (C ⊗ B))
                                     ∧ (framed_linkrel A C))"

definition framed_linkrel_diagram_right::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_right x y ≡ ∃A.∃B.∃C.((x = (A ⊗ B))∧ (y = (A ⊗ C))
                                  ∧ (framed_linkrel B C))"

definition framed_linkrel_diagram_center::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_center x y ≡ ∃A.∃B1.∃B2.∃C.((x = (A ∘ (B1::walls) ⊗ C))
                                           ∧ (y = (A ∘ (B2::walls) ⊗ C))
                                     ∧ (framed_linkrel B1 B2))"

definition framed_linkrel_diagram_middle_center::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_middle_center x y ≡ ∃A.∃B.∃C1.∃C2.∃D.∃E.((x = (A ∘ (B::walls) ⊗ C1 ⊗ D ∘ E))
                                           ∧ (y = (A ∘ (B::walls) ⊗ C2 ⊗ D ∘ E))
                                     ∧ (framed_linkrel C1 C2))"

definition framed_linkrel_diagram_middle_left:: "walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_middle_left x y ≡ ∃A.∃B1.∃B2.∃C.∃D.((x = (A ∘ ((B1::walls)⊗C) ∘D))
                                           ∧ (y = (A ∘ ((B2::walls) ⊗ C) ∘ D))
                                     ∧ (framed_linkrel B1 B2))"

definition framed_linkrel_diagram_middle_right::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_middle_right x y ≡ ∃A.∃B.∃C1.∃C2.∃D.((x = (A ∘ (B::walls)⊗C1∘ D))
                                           ∧ (y =  (A ∘ (B::walls) ⊗ C2 ∘ D))
                                     ∧ (framed_linkrel C1 C2))"

definition framed_linkrel_diagram_bottom_left::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_bottom_left x y ≡ ∃A1.∃A2.∃B.∃C.((x = (((A1::walls) ⊗ B) ∘ C))
                                                ∧((y = (((A2::walls) ⊗ B) ∘ C)))
                                                ∧(framed_linkrel A1 A2))"

definition framed_linkrel_diagram_bottom_right::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_bottom_right x y ≡ ∃A.∃B1.∃B2.∃C.((x = (((A::walls) ⊗ B1) ∘ C))
                                                ∧((y = (((A::walls) ⊗ B2) ∘ C)))
                                                ∧(framed_linkrel B1 B2))"
definition framed_linkrel_diagram_bottom_center::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_bottom_center x y ≡ ∃A.∃B1.∃B2.∃C.∃D.((x = (((A::walls) ⊗ B1 ⊗ C) ∘ D))
                                                ∧((y = (((A::walls) ⊗ B2 ⊗ C) ∘ D)))
                                                ∧(framed_linkrel B1 B2))"

definition framed_linkrel_diagram_top_left::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_top_left x y ≡ ∃A.∃B1.∃B2.∃C.((x = (A ∘ ((B1::walls) ⊗  C)))
                                                ∧(y = (A ∘ ((B2::walls) ⊗ C)))
                                                ∧(framed_linkrel B1 B2))"

definition framed_linkrel_diagram_top_right::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_top_right x y ≡ ∃A.∃B.∃C1.∃C2.((x = (A ∘((B::walls) ⊗ C1)))
                                                 ∧(y = (A ∘ (B ⊗ C2)))
                                                 ∧(framed_linkrel C1 C2))"
definition framed_linkrel_diagram_top_center::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_top_center x y ≡ ∃A.∃B.∃C1.∃C2.∃D.((x = (A ∘  ((B::walls) ⊗ C1 ⊗ D)))
                                                ∧(y = ((A ∘ (B ⊗ C2 ⊗ D)))
                                                ∧(framed_linkrel C1 C2)))"

(*Framed_linkrel_diagram is the generating relation between two given Links*)
definition framed_linkrel_diagram::"walls ⇒ walls ⇒ bool"
where
"framed_linkrel_diagram x y ≡ (
(framed_linkrel_diagram_left x y)∨(framed_linkrel_diagram_right x y) ∨ (framed_linkrel_diagram_center x y)
∨(framed_linkrel_diagram_middle_left x y)∨(framed_linkrel_diagram_middle_right x y)
∨(framed_linkrel_diagram_middle_center x y)
∨(framed_linkrel_diagram_bottom_left x y)∨(framed_linkrel_diagram_bottom_left x y)
∨(framed_linkrel_diagram_bottom_center x y)
∨(framed_linkrel_diagram_top_left x y)∨(framed_linkrel_diagram_top_right x y)∨(framed_linkrel_diagram_top_center x y)
)"

(*proving the symmetry of framed_linkrel_diagram*)
lemma framed_symm_left:"(framed_linkrel_diagram_left x y) ⟹ (framed_linkrel_diagram_left y x)"
 using framed_linkrel_def framed_linkrel_diagram_left_def by auto

lemma framed_symm_right: "(framed_linkrel_diagram_right x y) ⟹ (framed_linkrel_diagram_right y x)"
 using framed_linkrel_def framed_linkrel_diagram_right_def by auto

lemma framed_symm_center:"(framed_linkrel_diagram_center x y) ⟹ (framed_linkrel_diagram_center y x)"
 using framed_linkrel_def framed_linkrel_diagram_center_def by auto

lemma framed_symm_middle_right:
  "(framed_linkrel_diagram_middle_right x y) ⟹ (framed_linkrel_diagram_middle_right y x)"
     unfolding framed_linkrel_def framed_linkrel_diagram_middle_right_def
     by (metis linkrel_symp sympD)

lemma framed_symm_middle_left:
  "(framed_linkrel_diagram_middle_left x y) ⟹ (framed_linkrel_diagram_middle_left y x)"
     unfolding framed_linkrel_def framed_linkrel_diagram_middle_left_def
     by (metis linkrel_symp sympD)

lemma framed_symm_middle_center:
  "(framed_linkrel_diagram_middle_center x y) ⟹ (framed_linkrel_diagram_middle_center y x)"
        unfolding framed_linkrel_def framed_linkrel_diagram_middle_center_def
        by (metis linkrel_symp sympD)

lemma framed_symm_bottom_left:
  "(framed_linkrel_diagram_bottom_left x y) ⟹ (framed_linkrel_diagram_bottom_left y x)"
        unfolding framed_linkrel_def framed_linkrel_diagram_bottom_left_def
        by (metis linkrel_symp sympD)

lemma framed_symm_bottom_right:
 "(framed_linkrel_diagram_bottom_right x y) ⟹ (framed_linkrel_diagram_bottom_right y x)"
        unfolding framed_linkrel_def framed_linkrel_diagram_bottom_right_def
        by (metis linkrel_symp sympD)

lemma framed_symm_bottom_center:
  "(framed_linkrel_diagram_bottom_center x y) ⟹ (framed_linkrel_diagram_bottom_center y x)"
         unfolding framed_linkrel_def framed_linkrel_diagram_bottom_center_def
         by (metis linkrel_symp sympD)

lemma framed_symm_top_left:
 "(framed_linkrel_diagram_top_left x y) ⟹ (framed_linkrel_diagram_top_left y x)"
         unfolding framed_linkrel_def framed_linkrel_diagram_top_left_def
         by (metis linkrel_symp sympD)

lemma framed_symm_top_right:
 "(framed_linkrel_diagram_top_right x y) ⟹ (framed_linkrel_diagram_top_right y x)"
         unfolding framed_linkrel_def framed_linkrel_diagram_top_right_def
         by (metis linkrel_symp sympD)

lemma framed_symm_top_center:
 "(framed_linkrel_diagram_top_center x y) ⟹ (framed_linkrel_diagram_top_center y x)"
         unfolding framed_linkrel_def framed_linkrel_diagram_top_center_def
         by (metis linkrel_symp sympD)

lemma  symm_framed_linkrel_diagram:
  "(framed_linkrel_diagram x y)⟹ (framed_linkrel_diagram y x)"
        unfolding framed_linkrel_diagram_def using framed_symm_bottom_center framed_symm_bottom_left
                  framed_symm_center framed_symm_left framed_symm_middle_center
                  framed_symm_middle_left framed_symm_middle_right framed_symm_right
                  framed_symm_top_center framed_symm_top_left framed_symm_top_right
        by metis

(*framed_linkrel_diagram_equiv is the equivalence class of walls*)

definition framed_linkrel_diagram_equiv::"walls⇒ walls ⇒ bool"
where
"framed_linkrel_diagram_equiv = (framed_linkrel_diagram)^**"

(*Proof that the Framed_Linkrel_Diagram_Equiv is symmetric*)
lemma symm_framed_linkrel_diagram_equiv:
  "framed_linkrel_diagram_equiv x y ⟹ (framed_linkrel_diagram_equiv y x)"
      using framed_linkrel_diagram_equiv_def symm_framed_linkrel_diagram symmetry3 symp_def
      by metis

lemma transitive_implication:
 assumes " ∀x.∀y.((r x y) ⟶(q x y))"
 shows "r^** x y ⟹ q^** x y"
proof(induction rule:rtranclp.induct)
 fix a
 let ?case = "q⇧*⇧* a a"
   show ?case by simp
 next
 fix a b c
 assume rtranclp : "r^** a b" "r b c" "q^** a b"
 let ?case = "q^** a c"
   have "(r b c)⟹ (q b c)" using assms by auto
   from this have "q b c" using assms rtranclp by auto
   from this  have "q^** a c" using rtranclp(3) rtranclp.rtrancl_into_rtrancl by auto
   thus ?case by simp
qed

definition framed_link_equiv::"diagram⇒ diagram ⇒ bool"
where
"framed_link_equiv x y = (framed_linkrel_diagram_equiv (Rep_diagram x) (Rep_diagram y))"

lemma ref: "(framed_link_equiv x x)"
unfolding framed_link_equiv_def framed_linkrel_diagram_equiv_def by auto

lemma sym:"(framed_link_equiv x y) ⟹ (framed_link_equiv y x)"
unfolding framed_link_equiv_def using symm_framed_linkrel_diagram_equiv  by auto

lemma trans:"(framed_link_equiv x y)∧ (framed_link_equiv y z) ⟹ (framed_link_equiv x z)"
using framed_link_equiv_def framed_linkrel_diagram_equiv_def rtranclp_trans by (metis)

quotient_type Framed_Link = "diagram" / "framed_link_equiv"
 morphisms Rep_framed_links Abs_framed_links
proof (rule equivpI)
show "reflp framed_link_equiv"
   using reflp_def  framed_link_equiv_def framed_linkrel_diagram_equiv_def rtranclp.rtrancl_refl
   by (metis (full_types))
show "symp framed_link_equiv"
   using  framed_link_equiv_def symm_framed_linkrel_diagram_equiv symp_def
   by (metis)
show "transp framed_link_equiv"
   using trans unfolding framed_link_equiv_def transp_def by metis
qed

(*It remains to be proved that Framed_Link_Equiv implies Link_Equiv*)
(*Some junk code but needs to be relooked -
(* we need to rewrite the definitions of framed_link_relations and repeat the above for framed_link_relations
definition framed_linkrel::"walls =>walls⇒bool"
where
"framed_linkrel x y = ((framed_linkrel_uncross x y) ∨ (linkrel_pull x y) ∨ (linkrel_straighten x y)
∨(linkrel_swing x y)∨(linkrel_rotate x y) ∨ (linkrel_compress x y) ∨ (linkrel_slide x y)
∨  (framed_linkrel_uncross y x) ∨ (linkrel_pull y x) ∨ (linkrel_straighten y x)
∨(linkrel_swing y x)∨(linkrel_rotate y x) ∨ (linkrel_compress y x) ∨ (linkrel_slide y x))"

text{*Following lemmas asserts that if two framed linked diagrams are equivalent, then the unframed
links are equivalent*}

lemma framed_linkrel_implies_linkrel: "(framed_linkrel x y) ⟹ (linkrel x y)"
using framed_uncross_implies_uncross framed_linkrel_def linkrel_def by auto

text{* the link relations are symmetric*}
lemma linkrel_symp: "symp linkrel" unfolding linkrel_def symp_def by auto

lemma framed_linkrel_symp: "symp framed_linkrel" unfolding framed_linkrel_def symp_def by auto

definition framed_linkrel_equiv::"walls⇒walls⇒bool"
where
"(framed_linkrel_equiv) = (framed_linkrel)^**"

text{*Following lemmas assert that if two framed link diagrams are related by the linkrel_equiv, then
the corresponding link diagrams are equivalent*}

lemma transitive_implication:
assumes " ∀x.∀y.((r x y) ⟶(q x y))"
shows "r^** x y ⟹ q^** x y"
proof(induction rule:rtranclp.induct)
fix a
let ?case = "q⇧*⇧* a a"
show ?case by simp
next
fix a b c
assume rtranclp : "r^** a b" "r b c" "q^** a b"
let ?case = "q^** a c"
have "(r b c)⟹ (q b c)" using assms by auto
from this have "q b c" using assms rtranclp by auto
from this  have "q^** a c" using rtranclp(3) rtranclp.rtrancl_into_rtrancl by auto
thus ?case by simp
qed

theorem framed_equiv_implies_linkequiv: "(framed_linkrel_equiv x y) ⟹ (linkrel_equiv x y)"
using  framed_linkrel_equiv_def linkrel_equiv_def transitive_implication
framed_linkrel_implies_linkrel
by metis
text{*Linkrel_equiv and Framed_Linkrel_equiv are  equivalence relations*}

lemma reflective: "linkrel_equiv x x" unfolding linkrel_equiv_def by simp

lemma framed_reflective: "framed_linkrel_equiv x x" unfolding framed_linkrel_equiv_def by simp

lemma link_symmetry:"symp linkrel_equiv" using linkrel_symp symmetry3
by (metis (full_types) linkrel_equiv_def)

lemma link_symmetry2:"(linkrel_equiv x y)⟹ (linkrel_equiv y x)" using link_symmetry sympD
 by metis

lemma framed_link_symmetry:"symp framed_linkrel_equiv" using framed_linkrel_symp symmetry3
by (metis (full_types) framed_linkrel_equiv_def)

(*following lemma proves that linkrel_equiv is transitive in the usual sense of the term*)
lemma linkrel_trans: assumes "linkrel_equiv x y" and "linkrel_equiv y z"
shows "linkrel_equiv x z"
using rtranclp_trans linkrel_equiv_def  by (metis (full_types) assms(1) assms(2))
*)*)
end


theory operators_basic
  imports "../conditions/conditions_kuratowski_infinitary"
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

abbreviation implies_rl::"bool\<Rightarrow>bool\<Rightarrow>bool" (infixl "\<longleftarrow>" 25) where "\<phi> \<longleftarrow> \<psi> \<equiv> \<psi> \<longrightarrow> \<phi>" (*for readability*)

section \<open>Topological operators\<close>

(**Below we define some conditions on algebraic operations (aka. operators) with type @{type "\<sigma>\<Rightarrow>\<sigma>"}.
Those operations are aimed at extending a Boolean 'algebra of propositions' towards different
generalizations of topological algebras.
We divide this section into two parts. In the first we define and interrelate the topological operators of
interior, closure, border and frontier. In the second we introduce the (more fundamental) notion of
derivative (aka. derived set) and its related notion of (Cantorian) coherence, defining both as operators.
We follow the naming conventions introduced originally by Kuratowski @{cite Kuratowski-1}
(cf. also @{cite Kuratowski-2}) and Zarycki @{cite Zarycki-1}.*)

subsection \<open>Interior and closure\<close>
(**In this section we examine the traditional notion of topological (closure, resp. interior) algebras
in the spirit of McKinsey \& Tarski @{cite AOT}, but drawing primarily from the works of Zarycki
@{cite Zarycki-1} and Kuratowski @{cite Kuratowski-1}.
We also explore the less-known notions of border (cf. 'Rand' @{cite Hausdorff}, 'bord' @{cite Zarycki-1}) and
frontier (aka. 'boundary'; cf. 'Grenze' @{cite Hausdorff}, 'fronti\`ere' @{cite Zarycki-1} @{cite Kuratowski-2})
as studied by Zarycki @{cite Zarycki-1} and define corresponding operations for them.*)

subsubsection \<open>Interior conditions\<close>

abbreviation "Int_1 \<phi>  \<equiv> MULT \<phi>"
abbreviation "Int_1a \<phi> \<equiv> MULT_a \<phi>"
abbreviation "Int_1b \<phi> \<equiv> MULT_b \<phi>"
abbreviation "Int_2 \<phi>  \<equiv> dEXP \<phi>"
abbreviation "Int_3 \<phi>  \<equiv> dNOR \<phi>"
abbreviation "Int_4 \<phi>  \<equiv> IDEM \<phi>"
abbreviation "Int_4' \<phi> \<equiv> IDEMa \<phi>"

abbreviation "Int_5 \<phi>  \<equiv> NOR \<phi>"
definition "Int_6 \<phi>  \<equiv> \<forall>A B. \<phi>(A \<^bold>\<leftharpoonup> B) \<^bold>\<preceq> \<phi>(A) \<^bold>\<leftharpoonup> \<phi>(B)"
definition "Int_7 \<phi>  \<equiv> \<forall>A B. \<phi>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<phi>(A) \<^bold>\<rightarrow> \<phi>(B)"
definition "Int_8 \<phi>  \<equiv> \<forall>A B. \<phi>(\<phi> A \<^bold>\<or> \<phi> B) \<^bold>\<approx> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition "Int_9 \<phi>  \<equiv> \<forall>A B. \<phi> A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B"

(**@{text "\<phi>"} is an interior operator (@{text "\<II>(\<phi>)"}) iff it satisfies conditions 1-4 (cf. @{cite Zarycki-1}
and also @{cite Kuratowski-2}). This characterization is shown consistent by generating a non-trivial model.*)
abbreviation "\<II> \<phi> \<equiv> Int_1 \<phi> \<and> Int_2 \<phi> \<and> Int_3 \<phi> \<and> Int_4 \<phi>"
lemma "\<II> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

(**We verify some properties which will become useful later (also to improve provers' performance).*)
lemma PI1: "Int_1 \<phi> = (Int_1a \<phi> \<and> Int_1b \<phi>)" by (metis MULT_def MULT_a_def MULT_b_def)
lemma PI4: "Int_2 \<phi> \<Longrightarrow> (Int_4 \<phi> = Int_4' \<phi>)" unfolding dEXP_def IDEM_def IDEMa_def by blast
lemma PI5: "Int_2 \<phi> \<Longrightarrow> Int_5 \<phi>" unfolding dEXP_def NOR_def conn by blast
lemma PI6: "Int_1a \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow> Int_6 \<phi>" by (smt dEXP_def Int_6_def MONO_MULTa MONO_def conn)
lemma PI7: "Int_1 \<phi> \<Longrightarrow> Int_7 \<phi>" proof -
  assume int1: "Int_1 \<phi>"
  { fix a b
    have "a \<^bold>\<and> b = a \<^bold>\<and> (a \<^bold>\<rightarrow> b)" unfolding conn by blast
    hence "\<phi>(a \<^bold>\<and> b) = \<phi>(a \<^bold>\<and> (a \<^bold>\<rightarrow> b))" by simp
    moreover from int1 have "\<phi>(a \<^bold>\<and> b) \<^bold>\<approx> \<phi> a \<^bold>\<and> \<phi> b" by (simp add: MULT_def)
    moreover from int1 have "\<phi>(a \<^bold>\<and> (a \<^bold>\<rightarrow> b)) \<^bold>\<approx> \<phi> a \<^bold>\<and> \<phi> (a \<^bold>\<rightarrow> b)" by (simp add: MULT_def)
    ultimately have "\<phi> a \<^bold>\<and> \<phi> (a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<phi> a \<^bold>\<and> \<phi> b" by simp
    hence "\<phi> a \<^bold>\<and> \<phi> (a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<phi> a \<^bold>\<and> (\<phi> a \<^bold>\<rightarrow> \<phi> b)" unfolding conn by blast
    hence "\<phi>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<phi> a \<^bold>\<rightarrow> \<phi> b" unfolding conn by blast
  } thus ?thesis by (simp add: Int_7_def)
qed
lemma PI8: "Int_1a \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Int_8 \<phi>" using ADDI_b_def IDEM_def Int_8_def MONO_ADDIb MONO_MULTa dEXP_def join_def by auto
lemma PI9: "Int_1a \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Int_9 \<phi>" using IDEM_def Int_9_def MONO_def MONO_MULTa by simp

subsubsection \<open>Closure conditions\<close>

abbreviation "Cl_1 \<phi> \<equiv> ADDI \<phi>"
abbreviation "Cl_1a \<phi> \<equiv> ADDI_a \<phi>"
abbreviation "Cl_1b \<phi> \<equiv> ADDI_b \<phi>"
abbreviation "Cl_2 \<phi> \<equiv> EXP \<phi>"
abbreviation "Cl_3 \<phi>  \<equiv> NOR \<phi>"
abbreviation "Cl_4 \<phi> \<equiv> IDEM \<phi>"
abbreviation "Cl_4' \<phi> \<equiv> IDEMb \<phi>"

abbreviation "Cl_5 \<phi>  \<equiv> dNOR \<phi>"
definition "Cl_6 \<phi>  \<equiv> \<forall>A B. (\<phi> A) \<^bold>\<leftharpoonup> (\<phi> B) \<^bold>\<preceq> \<phi> (A \<^bold>\<leftharpoonup> B)"
definition "Cl_7 \<phi> \<equiv> \<forall>A B. (\<phi> A) \<^bold>\<rightarrow> (\<phi> B) \<^bold>\<preceq> \<phi> (A \<^bold>\<rightarrow> B)"
definition "Cl_8 \<phi>  \<equiv> \<forall>A B. \<phi>(\<phi> A \<^bold>\<and> \<phi> B) \<^bold>\<approx> (\<phi> A) \<^bold>\<and> (\<phi> B)"
definition "Cl_9 \<phi>  \<equiv> \<forall>A B.  A \<^bold>\<preceq> \<phi> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B"

(**@{text "\<phi>"} is a closure operator (@{text "\<CC>(\<phi>)"}) iff it satisfies conditions 1-4 (cf. @{cite Kuratowski-1}
@{cite Kuratowski-2}). This characterization is shown consistent by generating a non-trivial model.*)
abbreviation "\<CC> \<phi>  \<equiv> Cl_1 \<phi> \<and> Cl_2 \<phi> \<and> Cl_3  \<phi> \<and> Cl_4 \<phi>"
lemma "\<CC> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

(**We verify some properties that will become useful later.*)

subsubsection \<open>Exploring dualities\<close>

lemma IC1_dual: "Int_1a \<phi> = Cl_1b \<phi>" using MONO_ADDIb MONO_MULTa by auto
lemma "Int_1b \<phi> = Cl_1a \<phi>" nitpick oops

lemma IC1a: "Int_1a \<phi> \<Longrightarrow> Cl_1b \<phi>\<^sup>d" by (smt MULT_a_def ADDI_b_def MONO_def MONO_MULTa dual_def conn)
lemma IC1b: "Int_1b \<phi> \<Longrightarrow> Cl_1a \<phi>\<^sup>d" unfolding MULT_b_def ADDI_a_def dual_def conn by auto
lemma IC1:  "Int_1 \<phi>  \<Longrightarrow> Cl_1 \<phi>\<^sup>d" unfolding MULT_def ADDI_def dual_def conn by simp
lemma IC2:  "Int_2 \<phi>  \<Longrightarrow> Cl_2 \<phi>\<^sup>d" unfolding dEXP_def EXP_def dual_def conn by blast
lemma IC3:  "Int_3 \<phi>  \<Longrightarrow> Cl_3 \<phi>\<^sup>d" unfolding dNOR_def NOR_def dual_def conn by simp
lemma IC4:  "Int_4 \<phi>  \<Longrightarrow> Cl_4 \<phi>\<^sup>d" unfolding IDEM_def IDEM_def dual_def conn by simp
lemma IC4': "Int_4' \<phi> \<Longrightarrow> Cl_4' \<phi>\<^sup>d" unfolding IDEMa_def IDEMb_def dual_def conn by metis
lemma IC5:  "Int_5 \<phi>  \<Longrightarrow> Cl_5 \<phi>\<^sup>d" unfolding NOR_def dNOR_def dual_def conn by simp

lemma CI1a: "Cl_1a \<phi>  \<Longrightarrow> Int_1b \<phi>\<^sup>d" proof -
  assume cl1a: "Cl_1a \<phi>"
  { fix A B
    have "\<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>(A \<^bold>\<and> B)) \<^bold>\<approx> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>B)" unfolding conn by simp
    moreover from cl1a have "\<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>B)) \<^bold>\<preceq> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>B)" using ADDI_a_def conn by metis
    ultimately have "\<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A)) \<^bold>\<and> \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>B)) \<^bold>\<preceq> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>(A \<^bold>\<and> B))" unfolding conn by simp
    hence "(\<phi>\<^sup>d A) \<^bold>\<and> (\<phi>\<^sup>d B) \<^bold>\<preceq> (\<phi>\<^sup>d (A \<^bold>\<and> B))" unfolding dual_def by simp
  } thus "Int_1b \<phi>\<^sup>d" using MULT_b_def by blast
qed
lemma CI1b: "Cl_1b \<phi> \<Longrightarrow> Int_1a \<phi>\<^sup>d" by (metis IC1a MONO_ADDIb MONO_MULTa)
lemma CI1:  "Cl_1 \<phi>  \<Longrightarrow> Int_1 \<phi>\<^sup>d" by (simp add: CI1a CI1b PC1 PI1)
lemma CI2:  "Cl_2 \<phi>  \<Longrightarrow> Int_2 \<phi>\<^sup>d" unfolding EXP_def dEXP_def dual_def conn by metis
lemma CI3:  "Cl_3 \<phi>  \<Longrightarrow> Int_3 \<phi>\<^sup>d" unfolding NOR_def dNOR_def dual_def conn by simp
lemma CI4:  "Cl_4 \<phi>  \<Longrightarrow> Int_4 \<phi>\<^sup>d" unfolding IDEM_def IDEM_def dual_def conn by simp
lemma CI4': "Cl_4' \<phi> \<Longrightarrow> Int_4' \<phi>\<^sup>d" unfolding IDEMa_def IDEMb_def dual_def conn by metis
lemma CI5:  "Cl_5 \<phi>  \<Longrightarrow> Int_5 \<phi>\<^sup>d" unfolding dNOR_def NOR_def dual_def conn by simp

subsection \<open>Frontier and border\<close>

subsubsection \<open>Frontier conditions\<close>

definition "Fr_1a \<phi> \<equiv> \<forall>A B. (A \<^bold>\<and> B) \<^bold>\<and> \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (A \<^bold>\<and> B) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi> B)"
definition "Fr_1b \<phi> \<equiv> \<forall>A B. (A \<^bold>\<and> B) \<^bold>\<and> \<phi>(A \<^bold>\<and> B) \<^bold>\<succeq> (A \<^bold>\<and> B) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi> B)"
definition "Fr_1 \<phi>  \<equiv> \<forall>A B. (A \<^bold>\<and> B) \<^bold>\<and> \<phi>(A \<^bold>\<and> B) \<^bold>\<approx> (A \<^bold>\<and> B) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi> B)"
definition "Fr_2 \<phi> \<equiv> \<forall>A. \<phi> A \<^bold>\<approx> \<phi>(\<^bold>\<midarrow>A)"
abbreviation "Fr_3 \<phi> \<equiv> NOR \<phi>"
definition "Fr_4 \<phi> \<equiv> \<forall>A. \<phi>(\<phi> A) \<^bold>\<preceq> (\<phi> A)"

definition "Fr_5 \<phi> \<equiv> \<forall>A. \<phi>(\<phi>(\<phi> A)) \<^bold>\<approx> \<phi>(\<phi> A)"
definition "Fr_6 \<phi> \<equiv> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> (\<phi> A \<^bold>\<preceq> B \<^bold>\<or> \<phi> B)"

(**@{text "\<phi>"} is a topological frontier operator (@{text "\<FF>(\<phi>)"}) iff it satisfies conditions 1-4
(cf. @{cite Zarycki-2}). This is also shown consistent by generating a non-trivial model.*)
abbreviation "\<FF> \<phi>  \<equiv> Fr_1 \<phi> \<and> Fr_2 \<phi> \<and> Fr_3 \<phi> \<and> Fr_4 \<phi>"
lemma "\<FF> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

(**We now verify some useful properties of the frontier operator.*)
lemma PF1: "Fr_1 \<phi> = (Fr_1a \<phi> \<and> Fr_1b \<phi>)" unfolding Fr_1_def Fr_1a_def Fr_1b_def by meson
lemma PF5: "Fr_1 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Fr_5 \<phi>" proof -
  assume fr1: "Fr_1 \<phi>" and fr4: "Fr_4 \<phi>"
  { fix A
    from fr1 have "(\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> \<phi>(\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<approx> (\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> (\<phi>(\<phi>(\<phi> A)) \<^bold>\<or> \<phi>(\<phi> A))" by (simp add: Fr_1_def)
    moreover have r1: "\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>(\<phi> A)" using meet_char Fr_4_def fr4 by simp
    moreover have r2: "\<phi>(\<phi>(\<phi> A)) \<^bold>\<or> \<phi>(\<phi> A) \<^bold>\<approx> \<phi>(\<phi> A)" using join_char Fr_4_def fr4 by simp
    ultimately have "(\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> \<phi>(\<phi>(\<phi> A)) \<^bold>\<approx> (\<phi>(\<phi> A) \<^bold>\<and> (\<phi> A)) \<^bold>\<and> \<phi>(\<phi> A)" unfolding conn by auto
    hence "\<phi>(\<phi>(\<phi> A)) \<^bold>\<approx> \<phi>(\<phi> A)" using r1 r2 conn by auto
  } thus ?thesis by (simp add: Fr_5_def)
qed
lemma PF6: "Fr_1b \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_6 \<phi>" proof -
  assume fr1b: "Fr_1b \<phi>" and fr2: "Fr_2 \<phi>"
  { fix A B
    have "\<phi>(\<^bold>\<midarrow>(A \<^bold>\<or> B)) \<^bold>\<approx> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B)" unfolding conn by simp
    hence aux: "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<approx> \<phi>(A \<^bold>\<or> B)" by (metis (mono_tags) Fr_2_def fr2)
    from fr1b have "(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<succeq> (\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<and> (\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>B))" using Fr_1b_def by metis
    hence "A \<^bold>\<or> B \<^bold>\<or> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<preceq> A \<^bold>\<or> B \<^bold>\<or> (\<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<^bold>\<midarrow>(\<phi> B))" using Fr_2_def fr2 conn by auto
    hence "\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B \<^bold>\<and> \<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B) \<^bold>\<preceq> \<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B \<^bold>\<and> \<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<^bold>\<midarrow>(\<phi> B)" unfolding conn by blast
    hence "A \<^bold>\<or> B \<^bold>\<or> \<phi>(A \<^bold>\<or> B) \<^bold>\<succeq> A \<^bold>\<or> B \<^bold>\<or> (\<phi> A) \<^bold>\<or> (\<phi> B)" using aux unfolding conn by blast
    hence "A \<^bold>\<preceq> B \<longrightarrow> B \<^bold>\<or> \<phi>(A \<^bold>\<or> B) \<^bold>\<succeq> B \<^bold>\<or> (\<phi> A) \<^bold>\<or> (\<phi> B)" unfolding conn by auto
    hence "A \<^bold>\<preceq> B \<longrightarrow> B \<^bold>\<or> (\<phi> B) \<^bold>\<succeq> B \<^bold>\<or> (\<phi> A) \<^bold>\<or> (\<phi> B)" using join_char unfolding conn by simp
    hence "A \<^bold>\<preceq> B \<longrightarrow> (\<phi> A) \<^bold>\<preceq> B \<^bold>\<or> (\<phi> B)" unfolding conn by simp
  } thus "Fr_6 \<phi>" by (simp add: Fr_6_def)
qed

subsubsection \<open>Border conditions\<close>

definition "Br_1 \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<approx> (A \<^bold>\<and> \<phi> B) \<^bold>\<or> (B \<^bold>\<and> \<phi> A)"
definition "Br_2 \<phi> \<equiv> (\<phi> \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<bottom>"
definition "Br_3 \<phi> \<equiv> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> A"

definition "Br_4 \<phi> \<equiv> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> A \<^bold>\<and> (\<phi> B) \<^bold>\<preceq> \<phi> A"
definition "Br_5a \<phi> \<equiv> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> \<phi> A"
definition "Br_5b \<phi> \<equiv> \<forall>A. \<phi> A \<^bold>\<preceq> A"
definition "Br_5c \<phi> \<equiv> \<forall>A. A \<^bold>\<preceq> \<phi>\<^sup>d A"
definition "Br_5d \<phi> \<equiv> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>\<^sup>d(\<phi> A)"
abbreviation "Br_6 \<phi> \<equiv> IDEM \<phi>"
abbreviation "Br_7 \<phi> \<equiv> ADDI_a \<phi>"
abbreviation "Br_8 \<phi> \<equiv> MULT_b \<phi>"
definition "Br_9 \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition "Br_10 \<phi> \<equiv> \<forall>A. \<phi>(\<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<phi>\<^sup>d A) \<^bold>\<approx> \<^bold>\<bottom>"

(**@{text "\<phi>"} is a topological border operator (@{text "\<BB>(\<phi>)"}) iff it satisfies conditions 1-3
(cf. @{cite Zarycki-2}). This is also shown consistent.*)
abbreviation "\<BB> \<phi>  \<equiv> Br_1 \<phi> \<and> Br_2 \<phi> \<and> Br_3 \<phi>"
lemma "\<BB> \<phi>" nitpick[satisfy, card w=3] oops (*model found: characterization is consistent*)

(**We now verify some useful properties of the border operator.*)

subsubsection \<open>Relation with closure and interior\<close>

(**We define and verify some conversion operators useful to derive border and frontier operators from
closure/interior operators and also between each other.*)

(**Frontier operator as derived from interior.*)
definition Fr_int::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>I") where "\<F>\<^sub>I \<I> \<equiv> \<lambda>A. \<^bold>\<midarrow>(\<I> A) \<^bold>\<and> \<I>\<^sup>d A"
lemma FI1: "Int_1 \<phi> \<Longrightarrow> Int_2 \<phi> \<Longrightarrow>  Fr_1(\<F>\<^sub>I \<phi>)" using EXP_def Fr_1_def Fr_int_def IC2 MULT_def conn by auto
lemma FI2: "Fr_2(\<F>\<^sub>I \<phi>)" using Fr_2_def Fr_int_def dual_def dual_symm unfolding conn by smt
lemma FI3: "Int_3 \<phi> \<Longrightarrow> Fr_3(\<F>\<^sub>I \<phi>)" using NOR_def Fr_int_def IC3 unfolding conn by auto
lemma FI4: "Int_1a \<phi> \<Longrightarrow> Int_2 \<phi>  \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Fr_4(\<F>\<^sub>I \<phi>)" unfolding Fr_int_def Fr_4_def dual_def conn by (smt Int_9_def MONO_MULTa PI9)

(**Frontier operator as derived from closure.*)
definition Fr_cl::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>C") where "\<F>\<^sub>C \<C> \<equiv> \<lambda>A. (\<C> A) \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)"
lemma FC1: "Cl_1 \<phi> \<Longrightarrow> Cl_2 \<phi> \<Longrightarrow>  Fr_1(\<F>\<^sub>C \<phi>)" using CI1 EXP_def Fr_1_def Fr_cl_def MULT_def dual_def unfolding conn by smt
lemma FC2: "Fr_2(\<F>\<^sub>C \<phi>)" using Fr_2_def Fr_cl_def dual_def dual_symm unfolding conn by smt
lemma FC3: "Cl_3 \<phi> \<Longrightarrow> Fr_3(\<F>\<^sub>C \<phi>)" unfolding NOR_def Fr_cl_def conn by simp
lemma FC4: "Cl_1b \<phi> \<Longrightarrow> Cl_2 \<phi> \<Longrightarrow> Cl_4 \<phi> \<Longrightarrow> Fr_4(\<F>\<^sub>C \<phi>)" using Cl_8_def MONO_ADDIb PC8 unfolding Fr_cl_def Fr_4_def conn by blast

(**Frontier operator as derived from border.*)
definition Fr_br::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>B") where "\<F>\<^sub>B \<B> \<equiv> \<lambda>A. \<B> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)"
lemma FB1: "Br_1 \<phi> \<Longrightarrow>  Fr_1(\<F>\<^sub>B \<phi>)" unfolding Fr_br_def Fr_1_def using Br_1_def Br_5b_def PB5b conn by smt
lemma FB2: "Fr_2(\<F>\<^sub>B \<phi>)" unfolding Fr_br_def Fr_2_def conn by auto
lemma FB3: "Br_1 \<phi> \<Longrightarrow> Br_2 \<phi> \<Longrightarrow>  Fr_3(\<F>\<^sub>B \<phi>)" using Br_2_def Br_5b_def PB5b unfolding Fr_br_def NOR_def conn by force
lemma FB4: "Br_1 \<phi> \<Longrightarrow> Br_3 \<phi> \<Longrightarrow>  Fr_4(\<F>\<^sub>B \<phi>)" proof -
  assume br1: "Br_1 \<phi>" and br3: "Br_3 \<phi>"
  { fix A
   have "(\<F>\<^sub>B \<phi>) ((\<F>\<^sub>B \<phi>) A) = \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)))" by (simp add: Fr_br_def conn)
   also have "... = \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A) \<^bold>\<and> \<phi>\<^sup>d A)" by (simp add: dual_def conn)
   also from br1 br3 have "... = \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<or> \<^bold>\<bottom>" using Br_10_def PB10 by metis
   finally have "(\<F>\<^sub>B \<phi>) ((\<F>\<^sub>B \<phi>) A) \<^bold>\<approx> \<phi>(\<phi> A \<^bold>\<or> \<phi>(\<^bold>\<midarrow>A))" unfolding conn by simp
   hence "(\<F>\<^sub>B \<phi>) ((\<F>\<^sub>B \<phi>) A) \<^bold>\<preceq> (\<F>\<^sub>B \<phi>) A" using Br_5b_def Fr_br_def PB5b br1 by fastforce
  } thus "Fr_4(\<F>\<^sub>B \<phi>)" using Fr_4_def by blast
qed

(**Border operator as derived from interior.*)
definition Br_int::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<B>\<^sub>I") where "\<B>\<^sub>I \<I> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> (\<I> A)"
lemma BI1: "Int_1 \<phi> \<Longrightarrow>  Br_1 (\<B>\<^sub>I \<phi>)" using Br_1_def Br_int_def MULT_def conn by auto
lemma BI2: "Int_3 \<phi> \<Longrightarrow>  Br_2 (\<B>\<^sub>I \<phi>)" by (simp add: Br_2_def Br_int_def dNOR_def conn)
lemma BI3: "Int_1a \<phi> \<Longrightarrow> Int_4 \<phi> \<Longrightarrow> Br_3 (\<B>\<^sub>I \<phi>)" unfolding Br_int_def Br_3_def dual_def by (smt Int_9_def MONO_MULTa PI9 conn)

(**Border operator as derived from closure.*)
definition Br_cl::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<B>\<^sub>C")  where "\<B>\<^sub>C \<C> \<equiv> \<lambda>A. A \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)"
lemma BC1: "Cl_1 \<phi> \<Longrightarrow>  Br_1(\<B>\<^sub>C \<phi>)" using Br_1_def Br_cl_def CI1 MULT_def dual_def unfolding conn by smt
lemma BC2: "Cl_3 \<phi> \<Longrightarrow>  Br_2(\<B>\<^sub>C \<phi>)" using Br_2_def Br_cl_def CI3 dNOR_def dual_def unfolding conn by auto
lemma BC3: "Cl_1b \<phi> \<Longrightarrow> Cl_4 \<phi> \<Longrightarrow> Br_3 (\<B>\<^sub>C \<phi>)" unfolding Br_cl_def Br_3_def dual_def conn by (metis (mono_tags, lifting) Cl_9_def MONO_ADDIb PC9)

(**Note that the previous two conversion functions are related:*)
lemma BI_BC_rel: "(\<B>\<^sub>I \<phi>) = \<B>\<^sub>C(\<phi>\<^sup>d)" by (simp add: Br_cl_def Br_int_def dual_def conn)

(**Border operator as derived from frontier.*)
definition Br_fr::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<B>\<^sub>F") where "\<B>\<^sub>F \<F> \<equiv> \<lambda>A. A \<^bold>\<and> (\<F> A)"
lemma BF1: "Fr_1 \<phi> \<Longrightarrow> Br_1(\<B>\<^sub>F \<phi>)" using Br_1_def Br_fr_def Fr_1_def conn by auto
lemma BF2: "Fr_2 \<phi> \<Longrightarrow> Fr_3 \<phi> \<Longrightarrow> Br_2(\<B>\<^sub>F \<phi>)" using Br_2_def Br_fr_def Fr_2_def NOR_def unfolding conn by fastforce
lemma BF3: "Fr_1b \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Br_3(\<B>\<^sub>F \<phi>)" proof -
  assume fr1b: "Fr_1b \<phi>" and fr2: "Fr_2 \<phi>" and fr4: "Fr_4 \<phi>"
  { fix A
    from fr1b fr2 have "let M= \<^bold>\<midarrow>A \<^bold>\<and> \<phi> A ; N= \<phi> A in M \<^bold>\<preceq> N \<longrightarrow> (\<phi> M \<^bold>\<preceq> N \<^bold>\<or> \<phi> N)" using PF1 PF6 by (simp add: Fr_6_def)
    hence "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A) \<^bold>\<preceq> \<phi> A \<^bold>\<or> \<phi>(\<phi> A)" unfolding conn by meson
    hence "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A) \<^bold>\<preceq> \<phi> A" using Fr_4_def fr4 unfolding conn by metis
    hence aux: "\<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A) \<^bold>\<and> \<^bold>\<midarrow>(\<phi> A) \<^bold>\<approx> \<^bold>\<bottom>" unfolding conn by blast
    have "(\<B>\<^sub>F \<phi>)((\<B>\<^sub>F \<phi>)\<^sup>d A) = \<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A)) \<^bold>\<and> \<phi>(\<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A)))" unfolding Br_fr_def dual_def by simp
    also have "... = (A \<^bold>\<or> \<^bold>\<midarrow>\<phi> A) \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A)" using Fr_2_def fr2 unfolding conn by force
    also have "... = (A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A)) \<^bold>\<or> (\<^bold>\<midarrow>\<phi> A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A))" unfolding conn by auto
    also have "... = (A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A))" using aux unfolding conn by blast
    finally have "(\<B>\<^sub>F \<phi>)((\<B>\<^sub>F \<phi>)\<^sup>d A) = A \<^bold>\<and> \<phi>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> A)" unfolding Br_fr_def dual_def conn by simp
  } thus "Br_3(\<B>\<^sub>F \<phi>)" unfolding Br_3_def Br_fr_def conn by meson
qed

(**Interior operator as derived from border.*)
definition Int_br::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<I>\<^sub>B") where "\<I>\<^sub>B \<B> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> (\<B> A)"
lemma IB1: "Br_1 \<phi> \<Longrightarrow> Int_1(\<I>\<^sub>B \<phi>)" using Br_1_def MULT_def Int_br_def conn by auto
lemma IB2: "Int_2(\<I>\<^sub>B \<phi>)" by (simp add: dEXP_def Int_br_def conn)
lemma IB3: "Br_2 \<phi> \<Longrightarrow> Int_3(\<I>\<^sub>B \<phi>)" by (simp add: Br_2_def dNOR_def Int_br_def conn)
lemma IB4: "Br_1 \<phi> \<Longrightarrow> Br_3 \<phi> \<Longrightarrow> Int_4(\<I>\<^sub>B \<phi>)" unfolding Int_br_def IDEM_def conn
  using Br_1_def Br_5c_def Br_5d_def PB5c PB5d dual_def unfolding conn by (metis (full_types))

(**Interior operator as derived from frontier.*)
definition Int_fr::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<I>\<^sub>F") where "\<I>\<^sub>F \<F> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> (\<F> A)"
lemma IF1a: "Fr_1b \<phi> \<Longrightarrow> Int_1a(\<I>\<^sub>F \<phi>)" using Fr_1b_def MULT_a_def Int_fr_def conn by auto
lemma IF1b: "Fr_1a \<phi> \<Longrightarrow> Int_1b(\<I>\<^sub>F \<phi>)" using Fr_1a_def MULT_b_def Int_fr_def conn by auto
lemma IF1: "Fr_1 \<phi> \<Longrightarrow> Int_1(\<I>\<^sub>F \<phi>)" by (simp add: IF1a IF1b PF1 PI1)
lemma IF2: "Int_2(\<I>\<^sub>F \<phi>)" by (simp add: dEXP_def Int_fr_def conn)
lemma IF3: "Fr_2 \<phi> \<Longrightarrow> Fr_3 \<phi> \<Longrightarrow> Int_3(\<I>\<^sub>F \<phi>)" using BF2 Br_2_def Br_fr_def dNOR_def Int_fr_def unfolding conn by auto
lemma IF4: "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Int_4(\<I>\<^sub>F \<phi>)"
  using Fr_1a_def Fr_2_def Fr_4_def unfolding Int_fr_def IDEM_def conn by metis

(**Closure operator as derived from border.*)
definition Cl_br::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>B") where "\<C>\<^sub>B \<B> \<equiv> \<lambda>A. A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)"

(**Closure operator as derived from frontier.*)
definition Cl_fr::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>F") where "\<C>\<^sub>F \<F> \<equiv> \<lambda>A. A \<^bold>\<or> (\<F> A)"
lemma CF1b: "Fr_1b \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1b(\<C>\<^sub>F \<phi>)" using Cl_fr_def Fr_6_def MONO_def MONO_ADDIb PF6 unfolding conn by auto
lemma CF1a: "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1a(\<C>\<^sub>F \<phi>)" proof -
  have aux: "Fr_2 \<phi> \<Longrightarrow> (\<I>\<^sub>F \<phi>)\<^sup>d = (\<C>\<^sub>F \<phi>)" by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def conn)
  hence "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1a(\<I>\<^sub>F \<phi>)\<^sup>d" using IC1b IF1b by blast
  thus "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1a(\<C>\<^sub>F \<phi>)" using ADDI_a_def aux unfolding conn by simp
qed
lemma CF1: "Fr_1 \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Cl_1(\<C>\<^sub>F \<phi>)" by (simp add: CF1a CF1b PC1 PF1)
lemma CF2: "Cl_2(\<C>\<^sub>F \<phi>)" by (simp add: EXP_def Cl_fr_def conn)
lemma CF3: "Fr_3 \<phi> \<Longrightarrow> Cl_3(\<C>\<^sub>F \<phi>)" by (simp add: Cl_fr_def NOR_def conn)
lemma CF4: "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Cl_4(\<C>\<^sub>F \<phi>)" proof -
  have aux: "Fr_2 \<phi> \<Longrightarrow> (\<I>\<^sub>F \<phi>)\<^sup>d = (\<C>\<^sub>F \<phi>)"  by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def conn)
  hence "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Cl_4(\<I>\<^sub>F \<phi>)\<^sup>d" using IC4 IF4 by blast
  thus "Fr_1a \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> Fr_4 \<phi> \<Longrightarrow> Cl_4(\<C>\<^sub>F \<phi>)" by (simp add: aux)
qed

subsubsection \<open>Infinitary conditions\<close>

(**We define the essential infinitary conditions for the closure and interior operators (entailing infinite
additivity and multiplicativity resp.). Observe that the other direction is implied by monotonicity (MONO).*)
abbreviation "Cl_inf \<phi> \<equiv> iADDI_a(\<phi>)"
abbreviation "Int_inf \<phi> \<equiv> iMULT_b(\<phi>)"

(**There exists indeed a condition on frontier operators responsible for the infinitary conditions above:*)
definition "Fr_inf \<phi> \<equiv> \<forall>S. \<^bold>\<And>S \<^bold>\<and> \<phi>(\<^bold>\<And>S) \<^bold>\<preceq> \<^bold>\<And>S \<^bold>\<and> \<^bold>\<Or>Ra[\<phi>|S]"

lemma CF_inf: "Fr_2 \<phi> \<Longrightarrow> Fr_inf \<phi> \<Longrightarrow> Cl_inf(\<C>\<^sub>F \<phi>)" unfolding iADDI_a_def  Fr_inf_def
  by (smt Cl_fr_def Fr_2_def Ra_restr_ex compl_def dom_compl_def2 iDM_b join_def meet_def supremum_def)
lemma IF_inf: "Fr_inf \<phi> \<Longrightarrow> Int_inf(\<I>\<^sub>F \<phi>)" unfolding Fr_inf_def iMULT_b_def Int_fr_def Ra_restr_all
  by (metis (mono_tags, hide_lams) diff_def infimum_def meet_def pfunRange_restr_def supremum_def)

(**This condition is indeed strong enough to entail closure of the fixed-point predicates under infimum/supremum.*)
lemma fp_IF_inf_closed: "Fr_inf \<phi> \<Longrightarrow> infimum_closed (fp (\<I>\<^sub>F \<phi>))" by (metis (full_types) IF2 IF_inf Ra_restr_all dEXP_def iMULT_b_def infimum_def)
lemma fp_CF_sup_closed: "Fr_inf \<phi> \<Longrightarrow> Fr_2 \<phi> \<Longrightarrow> supremum_closed (fp (\<C>\<^sub>F \<phi>))" by (metis (full_types) CF2 CF_inf EXP_def Ra_restr_ex iADDI_a_def supremum_def)

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/TBA/operators_basic.thy


section \<open>Elementary Group Constructions\<close>

(*  Title:      HOL/Algebra/Elementary_Groups.thy
    Author:     LC Paulson, ported from HOL Light
*)

theory Elementary_Groups
imports Generated_Groups Multiplicative_Group "HOL-Library.Infinite_Set"
begin

subsection\<open>Direct sum/product lemmas\<close>

locale group_disjoint_sum = group G + AG: subgroup A G + BG: subgroup B G for G (structure) and A B
begin

lemma subset_one: "A \<inter> B \<subseteq> {\<one>} \<longleftrightarrow> A \<inter> B = {\<one>}"
  by  auto

lemma sub_id_iff: "A \<inter> B \<subseteq> {\<one>} \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = \<one> \<longrightarrow> x = \<one> \<and> y = \<one>)"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> inv y = \<one> \<longrightarrow> x = \<one> \<and> inv y = \<one>)"
  proof (intro ballI iffI impI)
    fix x y
    assume "A \<inter> B \<subseteq> {\<one>}" "x \<in> A" "y \<in> B" "x \<otimes> inv y = \<one>"
    then have "y = x"
      using group.inv_equality group_l_invI by fastforce
    then show "x = \<one> \<and> inv y = \<one>"
      using \<open>A \<inter> B \<subseteq> {\<one>}\<close> \<open>x \<in> A\<close> \<open>y \<in> B\<close> by fastforce
  next
    assume "\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> inv y = \<one> \<longrightarrow> x = \<one> \<and> inv y = \<one>"
    then show "A \<inter> B \<subseteq> {\<one>}"
      by auto
  qed
  also have "\<dots> = ?rhs"
    by (metis BG.mem_carrier BG.subgroup_axioms inv_inv subgroup_def)
  finally show ?thesis .
qed

lemma cancel: "A \<inter> B \<subseteq> {\<one>} \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. \<forall>x'\<in>A. \<forall>y'\<in>B. x \<otimes> y = x' \<otimes> y' \<longrightarrow> x = x' \<and> y = y')"
        (is "?lhs = ?rhs")
proof -
  have "(\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = \<one> \<longrightarrow> x = \<one> \<and> y = \<one>) = ?rhs"
    (is "?med = _")
  proof (intro ballI iffI impI)
    fix x y x' y'
    assume * [rule_format]: "\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = \<one> \<longrightarrow> x = \<one> \<and> y = \<one>"
      and AB: "x \<in> A" "y \<in> B" "x' \<in> A" "y' \<in> B" and eq: "x \<otimes> y = x' \<otimes> y'"
    then have carr: "x \<in> carrier G" "x' \<in> carrier G" "y \<in> carrier G" "y' \<in> carrier G"
      using AG.subset BG.subset by auto
    then have "inv x' \<otimes> x \<otimes> (y \<otimes> inv y') = inv x' \<otimes> (x \<otimes> y) \<otimes> inv y'"
      by (simp add: m_assoc)
    also have "\<dots> = \<one>"
      using carr  by (simp add: eq) (simp add: m_assoc)
    finally have 1: "inv x' \<otimes> x \<otimes> (y \<otimes> inv y') = \<one>" .
    show "x = x' \<and> y = y'"
      using * [OF _ _ 1] AB by simp (metis carr inv_closed inv_inv local.inv_equality)
  next
    fix x y
    assume * [rule_format]: "\<forall>x\<in>A. \<forall>y\<in>B. \<forall>x'\<in>A. \<forall>y'\<in>B. x \<otimes> y = x' \<otimes> y' \<longrightarrow> x = x' \<and> y = y'"
      and xy: "x \<in> A" "y \<in> B" "x \<otimes> y = \<one>"
    show "x = \<one> \<and> y = \<one>"
      by (rule *) (use xy in auto)
  qed
  then show ?thesis
    by (simp add: sub_id_iff)
qed

lemma commuting_imp_normal1:
  assumes sub: "carrier G \<subseteq> A <#> B"
     and mult: "\<And>x y. \<lbrakk>x \<in> A; y \<in> B\<rbrakk> \<Longrightarrow> x \<otimes> y = y \<otimes> x"
   shows "A \<lhd> G"
proof -
  have AB: "A \<subseteq> carrier G \<and> B \<subseteq> carrier G"
    by (simp add: AG.subset BG.subset)
  have "A #> x = x <# A"
    if x: "x \<in> carrier G" for x
  proof -
    obtain a b where xeq: "x = a \<otimes> b" and "a \<in> A" "b \<in> B" and carr: "a \<in> carrier G" "b \<in> carrier G"
      using x sub AB by (force simp: set_mult_def)
    have Ab: "A <#> {b} = {b} <#> A"
      using AB \<open>a \<in> A\<close> \<open>b \<in> B\<close> mult
      by (force simp: set_mult_def m_assoc subset_iff)
    have "A #> x = A <#> {a \<otimes> b}"
      by (auto simp: l_coset_eq_set_mult r_coset_eq_set_mult xeq)
    also have "\<dots> = A <#> {a} <#> {b}"
      using AB \<open>a \<in> A\<close> \<open>b \<in> B\<close>
      by (auto simp: set_mult_def m_assoc subset_iff)
    also have "\<dots> = {a} <#> A <#> {b}"
      by (metis AG.rcos_const AG.subgroup_axioms \<open>a \<in> A\<close> coset_join3 is_group l_coset_eq_set_mult r_coset_eq_set_mult subgroup.mem_carrier)
    also have "\<dots> = {a} <#> {b} <#> A"
      by (simp add: is_group carr group.set_mult_assoc AB Ab)
    also have "\<dots> = {x} <#> A"
      by (auto simp: set_mult_def xeq)
    finally show "A #> x = x <# A"
      by (simp add: l_coset_eq_set_mult)
  qed
  then show ?thesis
    by (auto simp: normal_def normal_axioms_def AG.subgroup_axioms is_group)
qed

lemma commuting_imp_normal2:
  assumes"carrier G \<subseteq> A <#> B"  "\<And>x y. \<lbrakk>x \<in> A; y \<in> B\<rbrakk> \<Longrightarrow> x \<otimes> y = y \<otimes> x"
  shows "B \<lhd> G"
proof (rule group_disjoint_sum.commuting_imp_normal1)
  show "group_disjoint_sum G B A"
  proof qed
next
  show "carrier G \<subseteq> B <#> A"
    using BG.subgroup_axioms assms commut_normal commuting_imp_normal1 by blast
qed (use assms in auto)

lemma (in group) normal_imp_commuting:
  assumes "A \<lhd> G" "B \<lhd> G" "A \<inter> B \<subseteq> {\<one>}" "x \<in> A" "y \<in> B"
  shows "x \<otimes> y = y \<otimes> x"
proof -
  interpret AG: normal A G
    using assms by auto
  interpret BG: normal B G
    using assms by auto
  interpret group_disjoint_sum G A B
  proof qed
  have * [rule_format]: "(\<forall>x\<in>A. \<forall>y\<in>B. \<forall>x'\<in>A. \<forall>y'\<in>B. x \<otimes> y = x' \<otimes> y' \<longrightarrow> x = x' \<and> y = y')"
    using cancel assms by (auto simp: normal_def)
  have carr: "x \<in> carrier G" "y \<in> carrier G"
    using assms AG.subset BG.subset by auto
  then show ?thesis
    using * [of x _ _ y] AG.coset_eq [rule_format, of y] BG.coset_eq [rule_format, of x]
    by (clarsimp simp: l_coset_def r_coset_def set_eq_iff) (metis \<open>x \<in> A\<close> \<open>y \<in> B\<close>)
qed

lemma normal_eq_commuting:
  assumes "carrier G \<subseteq> A <#> B" "A \<inter> B \<subseteq> {\<one>}"
  shows "A \<lhd> G \<and> B \<lhd> G \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = y \<otimes> x)"
  by (metis assms commuting_imp_normal1 commuting_imp_normal2 normal_imp_commuting)

lemma (in group) hom_group_mul_rev:
  assumes "(\<lambda>(x,y). x \<otimes> y) \<in> hom (subgroup_generated G A \<times>\<times> subgroup_generated G B) G"
          (is "?h \<in> hom ?P G")
   and "x \<in> carrier G" "y \<in> carrier G" "x \<in> A" "y \<in> B"
 shows "x \<otimes> y = y \<otimes> x"
proof -
  interpret P: group_hom ?P G ?h
    by (simp add: assms DirProd_group group_hom.intro group_hom_axioms.intro is_group)
  have xy: "(x,y) \<in> carrier ?P"
    by (auto simp: assms carrier_subgroup_generated generate.incl)
  have "x \<otimes> (x \<otimes> (y \<otimes> y)) = x \<otimes> (y \<otimes> (x \<otimes> y))"
    using P.hom_mult [OF xy xy] by (simp add: m_assoc assms)
  then have "x \<otimes> (y \<otimes> y) = y \<otimes> (x \<otimes> y)"
    using assms by simp
  then show ?thesis
    by (simp add: assms flip: m_assoc)
qed

lemma hom_group_mul_eq:
   "(\<lambda>(x,y). x \<otimes> y) \<in> hom (subgroup_generated G A \<times>\<times> subgroup_generated G B) G
     \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = y \<otimes> x)"
         (is "?lhs = ?rhs")
proof
  assume ?lhs then show ?rhs
    using hom_group_mul_rev AG.subset BG.subset by blast
next
  assume R: ?rhs
  have subG: "generate G (carrier G \<inter> A) \<subseteq> carrier G" for A
    by (simp add: generate_incl)
  have *: "x \<otimes> u \<otimes> (y \<otimes> v) = x \<otimes> y \<otimes> (u \<otimes> v)"
    if eq [rule_format]: "\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = y \<otimes> x"
      and gen: "x \<in> generate G (carrier G \<inter> A)" "y \<in> generate G (carrier G \<inter> B)"
      "u \<in> generate G (carrier G \<inter> A)" "v \<in> generate G (carrier G \<inter> B)"
    for x y u v
  proof -
    have "u \<otimes> y = y \<otimes> u"
      by (metis AG.carrier_subgroup_generated_subgroup BG.carrier_subgroup_generated_subgroup carrier_subgroup_generated eq that(3) that(4))
    then have "x \<otimes> u \<otimes> y = x \<otimes> y \<otimes> u"
      using gen by (simp add: m_assoc subsetD [OF subG])
    then show ?thesis
      using gen by (simp add: subsetD [OF subG] flip: m_assoc)
  qed
  show ?lhs
    using R by (auto simp: hom_def carrier_subgroup_generated subsetD [OF subG] *)
qed

lemma epi_group_mul_eq:
   "(\<lambda>(x,y). x \<otimes> y) \<in> epi (subgroup_generated G A \<times>\<times> subgroup_generated G B) G
     \<longleftrightarrow> A <#> B = carrier G \<and> (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = y \<otimes> x)"
proof -
  have subGA: "generate G (carrier G \<inter> A) \<subseteq> A"
    by (simp add: AG.subgroup_axioms generate_subgroup_incl)
  have subGB: "generate G (carrier G \<inter> B) \<subseteq> B"
    by (simp add: BG.subgroup_axioms generate_subgroup_incl)
  have "(((\<lambda>(x, y). x \<otimes> y) ` (generate G (carrier G \<inter> A) \<times> generate G (carrier G \<inter> B)))) = ((A <#> B))"
    by (auto simp: set_mult_def generate.incl pair_imageI dest: subsetD [OF subGA] subsetD [OF subGB])
  then show ?thesis
    by (auto simp: epi_def hom_group_mul_eq carrier_subgroup_generated)
qed

lemma mon_group_mul_eq:
    "(\<lambda>(x,y). x \<otimes> y) \<in> mon (subgroup_generated G A \<times>\<times> subgroup_generated G B) G
     \<longleftrightarrow> A \<inter> B = {\<one>} \<and> (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = y \<otimes> x)"
proof -
  have subGA: "generate G (carrier G \<inter> A) \<subseteq> A"
    by (simp add: AG.subgroup_axioms generate_subgroup_incl)
  have subGB: "generate G (carrier G \<inter> B) \<subseteq> B"
    by (simp add: BG.subgroup_axioms generate_subgroup_incl)
  show ?thesis
    apply (auto simp: mon_def hom_group_mul_eq simp flip: subset_one)
     apply (simp_all (no_asm_use) add: inj_on_def AG.carrier_subgroup_generated_subgroup BG.carrier_subgroup_generated_subgroup)
    using cancel apply blast+
    done
qed

lemma iso_group_mul_alt:
    "(\<lambda>(x,y). x \<otimes> y) \<in> iso (subgroup_generated G A \<times>\<times> subgroup_generated G B) G
     \<longleftrightarrow> A \<inter> B = {\<one>} \<and> A <#> B = carrier G \<and> (\<forall>x\<in>A. \<forall>y\<in>B. x \<otimes> y = y \<otimes> x)"
  by (auto simp: iso_iff_mon_epi mon_group_mul_eq epi_group_mul_eq)

lemma iso_group_mul_eq:
    "(\<lambda>(x,y). x \<otimes> y) \<in> iso (subgroup_generated G A \<times>\<times> subgroup_generated G B) G
     \<longleftrightarrow> A \<inter> B = {\<one>} \<and> A <#> B = carrier G \<and> A \<lhd> G \<and> B \<lhd> G"
  by (simp add: iso_group_mul_alt normal_eq_commuting cong: conj_cong)

lemma (in group) iso_group_mul_gen:
  assumes "A \<lhd> G" "B \<lhd> G"
  shows "(\<lambda>(x,y). x \<otimes> y) \<in> iso (subgroup_generated G A \<times>\<times> subgroup_generated G B) G
     \<longleftrightarrow> A \<inter> B \<subseteq> {\<one>} \<and> A <#> B = carrier G"
proof -
  interpret group_disjoint_sum G A B
    using assms by (auto simp: group_disjoint_sum_def normal_def)
  show ?thesis
    by (simp add: subset_one iso_group_mul_eq assms)
qed

lemma iso_group_mul:
  assumes "comm_group G"
  shows "((\<lambda>(x,y). x \<otimes> y) \<in> iso (DirProd (subgroup_generated G A) (subgroup_generated G B)) G
     \<longleftrightarrow> A \<inter> B \<subseteq> {\<one>} \<and> A <#> B = carrier G)"
proof (rule iso_group_mul_gen)
  interpret comm_group
    by (rule assms)
  show "A \<lhd> G"
    by (simp add: AG.subgroup_axioms subgroup_imp_normal)
  show "B \<lhd> G"
    by (simp add: BG.subgroup_axioms subgroup_imp_normal)
qed

end

subsection\<open>The one-element group on a given object\<close>

definition singleton_group :: "'a \<Rightarrow> 'a monoid"
  where "singleton_group a = \<lparr>carrier = {a}, monoid.mult = (\<lambda>x y. a), one = a\<rparr>"

lemma singleton_group [simp]: "group (singleton_group a)"
  unfolding singleton_group_def by (auto intro: groupI)

lemma singleton_abelian_group [simp]: "comm_group (singleton_group a)"
  by (metis group.group_comm_groupI monoid.simps(1) singleton_group singleton_group_def)

lemma carrier_singleton_group [simp]: "carrier (singleton_group a) = {a}"
  by (auto simp: singleton_group_def)

lemma (in group) hom_into_singleton_iff [simp]:
  "h \<in> hom G (singleton_group a) \<longleftrightarrow> h \<in> carrier G \<rightarrow> {a}"
  by (auto simp: hom_def singleton_group_def)

declare group.hom_into_singleton_iff [simp]

lemma (in group) id_hom_singleton: "id \<in> hom (singleton_group \<one>) G"
  by (simp add: hom_def singleton_group_def)

subsection\<open>Similarly, trivial groups\<close>

definition trivial_group :: "('a, 'b) monoid_scheme \<Rightarrow> bool"
  where "trivial_group G \<equiv> group G \<and> carrier G = {one G}"

lemma trivial_imp_finite_group:
   "trivial_group G \<Longrightarrow> finite(carrier G)"
  by (simp add: trivial_group_def)

lemma trivial_singleton_group [simp]: "trivial_group(singleton_group a)"
  by (metis monoid.simps(2) partial_object.simps(1) singleton_group singleton_group_def trivial_group_def)

lemma (in group) trivial_group_subset:
   "trivial_group G \<longleftrightarrow> carrier G \<subseteq> {one G}"
  using is_group trivial_group_def by fastforce

lemma (in group) trivial_group: "trivial_group G \<longleftrightarrow> (\<exists>a. carrier G = {a})"
  unfolding trivial_group_def using one_closed is_group by fastforce

lemma (in group) trivial_group_alt:
   "trivial_group G \<longleftrightarrow> (\<exists>a. carrier G \<subseteq> {a})"
  by (auto simp: trivial_group)

lemma (in group) trivial_group_subgroup_generated:
  assumes "S \<subseteq> {one G}"
  shows "trivial_group(subgroup_generated G S)"
proof -
  have "carrier (subgroup_generated G S) \<subseteq> {\<one>}"
    using generate_empty generate_one subset_singletonD assms
    by (fastforce simp add: carrier_subgroup_generated)
  then show ?thesis
    by (simp add: group.trivial_group_subset)
qed

lemma (in group) trivial_group_subgroup_generated_eq:
  "trivial_group(subgroup_generated G s) \<longleftrightarrow> carrier G \<inter> s \<subseteq> {one G}"
  apply (rule iffI)
   apply (force simp: trivial_group_def carrier_subgroup_generated generate.incl)
  by (metis subgroup_generated_restrict trivial_group_subgroup_generated)

lemma isomorphic_group_triviality1:
  assumes "G \<cong> H" "group H" "trivial_group G"
  shows "trivial_group H"
  using assms
  by (auto simp: trivial_group_def is_iso_def iso_def group.is_monoid Group.group_def bij_betw_def hom_one)

lemma isomorphic_group_triviality:
  assumes "G \<cong> H" "group G" "group H"
  shows "trivial_group G \<longleftrightarrow> trivial_group H"
  by (meson assms group.iso_sym isomorphic_group_triviality1)

lemma (in group_hom) kernel_from_trivial_group:
   "trivial_group G \<Longrightarrow> kernel G H h = carrier G"
  by (auto simp: trivial_group_def kernel_def)

lemma (in group_hom) image_from_trivial_group:
   "trivial_group G \<Longrightarrow> h ` carrier G = {one H}"
  by (auto simp: trivial_group_def)

lemma (in group_hom) kernel_to_trivial_group:
   "trivial_group H \<Longrightarrow> kernel G H h = carrier G"
  unfolding kernel_def trivial_group_def
  using hom_closed by blast

subsection\<open>The additive group of integers\<close>

definition integer_group
  where "integer_group = \<lparr>carrier = UNIV, monoid.mult = (+), one = (0::int)\<rparr>"

lemma group_integer_group [simp]: "group integer_group"
  unfolding integer_group_def
proof (rule groupI; simp)
  show "\<And>x::int. \<exists>y. y + x = 0"
  by presburger
qed

lemma carrier_integer_group [simp]: "carrier integer_group = UNIV"
  by (auto simp: integer_group_def)

lemma one_integer_group [simp]: "\<one>\<^bsub>integer_group\<^esub> = 0"
  by (auto simp: integer_group_def)

lemma mult_integer_group [simp]: "x \<otimes>\<^bsub>integer_group\<^esub> y = x + y"
  by (auto simp: integer_group_def)

lemma inv_integer_group [simp]: "inv\<^bsub>integer_group\<^esub> x = -x"
  by (rule group.inv_equality [OF group_integer_group]) (auto simp: integer_group_def)

lemma abelian_integer_group: "comm_group integer_group"
  by (rule group.group_comm_groupI [OF group_integer_group]) (auto simp: integer_group_def)

lemma group_nat_pow_integer_group [simp]:
  fixes n::nat and x::int
  shows "pow integer_group x n = int n * x"
  by (induction n) (auto simp: integer_group_def algebra_simps)

lemma group_int_pow_integer_group [simp]:
  fixes n::int and x::int
  shows "pow integer_group x n = n * x"
  by (simp add: int_pow_def2)

lemma (in group) hom_integer_group_pow:
   "x \<in> carrier G \<Longrightarrow> pow G x \<in> hom integer_group G"
  by (rule homI) (auto simp: int_pow_mult)

subsection\<open>Additive group of integers modulo n (n = 0 gives just the integers)\<close>

definition integer_mod_group :: "nat \<Rightarrow> int monoid"
  where
  "integer_mod_group n \<equiv>
     if n = 0 then integer_group
     else \<lparr>carrier = {0..<int n}, monoid.mult = (\<lambda>x y. (x+y) mod int n), one = 0\<rparr>"

lemma carrier_integer_mod_group:
  "carrier(integer_mod_group n) = (if n=0 then UNIV else {0..<int n})"
  by (simp add: integer_mod_group_def)

lemma one_integer_mod_group[simp]: "one(integer_mod_group n) = 0"
  by (simp add: integer_mod_group_def)

lemma mult_integer_mod_group[simp]: "monoid.mult(integer_mod_group n) = (\<lambda>x y. (x + y) mod int n)"
  by (simp add: integer_mod_group_def integer_group_def)

lemma group_integer_mod_group [simp]: "group (integer_mod_group n)"
proof -
  have *: "\<exists>y\<ge>0. y < int n \<and> (y + x) mod int n = 0" if "x < int n" "0 \<le> x" for x
  proof (cases "x=0")
    case False
    with that show ?thesis
      by (rule_tac x="int n - x" in exI) auto
  qed (use that in auto)
  show ?thesis
    apply (rule groupI)
        apply (auto simp: integer_mod_group_def Bex_def *, presburger+)
    done
qed

lemma inv_integer_mod_group[simp]:
  "x \<in> carrier (integer_mod_group n) \<Longrightarrow> m_inv(integer_mod_group n) x = (-x) mod int n"
  by (rule group.inv_equality [OF group_integer_mod_group]) (auto simp: integer_mod_group_def add.commute mod_add_right_eq)

lemma pow_integer_mod_group [simp]:
  fixes m::nat
  shows "pow (integer_mod_group n) x m = (int m * x) mod int n"
proof (cases "n=0")
  case False
  show ?thesis
    by (induction m) (auto simp: add.commute mod_add_right_eq distrib_left mult.commute)
qed (simp add: integer_mod_group_def)

lemma int_pow_integer_mod_group:
  "pow (integer_mod_group n) x m = (m * x) mod int n"
proof -
  have "inv\<^bsub>integer_mod_group n\<^esub> (- (m * x) mod int n) = m * x mod int n"
    by (simp add: carrier_integer_mod_group mod_minus_eq)
  then show ?thesis
    by (simp add: int_pow_def2)
qed

lemma abelian_integer_mod_group [simp]: "comm_group(integer_mod_group n)"
  by (simp add: add.commute group.group_comm_groupI)

lemma integer_mod_group_0 [simp]: "0 \<in> carrier(integer_mod_group n)"
  by (simp add: integer_mod_group_def)

lemma integer_mod_group_1 [simp]: "1 \<in> carrier(integer_mod_group n) \<longleftrightarrow> (n \<noteq> 1)"
  by (auto simp: integer_mod_group_def)

lemma trivial_integer_mod_group: "trivial_group(integer_mod_group n) \<longleftrightarrow> n = 1"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
  by (simp add: trivial_group_def carrier_integer_mod_group set_eq_iff split: if_split_asm) (presburger+)
next
  assume ?rhs
  then show ?lhs
    by (force simp: trivial_group_def carrier_integer_mod_group)
qed

subsection\<open>Cyclic groups\<close>

lemma (in group) subgroup_of_powers:
  "x \<in> carrier G \<Longrightarrow> subgroup (range (\<lambda>n::int. x [^] n)) G"
  apply (auto simp: subgroup_def image_iff simp flip: int_pow_mult int_pow_neg)
  apply (metis group.int_pow_diff int_pow_closed is_group r_inv)
  done

lemma (in group) carrier_subgroup_generated_by_singleton:
  assumes "x \<in> carrier G"
  shows "carrier(subgroup_generated G {x}) = (range (\<lambda>n::int. x [^] n))"
proof
  show "carrier (subgroup_generated G {x}) \<subseteq> range (\<lambda>n::int. x [^] n)"
  proof (rule subgroup_generated_minimal)
    show "subgroup (range (\<lambda>n::int. x [^] n)) G"
      using assms subgroup_of_powers by blast
    show "{x} \<subseteq> range (\<lambda>n::int. x [^] n)"
      by clarify (metis assms int_pow_1 range_eqI)
  qed
  have x: "x \<in> carrier (subgroup_generated G {x})"
    using assms subgroup_generated_subset_carrier_subset by auto
  show "range (\<lambda>n::int. x [^] n) \<subseteq> carrier (subgroup_generated G {x})"
  proof clarify
    fix n :: "int"
    show "x [^] n \<in> carrier (subgroup_generated G {x})"
        by (simp add: x subgroup_int_pow_closed subgroup_subgroup_generated)
  qed
qed

definition cyclic_group
  where "cyclic_group G \<equiv> \<exists>x \<in> carrier G. subgroup_generated G {x} = G"

lemma (in group) cyclic_group:
  "cyclic_group G \<longleftrightarrow> (\<exists>x \<in> carrier G. carrier G = range (\<lambda>n::int. x [^] n))"
proof -
  have "\<And>x. \<lbrakk>x \<in> carrier G; carrier G = range (\<lambda>n::int. x [^] n)\<rbrakk>
         \<Longrightarrow> \<exists>x\<in>carrier G. subgroup_generated G {x} = G"
    by (rule_tac x=x in bexI) (auto simp: generate_pow subgroup_generated_def intro!: monoid.equality)
  then show ?thesis
    unfolding cyclic_group_def
    using carrier_subgroup_generated_by_singleton by fastforce
qed

lemma cyclic_integer_group [simp]: "cyclic_group integer_group"
proof -
  have *: "int n \<in> generate integer_group {1}" for n
  proof (induction n)
    case 0
    then show ?case
    using generate.simps by force
  next
    case (Suc n)
    then show ?case
    by simp (metis generate.simps insert_subset integer_group_def monoid.simps(1) subsetI)
  qed
  have **: "i \<in> generate integer_group {1}" for i
  proof (cases i rule: int_cases)
    case (nonneg n)
    then show ?thesis
      by (simp add: *)
  next
    case (neg n)
    then have "-i \<in> generate integer_group {1}"
      by (metis "*" add.inverse_inverse)
    then have "- (-i) \<in> generate integer_group {1}"
      by (metis UNIV_I group.generate_m_inv_closed group_integer_group integer_group_def inv_integer_group partial_object.select_convs(1) subsetI)
    then show ?thesis
      by simp
  qed
  show ?thesis
    unfolding cyclic_group_def
    by (rule_tac x=1 in bexI)
       (auto simp: carrier_subgroup_generated ** intro: monoid.equality)
qed

lemma nontrivial_integer_group [simp]: "\<not> trivial_group integer_group"
  using integer_mod_group_def trivial_integer_mod_group by presburger

lemma (in group) cyclic_imp_abelian_group:
  "cyclic_group G \<Longrightarrow> comm_group G"
  apply (auto simp: cyclic_group comm_group_def is_group intro!: monoid_comm_monoidI)
  apply (metis add.commute int_pow_mult rangeI)
  done

lemma trivial_imp_cyclic_group:
   "trivial_group G \<Longrightarrow> cyclic_group G"
  by (metis cyclic_group_def group.subgroup_generated_group_carrier insertI1 trivial_group_def)

lemma (in group) cyclic_group_alt:
   "cyclic_group G \<longleftrightarrow> (\<exists>x. subgroup_generated G {x} = G)"
proof safe
  fix x
  assume *: "subgroup_generated G {x} = G"
  show "cyclic_group G"
  proof (cases "x \<in> carrier G")
    case True
    then show ?thesis
      using \<open>subgroup_generated G {x} = G\<close> cyclic_group_def by blast
  next
    case False
    then show ?thesis
      by (metis "*" Int_empty_right Int_insert_right_if0 carrier_subgroup_generated generate_empty trivial_group trivial_imp_cyclic_group)
  qed
qed (auto simp: cyclic_group_def)

lemma (in group) cyclic_group_generated:
  "cyclic_group (subgroup_generated G {x})"
  using group.cyclic_group_alt group_subgroup_generated subgroup_generated2 by blast

lemma (in group) cyclic_group_epimorphic_image:
  assumes "h \<in> epi G H" "cyclic_group G" "group H"
  shows "cyclic_group H"
proof -
  interpret h: group_hom
    using assms
    by (simp add: group_hom_def group_hom_axioms_def is_group epi_def)
  obtain x where "x \<in> carrier G" and x: "carrier G = range (\<lambda>n::int. x [^] n)" and eq: "carrier H = h ` carrier G"
    using assms by (auto simp: cyclic_group epi_def)
  have "h ` carrier G = range (\<lambda>n::int. h x [^]\<^bsub>H\<^esub> n)"
    by (metis (no_types, lifting) \<open>x \<in> carrier G\<close> h.hom_int_pow image_cong image_image x)
  then show ?thesis
    using \<open>x \<in> carrier G\<close> eq h.cyclic_group by blast
qed

lemma isomorphic_group_cyclicity:
   "\<lbrakk>G \<cong> H; group G; group H\<rbrakk> \<Longrightarrow> cyclic_group G \<longleftrightarrow> cyclic_group H"
  by (meson ex_in_conv group.cyclic_group_epimorphic_image group.iso_sym is_iso_def iso_iff_mon_epi)

lemma (in group)
  assumes "x \<in> carrier G"
  shows finite_cyclic_subgroup:
        "finite(carrier(subgroup_generated G {x})) \<longleftrightarrow> (\<exists>n::nat. n \<noteq> 0 \<and> x [^] n = \<one>)" (is "?fin \<longleftrightarrow> ?nat1")
    and infinite_cyclic_subgroup:
        "infinite(carrier(subgroup_generated G {x})) \<longleftrightarrow> (\<forall>m n::nat. x [^] m = x [^] n \<longrightarrow> m = n)" (is "\<not> ?fin \<longleftrightarrow> ?nateq")
    and finite_cyclic_subgroup_int:
        "finite(carrier(subgroup_generated G {x})) \<longleftrightarrow> (\<exists>i::int. i \<noteq> 0 \<and> x [^] i = \<one>)" (is "?fin \<longleftrightarrow> ?int1")
    and infinite_cyclic_subgroup_int:
        "infinite(carrier(subgroup_generated G {x})) \<longleftrightarrow> (\<forall>i j::int. x [^] i = x [^] j \<longrightarrow> i = j)" (is "\<not> ?fin \<longleftrightarrow> ?inteq")
proof -
  have 1: "\<not> ?fin" if ?nateq
  proof -
    have "infinite (range (\<lambda>n::nat. x [^] n))"
      using that range_inj_infinite [of "(\<lambda>n::nat. x [^] n)"] by (auto simp: inj_on_def)
    moreover have "range (\<lambda>n::nat. x [^] n) \<subseteq> range (\<lambda>i::int. x [^] i)"
      apply clarify
      by (metis assms group.int_pow_neg int_pow_closed int_pow_neg_int is_group local.inv_equality nat_pow_closed r_inv rangeI)
    ultimately show ?thesis
      using carrier_subgroup_generated_by_singleton [OF assms] finite_subset by auto
  qed
  have 2: "m = n" if mn: "x [^] m = x [^] n" and eq [rule_format]: "?inteq" for m n::nat
    using eq [of "int m" "int n"]
    by (simp add: int_pow_int mn)
  have 3: ?nat1 if non: "\<not> ?inteq"
  proof -
    obtain i j::int where eq: "x [^] i = x [^] j" and "i \<noteq> j"
      using non by auto
    show ?thesis
    proof (cases i j rule: linorder_cases)
      case less
      then have [simp]: "x [^] (j - i) = \<one>"
        by (simp add: eq assms int_pow_diff)
      show ?thesis
        using less by (rule_tac x="nat (j-i)" in exI) auto
    next
      case greater
      then have [simp]: "x [^] (i - j) = \<one>"
        by (simp add: eq assms int_pow_diff)
      then show ?thesis
        using greater by (rule_tac x="nat (i-j)" in exI) auto
    qed (use \<open>i \<noteq> j\<close> in auto)
  qed
  have 4: "\<exists>i::int. (i \<noteq> 0) \<and> x [^] i = \<one>" if "n \<noteq> 0" "x [^] n = \<one>" for n::nat
    apply (rule_tac x="int n" in exI)
    by (simp add: int_pow_int that)
  have 5: "finite (carrier (subgroup_generated G {x}))" if "i \<noteq> 0" and 1: "x [^] i = \<one>" for i::int
  proof -
    obtain n::nat where n: "n > 0" "x [^] n = \<one>"
      using "1" "3" \<open>i \<noteq> 0\<close> by fastforce
    have "x [^] a \<in> ([^]) x ` {0..<n}" for a::int
    proof
      show "x [^] a = x [^] nat (a mod int n)"
        using n
        by simp (metis (no_types, lifting) assms dvd_minus_mod dvd_trans int_pow_eq int_pow_eq_id int_pow_int)
      show "nat (a mod int n) \<in> {0..<n}"
        using n  apply (simp add:  split: split_nat)
        using Euclidean_Division.pos_mod_bound by presburger
    qed
    then have "carrier (subgroup_generated G {x}) \<subseteq> ([^]) x ` {0..<n}"
      using carrier_subgroup_generated_by_singleton [OF assms] by auto
    then show ?thesis
      using finite_surj by blast
  qed
  show "?fin \<longleftrightarrow> ?nat1" "\<not> ?fin \<longleftrightarrow> ?nateq" "?fin \<longleftrightarrow> ?int1" "\<not> ?fin \<longleftrightarrow> ?inteq"
    using 1 2 3 4 5 by meson+
qed

lemma (in group) finite_cyclic_subgroup_order:
   "x \<in> carrier G \<Longrightarrow> finite(carrier(subgroup_generated G {x})) \<longleftrightarrow> ord x \<noteq> 0"
  by (simp add: finite_cyclic_subgroup ord_eq_0)

lemma (in group) infinite_cyclic_subgroup_order:
   "x \<in> carrier G \<Longrightarrow> infinite (carrier(subgroup_generated G {x})) \<longleftrightarrow> ord x = 0"
  by (simp add: finite_cyclic_subgroup_order)

end


section {*\isaheader{Implementation of Annotated Lists by 2-3 Finger Trees}*}
theory FTAnnotatedListImpl
imports
  "../../../Finger-Trees/FingerTree"
  "../tools/Locale_Code"
  "../tools/Record_Intf"
  "../spec/AnnotatedListSpec"
begin

(*@impl AnnotatedList
  @type ('a,'b::monoid_add) ft
  @abbrv ft
  Annotated lists implemented by 2-3 finger trees.
*)

type_synonym ('a,'b) ft = "('a,'b) FingerTree"
subsection "Definitions"

definition ft_\<alpha> where
  "ft_\<alpha> \<equiv> FingerTree.toList"
abbreviation (input) ft_invar :: "('a,'b) FingerTree \<Rightarrow> bool" where
  "ft_invar \<equiv> \<lambda>_. True"
definition ft_empty where
  "ft_empty \<equiv> \<lambda>_::unit. FingerTree.empty"
definition ft_isEmpty where
  "ft_isEmpty \<equiv> FingerTree.isEmpty"
definition ft_count where
  "ft_count \<equiv> FingerTree.count"
definition ft_consl where
  "ft_consl e a s = FingerTree.lcons (e,a) s"
definition ft_consr where
  "ft_consr s e a = FingerTree.rcons s (e,a)"
definition ft_head where
  "ft_head \<equiv> FingerTree.head"
definition ft_tail where
  "ft_tail \<equiv> FingerTree.tail"
definition ft_headR where
  "ft_headR \<equiv> FingerTree.headR"
definition ft_tailR where
  "ft_tailR \<equiv> FingerTree.tailR"
definition ft_foldl where
  "ft_foldl \<equiv> FingerTree.foldl"
definition ft_foldr where
  "ft_foldr \<equiv> FingerTree.foldr"
definition ft_app where
  "ft_app \<equiv> FingerTree.app"
definition ft_annot where
  "ft_annot \<equiv> FingerTree.annot"
definition ft_splits where
  "ft_splits \<equiv> FingerTree.splitTree"

lemmas ft_defs =
  ft_\<alpha>_def
  ft_empty_def
  ft_isEmpty_def
  ft_count_def
  ft_consl_def
  ft_consr_def
  ft_head_def
  ft_tail_def
  ft_headR_def
  ft_tailR_def
  ft_foldl_def
  ft_foldr_def
  ft_app_def
  ft_annot_def
  ft_splits_def

lemma ft_empty_impl: "al_empty ft_\<alpha> ft_invar ft_empty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.empty_correct)
  done

lemma ft_consl_impl: "al_consl ft_\<alpha> ft_invar ft_consl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.lcons_correct)
done

lemma ft_consr_impl: "al_consr ft_\<alpha> ft_invar ft_consr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.rcons_correct)
done

lemma ft_isEmpty_impl: "al_isEmpty ft_\<alpha> ft_invar ft_isEmpty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.isEmpty_correct FingerTree.empty_correct)
  done

lemma ft_count_impl: "al_count ft_\<alpha> ft_invar ft_count"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.count_correct)
  done

lemma ft_head_impl: "al_head ft_\<alpha> ft_invar ft_head"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.head_correct FingerTree.empty_correct)
done

lemma ft_tail_impl: "al_tail ft_\<alpha> ft_invar ft_tail"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tail_correct FingerTree.empty_correct)
done

lemma ft_headR_impl: "al_headR ft_\<alpha> ft_invar ft_headR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.headR_correct FingerTree.empty_correct)
done

lemma ft_tailR_impl: "al_tailR ft_\<alpha> ft_invar ft_tailR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tailR_correct FingerTree.empty_correct)
    done

lemma ft_foldl_impl: "al_foldl ft_\<alpha> ft_invar ft_foldl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_impl: "al_foldr ft_\<alpha> ft_invar ft_foldr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_foldl_cunfold[code_unfold]:
  "List.foldl f \<sigma> (ft_\<alpha> t) = ft_foldl f \<sigma> t"
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_cunfold[code_unfold]:
  "List.foldr f (ft_\<alpha> t) \<sigma> = ft_foldr f t \<sigma>"
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_app_impl: "al_app ft_\<alpha> ft_invar ft_app"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.app_correct)
  done

lemma ft_annot_impl: "al_annot ft_\<alpha> ft_invar ft_annot"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.annot_correct)
  done

lemma ft_splits_impl: "al_splits ft_\<alpha> ft_invar ft_splits"
  apply unfold_locales
  apply (unfold ft_defs)
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply (frule (3) FingerTree.splitTree_correct(1))
  apply (frule (3) FingerTree.splitTree_correct(2))
  apply (frule (3) FingerTree.splitTree_correct(3))
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply simp
  done

subsubsection "Record Based Implementation"

definition [icf_rec_def]: "ft_ops = \<lparr>
  alist_op_\<alpha> = ft_\<alpha>,
  alist_op_invar = ft_invar,
  alist_op_empty = ft_empty,
  alist_op_isEmpty = ft_isEmpty,
  alist_op_count = ft_count,
  alist_op_consl = ft_consl,
  alist_op_consr = ft_consr,
  alist_op_head = ft_head,
  alist_op_tail = ft_tail,
  alist_op_headR = ft_headR,
  alist_op_tailR = ft_tailR,
  alist_op_app = ft_app,
  alist_op_annot = ft_annot,
  alist_op_splits = ft_splits
  \<rparr>"

setup Locale_Code.open_block
interpretation ft: StdAL ft_ops
  apply (rule StdAL.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    ft_empty_impl
    ft_consl_impl
    ft_consr_impl
    ft_isEmpty_impl
    ft_count_impl
    ft_head_impl
    ft_tail_impl
    ft_headR_impl
    ft_tailR_impl
    ft_foldl_impl
    ft_foldr_impl
    ft_app_impl
    ft_annot_impl
    ft_splits_impl
  )+
  done
interpretation ft: StdAL_no_invar ft_ops
  by (unfold_locales) (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "ft"*}

definition "test_codegen \<equiv> (
  ft.empty,
  ft.isEmpty,
  ft.count,
  ft.consl,
  ft.consr,
  ft.head,
  ft.tail,
  ft.headR,
  ft.tailR,
  ft.app,
  ft.annot,
  ft.splits,
  ft.foldl,
  ft.foldr
)"

export_code test_codegen in SML

end


(*
  File:         Finite_Map_Multiset.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory Finite_Map_Multiset
imports
  "HOL-Library.Finite_Map"
  Nested_Multisets_Ordinals.Duplicate_Free_Multiset
begin

notation image_mset (infixr "`#" 90)

section \<open>Finite maps and multisets\<close>

subsection \<open>Finite sets and multisets\<close>

abbreviation mset_fset :: \<open>'a fset \<Rightarrow> 'a multiset\<close> where
  \<open>mset_fset N \<equiv> mset_set (fset N)\<close>

definition fset_mset :: \<open>'a multiset \<Rightarrow> 'a fset\<close> where
  \<open>fset_mset N \<equiv> Abs_fset (set_mset N)\<close>

lemma fset_mset_mset_fset: \<open>fset_mset (mset_fset N) = N\<close>
  by (auto simp: fset.fset_inverse fset_mset_def)

lemma mset_fset_fset_mset[simp]:
  \<open>mset_fset (fset_mset N) = remdups_mset N\<close>
  by (auto simp: fset.fset_inverse fset_mset_def Abs_fset_inverse remdups_mset_def)

lemma in_fset_mset_mset[simp]: \<open>x |\<in>| fset_mset N \<longleftrightarrow> x \<in># N\<close>
  by (auto simp: fmember.rep_eq fset_mset_def Abs_fset_inverse)

subsection \<open>Finite map and multisets\<close>

text \<open>Roughly the same as \<^term>\<open>ran\<close> and \<^term>\<open>dom\<close>, but with duplication in the content (unlike their
  finite sets counterpart) while still working on finite domains (unlike a function mapping).
  Remark that \<^term>\<open>dom_m\<close> (the keys) does not contain duplicates, but we keep for symmetry (and for
  easier use of multiset operators as in the definition of \<^term>\<open>ran_m\<close>).
\<close>
definition dom_m where
  \<open>dom_m N = mset_fset (fmdom N)\<close>

definition ran_m where
  \<open>ran_m N = the `# fmlookup N `# dom_m N\<close>

lemma dom_m_fmdrop[simp]: \<open>dom_m (fmdrop C N) = remove1_mset C (dom_m N)\<close>
  unfolding dom_m_def
  by (cases \<open>C |\<in>| fmdom N\<close>)
    (auto simp: mset_set.remove fmember.rep_eq)

lemma dom_m_fmdrop_All: \<open>dom_m (fmdrop C N) = removeAll_mset C (dom_m N)\<close>
  unfolding dom_m_def
  by (cases \<open>C |\<in>| fmdom N\<close>)
    (auto simp: mset_set.remove fmember.rep_eq)

lemma dom_m_fmupd[simp]: \<open>dom_m (fmupd k C N) = add_mset k (remove1_mset k (dom_m N))\<close>
  unfolding dom_m_def
  by (cases \<open>k |\<in>| fmdom N\<close>)
    (auto simp: mset_set.remove fmember.rep_eq mset_set.insert_remove)

lemma distinct_mset_dom: \<open>distinct_mset (dom_m N)\<close>
  by (simp add: distinct_mset_mset_set dom_m_def)

lemma in_dom_m_lookup_iff: \<open>C \<in># dom_m N' \<longleftrightarrow> fmlookup N' C \<noteq> None\<close>
  by (auto simp: dom_m_def fmdom.rep_eq fmlookup_dom'_iff)

lemma in_dom_in_ran_m[simp]: \<open>i \<in># dom_m N \<Longrightarrow> the (fmlookup N i) \<in># ran_m N\<close>
  by (auto simp: ran_m_def)

lemma fmupd_same[simp]:
  \<open>x1 \<in># dom_m x1aa \<Longrightarrow> fmupd x1 (the (fmlookup x1aa x1)) x1aa = x1aa\<close>
  by (metis fmap_ext fmupd_lookup in_dom_m_lookup_iff option.collapse)

lemma ran_m_fmempty[simp]: \<open>ran_m fmempty = {#}\<close> and
    dom_m_fmempty[simp]: \<open>dom_m fmempty = {#}\<close>
  by (auto simp: ran_m_def dom_m_def)

lemma fmrestrict_set_fmupd:
  \<open>a \<in> xs \<Longrightarrow> fmrestrict_set xs (fmupd a C N) = fmupd a C (fmrestrict_set xs N)\<close>
  \<open>a \<notin> xs \<Longrightarrow> fmrestrict_set xs (fmupd a C N) = fmrestrict_set xs N\<close>
  by (auto simp: fmfilter_alt_defs)

lemma fset_fmdom_fmrestrict_set:
  \<open>fset (fmdom (fmrestrict_set xs N)) = fset (fmdom N) \<inter> xs\<close>
  by (auto simp: fmfilter_alt_defs)

lemma dom_m_fmrestrict_set: \<open>dom_m (fmrestrict_set (set xs) N) = mset xs \<inter># dom_m N\<close>
  using fset_fmdom_fmrestrict_set[of \<open>set xs\<close> N] distinct_mset_dom[of N]
  distinct_mset_inter_remdups_mset[of \<open>mset_fset (fmdom N)\<close> \<open>mset xs\<close>]
  by (auto simp: dom_m_def fset_mset_mset_fset finite_mset_set_inter multiset_inter_commute
    remdups_mset_def)

lemma dom_m_fmrestrict_set': \<open>dom_m (fmrestrict_set xs N) = mset_set (xs \<inter> set_mset (dom_m N))\<close>
  using fset_fmdom_fmrestrict_set[of \<open>xs\<close> N] distinct_mset_dom[of N]
  by (auto simp: dom_m_def fset_mset_mset_fset finite_mset_set_inter multiset_inter_commute
    remdups_mset_def)

lemma indom_mI: \<open>fmlookup m x = Some y \<Longrightarrow> x \<in># dom_m m\<close>
  by (drule fmdomI)  (auto simp: dom_m_def fmember.rep_eq)

lemma fmupd_fmdrop_id:
  assumes \<open>k |\<in>| fmdom N'\<close>
  shows \<open>fmupd k (the (fmlookup N' k)) (fmdrop k N') = N'\<close>
proof -
  have [simp]: \<open>map_upd k (the (fmlookup N' k))
       (\<lambda>x. if x \<noteq> k then fmlookup N' x else None) =
     map_upd k (the (fmlookup N' k))
       (fmlookup N')\<close>
    by (auto intro!: ext simp: map_upd_def)
  have [simp]: \<open>map_upd k (the (fmlookup N' k)) (fmlookup N') = fmlookup N'\<close>
    using assms
    by (auto intro!: ext simp: map_upd_def)
  have [simp]: \<open>finite (dom (\<lambda>x. if x = k then None else fmlookup N' x))\<close>
    by (subst dom_if) auto
  show ?thesis
    apply (auto simp: fmupd_def fmupd.abs_eq[symmetric])
    unfolding fmlookup_drop
    apply (simp add: fmlookup_inverse)
    done
qed

lemma fm_member_split: \<open>k |\<in>| fmdom N' \<Longrightarrow> \<exists>N'' v. N' = fmupd k v N'' \<and> the (fmlookup N' k) = v \<and>
    k |\<notin>| fmdom N''\<close>
  by (rule exI[of _ \<open>fmdrop k N'\<close>])
    (auto simp: fmupd_fmdrop_id)

lemma \<open>fmdrop k (fmupd k va N'') = fmdrop k N''\<close>
  by (simp add: fmap_ext)

lemma fmap_ext_fmdom:
  \<open>(fmdom N = fmdom N') \<Longrightarrow> (\<And> x. x |\<in>| fmdom N \<Longrightarrow> fmlookup N x = fmlookup N' x) \<Longrightarrow>
       N = N'\<close>
  by (rule fmap_ext)
    (case_tac \<open>x |\<in>| fmdom N\<close>, auto simp: fmdom_notD)

lemma fmrestrict_set_insert_in:
  \<open>xa  \<in> fset (fmdom N) \<Longrightarrow>
    fmrestrict_set (insert xa l1) N = fmupd xa (the (fmlookup N xa)) (fmrestrict_set l1 N)\<close>
  apply (rule fmap_ext_fmdom)
   apply (auto simp: fset_fmdom_fmrestrict_set fmember.rep_eq notin_fset; fail)[]
  apply (auto simp: fmlookup_dom_iff; fail)
  done

lemma fmrestrict_set_insert_notin:
  \<open>xa  \<notin> fset (fmdom N) \<Longrightarrow>
    fmrestrict_set (insert xa l1) N = fmrestrict_set l1 N\<close>
  by (rule fmap_ext_fmdom)
     (auto simp: fset_fmdom_fmrestrict_set fmember.rep_eq notin_fset)

lemma fmrestrict_set_insert_in_dom_m[simp]:
  \<open>xa  \<in># dom_m N \<Longrightarrow>
    fmrestrict_set (insert xa l1) N = fmupd xa (the (fmlookup N xa)) (fmrestrict_set l1 N)\<close>
  by (simp add: fmrestrict_set_insert_in dom_m_def)

lemma fmrestrict_set_insert_notin_dom_m[simp]:
  \<open>xa  \<notin># dom_m N \<Longrightarrow>
    fmrestrict_set (insert xa l1) N = fmrestrict_set l1 N\<close>
  by (simp add: fmrestrict_set_insert_notin dom_m_def)

lemma fmlookup_restrict_set_id: \<open>fset (fmdom N) \<subseteq> A \<Longrightarrow> fmrestrict_set A N = N\<close>
  by (metis fmap_ext fmdom'_alt_def fmdom'_notD fmlookup_restrict_set subset_iff)

lemma fmlookup_restrict_set_id': \<open>set_mset (dom_m N) \<subseteq> A \<Longrightarrow> fmrestrict_set A N = N\<close>
  by (rule fmlookup_restrict_set_id)
    (auto simp: dom_m_def)

lemma ran_m_mapsto_upd:
  assumes
    NC: \<open>C \<in># dom_m N\<close>
  shows \<open>ran_m (fmupd C C' N) = add_mset C' (remove1_mset (the (fmlookup N C)) (ran_m N))\<close>
proof -
  define N' where
    \<open>N' = fmdrop C N\<close>
  have N_N': \<open>dom_m N = add_mset C (dom_m N')\<close>
    using NC unfolding N'_def by auto
  have \<open>C \<notin># dom_m N'\<close>
    using NC distinct_mset_dom[of N] unfolding N_N' by auto
  then show ?thesis
    by (auto simp: N_N' ran_m_def mset_set.insert_remove image_mset_remove1_mset_if
      intro!: image_mset_cong)
qed

lemma ran_m_mapsto_upd_notin:
  assumes NC: \<open>C \<notin># dom_m N\<close>
  shows \<open>ran_m (fmupd C C' N) = add_mset C' (ran_m N)\<close>
  using NC
  by (auto simp: ran_m_def mset_set.insert_remove image_mset_remove1_mset_if
      intro!: image_mset_cong split: if_splits)

lemma image_mset_If_eq_notin:
   \<open>C \<notin># A \<Longrightarrow> {#f (if x = C then a x else b x). x \<in># A#} = {# f(b x). x \<in># A #}\<close>
  by (induction A) auto

lemma filter_mset_cong2:
  "(\<And>x. x \<in># M \<Longrightarrow> f x = g x) \<Longrightarrow> M = N \<Longrightarrow> filter_mset f M = filter_mset g N"
  by (hypsubst, rule filter_mset_cong, simp)

lemma ran_m_fmdrop:
  \<open>C \<in># dom_m N \<Longrightarrow>  ran_m (fmdrop C N) = remove1_mset (the (fmlookup N C)) (ran_m N)\<close>
  using distinct_mset_dom[of N]
  by (cases \<open>fmlookup N C\<close>)
    (auto simp: ran_m_def image_mset_If_eq_notin[of C _ \<open>\<lambda>x. fst (the x)\<close>]
     dest!: multi_member_split
     intro!: filter_mset_cong2 image_mset_cong2)

lemma ran_m_fmdrop_notin:
  \<open>C \<notin># dom_m N \<Longrightarrow> ran_m (fmdrop C N) = ran_m N\<close>
  using distinct_mset_dom[of N]
  by (auto simp: ran_m_def image_mset_If_eq_notin[of C _ \<open>\<lambda>x. fst (the x)\<close>]
    dest!: multi_member_split
    intro!: filter_mset_cong2 image_mset_cong2)

lemma ran_m_fmdrop_If:
  \<open>ran_m (fmdrop C N) = (if C \<in># dom_m N then remove1_mset (the (fmlookup N C)) (ran_m N) else ran_m N)\<close>
  using distinct_mset_dom[of N]
  by (auto simp: ran_m_def image_mset_If_eq_notin[of C _ \<open>\<lambda>x. fst (the x)\<close>]
    dest!: multi_member_split
    intro!: filter_mset_cong2 image_mset_cong2)

lemma dom_m_empty_iff[iff]:
  \<open>dom_m NU = {#} \<longleftrightarrow> NU = fmempty\<close>
  by (cases NU) (auto simp: dom_m_def mset_set.insert_remove)

end