theory AbelianGroups
  imports Main
         "HOL-Algebra.Group"
         "HOL-Algebra.Free_Abelian_Groups"
         PointedSet
         "Category3.FunctorCategory"
         SomeCategoryTheory
         "Category3.Yoneda"
         "Category3.SetCategory"
         PointedSetFactorization
         FiniteSum
         SimplicialSet
begin

section "Category of abelian groups"

type_synonym ('c, 'd) Ab_hom = "(('c \<Rightarrow> 'c) \<times> ('c, 'd) monoid_scheme \<times> ('c, 'd) monoid_scheme) option"

locale abelian_group_category
begin

definition Obj' where
  "Obj' G = comm_group G"

definition Dom' where
  "Dom' f = fst (snd f)"

definition Cod' where
  "Cod' f = snd (snd f)"

definition Arr' where
  "Arr' f = (Obj' (Dom' f) \<and> Obj' (Cod' f) \<and>
            (fst f \<in> extensional (carrier (Dom' f))) \<and>
            (fst f \<in> hom (Dom' f) (Cod' f)))"

definition Id' where
  "Id' G = ((\<lambda>x \<in> carrier G. x), (G, G))"

definition Comp' where
  "Comp' f g = ((\<lambda>x \<in>carrier (Dom' g).  fst f (fst g x)), (Dom' g, Cod' f))"

interpretation AbCC : classical_category Obj' Arr' Dom' Cod' Id' Comp'
  unfolding classical_category_def
  apply auto
proof-
  fix G
  assume "Obj' G"
  then show "Arr' (Id' G)"
    unfolding Arr'_def Id'_def Dom'_def Cod'_def apply simp
    unfolding hom_def Obj'_def apply auto
    by (simp add: comm_groupE(1))
  show "Dom' (Id' G) = G"
    unfolding Arr'_def Id'_def Dom'_def by simp
  show "Cod' (Id' G) = G"
    unfolding Arr'_def Id'_def Cod'_def by simp
next
  fix f
  fix G H :: "('a, 'b) monoid_scheme"
  assume "Arr' (f, G, H)"
  then show "Obj' (Dom' (f, G, H))"
    unfolding Arr'_def by simp
  from \<open>Arr' (f, G, H)\<close> show "Obj' (Cod' (f, G, H))"
    unfolding Arr'_def by simp
  from \<open>Arr' (f, G, H)\<close> have ext_f: "f \<in> extensional (carrier G)"
    unfolding Arr'_def Dom'_def by simp
  from \<open>Arr' (f, G, H)\<close> have hom_f: "f \<in> hom G H"
    unfolding Arr'_def Dom'_def Cod'_def by simp
  show "Comp' (f, G, H) (Id' (Dom' (f, G, H))) = (f, G, H)"
    unfolding Comp'_def Id'_def Dom'_def Cod'_def apply simp
    apply (rule_tac ext)
    using ext_f
    unfolding extensional_def by auto
  show "Comp' (Id' (Cod' (f, G, H))) (f, G, H) = (f, G, H)"
    unfolding Comp'_def Id'_def Dom'_def Cod'_def apply simp
    apply (rule_tac ext)
    using ext_f hom_f
    unfolding extensional_def hom_def by auto
next
  fix f g
  fix A B C D :: "('a, 'b) monoid_scheme"
  assume arr_f: "Arr' (f, A, B)"
  assume arr_g: "Arr' (g, C, D)"
  assume "Cod' (f, A, B) = Dom' (g, C, D)"
  then have "B = C"
    unfolding Cod'_def Dom'_def by simp
  show "Arr' (Comp' (g, C, D) (f, A, B))"
    using arr_f arr_g
    unfolding Arr'_def Comp'_def Dom'_def Cod'_def apply simp
    unfolding \<open>B = C\<close>
    unfolding hom_def
    apply auto
  proof-
    fix x y
    assume "Obj' A"
    then have "comm_group A"
      unfolding Obj'_def.
    assume x_A: "x \<in> carrier A"
    assume y_A: "y \<in> carrier A"
    from x_A y_A \<open>comm_group A\<close> have "x \<otimes>\<^bsub>A\<^esub> y \<in> carrier A"
      by (simp add: comm_groupE(1))
    then show "x \<otimes>\<^bsub>A\<^esub> y \<notin> carrier A \<Longrightarrow> undefined = g (f x) \<otimes>\<^bsub>D\<^esub> g (f y)"
      by simp
    assume f_AC: "f \<in> carrier A \<rightarrow> carrier C"
    from f_AC have fx_C : "f x \<in> carrier C"
      using x_A by auto
    from f_AC have fy_C : "f y \<in> carrier C"
      using y_A by auto
    assume "\<forall>x\<in>carrier C. \<forall>y\<in>carrier C. g (x \<otimes>\<^bsub>C\<^esub> y) = g x \<otimes>\<^bsub>D\<^esub> g y"
    then show "g (f x \<otimes>\<^bsub>C\<^esub> f y) = g (f x) \<otimes>\<^bsub>D\<^esub> g (f y)"
      using fx_C fy_C by simp
  qed
  show "Dom' (Comp' (g, C, D) (f, A, B)) = Dom' (f, A, B)"
    unfolding Comp'_def Dom'_def by simp
  show "Cod' (Comp' (g, C, D) (f, A, B)) = Cod' (g, C, D)"
    unfolding Comp'_def Cod'_def by simp
next
  fix f g h
  fix A B C D E F :: "('a, 'b) monoid_scheme"
  assume arr_f : "Arr' (f, A, B)"
  assume arr_g : "Arr' (g, C, D)"
  assume arr_h : "Arr' (h, E, F)"
  assume "Cod' (f, A, B) = Dom' (g, C, D)"
  then have "B = C"
    unfolding Cod'_def Dom'_def by simp
  assume "Cod' (g, C, D) = Dom' (h, E, F)"
  then have "D = E"
    unfolding Cod'_def Dom'_def by simp
  show "Comp' (Comp' (h, E, F) (g, C, D)) (f, A, B) =
       Comp' (h, E, F) (Comp' (g, C, D) (f, A, B))"
    using arr_f
    unfolding Comp'_def Dom'_def Cod'_def apply auto
    apply (rule_tac ext)
    unfolding Arr'_def Dom'_def Cod'_def hom_def \<open>B = C\<close>
    by auto
qed

definition comp where
  "comp = AbCC.comp"

lemma is_category : "category comp"
  unfolding comp_def
  using AbCC.induces_category.

lemma is_classical_category : "classical_category Obj' Arr' Dom' Cod' Id' Comp'"
  using AbCC.classical_category_axioms.

lemma fun_eqI:
  assumes "AbCC.arr f" "AbCC.arr g"
  and dom_eq:  "AbCC.dom f = AbCC.dom g"
  and cod_eq: "AbCC.cod f = AbCC.cod g"
  and fst_eq : "\<And>x. x \<in> carrier (Dom' (the f)) \<Longrightarrow>
                    x \<in> carrier (Dom' (the g)) \<Longrightarrow>
                    fst (the f) x = fst (the g) x"
shows "f = g"
proof-
  have dom_eq' : "Dom' (the f) = Dom' (the g)"
    using dom_eq
    unfolding AbCC.dom_char
    apply (simp add: assms)
    unfolding Id'_def by simp

  have "the f = the g"
  proof
    show "fst (the f) = fst (the g)"
      apply (rule_tac ext)
    proof-
      fix x
      have "x \<in> carrier (Dom' (the f)) \<or> x \<notin> carrier (Dom' (the f))" by auto
      then show "fst (the f) x = fst (the g) x"
      proof
        show "x \<in> carrier (Dom' (the f)) \<Longrightarrow> fst (the f) x = fst (the g) x"
          apply (rule_tac fst_eq)
          unfolding dom_eq'.
        show "x \<notin> carrier (Dom' (the f)) \<Longrightarrow> fst (the f) x = fst (the g) x"
          using \<open>AbCC.arr f\<close> \<open>AbCC.arr g\<close>
          unfolding AbCC.arr_char Arr'_def extensional_def
          unfolding dom_eq'
          by simp
      qed
    qed
    show "snd (the f) = snd (the g)"
    proof
      show "fst (snd (the f)) = fst (snd (the g))"
        using dom_eq'
        unfolding Dom'_def.
      show "snd (snd (the f)) = snd (snd (the g))"
        using cod_eq
        unfolding AbCC.cod_char
        apply (simp add: assms)
        unfolding Id'_def Cod'_def
        by simp
    qed
  qed
  then show "f = g"
    using \<open>AbCC.arr f\<close> \<open>AbCC.arr g\<close>
    unfolding AbCC.arr_char
    by auto
qed

lemma comp_eqI :
  assumes "AbCC.arr f" "AbCC.arr g" "AbCC.arr h"
  and "AbCC.dom f = AbCC.dom h"
  and "AbCC.cod f = AbCC.cod g"
  and "AbCC.cod h = AbCC.dom g"
  and fst_eq: "\<And>x. x \<in> carrier (Dom' (the f)) \<Longrightarrow>
           x \<in> carrier (Dom' (the h)) \<Longrightarrow>
           fst (the h) x \<in> carrier (Dom' (the g)) \<Longrightarrow>
         fst (the f) x = fst (the g) (fst (the h) x)"
shows "f = comp g h"
  unfolding comp_def
  apply (subst AbCC.comp_simp)
proof-
  have "AbCC.seq g h"
    apply (rule_tac AbCC.seqI)
    using assms by simp_all
  then show "AbCC.comp g h \<noteq> AbCC.null"
    by auto
  then have "f = Some (the f)"
    using \<open>AbCC.arr f\<close>
    unfolding AbCC.arr_char by simp

  show "f = Some (Comp' (the g) (the h))"
    unfolding Comp'_def
    apply (subst \<open>f = Some (the f)\<close>)
    apply simp
  proof

    have dom_eq : "Dom' (the f) = Dom' (the h)"
      using \<open>AbCC.dom f = AbCC.dom h\<close>
      unfolding AbCC.dom_char
      using \<open>AbCC.arr f\<close> \<open>AbCC.arr h\<close>
      apply simp
      unfolding Id'_def Dom'_def
      by simp

    show "snd (the f) =
    snd (\<lambda>x\<in>carrier (Dom' (the h)). fst (the g) (fst (the h) x), Dom' (the h),
         Cod' (the g))"
      apply simp
    proof
      show "fst (snd (the f)) = fst (Dom' (the h), Cod' (the g))"
        using dom_eq
        unfolding Dom'_def by simp
      show "snd (snd (the f)) = snd (Dom' (the h), Cod' (the g))"
        using \<open>AbCC.cod f = AbCC.cod g\<close>
        unfolding AbCC.cod_char
        using \<open>AbCC.arr f\<close> \<open>AbCC.arr g\<close>
        apply simp
        unfolding Id'_def Cod'_def
        by simp
    qed
    show "fst (the f) =
    fst (\<lambda>x\<in>carrier (Dom' (the h)). fst (the g) (fst (the h) x), Dom' (the h),
         Cod' (the g))"
      apply (rule_tac ext)
      apply auto
    proof-
      show "\<And>x. x \<notin> carrier (Dom' (the h)) \<Longrightarrow> fst (the f) x = undefined"
        unfolding reverse_equality [OF dom_eq]
        using \<open>AbCC.arr f\<close>
        unfolding AbCC.arr_char Arr'_def extensional_def
        by auto

      have seq_eq : "Dom' (the g) = Cod' (the h)"
        using \<open>AbCC.cod h = AbCC.dom g\<close>
        unfolding AbCC.cod_char AbCC.dom_char
        using \<open>AbCC.arr h\<close> \<open>AbCC.arr g\<close>
        apply simp
        unfolding Id'_def by simp

      fix x
      assume x_in: "x \<in> carrier (Dom' (the h))"
      then have hx_in: "(fst (the h) x) \<in> carrier (Dom' (the g))"
        unfolding seq_eq
        using \<open>AbCC.arr h\<close>
        unfolding AbCC.arr_char Arr'_def hom_def
        by auto
      show "fst (the f) x = fst (the g) (fst (the h) x)"
        apply (rule_tac fst_eq)
        unfolding dom_eq
        using x_in hx_in by auto
    qed
  qed
qed

lemma in_hom_mapsto:
  assumes "AbCC.in_hom f A B"
  and AC: "carrier (Dom' (the A)) = C"
  and BD: "carrier (Dom' (the B)) = D"
shows "fst (the f) \<in> C \<rightarrow> D"
proof-
  have In_Hom: "AbCC.In_Hom (the f) (Dom' (the A)) (Dom' (the B))"
  using \<open>AbCC.in_hom f A B\<close>
  unfolding AbCC.in_hom_char
  unfolding AbCC.In_Hom_def
  by simp
  then have dom_eq : "Dom' (the f) = Dom' (the A)"
    unfolding AbCC.In_Hom_def by simp
  from In_Hom have cod_eq : "Cod' (the f) = Dom' (the B)"
    unfolding AbCC.In_Hom_def by simp
  from In_Hom have "Arr' (the f)"
    unfolding AbCC.In_Hom_def by simp
  then show "fst (the f) \<in> C \<rightarrow> D"
    unfolding Arr'_def
    unfolding hom_def
    unfolding dom_eq cod_eq
    unfolding AC BD
    by simp
qed

definition MkArr :: "('a, 'b) monoid_scheme \<Rightarrow> ('a, 'b) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow>
                    ('a, 'b) Ab_hom" where
  "MkArr A B F \<equiv> Some (restrict F (carrier A), (A, B))"

context begin

section "Hom-functor for abelian groups"

interpretation Hom : hom_functor AbCC.comp SetCat.comp "(\<lambda>_. SetCat.UP)"
  using AbCC.has_hom_functor.

definition zero_map where
  "zero_map G H = (Some ((\<lambda>x \<in> carrier G. \<one>\<^bsub>H\<^esub>), G, H))"

lemma zero_in_hom1: assumes G : "comm_group G"
  and H : "comm_group H"
shows "AbCC.in_hom (zero_map G H) (Some (Id' G)) (Some (Id' H))"
proof-
  have arr: "AbCC.arr (Some (\<lambda>x\<in>carrier G. \<one>\<^bsub>H\<^esub>, G, H))"
    unfolding AbCC.arr_char apply simp
    unfolding Arr'_def Obj'_def Dom'_def Cod'_def apply (simp add: G H)
    unfolding hom_def apply auto
    using comm_groupE(2) [OF H] apply simp
    using comm_groupE(5) [OF H comm_groupE(2) [OF H]] apply simp
    using comm_groupE(1) [OF G] by simp
  show "AbCC.in_hom (zero_map G H) (Some (Id' G)) (Some (Id' H))"
    unfolding zero_map_def
    apply (rule_tac AbCC.in_homI)
    unfolding AbCC.dom_char AbCC.cod_char
      apply (simp_all add: arr)
    unfolding Dom'_def Cod'_def by simp_all
qed

lemma zero_in_hom2: assumes G : "comm_group G"
  and H : "comm_group H"
  shows "SetCat.UP (zero_map G H) \<in> Hom.set (Some (Id' G), Some (Id' H))"
proof-
  have in_hom: "AbCC.in_hom (zero_map G H) (Some (Id' G)) (Some (Id' H))"
    using zero_in_hom1 [OF G H].
  have ide_G: "AbCC.ide (Some (Id' G))"
    unfolding AbCC.ide_char apply auto
     apply (rule_tac AbCC.Arr_Id)
    unfolding Obj'_def apply (simp add: G)
    unfolding Id'_def Dom'_def by simp
  have ide_H: "AbCC.ide (Some (Id' H))"
    unfolding AbCC.ide_char apply auto
     apply (rule_tac AbCC.Arr_Id)
    unfolding Obj'_def apply (simp add: H)
    unfolding Id'_def Dom'_def by simp
  show "SetCat.UP (zero_map G H) \<in> Hom.set (Some (Id' G), Some (Id' H))"
    using Hom.\<phi>_local_bij [OF ide_G ide_H]
    unfolding bij_betw_def
    using in_hom by auto
qed

interpretation pfactor: pointed_set_factorization SetCat.comp Hom.CopxC.comp Hom.map
     "(\<lambda>c. SetCat.UP (zero_map (fst (snd (the (fst c)))) (fst (snd (the (snd c))))))"
  unfolding pointed_set_factorization_def
  apply (simp add: SetCat.is_set_category Hom.functor_axioms)
  unfolding pointed_set_factorization_axioms_def
  apply auto
   apply (subst Hom.S.set_mkIde)
    apply (simp add: Hom.set_subset_Univ)
proof-
  have zero_in_hom: "\<And>a b. AbCC.ide a \<Longrightarrow>
           AbCC.ide b \<Longrightarrow> SetCat.UP (zero_map (fst (snd (the a))) (fst (snd (the b)))) \<in> Hom.set (a, b)
                       \<and> AbCC.in_hom (zero_map (fst (snd (the a))) (fst (snd (the b)))) a b "
  proof
    fix a b :: "(('c \<Rightarrow> 'c) \<times> ('c, 'd) monoid_scheme \<times> ('c, 'd) monoid_scheme) option"
    assume ide_a : "AbCC.ide a"
    then interpret A: comm_group "(fst (snd (the a)))"
      unfolding AbCC.ide_char Arr'_def Obj'_def Dom'_def by simp
    from ide_a have a_eq : "Some (Id' (fst (snd (the a)))) = a"
      unfolding AbCC.ide_char Dom'_def by simp
    assume ide_b : "AbCC.ide b"
    then interpret B: comm_group "(fst (snd (the b)))"
      unfolding AbCC.ide_char Arr'_def Obj'_def Dom'_def by simp
    from ide_b have b_eq : "Some (Id' (fst (snd (the b)))) = b"
      unfolding AbCC.ide_char Dom'_def by simp
    show "SetCat.UP (zero_map (fst (snd (the a))) (fst (snd (the b)))) \<in> Hom.set (a, b)"
      using zero_in_hom2 [OF A.comm_group_axioms B.comm_group_axioms]
      unfolding a_eq b_eq by simp
    show "AbCC.in_hom (zero_map (fst (snd (the a))) (fst (snd (the b)))) a b"
      using zero_in_hom1 [OF A.comm_group_axioms B.comm_group_axioms]
      unfolding a_eq b_eq by simp
  qed
  then show "\<And>a b. AbCC.ide a \<Longrightarrow>
           AbCC.ide b \<Longrightarrow>
           pointed_set.Obj' (SetCat.UP (zero_map (fst (snd (the a))) (fst (snd (the b)))), Hom.set (a, b))"
    unfolding pointed_set.Obj'_def apply simp
    by blast
  fix a b :: "(('c \<Rightarrow> 'c) \<times> ('c, 'd) monoid_scheme \<times> ('c, 'd) monoid_scheme) option"
  assume arr_a: "AbCC.arr a"
  assume arr_b: "AbCC.arr b"
  have arr_ab : "Hom.CopxC.arr (a, b)"
    by (simp add: arr_a arr_b)
  have arr_hom_ab : "Hom.S.arr (Hom.map (a, b))"
    apply (rule_tac Hom.preserves_arr)
    using arr_ab.

  show "Hom.S.Fun (Hom.map (a, b))
            (SetCat.UP (zero_map (fst (snd (the (AbCC.cod a)))) (fst (snd (the (AbCC.dom b)))))) =
           SetCat.UP (zero_map (fst (snd (the (AbCC.dom a)))) (fst (snd (the (AbCC.cod b)))))"
    unfolding Hom.map_def
    apply (simp add: arr_a arr_b)
    apply (subst Hom.S.Fun_mkArr)
    using arr_hom_ab
    unfolding Hom.map_def
    apply (simp add: arr_a arr_b)
    apply (simp add: zero_in_hom  [OF AbCC.ide_cod
              [OF arr_a] AbCC.ide_dom [OF arr_b]])
  proof-
    define zero1 where "zero1 = (zero_map (fst (snd (the (AbCC.cod a)))) (fst (snd (the (AbCC.dom b)))))"
    have arr1: "AbCC.arr zero1"
      using zero_in_hom [OF AbCC.ide_cod
              [OF arr_a] AbCC.ide_dom [OF arr_b]]
      unfolding zero1_def by blast
    have seq1: "AbCC.seq zero1 a"
      apply (rule_tac AbCC.seqI')
       apply (rule_tac AbCC.in_homI)
      apply (simp_all add: arr_a)
      unfolding zero1_def
      apply (rule_tac conjunct2 [OF zero_in_hom])
      using AbCC.ide_cod arr_a apply simp
      using AbCC.ide_dom arr_b by simp
    define zero2 where "zero2 = (zero_map (fst (snd (the (AbCC.dom a)))) (fst (snd (the (AbCC.dom b)))))"
    have a_zero_eq: "AbCC.comp zero1 a = zero2"
      apply (subst AbCC.comp_def)
      using AbCC.seqE [OF seq1] arr_a arr1
      unfolding AbCC.arr_char
      apply simp
    proof-
      have a_carrier: "fst (the a) \<in> carrier (Dom' (the a)) \<rightarrow> carrier (Cod' (the a))"
        using arr_a
        unfolding AbCC.arr_char Arr'_def hom_def by simp
      have dom_eq: "fst (snd (the a)) = fst (snd (the (AbCC.dom a)))"
        unfolding AbCC.dom_char
        by (simp add: arr_a Id'_def Dom'_def)
      show "Some (Comp' (the zero1) (the a)) = zero2"
        apply (subst Comp'_def)
        unfolding zero1_def zero2_def
        unfolding zero_map_def
        apply (simp add: Dom'_def Cod'_def dom_eq)
        apply (rule_tac ext)
        apply auto
        unfolding AbCC.cod_char AbCC.dom_char
        apply (simp add: arr_a Id'_def Dom'_def Cod'_def)
        using a_carrier
        unfolding Dom'_def Cod'_def by auto
    qed
    have arr2: "AbCC.arr zero2"
      using zero_in_hom [OF AbCC.ide_dom
              [OF arr_a] AbCC.ide_dom [OF arr_b]]
      unfolding zero2_def by blast
    have seq2: "AbCC.seq b zero2"
      apply (rule_tac AbCC.seqI')
      unfolding zero2_def
      apply (rule_tac conjunct2 [OF zero_in_hom])
      using AbCC.ide_dom arr_a apply simp
      using AbCC.ide_dom arr_b apply simp
      apply (rule_tac AbCC.in_homI)
      by (simp_all add: arr_b)
    have b_zero_eq : "AbCC.comp b zero2 = (zero_map (fst (snd (the (AbCC.dom a)))) (fst (snd (the (AbCC.cod b)))))"
      apply (subst AbCC.comp_def)
      using AbCC.seqE [OF seq2] arr_b arr2
      unfolding AbCC.arr_char
      apply simp
    proof-
      have b_in_hom : "fst (the b) \<in> hom (Dom' (the b)) (Cod' (the b))"
        using arr_b
        unfolding AbCC.arr_char Arr'_def by simp
      interpret BDom: comm_group "(fst (snd (the b)))"
        using arr_b
        unfolding AbCC.arr_char Arr'_def Obj'_def Dom'_def by simp
      interpret BCod: comm_group "(snd (snd (the b)))"
        using arr_b
        unfolding AbCC.arr_char Arr'_def Obj'_def Cod'_def by simp
      have cod_eq : "snd (snd (the b)) = fst (snd (the (AbCC.cod b)))"
        unfolding AbCC.cod_char
        by (simp add: arr_b Id'_def Cod'_def)
      show "Some (Comp' (the b) (the zero2)) = zero_map (fst (snd (the (AbCC.dom a)))) (fst (snd (the (AbCC.cod b))))"
        apply (subst Comp'_def)
        unfolding zero2_def
        unfolding zero_map_def
        apply (simp add: Dom'_def Cod'_def cod_eq)
        apply (rule_tac ext)
        apply auto
        unfolding AbCC.cod_char AbCC.dom_char
        apply (simp add: arr_b arr_a Id'_def Dom'_def Cod'_def)
        using b_in_hom
        unfolding Dom'_def Cod'_def
        by (simp add: hom_one)
    qed
    show "SetCat.UP
     (AbCC.comp b (AbCC.comp (zero_map (fst (snd (the (AbCC.cod a)))) (fst (snd (the (AbCC.dom b))))) a)) =
    SetCat.UP (zero_map (fst (snd (the (AbCC.dom a)))) (fst (snd (the (AbCC.cod b)))))"
      unfolding reverse_equality [OF zero1_def]
      apply (subst a_zero_eq)
      using b_zero_eq by simp
  qed
qed

definition pointed_hom_functor where
  "pointed_hom_functor = pfactor.map"

lemma pointed_hom_functor : "functor Hom.CopxC.comp pointed_set.pointed_set_comp pointed_hom_functor"
  unfolding pointed_hom_functor_def
  using pfactor.is_functor.

lemma pointed_hom_binary_functor : "binary_functor Hom.Cop.comp comp pointed_set.pointed_set_comp
                                    pointed_hom_functor"
  unfolding binary_functor_def comp_def
  apply (simp add: pointed_hom_functor)
  unfolding product_category_def
  by (simp add: AbCC.induces_category Hom.Cop.category_axioms pointed_set.is_category)

end

section "Lawvere theory of abelian groups"

term free_Abelian_group

definition is_Z_tothe_n :: "(nat \<Rightarrow>\<^sub>0 int) monoid \<Rightarrow> bool" where
  "is_Z_tothe_n A = (\<exists> S. finite S \<and> free_Abelian_group S = A)"

interpretation LawvAb : classical_full_subcategory
     Obj' Arr' Dom' Cod' Id' Comp' is_Z_tothe_n
  unfolding classical_full_subcategory_def
  apply (simp add: AbCC.classical_category_axioms)
  unfolding classical_full_subcategory_axioms_def
  unfolding is_Z_tothe_n_def Obj'_def
  apply auto
  by (simp add: abelian_free_Abelian_group)

lemma Lawv_is_classical_full_subcategory:
   "classical_full_subcategory
     Obj' Arr' Dom' Cod' Id' Comp' is_Z_tothe_n"
using LawvAb.classical_full_subcategory_axioms.

definition Lawv_comp where
  "Lawv_comp = LawvAb.comp"

lemma Lawv_is_category : "category Lawv_comp"
  unfolding Lawv_comp_def
  using LawvAb.induces_category.

lemma Lawv_is_classical_category : "classical_category is_Z_tothe_n LawvAb.SArr Dom' Cod' Id' Comp'"
  using LawvAb.is_classical_category.

definition LawvInclusion where
  "LawvInclusion = LawvAb.inclusion_functor"

lemma LawvInclusion_functor : "functor LawvAb.comp AbCC.comp LawvInclusion"
  unfolding LawvInclusion_def
  using LawvAb.inclusion_functor.

end

locale group_to_Lawvere_theory_functor =
  A : comm_group A
  for A :: "('a, 'b) monoid_scheme"
begin
(*Takes an abelian group A, and produces a product-preserving functor from the Lawvere theory
  of abelian groups, into the category of pointed sets.*)

type_synonym Lawv_arr = "(((nat \<Rightarrow>\<^sub>0 int) \<Rightarrow> nat \<Rightarrow>\<^sub>0 int) \<times> (nat \<Rightarrow>\<^sub>0 int) monoid \<times> (nat \<Rightarrow>\<^sub>0 int) monoid) option"
type_synonym Lawv_obj = "(nat \<Rightarrow>\<^sub>0 int)"

section "Embedding A into a larger type"

definition extend_monoid_scheme_left :: "('a, 'b) monoid_scheme \<Rightarrow> ('a + Lawv_obj, 'b + unit) monoid_scheme" where
  "extend_monoid_scheme_left B = \<lparr>carrier = Inl ` carrier B,
         mult = (\<lambda>x y. Inl (mult B (SOME x'. x = Inl x') (SOME y'. y = Inl y'))),
         one = Inl (one B),  \<dots> = Inl (monoid.more B)\<rparr>"

definition extend_monoid_scheme_right :: "(Lawv_obj, unit) monoid_scheme \<Rightarrow> ('a + Lawv_obj, 'b + unit) monoid_scheme" where
  "extend_monoid_scheme_right B = \<lparr>carrier = Inr ` carrier B,
         mult = (\<lambda>x y. Inr (mult B (SOME x'. x = Inr x') (SOME y'. y = Inr y'))),
         one = Inr (one B),  \<dots> = Inr (monoid.more B)\<rparr>"

lemma extend_comm_group_left: assumes "comm_group B"
  shows "comm_group (extend_monoid_scheme_left B)"
proof-
  interpret B : comm_group B
    using \<open>comm_group B\<close>.
  show "comm_group (extend_monoid_scheme_left B)"
    apply (rule_tac comm_groupI)
    unfolding extend_monoid_scheme_left_def
    using B.m_assoc B.m_comm
    by auto
qed

lemma extend_comm_group_left_iso: assumes "comm_group B"
  shows "group_isomorphisms B (extend_monoid_scheme_left B) Inl (\<lambda>x. (SOME x'. x = Inl x'))"
proof-
  interpret B : comm_group B
    using \<open>comm_group B\<close>.
  show "group_isomorphisms B (extend_monoid_scheme_left B) Inl (\<lambda>x. (SOME x'. x = Inl x'))"
  unfolding group_isomorphisms_def
  unfolding hom_def extend_monoid_scheme_left_def
  by auto
qed

lemma extend_comm_group_right: assumes "comm_group B"
  shows "comm_group (extend_monoid_scheme_right B)"
proof-
  interpret B : comm_group B
    using \<open>comm_group B\<close>.
  show "comm_group (extend_monoid_scheme_right B)"
    apply (rule_tac comm_groupI)
    unfolding extend_monoid_scheme_right_def
    using B.m_assoc B.m_comm
    by auto
qed

lemma extend_comm_group_right_iso: assumes "comm_group B"
  shows "group_isomorphisms B (extend_monoid_scheme_right B) Inr (\<lambda>x. (SOME x'. x = Inr x'))"
proof-
  interpret B : comm_group B
    using \<open>comm_group B\<close>.
  show "group_isomorphisms B (extend_monoid_scheme_right B) Inr (\<lambda>x. (SOME x'. x = Inr x'))"
  unfolding group_isomorphisms_def
  unfolding hom_def extend_monoid_scheme_right_def
  by auto
qed

definition A' :: "('a + Lawv_obj, 'b + unit) monoid_scheme" where
  "A' = extend_monoid_scheme_left A"

interpretation A' : comm_group A'
  unfolding A'_def
  using extend_comm_group_left [OF A.comm_group_axioms].

section "Embedding the Lawvere theory into a category of abelian groups of the desired type"

interpretation Ab : abelian_group_category.
interpretation AbCC : classical_category Ab.Obj' Ab.Arr' Ab.Dom' Ab.Cod' Ab.Id' Ab.Comp'
  using Ab.is_classical_category.

definition Inr_functor :: "Lawv_arr \<Rightarrow> ('a + Lawv_obj, 'b + unit) Ab_hom" where
  "Inr_functor = MkFunctor AbCC.comp AbCC.comp
                 (\<lambda>f. Some ((\<lambda>a \<in> carrier (extend_monoid_scheme_right (Ab.Dom' (the f))).
                  Inr (fst (the f) (SOME a'. a = Inr a'))) ,
                  extend_monoid_scheme_right (Ab.Dom' (the f)) ,
                  extend_monoid_scheme_right (Ab.Cod' (the f))))"

lemma Inr_functor : "functor AbCC.comp AbCC.comp Inr_functor"
  unfolding functor_def
  apply (simp add: AbCC.induces_category)
  unfolding functor_axioms_def
  apply auto
      apply (simp add: Inr_functor_def)
proof-
  show arr: "\<And>f. AbCC.arr f \<Longrightarrow> AbCC.arr (Inr_functor f)"
    apply (subst AbCC.arr_char)
    apply (subst Inr_functor_def)
    apply simp
    apply (subst Ab.Arr'_def)
    apply auto
  proof-
    fix f :: "Lawv_arr"
    assume arr_f : "AbCC.arr f"
    then have Arr'_f: "Ab.Arr' (the f)"
      unfolding AbCC.arr_char by simp
    show "Ab.Obj' (Ab.Dom' (the (Inr_functor f)))"
      unfolding Inr_functor_def
      apply (simp add: arr_f)
      unfolding Ab.Dom'_def Ab.Obj'_def
      apply simp
      apply (rule_tac extend_comm_group_right)
      using Arr'_f
      unfolding Ab.Arr'_def Ab.Obj'_def Ab.Dom'_def
      by simp
    show "Ab.Obj' (Ab.Cod' (the (Inr_functor f)))"
      unfolding Inr_functor_def
      apply (simp add: arr_f)
      unfolding Ab.Cod'_def Ab.Obj'_def
      apply simp
      apply (rule_tac extend_comm_group_right)
      using Arr'_f
      unfolding Ab.Arr'_def Ab.Obj'_def Ab.Cod'_def
      by simp
    show "fst (the (Inr_functor f)) \<in> extensional (carrier (Ab.Dom' (the (Inr_functor f))))"
      unfolding Inr_functor_def
      by (simp add: arr_f Ab.Dom'_def)
    have f_hom : "fst (the f) \<in> hom (Ab.Dom' (the f)) (Ab.Cod' (the f))"
      using Arr'_f unfolding Ab.Arr'_def by simp
    interpret Dom: comm_group "(fst (snd (the f)))"
      using Arr'_f
      unfolding Ab.Arr'_def Ab.Obj'_def Ab.Dom'_def
      by simp
    show "fst (the (Inr_functor f)) \<in> hom (Ab.Dom' (the (Inr_functor f))) (Ab.Cod' (the (Inr_functor f)))"
      unfolding Inr_functor_def
       apply (simp add: arr_f Ab.Dom'_def Ab.Cod'_def)
      using f_hom
      apply (rule_tac homI)
      unfolding extend_monoid_scheme_right_def
       apply simp_all
      unfolding hom_def Ab.Dom'_def Ab.Cod'_def
      by auto
  qed
  show dom: "\<And>f. AbCC.arr f \<Longrightarrow> AbCC.dom (Inr_functor f) = Inr_functor (AbCC.dom f)"
    apply (subst AbCC.dom_char)
    apply (simp add: arr)
    unfolding Inr_functor_def
    apply (simp add: Ab.Id'_def Ab.Dom'_def Ab.Cod'_def)
    unfolding AbCC.dom_char apply (simp add: Ab.Id'_def Ab.Dom'_def)
    unfolding extend_monoid_scheme_right_def
    apply simp
    apply (rule_tac ext)
    by auto
  show cod: "\<And>f. AbCC.arr f \<Longrightarrow> AbCC.cod (Inr_functor f) = Inr_functor (AbCC.cod f)"
    apply (subst AbCC.cod_char)
    apply (simp add: arr)
    unfolding Inr_functor_def
    apply (simp add: Ab.Id'_def Ab.Dom'_def Ab.Cod'_def)
    unfolding AbCC.cod_char apply (simp add: Ab.Id'_def Ab.Cod'_def)
    unfolding extend_monoid_scheme_right_def
    apply simp
    apply (rule_tac ext)
    by auto
  fix g f :: "Lawv_arr"
  assume arr_gf : "AbCC.seq g f"
  interpret AbC : category Ab.comp
    using Ab.is_category.
  have arr_gf' : "AbC.seq g f"
    unfolding Ab.comp_def
    using arr_gf.
  have arr_igf : "AbCC.seq (Inr_functor g) (Inr_functor f)"
    apply (rule_tac AbC.seqE [OF arr_gf'])
    unfolding Ab.comp_def
    apply (rule_tac AbCC.seqI)
    unfolding dom cod
    by (simp_all add: arr)
  have arr_igf' : "AbC.seq (Inr_functor g) (Inr_functor f)"
    unfolding Ab.comp_def
    using arr_igf.
  show "Inr_functor (AbCC.comp g f) = AbCC.comp (Inr_functor g) (Inr_functor f)"
    apply (subst Inr_functor_def)
    apply (simp add: arr_gf)
    unfolding AbCC.comp_def
    apply (rule_tac AbC.seqE [OF arr_gf'])
    apply (rule_tac AbC.seqE [OF arr_igf'])
    unfolding Ab.comp_def
    using AbCC.seqE [OF arr_gf]
          AbCC.seqE [OF arr_igf] apply (simp add: AbCC.arr_char)
  proof-
    show "(\<lambda>a\<in>carrier (extend_monoid_scheme_right (Ab.Dom' (the f))).
        Inr (fst (Ab.Comp' (the g) (the f)) (SOME a'. a = Inr a')),
     extend_monoid_scheme_right (Ab.Dom' (the f)), extend_monoid_scheme_right (Ab.Cod' (the g))) =
    Ab.Comp' (the (Inr_functor g)) (the (Inr_functor f))"
      apply (rule_tac AbC.seqE [OF arr_gf'])
      unfolding Ab.comp_def
      unfolding Inr_functor_def apply simp
      apply (subst Ab.Comp'_def)
      apply (subst Ab.Comp'_def)
      apply (simp add: Ab.Dom'_def Ab.Cod'_def)
      unfolding extend_monoid_scheme_right_def
      apply simp
      apply (rule_tac ext)
      apply auto
      unfolding AbCC.dom_char AbCC.cod_char
      apply (simp add: Ab.Dom'_def Ab.Cod'_def Ab.Id'_def)
      unfolding AbCC.arr_char
    proof-
      fix x
      assume "f \<noteq> None \<and> Ab.Arr' (the f)"
      then have "Ab.Arr' (the f)" by simp
      then have f_mapsto: "fst (the f) \<in> carrier (fst (snd (the f))) \<rightarrow> carrier (snd (snd (the f)))"
        unfolding Ab.Arr'_def hom_def Ab.Dom'_def Ab.Cod'_def by simp
      assume "x \<in> carrier (fst (snd (the f)))"
      then have fx_in_cod: "(fst (the f) x) \<in> carrier (snd (snd (the f)))"
        using f_mapsto by auto
      assume "Inr (fst (the f) x) \<notin> Inr ` carrier (snd (snd (the f)))"
      then have "False"
        using fx_in_cod by simp
      then show "Inr (fst (the g) (fst (the f) x)) = undefined"
        by simp
    qed
  qed
qed

section "Constructing the functor"

interpretation P : pointed_set.

definition Hom_into_A where
  "Hom_into_A f = Ab.pointed_hom_functor (f, Some (Ab.Id' A'))"

lemma Hom_into_A_functor : "functor (dual_category.comp Ab.comp) P.pointed_set_comp Hom_into_A"
  unfolding Hom_into_A_def Ab.comp_def
  apply (rule_tac binary_functor.fixing_ide_gives_functor_2 [OF Ab.pointed_hom_binary_functor])
  unfolding Ab.comp_def AbCC.ide_char apply auto
   apply (rule_tac AbCC.Arr_Id)
  unfolding Ab.Obj'_def
   apply (simp add: A'.comm_group_axioms)
  unfolding Ab.Id'_def Ab.Dom'_def by simp

definition map where
  "map = Hom_into_A \<circ> (dual_functor.map (Inr_functor \<circ> Ab.LawvInclusion))"

interpretation AF : "functor" "(dual_category.comp (Ab.Lawv_comp))" pointed_set.pointed_set_comp
                    map
  unfolding map_def
  apply (rule_tac functor_comp)
  apply (rule_tac dual_functor.is_functor)
  unfolding dual_functor_def
  unfolding dual_category_def
   apply (simp add: Ab.Lawv_is_category)
   apply (rule_tac conjI)
    apply (rule_tac functor_comp)
  unfolding Ab.Lawv_comp_def
  using Ab.LawvInclusion_functor apply simp
  using Inr_functor apply simp
  using AbCC.induces_category apply simp
  using Hom_into_A_functor
  unfolding Ab.comp_def.

lemma is_functor : "functor (dual_category.comp (Ab.Lawv_comp)) pointed_set.pointed_set_comp
                    map"
  using AF.functor_axioms.

end

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: ranks.thy                                                            *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Type Ranks\<close>

theory ranks
imports Main
  "HOL-Eisbach.Eisbach"
  "../core/uattrib"
begin

default_sort type

text \<open>
  Ranks are used to index HOL types by a natural number. While HOL does not
  support dependent typing, we use type classes as a poor man's dependency
  mechanism to associate each HOL type with a rank. Ranks are used later on
  in the theory @{text uval} to formalise the axioms of the universal value
  model: they determine a (lower bound for) the index @{text "'idx"} of type
  @{text "'idx uval"} into which a HOL type can be injected.
\<close>

subsection \<open>Theorem Attribute\<close>

text \<open>Attribute collecting theorems to facilitate proofs about type ranks.\<close>

named_theorems ranks "rank theorems"

ML \<open>
  structure ranks = Named_Attrib(val name = @{named_theorems ranks});
\<close>

subsection \<open>Rank Class\<close>

text \<open>The class @{text rank} allows us to specify a rank for each HOL type.\<close>

class rank =
  fixes rank :: "'a itself \<Rightarrow> nat"

subsection \<open>Rank Syntax\<close>

text \<open>
  Syntax that lets us write @{text "RANK('t)"} for some HOL type @{text "t"}.
\<close>

syntax "_rank" :: "type \<Rightarrow> nat" ("RANK'(_')")

translations "RANK('a)" \<rightleftharpoons> "(CONST rank) TYPE('a)"

subsection \<open>Instantiations\<close>

text \<open>
  We require a few instantiations of ground types: types that are created
  by type declarations rather than by type definitions. Namely, those types
  are @{type bool}, @{type ind}, @{type fun} and @{type set}. All other HOL
  types are introduced by virtue of type definitions, and for those types we
  automatically obtain instantiations of the @{class rank} class by the type
  interpretation that we configure by virtue of the file @{text "rank.ML"}.
  Correct instantiation of class @{class rank} is crucial for our approach
  to be definitionally sound. All ground types other than @{text uval} have
  a rank of zero, and parametric types obtain their ranks as the maximum of
  their constituent argument types.
\<close>

text \<open>
  An open issue are type declarations as for these we have no mechanism that
  assigns a type rank. I presume that it is safe to assign any rank to them,
  hence such a mechanism might not be required for definitional soundness?!
\<close>

instantiation bool :: rank
begin
definition rank_bool :: "bool itself \<Rightarrow> nat" where
[ranks]: "rank_bool t = 0"
instance ..
end

instantiation ind :: rank
begin
definition rank_ind :: "ind itself \<Rightarrow> nat" where
[ranks]: "rank_ind t = 0"
instance ..
end

(* rank(A \<Rightarrow> B) = rank(A) + 1 according to Burkhart Wolff. *)

(* Citation: Ranked typed systems (see HOL discussion group). *)

(* Work that caused impact / discussion in ITP 2016! *)

instantiation "fun" :: (rank, rank) rank
begin
definition rank_fun :: "('a \<Rightarrow> 'b) itself \<Rightarrow> nat" where
(* [ranks]: "rank_fun t = RANK('a) + 1" *)
[ranks]: "rank_fun t = max RANK('a) RANK('b)"
instance ..
end

instantiation set :: (rank) rank
begin
definition rank_set :: "('a set) itself \<Rightarrow> nat" where
[ranks]: "rank_set t = RANK('a)"
instance ..
end

subsection \<open>Proof Support\<close>

text \<open>
  We next configure a mechanism that instantiates the @{class rank} class
  automatically for any existing or new type definition. This is done via an
  interpretation of @{text typedef}. Correct instantiation is crucial since
  the soundness of the axiomatic UTP value model relies on it. We hence must
  not delegate this task to the user to evade the risk of inconsistencies.
\<close>

text \<open>
  For efficiency reasons, the theorems stored inside the @{attribute ranks}
  attribute are incrementally simplified, evaluating ranks in the RHS of
  definitional theorems `as we go along'. This is necessary since the rank
  terms of subtypes become rapidly large when we evaluate them na\"{i}vely,
  causing such evaluations to become very slow. Additional simplification
  laws are defined below and used to further simplify rank theorems prior to
  inclusion in the @{attribute ranks} attribute.
\<close>

theorem max_cancel_simps :
fixes a :: "nat"
fixes b :: "nat"
fixes c :: "nat"
shows
"max a a = a"
"max (max a b) c = max a (max b c)"
"max a (max b a) = max a b"
"max a (max b (max c a)) = max a (max b c)"
"max a (max a X) = max a X"
"max a (max b (max a X)) = max a (max b X)"
"max a (max b (max c (max a X))) = max a (max b (max c X))"
apply (clarsimp)
apply (auto)
done

ML_file "ranks.ML"

text \<open>
  We lastly configure the @{text Typedef} interpretation. This bootstraps the
  retrospective instantiation of the @{class rank} class for all existing HOL
  types, as well as automatically performs the instantiation of @{class rank}
  for all future type definitions; this is outside the control of the user.
\<close>

setup \<open>
  (Typedef.interpretation
    (Local_Theory.background_theory o Ranks.ensure_rank))
\<close>

text \<open>Automatic tactic to simplify and prove properties of ranks.\<close>

method rank_tac = (auto simp: ranks)

subsection \<open>Dynamic Ranks\<close>

text \<open>
  In order to facilitate the dynamic construction of types with arbitrary
  ranks i.e.~without having to declare a new type for each desired rank, we
  provide two designated types:~type (@{text "r0"}) has a rank of zero and
  (parametric) type (@{text "'a rS"}) increments the rank of @{typ "'a"}.
  In analogy to the construction of natural numbers, composition of the two
  type constructors enable us to create types with any desired rank. Lastly,
  those constructions can also include type parameters, increasing the rank
  of some type @{typ "'a"} by a fixed number.
\<close>

subsubsection \<open>Index Class\<close>

text \<open>
  We use the below to tag types that are used as indices. Note that there is
  currently no mechanism that prevents the user from instantiating other HOL
  types as indices too. While this may not be desirable, I believe that doing
  so does not pose a danger to soundness of the mechanisation. The same is
  true for instantiating the @{class rank} class for declared types added by
  the user. When using the syntax for index types below, sort constraints for
  membership to class @{text index} are imposed automatically on free types.
\<close>

class index = typerep + rank

subsubsection \<open>Index Types\<close>

text \<open>We introduce our two index type constructors as type declarations.\<close>

paragraph \<open>Zero Index\<close>

typedecl r0

instantiation r0 :: typerep
begin
definition typerep_r0 :: "r0 itself \<Rightarrow> typerep" where
[typing]: "typerep_r0 (t :: r0 itself) =
  typerep.Typerep (STR ''ranks.r0'') []"
instance ..
end

instantiation r0 :: index
begin
definition rank_r0 :: "r0 itself \<Rightarrow> nat" where
[ranks]: "rank_r0 t = 0"
instance ..
end

paragraph \<open>Successor Index\<close>

typedecl 'idx(*::index*) rS

instantiation rS :: (typerep) typerep
begin
definition typerep_rS :: "'a rS itself \<Rightarrow> typerep" where
[ranks]: "typerep_rS (t :: 'a rS itself) =
  typerep.Typerep (STR ''ranks.rS'') [TYPEREP('a)]"
instance ..
end

instantiation rS :: (rank) rank
begin
definition rank_rS :: "('a rS) itself \<Rightarrow> nat" where
[ranks]: "rank_rS t = RANK('a) + 1"
instance ..
end

instance rS :: (index) index ..

subsubsection \<open>Index Syntax\<close>

text \<open>
  Lastly, we define a neat syntax for index types. We distinguish open and
  closed index types. Open index types are, for instance, @{text "1>'a"} and
  @{text "2>'a"} for some free type @{text "'a"}. Open types raise the rank
  of the underlying free type. Closed indices are, for instance, @{text "0"},
  @{text "1"}, @{text "2"}, and so one. They are monomorphic types.
\<close>

paragraph \<open>Syntax Definitions\<close>

syntax "_open_idx0" :: "type \<Rightarrow> type" ("0>_")
syntax "_open_idx1" :: "type \<Rightarrow> type" ("1>_")
syntax "_open_idxn" :: "num_const \<Rightarrow> tid \<Rightarrow> type" ("_>_")

syntax "_closed_idx0" :: "type" ("0")
syntax "_closed_idx1" :: "type" ("1")
syntax "_closed_idxn" :: "num_const \<Rightarrow> type" ("_")

paragraph \<open>Syntax Translations\<close>

translations
  (type) "0>'a" \<rightharpoonup> (type) "'a::index"
  (type) "1>'a" \<rightharpoonup> (type) "'a::index rS"

translations
  (type) "0" \<rightharpoonup> (type) "r0"
  (type) "1" \<rightharpoonup> (type) "r0 rS"

paragraph \<open>Parser and Printer\<close>

ML_file "indices.ML"

parse_translation \<open>
  [(@{syntax_const "_open_idxn"}, Idx_Parser.open_idx_tr),
   (@{syntax_const "_closed_idxn"}, Idx_Parser.close_idx_tr)]
\<close>

print_translation \<open>
  [(@{type_syntax "r0"}, Idx_Printer.r0_tr'),
   (@{type_syntax "rS"}, Idx_Printer.rS_tr')]
\<close>

subsection \<open>Experiments\<close>

declare [[show_types=true]]

thm ranks \<comment> \<open>This prints all current rank simplification laws.\<close>

declare [[show_types=false]]

declare [[show_sorts]]

typ "0"
typ "1"
typ "2"
typ "3"

typ "0>'a"
typ "1>'b"
typ "2>'c"
typ "3>'d"

declare [[show_sorts=false]]
end


(*  Title:      HOL/Metis_Examples/Tarski.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring the full theorem of Tarski.
*)

section \<open>Metis Example Featuring the Full Theorem of Tarski\<close>

theory Tarski
imports MainRLT "HOL-Library.FuncSet"
begin

declare [[metis_new_skolem]]

(*Many of these higher-order problems appear to be impossible using the
current linkup. They often seem to need either higher-order unification
or explicit reasoning about connectives such as conjunction. The numerous
set comprehensions are to blame.*)

record 'a potype =
  pset  :: "'a set"
  order :: "('a * 'a) set"

definition monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool" where
  "monotone f A r == \<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> r --> ((f x), (f y)) \<in> r"

definition least :: "['a => bool, 'a potype] => 'a" where
  "least P po \<equiv> SOME x. x \<in> pset po \<and> P x \<and>
                       (\<forall>y \<in> pset po. P y \<longrightarrow> (x,y) \<in> order po)"

definition greatest :: "['a => bool, 'a potype] => 'a" where
  "greatest P po \<equiv> SOME x. x \<in> pset po \<and> P x \<and>
                          (\<forall>y \<in> pset po. P y \<longrightarrow> (y,x) \<in> order po)"

definition lub  :: "['a set, 'a potype] => 'a" where
  "lub S po == least (\<lambda>x. \<forall>y\<in>S. (y,x) \<in> order po) po"

definition glb  :: "['a set, 'a potype] => 'a" where
  "glb S po \<equiv> greatest (\<lambda>x. \<forall>y\<in>S. (x,y) \<in> order po) po"

definition isLub :: "['a set, 'a potype, 'a] => bool" where
  "isLub S po \<equiv> \<lambda>L. (L \<in> pset po \<and> (\<forall>y\<in>S. (y,L) \<in> order po) \<and>
                   (\<forall>z\<in>pset po. (\<forall>y\<in>S. (y,z) \<in> order po) \<longrightarrow> (L,z) \<in> order po))"

definition isGlb :: "['a set, 'a potype, 'a] => bool" where
  "isGlb S po \<equiv> \<lambda>G. (G \<in> pset po \<and> (\<forall>y\<in>S. (G,y) \<in> order po) \<and>
                 (\<forall>z \<in> pset po. (\<forall>y\<in>S. (z,y) \<in> order po) \<longrightarrow> (z,G) \<in> order po))"

definition "fix"    :: "[('a => 'a), 'a set] => 'a set" where
  "fix f A  \<equiv> {x. x \<in> A \<and> f x = x}"

definition interval :: "[('a*'a) set,'a, 'a ] => 'a set" where
  "interval r a b == {x. (a,x) \<in> r & (x,b) \<in> r}"

definition Bot :: "'a potype => 'a" where
  "Bot po == least (\<lambda>x. True) po"

definition Top :: "'a potype => 'a" where
  "Top po == greatest (\<lambda>x. True) po"

definition PartialOrder :: "('a potype) set" where
  "PartialOrder == {P. refl_on (pset P) (order P) & antisym (order P) &
                       trans (order P)}"

definition CompleteLattice :: "('a potype) set" where
  "CompleteLattice == {cl. cl \<in> PartialOrder \<and>
                        (\<forall>S. S \<subseteq> pset cl \<longrightarrow> (\<exists>L. isLub S cl L)) \<and>
                        (\<forall>S. S \<subseteq> pset cl \<longrightarrow> (\<exists>G. isGlb S cl G))}"

definition induced :: "['a set, ('a * 'a) set] => ('a *'a)set" where
  "induced A r \<equiv> {(a,b). a \<in> A \<and> b \<in> A \<and> (a,b) \<in> r}"

definition sublattice :: "('a potype * 'a set)set" where
  "sublattice \<equiv>
      SIGMA cl : CompleteLattice.
          {S. S \<subseteq> pset cl \<and>
           \<lparr>pset = S, order = induced S (order cl)\<rparr> \<in> CompleteLattice}"

abbreviation
  sublattice_syntax :: "['a set, 'a potype] => bool" ("_ <<= _" [51, 50] 50)
  where "S <<= cl \<equiv> S \<in> sublattice `` {cl}"

definition dual :: "'a potype => 'a potype" where
  "dual po == (| pset = pset po, order = converse (order po) |)"

locale PO =
  fixes cl :: "'a potype"
    and A  :: "'a set"
    and r  :: "('a * 'a) set"
  assumes cl_po:  "cl \<in> PartialOrder"
  defines A_def: "A == pset cl"
     and  r_def: "r == order cl"

locale CL = PO +
  assumes cl_co:  "cl \<in> CompleteLattice"

definition CLF_set :: "('a potype * ('a => 'a)) set" where
  "CLF_set = (SIGMA cl: CompleteLattice.
            {f. f \<in> pset cl \<rightarrow> pset cl \<and> monotone f (pset cl) (order cl)})"

locale CLF = CL +
  fixes f :: "'a => 'a"
    and P :: "'a set"
  assumes f_cl:  "(cl,f) \<in> CLF_set" (*was the equivalent "f : CLF``{cl}"*)
  defines P_def: "P == fix f A"

locale Tarski = CLF +
  fixes Y     :: "'a set"
    and intY1 :: "'a set"
    and v     :: "'a"
  assumes
    Y_ss: "Y \<subseteq> P"
  defines
    intY1_def: "intY1 == interval r (lub Y cl) (Top cl)"
    and v_def: "v == glb {x. ((\<lambda>x \<in> intY1. f x) x, x) \<in> induced intY1 r \<and>
                             x \<in> intY1}
                      \<lparr>pset=intY1, order=induced intY1 r\<rparr>"

subsection \<open>Partial Order\<close>

lemma (in PO) PO_imp_refl_on: "refl_on A r"
apply (insert cl_po)
apply (simp add: PartialOrder_def A_def r_def)
done

lemma (in PO) PO_imp_sym: "antisym r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) PO_imp_trans: "trans r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) reflE: "x \<in> A ==> (x, x) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def refl_on_def A_def r_def)
done

lemma (in PO) antisymE: "[| (a, b) \<in> r; (b, a) \<in> r |] ==> a = b"
apply (insert cl_po)
apply (simp add: PartialOrder_def antisym_def r_def)
done

lemma (in PO) transE: "[| (a, b) \<in> r; (b, c) \<in> r|] ==> (a,c) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
apply (unfold trans_def, fast)
done

lemma (in PO) monotoneE:
     "[| monotone f A r;  x \<in> A; y \<in> A; (x, y) \<in> r |] ==> (f x, f y) \<in> r"
by (simp add: monotone_def)

lemma (in PO) po_subset_po:
     "S \<subseteq> A ==> (| pset = S, order = induced S r |) \<in> PartialOrder"
apply (simp (no_asm) add: PartialOrder_def)
apply auto
\<comment> \<open>refl\<close>
apply (simp add: refl_on_def induced_def)
apply (blast intro: reflE)
\<comment> \<open>antisym\<close>
apply (simp add: antisym_def induced_def)
apply (blast intro: antisymE)
\<comment> \<open>trans\<close>
apply (simp add: trans_def induced_def)
apply (blast intro: transE)
done

lemma (in PO) indE: "[| (x, y) \<in> induced S r; S \<subseteq> A |] ==> (x, y) \<in> r"
by (simp add: add: induced_def)

lemma (in PO) indI: "[| (x, y) \<in> r; x \<in> S; y \<in> S |] ==> (x, y) \<in> induced S r"
by (simp add: add: induced_def)

lemma (in CL) CL_imp_ex_isLub: "S \<subseteq> A ==> \<exists>L. isLub S cl L"
apply (insert cl_co)
apply (simp add: CompleteLattice_def A_def)
done

declare (in CL) cl_co [simp]

lemma isLub_lub: "(\<exists>L. isLub S cl L) = isLub S cl (lub S cl)"
by (simp add: lub_def least_def isLub_def some_eq_ex [symmetric])

lemma isGlb_glb: "(\<exists>G. isGlb S cl G) = isGlb S cl (glb S cl)"
by (simp add: glb_def greatest_def isGlb_def some_eq_ex [symmetric])

lemma isGlb_dual_isLub: "isGlb S cl = isLub S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma isLub_dual_isGlb: "isLub S cl = isGlb S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma (in PO) dualPO: "dual cl \<in> PartialOrder"
apply (insert cl_po)
apply (simp add: PartialOrder_def dual_def)
done

lemma Rdual:
     "\<forall>S. (S \<subseteq> A -->( \<exists>L. isLub S (| pset = A, order = r|) L))
      ==> \<forall>S. (S \<subseteq> A --> (\<exists>G. isGlb S (| pset = A, order = r|) G))"
apply safe
apply (rule_tac x = "lub {y. y \<in> A & (\<forall>k \<in> S. (y, k) \<in> r)}
                      (|pset = A, order = r|) " in exI)
apply (drule_tac x = "{y. y \<in> A & (\<forall>k \<in> S. (y,k) \<in> r) }" in spec)
apply (drule mp, fast)
apply (simp add: isLub_lub isGlb_def)
apply (simp add: isLub_def, blast)
done

lemma lub_dual_glb: "lub S cl = glb S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma glb_dual_lub: "glb S cl = lub S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma CL_subset_PO: "CompleteLattice \<subseteq> PartialOrder"
by (simp add: PartialOrder_def CompleteLattice_def, fast)

lemmas CL_imp_PO = CL_subset_PO [THEN subsetD]

declare PO.PO_imp_refl_on  [OF PO.intro [OF CL_imp_PO], simp]
declare PO.PO_imp_sym   [OF PO.intro [OF CL_imp_PO], simp]
declare PO.PO_imp_trans [OF PO.intro [OF CL_imp_PO], simp]

lemma (in CL) CO_refl_on: "refl_on A r"
by (rule PO_imp_refl_on)

lemma (in CL) CO_antisym: "antisym r"
by (rule PO_imp_sym)

lemma (in CL) CO_trans: "trans r"
by (rule PO_imp_trans)

lemma CompleteLatticeI:
     "[| po \<in> PartialOrder; (\<forall>S. S \<subseteq> pset po --> (\<exists>L. isLub S po L));
         (\<forall>S. S \<subseteq> pset po --> (\<exists>G. isGlb S po G))|]
      ==> po \<in> CompleteLattice"
apply (unfold CompleteLattice_def, blast)
done

lemma (in CL) CL_dualCL: "dual cl \<in> CompleteLattice"
apply (insert cl_co)
apply (simp add: CompleteLattice_def dual_def)
apply (fold dual_def)
apply (simp add: isLub_dual_isGlb [symmetric] isGlb_dual_isLub [symmetric]
                 dualPO)
done

lemma (in PO) dualA_iff: "pset (dual cl) = pset cl"
by (simp add: dual_def)

lemma (in PO) dualr_iff: "((x, y) \<in> (order(dual cl))) = ((y, x) \<in> order cl)"
by (simp add: dual_def)

lemma (in PO) monotone_dual:
     "monotone f (pset cl) (order cl)
     ==> monotone f (pset (dual cl)) (order(dual cl))"
by (simp add: monotone_def dualA_iff dualr_iff)

lemma (in PO) interval_dual:
     "[| x \<in> A; y \<in> A|] ==> interval r x y = interval (order(dual cl)) y x"
apply (simp add: interval_def dualr_iff)
apply (fold r_def, fast)
done

lemma (in PO) interval_not_empty:
     "[| trans r; interval r a b \<noteq> {} |] ==> (a, b) \<in> r"
apply (simp add: interval_def)
apply (unfold trans_def, blast)
done

lemma (in PO) interval_imp_mem: "x \<in> interval r a b ==> (a, x) \<in> r"
by (simp add: interval_def)

lemma (in PO) left_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> a \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

lemma (in PO) right_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> b \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

subsection \<open>sublattice\<close>

lemma (in PO) sublattice_imp_CL:
     "S <<= cl  ==> (| pset = S, order = induced S r |) \<in> CompleteLattice"
by (simp add: sublattice_def CompleteLattice_def A_def r_def)

lemma (in CL) sublatticeI:
     "[| S \<subseteq> A; (| pset = S, order = induced S r |) \<in> CompleteLattice |]
      ==> S <<= cl"
by (simp add: sublattice_def A_def r_def)

subsection \<open>lub\<close>

lemma (in CL) lub_unique: "[| S \<subseteq> A; isLub S cl x; isLub S cl L|] ==> x = L"
apply (rule antisymE)
apply (auto simp add: isLub_def r_def)
done

lemma (in CL) lub_upper: "[|S \<subseteq> A; x \<in> S|] ==> (x, lub S cl) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def)
done

lemma (in CL) lub_least:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r |] ==> (lub S cl, L) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule_tac s=x in some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def A_def)
done

lemma (in CL) lub_in_lattice: "S \<subseteq> A ==> lub S cl \<in> A"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (subst some_equality)
apply (simp add: isLub_def)
prefer 2 apply (simp add: isLub_def A_def)
apply (simp add: lub_unique A_def isLub_def)
done

lemma (in CL) lubI:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r;
         \<forall>z \<in> A. (\<forall>y \<in> S. (y,z) \<in> r) --> (L,z) \<in> r |] ==> L = lub S cl"
apply (rule lub_unique, assumption)
apply (simp add: isLub_def A_def r_def)
apply (unfold isLub_def)
apply (rule conjI)
apply (fold A_def r_def)
apply (rule lub_in_lattice, assumption)
apply (simp add: lub_upper lub_least)
done

lemma (in CL) lubIa: "[| S \<subseteq> A; isLub S cl L |] ==> L = lub S cl"
by (simp add: lubI isLub_def A_def r_def)

lemma (in CL) isLub_in_lattice: "isLub S cl L ==> L \<in> A"
by (simp add: isLub_def  A_def)

lemma (in CL) isLub_upper: "[|isLub S cl L; y \<in> S|] ==> (y, L) \<in> r"
by (simp add: isLub_def r_def)

lemma (in CL) isLub_least:
     "[| isLub S cl L; z \<in> A; \<forall>y \<in> S. (y, z) \<in> r|] ==> (L, z) \<in> r"
by (simp add: isLub_def A_def r_def)

lemma (in CL) isLubI:
     "\<lbrakk>L \<in> A; \<forall>y \<in> S. (y, L) \<in> r;
         (\<forall>z \<in> A. (\<forall>y \<in> S. (y, z) \<in> r) \<longrightarrow> (L, z) \<in> r)\<rbrakk> \<Longrightarrow> isLub S cl L"
by (simp add: isLub_def A_def r_def)

subsection \<open>glb\<close>

lemma (in CL) glb_in_lattice: "S \<subseteq> A ==> glb S cl \<in> A"
apply (subst glb_dual_lub)
apply (simp add: A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CL.lub_in_lattice)
apply (rule CL.intro)
apply (rule PO.intro)
apply (rule dualPO)
apply (rule CL_axioms.intro)
apply (rule CL_dualCL)
apply (simp add: dualA_iff)
done

lemma (in CL) glb_lower: "[|S \<subseteq> A; x \<in> S|] ==> (glb S cl, x) \<in> r"
apply (subst glb_dual_lub)
apply (simp add: r_def)
apply (rule dualr_iff [THEN subst])
apply (rule CL.lub_upper)
apply (rule CL.intro)
apply (rule PO.intro)
apply (rule dualPO)
apply (rule CL_axioms.intro)
apply (rule CL_dualCL)
apply (simp add: dualA_iff A_def, assumption)
done

text \<open>
  Reduce the sublattice property by using substructural properties;
  abandoned see \<open>Tarski_4.ML\<close>.
\<close>

declare (in CLF) f_cl [simp]

lemma (in CLF) [simp]:
    "f \<in> pset cl \<rightarrow> pset cl \<and> monotone f (pset cl) (order cl)"
proof -
  have "\<forall>u v. (v, u) \<in> CLF_set \<longrightarrow> u \<in> {R \<in> pset v \<rightarrow> pset v. monotone R (pset v) (order v)}"
    unfolding CLF_set_def using SigmaE2 by blast
  hence F1: "\<forall>u v. (v, u) \<in> CLF_set \<longrightarrow> u \<in> pset v \<rightarrow> pset v \<and> monotone u (pset v) (order v)"
    using CollectE by blast
  hence "Tarski.monotone f (pset cl) (order cl)" by (metis f_cl)
  hence "(cl, f) \<in> CLF_set \<and> Tarski.monotone f (pset cl) (order cl)"
    by (metis f_cl)
  thus "f \<in> pset cl \<rightarrow> pset cl \<and> Tarski.monotone f (pset cl) (order cl)"
    using F1 by metis
qed

lemma (in CLF) f_in_funcset: "f \<in> A \<rightarrow> A"
by (simp add: A_def)

lemma (in CLF) monotone_f: "monotone f A r"
by (simp add: A_def r_def)

(*never proved, 2007-01-22*)

declare (in CLF) CLF_set_def [simp] CL_dualCL [simp] monotone_dual [simp] dualA_iff [simp]

lemma (in CLF) CLF_dual: "(dual cl, f) \<in> CLF_set"
apply (simp del: dualA_iff)
apply (simp)
done

declare (in CLF) CLF_set_def[simp del] CL_dualCL[simp del] monotone_dual[simp del]
          dualA_iff[simp del]

subsection \<open>fixed points\<close>

lemma fix_subset: "fix f A \<subseteq> A"
by (auto simp add: fix_def)

lemma fix_imp_eq: "x \<in> fix f A ==> f x = x"
by (simp add: fix_def)

lemma fixf_subset:
     "[| A \<subseteq> B; x \<in> fix (\<lambda>y \<in> A. f y) A |] ==> x \<in> fix f B"
by (simp add: fix_def, auto)

subsection \<open>lemmas for Tarski, lub\<close>

(*never proved, 2007-01-22*)

declare CL.lub_least[intro] CLF.f_in_funcset[intro] funcset_mem[intro] CL.lub_in_lattice[intro] PO.transE[intro] PO.monotoneE[intro] CLF.monotone_f[intro] CL.lub_upper[intro]

lemma (in CLF) lubH_le_flubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> (lub H cl, f (lub H cl)) \<in> r"
apply (rule lub_least, fast)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lub_in_lattice, fast)
\<comment> \<open>\<open>\<forall>x:H. (x, f (lub H r)) \<in> r\<close>\<close>
apply (rule ballI)
(*never proved, 2007-01-22*)
apply (rule transE)
\<comment> \<open>instantiates \<open>(x, ?z) \<in> order cl to (x, f x)\<close>,\<close>
\<comment> \<open>because of the definition of \<open>H\<close>\<close>
apply fast
\<comment> \<open>so it remains to show \<open>(f x, f (lub H cl)) \<in> r\<close>\<close>
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f, fast)
apply (rule lub_in_lattice, fast)
apply (rule lub_upper, fast)
apply assumption
done

declare CL.lub_least[rule del] CLF.f_in_funcset[rule del]
        funcset_mem[rule del] CL.lub_in_lattice[rule del]
        PO.transE[rule del] PO.monotoneE[rule del]
        CLF.monotone_f[rule del] CL.lub_upper[rule del]

(*never proved, 2007-01-22*)

declare CLF.f_in_funcset[intro] funcset_mem[intro] CL.lub_in_lattice[intro]
     PO.monotoneE[intro] CLF.monotone_f[intro] CL.lub_upper[intro]
     CLF.lubH_le_flubH[simp]

lemma (in CLF) flubH_le_lubH:
     "[|  H = {x. (x, f x) \<in> r & x \<in> A} |] ==> (f (lub H cl), lub H cl) \<in> r"
apply (rule lub_upper, fast)
apply (rule_tac t = "H" in ssubst, assumption)
apply (rule CollectI)
by (metis (lifting) CO_refl_on lubH_le_flubH monotone_def monotone_f refl_onD1 refl_onD2)

declare CLF.f_in_funcset[rule del] funcset_mem[rule del]
        CL.lub_in_lattice[rule del] PO.monotoneE[rule del]
        CLF.monotone_f[rule del] CL.lub_upper[rule del]
        CLF.lubH_le_flubH[simp del]

(*never proved, 2007-01-22*)

(* Single-step version fails. The conjecture clauses refer to local abstraction
functions (Frees). *)
lemma (in CLF) lubH_is_fixp:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> lub H cl \<in> fix f A"
apply (simp add: fix_def)
apply (rule conjI)
proof -
  assume A1: "H = {x. (x, f x) \<in> r \<and> x \<in> A}"
  have F1: "\<forall>u v. v \<inter> u \<subseteq> u" by (metis Int_commute Int_lower1)
  have "{R. (R, f R) \<in> r} \<inter> {R. R \<in> A} = H" using A1 by (metis Collect_conj_eq)
  hence "H \<subseteq> {R. R \<in> A}" using F1 by metis
  hence "H \<subseteq> A" by (metis Collect_mem_eq)
  hence "lub H cl \<in> A" by (metis lub_in_lattice)
  thus "lub {x. (x, f x) \<in> r \<and> x \<in> A} cl \<in> A" using A1 by metis
next
  assume A1: "H = {x. (x, f x) \<in> r \<and> x \<in> A}"
  have F1: "\<forall>v. {R. R \<in> v} = v" by (metis Collect_mem_eq)
  have F2: "\<forall>w u. {R. R \<in> u \<and> R \<in> w} = u \<inter> w"
    by (metis Collect_conj_eq Collect_mem_eq)
  have F3: "\<forall>x v. {R. v R \<in> x} = v -` x" by (metis vimage_def)
  hence F4: "A \<inter> (\<lambda>R. (R, f R)) -` r = H" using A1 by auto
  hence F5: "(f (lub H cl), lub H cl) \<in> r"
    by (metis A1 flubH_le_lubH)
  have F6: "(lub H cl, f (lub H cl)) \<in> r"
    by (metis A1 lubH_le_flubH)
  have "(lub H cl, f (lub H cl)) \<in> r \<longrightarrow> f (lub H cl) = lub H cl"
    using F5 by (metis antisymE)
  hence "f (lub H cl) = lub H cl" using F6 by metis
  thus "H = {x. (x, f x) \<in> r \<and> x \<in> A}
        \<Longrightarrow> f (lub {x. (x, f x) \<in> r \<and> x \<in> A} cl) =
           lub {x. (x, f x) \<in> r \<and> x \<in> A} cl"
    by metis
qed

lemma (in CLF) (*lubH_is_fixp:*)
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> lub H cl \<in> fix f A"
apply (simp add: fix_def)
apply (rule conjI)
apply (metis CO_refl_on lubH_le_flubH refl_onD1)
apply (metis antisymE flubH_le_lubH lubH_le_flubH)
done

lemma (in CLF) fix_in_H:
     "[| H = {x. (x, f x) \<in> r & x \<in> A};  x \<in> P |] ==> x \<in> H"
by (simp add: P_def fix_imp_eq [of _ f A] reflE CO_refl_on
                    fix_subset [of f A, THEN subsetD])

lemma (in CLF) fixf_le_lubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> \<forall>x \<in> fix f A. (x, lub H cl) \<in> r"
apply (rule ballI)
apply (rule lub_upper, fast)
apply (rule fix_in_H)
apply (simp_all add: P_def)
done

lemma (in CLF) lubH_least_fixf:
     "H = {x. (x, f x) \<in> r & x \<in> A}
      ==> \<forall>L. (\<forall>y \<in> fix f A. (y,L) \<in> r) --> (lub H cl, L) \<in> r"
apply (metis P_def lubH_is_fixp)
done

subsection \<open>Tarski fixpoint theorem 1, first part\<close>

declare CL.lubI[intro] fix_subset[intro] CL.lub_in_lattice[intro]
        CLF.fixf_le_lubH[simp] CLF.lubH_least_fixf[simp]

lemma (in CLF) T_thm_1_lub: "lub P cl = lub {x. (x, f x) \<in> r & x \<in> A} cl"
(*sledgehammer;*)
apply (rule sym)
apply (simp add: P_def)
apply (rule lubI)
apply (simp add: fix_subset)
using fix_subset lubH_is_fixp apply fastforce
apply (simp add: fixf_le_lubH)
using lubH_is_fixp apply blast
done

declare CL.lubI[rule del] fix_subset[rule del] CL.lub_in_lattice[rule del]
        CLF.fixf_le_lubH[simp del] CLF.lubH_least_fixf[simp del]

(*never proved, 2007-01-22*)

declare glb_dual_lub[simp] PO.dualA_iff[intro] CLF.lubH_is_fixp[intro]
        PO.dualPO[intro] CL.CL_dualCL[intro] PO.dualr_iff[simp]

lemma (in CLF) glbH_is_fixp: "H = {x. (f x, x) \<in> r & x \<in> A} ==> glb H cl \<in> P"
  \<comment> \<open>Tarski for glb\<close>
(*sledgehammer;*)
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.lubH_is_fixp)
apply (rule CLF.intro)
apply (rule CL.intro)
apply (rule PO.intro)
apply (rule dualPO)
apply (rule CL_axioms.intro)
apply (rule CL_dualCL)
apply (rule CLF_axioms.intro)
apply (rule CLF_dual)
apply (simp add: dualr_iff dualA_iff)
done

declare glb_dual_lub[simp del] PO.dualA_iff[rule del] CLF.lubH_is_fixp[rule del]
        PO.dualPO[rule del] CL.CL_dualCL[rule del] PO.dualr_iff[simp del]

(*never proved, 2007-01-22*)

lemma (in CLF) T_thm_1_glb: "glb P cl = glb {x. (f x, x) \<in> r & x \<in> A} cl"
(*sledgehammer;*)
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
(*never proved, 2007-01-22*)
(*sledgehammer;*)
apply (simp add: CLF.T_thm_1_lub [of _ f, OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro,
  OF dualPO CL_dualCL] dualPO CL_dualCL CLF_dual dualr_iff)
done

subsection \<open>interval\<close>

declare (in CLF) CO_refl_on[simp] refl_on_def [simp]

lemma (in CLF) rel_imp_elem: "(x, y) \<in> r ==> x \<in> A"
by (metis CO_refl_on refl_onD1)

declare (in CLF) CO_refl_on[simp del]  refl_on_def [simp del]

declare (in CLF) rel_imp_elem[intro]
declare interval_def [simp]

lemma (in CLF) interval_subset: "[| a \<in> A; b \<in> A |] ==> interval r a b \<subseteq> A"
by (metis CO_refl_on interval_imp_mem refl_onD refl_onD2 rel_imp_elem subset_eq)

declare (in CLF) rel_imp_elem[rule del]
declare interval_def [simp del]

lemma (in CLF) intervalI:
     "[| (a, x) \<in> r; (x, b) \<in> r |] ==> x \<in> interval r a b"
by (simp add: interval_def)

lemma (in CLF) interval_lemma1:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (a, x) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) interval_lemma2:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (x, b) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) a_less_lub:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (a,x) \<in> r; \<forall>y \<in> S. (y, L) \<in> r |] ==> (a,L) \<in> r"
by (blast intro: transE)

lemma (in CLF) glb_less_b:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (x,b) \<in> r; \<forall>y \<in> S. (G, y) \<in> r |] ==> (G,b) \<in> r"
by (blast intro: transE)

lemma (in CLF) S_intv_cl:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b |]==> S \<subseteq> A"
by (simp add: subset_trans [OF _ interval_subset])

lemma (in CLF) L_in_interval:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b;
         S \<noteq> {}; isLub S cl L; interval r a b \<noteq> {} |] ==> L \<in> interval r a b"
(*WON'T TERMINATE
apply (metis CO_trans intervalI interval_lemma1 interval_lemma2 isLub_least isLub_upper subset_empty subset_iff trans_def)
*)
apply (rule intervalI)
apply (rule a_less_lub)
prefer 2 apply assumption
apply (simp add: S_intv_cl)
apply (rule ballI)
apply (simp add: interval_lemma1)
apply (simp add: isLub_upper)
\<comment> \<open>\<open>(L, b) \<in> r\<close>\<close>
apply (simp add: isLub_least interval_lemma2)
done

(*never proved, 2007-01-22*)

lemma (in CLF) G_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {}; S \<subseteq> interval r a b; isGlb S cl G;
         S \<noteq> {} |] ==> G \<in> interval r a b"
apply (simp add: interval_dual)
apply (simp add: CLF.L_in_interval [of _ f, OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro]
                 dualA_iff A_def dualPO CL_dualCL CLF_dual isGlb_dual_isLub)
done

lemma (in CLF) intervalPO:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
      ==> (| pset = interval r a b, order = induced (interval r a b) r |)
          \<in> PartialOrder"
proof -
  assume A1: "a \<in> A"
  assume "b \<in> A"
  hence "\<forall>u. u \<in> A \<longrightarrow> interval r u b \<subseteq> A" by (metis interval_subset)
  hence "interval r a b \<subseteq> A" using A1 by metis
  hence "interval r a b \<subseteq> A" by metis
  thus ?thesis by (metis po_subset_po)
qed

lemma (in CLF) intv_CL_lub:
 "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
  ==> \<forall>S. S \<subseteq> interval r a b -->
          (\<exists>L. isLub S (| pset = interval r a b,
                          order = induced (interval r a b) r |)  L)"
apply (intro strip)
apply (frule S_intv_cl [THEN CL_imp_ex_isLub])
prefer 2 apply assumption
apply assumption
apply (erule exE)
\<comment> \<open>define the lub for the interval as\<close>
apply (rule_tac x = "if S = {} then a else L" in exI)
apply (simp (no_asm_simp) add: isLub_def split del: if_split)
apply (intro impI conjI)
\<comment> \<open>\<open>(if S = {} then a else L) \<in> interval r a b\<close>\<close>
apply (simp add: CL_imp_PO L_in_interval)
apply (simp add: left_in_interval)
\<comment> \<open>lub prop 1\<close>
apply (case_tac "S = {}")
\<comment> \<open>\<open>S = {}, y \<in> S = False => everything\<close>\<close>
apply fast
\<comment> \<open>\<open>S \<noteq> {}\<close>\<close>
apply simp
\<comment> \<open>\<open>\<forall>y:S. (y, L) \<in> induced (interval r a b) r\<close>\<close>
apply (rule ballI)
apply (simp add: induced_def  L_in_interval)
apply (rule conjI)
apply (rule subsetD)
apply (simp add: S_intv_cl, assumption)
apply (simp add: isLub_upper)
\<comment> \<open>\<open>\<forall>z:interval r a b. (\<forall>y:S. (y, z) \<in> induced (interval r a b) r \<longrightarrow> (if S = {} then a else L, z) \<in> induced (interval r a b) r\<close>\<close>
apply (rule ballI)
apply (rule impI)
apply (case_tac "S = {}")
\<comment> \<open>\<open>S = {}\<close>\<close>
apply simp
apply (simp add: induced_def  interval_def)
apply (rule conjI)
apply (rule reflE, assumption)
apply (rule interval_not_empty)
apply (rule CO_trans)
apply (simp add: interval_def)
\<comment> \<open>\<open>S \<noteq> {}\<close>\<close>
apply simp
apply (simp add: induced_def  L_in_interval)
apply (rule isLub_least, assumption)
apply (rule subsetD)
prefer 2 apply assumption
apply (simp add: S_intv_cl, fast)
done

lemmas (in CLF) intv_CL_glb = intv_CL_lub [THEN Rdual]

(*never proved, 2007-01-22*)

lemma (in CLF) interval_is_sublattice:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
        ==> interval r a b <<= cl"
(*sledgehammer *)
apply (rule sublatticeI)
apply (simp add: interval_subset)
(*never proved, 2007-01-22*)
(*sledgehammer *)
apply (rule CompleteLatticeI)
apply (simp add: intervalPO)
 apply (simp add: intv_CL_lub)
apply (simp add: intv_CL_glb)
done

lemmas (in CLF) interv_is_compl_latt =
    interval_is_sublattice [THEN sublattice_imp_CL]

subsection \<open>Top and Bottom\<close>
lemma (in CLF) Top_dual_Bot: "Top cl = Bot (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_dual_Top: "Bot cl = Top (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_in_lattice: "Bot cl \<in> A"
(*sledgehammer; *)
apply (simp add: Bot_def least_def)
apply (rule_tac a="glb A cl" in someI2)
apply (simp_all add: glb_in_lattice glb_lower
                     r_def [symmetric] A_def [symmetric])
done

(*first proved 2007-01-25 after relaxing relevance*)

lemma (in CLF) Top_in_lattice: "Top cl \<in> A"
(*sledgehammer;*)
apply (simp add: Top_dual_Bot A_def)
(*first proved 2007-01-25 after relaxing relevance*)
(*sledgehammer*)
apply (rule dualA_iff [THEN subst])
apply (blast intro!: CLF.Bot_in_lattice [OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro] dualPO CL_dualCL CLF_dual)
done

lemma (in CLF) Top_prop: "x \<in> A ==> (x, Top cl) \<in> r"
apply (simp add: Top_def greatest_def)
apply (rule_tac a="lub A cl" in someI2)
apply (rule someI2)
apply (simp_all add: lub_in_lattice lub_upper
                     r_def [symmetric] A_def [symmetric])
done

(*never proved, 2007-01-22*)

lemma (in CLF) Bot_prop: "x \<in> A ==> (Bot cl, x) \<in> r"
(*sledgehammer*)
apply (simp add: Bot_dual_Top r_def)
apply (rule dualr_iff [THEN subst])
apply (simp add: CLF.Top_prop [of _ f, OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro]
                 dualA_iff A_def dualPO CL_dualCL CLF_dual)
done

lemma (in CLF) Top_intv_not_empty: "x \<in> A  ==> interval r x (Top cl) \<noteq> {}"
apply (metis Top_in_lattice Top_prop empty_iff intervalI reflE)
done

lemma (in CLF) Bot_intv_not_empty: "x \<in> A ==> interval r (Bot cl) x \<noteq> {}"
apply (metis Bot_prop ex_in_conv intervalI reflE rel_imp_elem)
done

subsection \<open>fixed points form a partial order\<close>

lemma (in CLF) fixf_po: "(| pset = P, order = induced P r|) \<in> PartialOrder"
by (simp add: P_def fix_subset po_subset_po)

(*first proved 2007-01-25 after relaxing relevance*)

declare (in Tarski) P_def[simp] Y_ss [simp]
declare fix_subset [intro] subset_trans [intro]

lemma (in Tarski) Y_subset_A: "Y \<subseteq> A"
(*sledgehammer*)
apply (rule subset_trans [OF _ fix_subset])
apply (rule Y_ss [simplified P_def])
done

declare (in Tarski) P_def[simp del] Y_ss [simp del]
declare fix_subset [rule del] subset_trans [rule del]

lemma (in Tarski) lubY_in_A: "lub Y cl \<in> A"
  by (rule Y_subset_A [THEN lub_in_lattice])

(*never proved, 2007-01-22*)

lemma (in Tarski) lubY_le_flubY: "(lub Y cl, f (lub Y cl)) \<in> r"
(*sledgehammer*)
apply (rule lub_least)
apply (rule Y_subset_A)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lubY_in_A)
\<comment> \<open>\<open>Y \<subseteq> P ==> f x = x\<close>\<close>
apply (rule ballI)
(*sledgehammer *)
apply (rule_tac t = "x" in fix_imp_eq [THEN subst])
apply (erule Y_ss [simplified P_def, THEN subsetD])
\<comment> \<open>\<open>reduce (f x, f (lub Y cl)) \<in> r to (x, lub Y cl) \<in> r\<close> by monotonicity\<close>
(*sledgehammer*)
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f)
apply (simp add: Y_subset_A [THEN subsetD])
apply (rule lubY_in_A)
apply (simp add: lub_upper Y_subset_A)
done

(*first proved 2007-01-25 after relaxing relevance*)

lemma (in Tarski) intY1_subset: "intY1 \<subseteq> A"
(*sledgehammer*)
apply (unfold intY1_def)
apply (rule interval_subset)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
done

lemmas (in Tarski) intY1_elem = intY1_subset [THEN subsetD]

(*never proved, 2007-01-22*)

lemma (in Tarski) intY1_f_closed: "x \<in> intY1 \<Longrightarrow> f x \<in> intY1"
(*sledgehammer*)
apply (simp add: intY1_def  interval_def)
apply (rule conjI)
apply (rule transE)
apply (rule lubY_le_flubY)
\<comment> \<open>\<open>(f (lub Y cl), f x) \<in> r\<close>\<close>
(*sledgehammer [has been proved before now...]*)
apply (rule_tac f=f in monotoneE)
apply (rule monotone_f)
apply (rule lubY_in_A)
apply (simp add: intY1_def interval_def  intY1_elem)
apply (simp add: intY1_def  interval_def)
\<comment> \<open>\<open>(f x, Top cl) \<in> r\<close>\<close>
apply (rule Top_prop)
apply (rule f_in_funcset [THEN funcset_mem])
apply (simp add: intY1_def interval_def  intY1_elem)
done

lemma (in Tarski) intY1_func: "(\<lambda>x \<in> intY1. f x) \<in> intY1 \<rightarrow> intY1"
apply (rule restrictI)
apply (metis intY1_f_closed)
done

lemma (in Tarski) intY1_mono:
     "monotone (\<lambda>x \<in> intY1. f x) intY1 (induced intY1 r)"
(*sledgehammer *)
apply (auto simp add: monotone_def induced_def intY1_f_closed)
apply (blast intro: intY1_elem monotone_f [THEN monotoneE])
done

(*proof requires relaxing relevance: 2007-01-25*)

lemma (in Tarski) intY1_is_cl:
    "(| pset = intY1, order = induced intY1 r |) \<in> CompleteLattice"
(*sledgehammer*)
apply (unfold intY1_def)
apply (rule interv_is_compl_latt)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
apply (rule Top_intv_not_empty)
apply (rule lubY_in_A)
done

(*never proved, 2007-01-22*)

lemma (in Tarski) v_in_P: "v \<in> P"
(*sledgehammer*)
apply (unfold P_def)
apply (rule_tac A = "intY1" in fixf_subset)
apply (rule intY1_subset)
apply (simp add: CLF.glbH_is_fixp [OF CLF.intro, OF CL.intro CLF_axioms.intro, OF PO.intro CL_axioms.intro, OF _ intY1_is_cl, simplified]
                 v_def CL_imp_PO intY1_is_cl CLF_set_def intY1_func intY1_mono)
done

lemma (in Tarski) z_in_interval:
     "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |] ==> z \<in> intY1"
(*sledgehammer *)
apply (unfold intY1_def P_def)
apply (rule intervalI)
prefer 2
 apply (erule fix_subset [THEN subsetD, THEN Top_prop])
apply (rule lub_least)
apply (rule Y_subset_A)
apply (fast elim!: fix_subset [THEN subsetD])
apply (simp add: induced_def)
done

lemma (in Tarski) f'z_in_int_rel: "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |]
      ==> ((\<lambda>x \<in> intY1. f x) z, z) \<in> induced intY1 r"
using P_def fix_imp_eq indI intY1_elem reflE z_in_interval by fastforce

(*never proved, 2007-01-22*)

lemma (in Tarski) tarski_full_lemma:
     "\<exists>L. isLub Y (| pset = P, order = induced P r |) L"
apply (rule_tac x = "v" in exI)
apply (simp add: isLub_def)
\<comment> \<open>\<open>v \<in> P\<close>\<close>
apply (simp add: v_in_P)
apply (rule conjI)
(*sledgehammer*)
\<comment> \<open>\<open>v\<close> is lub\<close>
\<comment> \<open>\<open>1. \<forall>y:Y. (y, v) \<in> induced P r\<close>\<close>
apply (rule ballI)
apply (simp add: induced_def subsetD v_in_P)
apply (rule conjI)
apply (erule Y_ss [THEN subsetD])
apply (rule_tac b = "lub Y cl" in transE)
apply (rule lub_upper)
apply (rule Y_subset_A, assumption)
apply (rule_tac b = "Top cl" in interval_imp_mem)
apply (simp add: v_def)
apply (fold intY1_def)
apply (rule CL.glb_in_lattice [OF CL.intro, OF PO.intro CL_axioms.intro, OF _ intY1_is_cl, simplified])
 apply (simp add: CL_imp_PO intY1_is_cl, force)
\<comment> \<open>\<open>v\<close> is LEAST ub\<close>
apply clarify
apply (rule indI)
  prefer 3 apply assumption
 prefer 2 apply (simp add: v_in_P)
apply (unfold v_def)
(*never proved, 2007-01-22*)
(*sledgehammer*)
apply (rule indE)
apply (rule_tac [2] intY1_subset)
(*never proved, 2007-01-22*)
(*sledgehammer*)
apply (rule CL.glb_lower [OF CL.intro, OF PO.intro CL_axioms.intro, OF _ intY1_is_cl, simplified])
  apply (simp add: CL_imp_PO intY1_is_cl)
 apply force
apply (simp add: induced_def intY1_f_closed z_in_interval)
apply (simp add: P_def fix_imp_eq [of _ f A] reflE
                 fix_subset [of f A, THEN subsetD])
done

lemma CompleteLatticeI_simp:
     "[| (| pset = A, order = r |) \<in> PartialOrder;
         \<forall>S. S \<subseteq> A --> (\<exists>L. isLub S (| pset = A, order = r |)  L) |]
    ==> (| pset = A, order = r |) \<in> CompleteLattice"
by (simp add: CompleteLatticeI Rdual)

(*never proved, 2007-01-22*)

declare (in CLF) fixf_po[intro] P_def [simp] A_def [simp] r_def [simp]
             Tarski.tarski_full_lemma [intro] cl_po [intro] cl_co [intro]
             CompleteLatticeI_simp [intro]

theorem (in CLF) Tarski_full:
     "(| pset = P, order = induced P r|) \<in> CompleteLattice"
  using A_def CLF_axioms P_def Tarski.intro Tarski_axioms.intro fixf_po r_def by blast
(*sledgehammer*)

declare (in CLF) fixf_po [rule del] P_def [simp del] A_def [simp del] r_def [simp del]
         Tarski.tarski_full_lemma [rule del] cl_po [rule del] cl_co [rule del]
         CompleteLatticeI_simp [rule del]

end


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

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

datatype Nat = Z | S "Nat"

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

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

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

theorem property0 :
  "((rotate (length y) y) = y)"
  oops

end


theory T154
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Univ imports "~~/src/HOL/BNF/Countable_Type"
begin

(* A fixed countable universe for interpreting countable models  *)

datatype univ = UU nat

lemma infinite_univ[simp]: "infinite (UNIV :: univ set)"
unfolding infinite_iff_card_of_nat card_of_ordLeq[symmetric]
unfolding inj_on_def by auto

lemma countable_univ[simp]: "countable (UNIV :: univ set)"
unfolding countable_card_of_nat apply(rule surj_imp_ordLeq[of _ UU])
by (metis subset_UNIV surj_def univ.exhaust)

end


theory Blexer
  imports "Lexer"
begin

section \<open>Bit-Encodings\<close>

datatype bit = Z | S

fun code :: "val \<Rightarrow> bit list"
where
  "code Void = []"
| "code (Char c) = []"
| "code (Left v) = Z # (code v)"
| "code (Right v) = S # (code v)"
| "code (Seq v1 v2) = (code v1) @ (code v2)"
| "code (Stars []) = [S]"
| "code (Stars (v # vs)) =  (Z # code v) @ code (Stars vs)"

fun sz where
  "sz ZERO = 0"
| "sz ONE = 0"
| "sz (CH _) = 0"
| "sz (SEQ r1 r2) = 1 + sz r1 + sz r2"
| "sz (ALT r1 r2) = 1 + sz r1 + sz r2"
| "sz (STAR r) = 1 + sz r"
| "sz (NTIMES r n) = 1 + (n + 1) + sz r"

fun
  Stars_add :: "val \<Rightarrow> val \<Rightarrow> val"
where
  "Stars_add v (Stars vs) = Stars (v # vs)"

function (sequential)
  decode' :: "bit list \<Rightarrow> rexp \<Rightarrow> (val * bit list)"
where
  "decode' bs ZERO = (undefined, bs)"
| "decode' bs ONE = (Void, bs)"
| "decode' bs (CH d) = (Char d, bs)"
| "decode' [] (ALT r1 r2) = (Void, [])"
| "decode' (Z # bs) (ALT r1 r2) = (let (v, bs') = decode' bs r1 in (Left v, bs'))"
| "decode' (S # bs) (ALT r1 r2) = (let (v, bs') = decode' bs r2 in (Right v, bs'))"
| "decode' bs (SEQ r1 r2) = (let (v1, bs') = decode' bs r1 in
                             let (v2, bs'') = decode' bs' r2 in (Seq v1 v2, bs''))"
| "decode' [] (STAR r) = (Void, [])"
| "decode' (S # bs) (STAR r) = (Stars [], bs)"
| "decode' (Z # bs) (STAR r) = (let (v, bs') = decode' bs r in
                                    let (vs, bs'') = decode' bs' (STAR r)
                                    in (Stars_add v vs, bs''))"
| "decode' bs (NTIMES r n) = decode' bs (STAR r)"
by pat_completeness auto

lemma decode'_smaller:
  assumes "decode'_dom (bs, r)"
  shows "length (snd (decode' bs r)) \<le> length bs"
using assms
apply(induct bs r)
apply(auto simp add: decode'.psimps split: prod.split)
using dual_order.trans apply blast
apply (meson dual_order.trans le_SucI)
  done

termination "decode'"
apply(relation "inv_image (measure(%cs. sz cs) <*lex*> measure(%s. size s)) (%(ds,r). (r,ds))")
apply(auto dest!: decode'_smaller)
   apply (metis less_Suc_eq_le snd_conv)
  done

definition
  decode :: "bit list \<Rightarrow> rexp \<Rightarrow> val option"
where
  "decode ds r \<equiv> (let (v, ds') = decode' ds r
                  in (if ds' = [] then Some v else None))"

lemma decode'_code_Stars:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> (\<forall>x. decode' (code v @ x) r = (v, x)) \<and> flat v \<noteq> []"
  shows "decode' (code (Stars vs) @ ds) (STAR r) = (Stars vs, ds)"
  using assms
  apply(induct vs)
  apply(auto)
  done

lemma decode'_code_NTIMES:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> (\<forall>x. decode' (code v @ x) r = (v, x))"
  shows "decode' (code (Stars vs) @ ds) (NTIMES r n) = (Stars vs, ds)"
  using assms
  apply(induct vs arbitrary: n r ds)
   apply(auto)
  done

lemma decode'_code:
  assumes "\<Turnstile> v : r"
  shows "decode' ((code v) @ ds) r = (v, ds)"
using assms
  apply(induct v r arbitrary: ds rule: Prf.induct)
  apply(auto)[6]
  using decode'_code_Stars apply blast
  apply(rule decode'_code_NTIMES)
  apply(simp)
  apply(auto)
  done

lemma decode_code:
  assumes "\<Turnstile> v : r"
  shows "decode (code v) r = Some v"
  using assms unfolding decode_def
  by (smt append_Nil2 decode'_code old.prod.case)

section \<open>Annotated Regular Expressions\<close>

datatype arexp =
  AZERO
| AONE "bit list"
| ACHAR "bit list" char
| ASEQ "bit list" arexp arexp
| AALTs "bit list" "arexp list"
| ASTAR "bit list" arexp
| ANTIMES "bit list" arexp nat

abbreviation
  "AALT bs r1 r2 \<equiv> AALTs bs [r1, r2]"

fun asize :: "arexp \<Rightarrow> nat" where
  "asize AZERO = 1"
| "asize (AONE cs) = 1"
| "asize (ACHAR cs c) = 1"
| "asize (AALTs cs rs) = Suc (sum_list (map asize rs))"
| "asize (ASEQ cs r1 r2) = Suc (asize r1 + asize r2)"
| "asize (ASTAR cs r) = Suc (asize r)"
| "asize (ANTIMES cs r n) = Suc (asize r) + n"

fun
  erase :: "arexp \<Rightarrow> rexp"
where
  "erase AZERO = ZERO"
| "erase (AONE _) = ONE"
| "erase (ACHAR _ c) = CH c"
| "erase (AALTs _ []) = ZERO"
| "erase (AALTs _ [r]) = (erase r)"
| "erase (AALTs bs (r#rs)) = ALT (erase r) (erase (AALTs bs rs))"
| "erase (ASEQ _ r1 r2) = SEQ (erase r1) (erase r2)"
| "erase (ASTAR _ r) = STAR (erase r)"
| "erase (ANTIMES _ r n) = NTIMES (erase r) n"

fun fuse :: "bit list \<Rightarrow> arexp \<Rightarrow> arexp" where
  "fuse bs AZERO = AZERO"
| "fuse bs (AONE cs) = AONE (bs @ cs)"
| "fuse bs (ACHAR cs c) = ACHAR (bs @ cs) c"
| "fuse bs (AALTs cs rs) = AALTs (bs @ cs) rs"
| "fuse bs (ASEQ cs r1 r2) = ASEQ (bs @ cs) r1 r2"
| "fuse bs (ASTAR cs r) = ASTAR (bs @ cs) r"
| "fuse bs (ANTIMES cs r n) = ANTIMES (bs @ cs) r n"

lemma fuse_append:
  shows "fuse (bs1 @ bs2) r = fuse bs1 (fuse bs2 r)"
  apply(induct r)
  apply(auto)
  done

fun intern :: "rexp \<Rightarrow> arexp" where
  "intern ZERO = AZERO"
| "intern ONE = AONE []"
| "intern (CH c) = ACHAR [] c"
| "intern (ALT r1 r2) = AALT [] (fuse [Z] (intern r1))
                                (fuse [S]  (intern r2))"
| "intern (SEQ r1 r2) = ASEQ [] (intern r1) (intern r2)"
| "intern (STAR r) = ASTAR [] (intern r)"
| "intern (NTIMES r n) = ANTIMES [] (intern r) n"

fun retrieve :: "arexp \<Rightarrow> val \<Rightarrow> bit list" where
  "retrieve (AONE bs) Void = bs"
| "retrieve (ACHAR bs c) (Char d) = bs"
| "retrieve (AALTs bs [r]) v = bs @ retrieve r v"
| "retrieve (AALTs bs (r#rs)) (Left v) = bs @ retrieve r v"
| "retrieve (AALTs bs (r#rs)) (Right v) = bs @ retrieve (AALTs [] rs) v"
| "retrieve (ASEQ bs r1 r2) (Seq v1 v2) = bs @ retrieve r1 v1 @ retrieve r2 v2"
| "retrieve (ASTAR bs r) (Stars []) = bs @ [S]"
| "retrieve (ASTAR bs r) (Stars (v#vs)) =
     bs @ [Z] @ retrieve r v @ retrieve (ASTAR [] r) (Stars vs)"
| "retrieve (ANTIMES bs r 0) (Stars []) = bs @ [S]"
| "retrieve (ANTIMES bs r (Suc n)) (Stars (v#vs)) =
     bs @ [Z] @ retrieve r v @ retrieve (ANTIMES [] r n) (Stars vs)"

fun
 bnullable :: "arexp \<Rightarrow> bool"
where
  "bnullable (AZERO) = False"
| "bnullable (AONE bs) = True"
| "bnullable (ACHAR bs c) = False"
| "bnullable (AALTs bs rs) = (\<exists>r \<in> set rs. bnullable r)"
| "bnullable (ASEQ bs r1 r2) = (bnullable r1 \<and> bnullable r2)"
| "bnullable (ASTAR bs r) = True"
| "bnullable (ANTIMES bs r n) = (if n  = 0 then True else bnullable r)"

abbreviation
  bnullables :: "arexp list \<Rightarrow> bool"
where
  "bnullables rs \<equiv> (\<exists>r \<in> set rs. bnullable r)"

function (sequential)
  bmkeps :: "arexp \<Rightarrow> bit list"
where
  "bmkeps(AONE bs) = bs"
| "bmkeps(ASEQ bs r1 r2) = bs @ (bmkeps r1) @ (bmkeps r2)"
| "bmkeps(AALTs bs (r#rs)) =
    (if bnullable(r) then (bs @ bmkeps r) else (bmkeps (AALTs bs rs)))"
| "bmkeps(ASTAR bs r) = bs @ [S]"
| "bmkeps(ANTIMES bs r n) =
    (if n = 0 then bs @ [S] else bs @ [Z] @ (bmkeps r) @ bmkeps(ANTIMES [] r (n - 1)))"
apply(pat_completeness)
apply(auto)
done

termination "bmkeps"
apply(relation "measure asize")
        apply(auto)
  using asize.elims by force

fun
   bmkepss :: "arexp list \<Rightarrow> bit list"
where
  "bmkepss (r # rs) = (if bnullable(r) then (bmkeps r) else (bmkepss rs))"

lemma bmkepss1:
  assumes "\<not> bnullables rs1"
  shows "bmkepss (rs1 @ rs2) = bmkepss rs2"
  using assms
  by(induct rs1) (auto)

lemma bmkepss2:
  assumes "bnullables rs1"
  shows "bmkepss (rs1 @ rs2) = bmkepss rs1"
  using assms
  by (induct rs1) (auto)

fun
 bder :: "char \<Rightarrow> arexp \<Rightarrow> arexp"
where
  "bder c (AZERO) = AZERO"
| "bder c (AONE bs) = AZERO"
| "bder c (ACHAR bs d) = (if c = d then AONE bs else AZERO)"
| "bder c (AALTs bs rs) = AALTs bs (map (bder c) rs)"
| "bder c (ASEQ bs r1 r2) =
     (if bnullable r1
      then AALT bs (ASEQ [] (bder c r1) r2) (fuse (bmkeps r1) (bder c r2))
      else ASEQ bs (bder c r1) r2)"
| "bder c (ASTAR bs r) = ASEQ (bs @ [Z]) (bder c r) (ASTAR [] r)"
| "bder c (ANTIMES bs r n) = (if n = 0 then AZERO else ASEQ (bs @ [Z]) (bder c r) (ANTIMES [] r (n - 1)))"

fun
  bders :: "arexp \<Rightarrow> string \<Rightarrow> arexp"
where
  "bders r [] = r"
| "bders r (c#s) = bders (bder c r) s"

lemma bders_append:
  "bders c (s1 @ s2) = bders (bders c s1) s2"
  apply(induct s1 arbitrary: c s2)
  apply(simp_all)
  done

lemma bnullable_correctness:
  shows "nullable (erase r) = bnullable r"
  apply(induct r rule: erase.induct)
  apply(simp_all)
  done

lemma erase_fuse:
  shows "erase (fuse bs r) = erase r"
  apply(induct r rule: erase.induct)
  apply(simp_all)
  done

lemma erase_intern [simp]:
  shows "erase (intern r) = r"
  apply(induct r)
  apply(simp_all add: erase_fuse)
  done

lemma erase_bder [simp]:
  shows "erase (bder a r) = der a (erase r)"
  apply(induct r rule: erase.induct)
  apply(simp_all add: erase_fuse bnullable_correctness)
  done

lemma erase_bders [simp]:
  shows "erase (bders r s) = ders s (erase r)"
  apply(induct s arbitrary: r )
  apply(simp_all)
  done

lemma bnullable_fuse:
  shows "bnullable (fuse bs r) = bnullable r"
  apply(induct r arbitrary: bs)
  apply(auto)
  done

lemma retrieve_encode_STARS:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> code v = retrieve (intern r) v"
  shows "code (Stars vs) = retrieve (ASTAR [] (intern r)) (Stars vs)"
  using assms
  apply(induct vs)
  apply(simp_all)
  done

lemma retrieve_encode_NTIMES:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> code v = retrieve (intern r) v" "length vs = n"
  shows "code (Stars vs) = retrieve (ANTIMES [] (intern r) n) (Stars vs)"
  using assms
  apply(induct vs arbitrary: n)
   apply(simp_all)
  by force

lemma retrieve_fuse2:
  assumes "\<Turnstile> v : (erase r)"
  shows "retrieve (fuse bs r) v = bs @ retrieve r v"
  using assms
  apply(induct r arbitrary: v bs)
  apply(auto elim: Prf_elims)[4]
  apply(case_tac x2a)
  apply(simp)
  using Prf_elims(1) apply blast
  apply(case_tac x2a)
  apply(simp)
  apply(simp)
  apply(case_tac list)
  apply(simp)
  apply(simp)
  apply (smt (verit, best) Prf_elims(3) append_assoc retrieve.simps(4) retrieve.simps(5))
  apply(simp)
  using retrieve_encode_STARS
  apply(auto elim!: Prf_elims)[1]
  apply(case_tac vs)
  apply(simp)
   apply(simp)
  (* NTIMES *)
  apply(auto elim!: Prf_elims)[1]
  apply(case_tac vs1)
   apply(simp_all)
  apply(case_tac vs2)
   apply(simp_all)
  done

lemma retrieve_fuse:
  assumes "\<Turnstile> v : r"
  shows "retrieve (fuse bs (intern r)) v = bs @ retrieve (intern r) v"
  using assms
  by (simp_all add: retrieve_fuse2)

lemma retrieve_code:
  assumes "\<Turnstile> v : r"
  shows "code v = retrieve (intern r) v"
  using assms
  apply(induct v r )
        apply(simp_all add: retrieve_fuse retrieve_encode_STARS)
  apply(subst retrieve_encode_NTIMES)
    apply(auto)
  done

lemma retrieve_AALTs_bnullable1:
  assumes "bnullable r"
  shows "retrieve (AALTs bs (r # rs)) (mkeps (erase (AALTs bs (r # rs))))
         = bs @ retrieve r (mkeps (erase r))"
  using assms
  apply(case_tac rs)
  apply(auto simp add: bnullable_correctness)
  done

lemma retrieve_AALTs_bnullable2:
  assumes "\<not>bnullable r" "bnullables rs"
  shows "retrieve (AALTs bs (r # rs)) (mkeps (erase (AALTs bs (r # rs))))
         = retrieve (AALTs bs rs) (mkeps (erase (AALTs bs rs)))"
  using assms
  apply(induct rs arbitrary: r bs)
  apply(auto)
  using bnullable_correctness apply blast
  apply(case_tac rs)
  apply(auto)
  using bnullable_correctness apply blast
  apply(case_tac rs)
  apply(auto)
  done

lemma bmkeps_retrieve_AALTs:
  assumes "\<forall>r \<in> set rs. bnullable r \<longrightarrow> bmkeps r = retrieve r (mkeps (erase r))"
          "bnullables rs"
  shows "bs @ bmkepss rs = retrieve (AALTs bs rs) (mkeps (erase (AALTs bs rs)))"
 using assms
  apply(induct rs arbitrary: bs)
  apply(auto)
  using retrieve_AALTs_bnullable1 apply presburger
  apply (metis retrieve_AALTs_bnullable2)
  apply (simp add: retrieve_AALTs_bnullable1)
  by (metis retrieve_AALTs_bnullable2)

lemma bmkeps_retrieve_ANTIMES:
  assumes "if n = 0 then True else bmkeps r = retrieve r (mkeps (erase r))"
  and     "bnullable (ANTIMES bs r n)"
  shows "bmkeps (ANTIMES bs r n) = retrieve (ANTIMES bs r n) (Stars (replicate n (mkeps (erase r))))"
 using assms
  apply(induct n arbitrary: r bs)
  apply(auto)[1]
  apply(simp)
  done

lemma bmkeps_retrieve:
  assumes "bnullable r"
  shows "bmkeps r = retrieve r (mkeps (erase r))"
  using assms
  apply(induct r rule: bmkeps.induct)
        apply(auto)
  apply (simp add: retrieve_AALTs_bnullable1)
  using retrieve_AALTs_bnullable1 apply force
  apply(metis retrieve_AALTs_bnullable2)
  by (metis Cons_eq_appendI One_nat_def Suc_diff_1 eq_Nil_appendI replicate_Suc retrieve.simps(10))

lemma bder_retrieve:
  assumes "\<Turnstile> v : der c (erase r)"
  shows "retrieve (bder c r) v = retrieve r (injval (erase r) c v)"
  using assms
  apply(induct r arbitrary: v rule: erase.induct)
  using Prf_elims(1) apply auto[1]
  using Prf_elims(1) apply auto[1]
  apply(auto)[1]
  apply (metis Prf_elims(4) injval.simps(1) retrieve.simps(1) retrieve.simps(2))
  using Prf_elims(1) apply blast
  (* AALTs case *)
  apply(simp)
  apply(erule Prf_elims)
  apply(simp)
  apply(simp)
  apply(rename_tac "r\<^sub>1" "r\<^sub>2" rs v)
  apply(erule Prf_elims)
  apply(simp)
  apply(simp)
  apply(case_tac rs)
  apply(simp)
  apply(simp)
  using Prf_elims(3) apply fastforce
  (* ASEQ case *)
  apply(simp)
  apply(case_tac "nullable (erase r1)")
  apply(simp)
  apply(erule Prf_elims)
  using Prf_elims(2) bnullable_correctness apply force
  apply (simp add: bmkeps_retrieve bnullable_correctness retrieve_fuse2)
  apply (simp add: bmkeps_retrieve bnullable_correctness retrieve_fuse2)
  using Prf_elims(2) apply force
  (* ASTAR case *)
  apply(rename_tac bs r v)
  apply(simp)
  apply(erule Prf_elims)
  apply(clarify)
  apply(erule Prf_elims)
  apply(clarify)
   apply (simp add: retrieve_fuse2)
  (* ANTIMES case *)
  apply(auto)
  apply(erule Prf_elims)
  apply(erule Prf_elims)
  apply(clarify)
  apply(erule Prf_elims)
  apply(clarify)
  by (metis (full_types) Suc_pred append_assoc injval.simps(8) retrieve.simps(10) retrieve.simps(6))

lemma MAIN_decode:
  assumes "\<Turnstile> v : ders s r"
  shows "Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r"
  using assms
proof (induct s arbitrary: v rule: rev_induct)
  case Nil
  have "\<Turnstile> v : ders [] r" by fact
  then have "\<Turnstile> v : r" by simp
  then have "Some v = decode (retrieve (intern r) v) r"
    using decode_code retrieve_code by auto
  then show "Some (flex r id [] v) = decode (retrieve (bders (intern r) []) v) r"
    by simp
next
  case (snoc c s v)
  have IH: "\<And>v. \<Turnstile> v : ders s r \<Longrightarrow>
     Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r" by fact
  have asm: "\<Turnstile> v : ders (s @ [c]) r" by fact
  then have asm2: "\<Turnstile> injval (ders s r) c v : ders s r"
    by (simp add: Prf_injval ders_append)
  have "Some (flex r id (s @ [c]) v) = Some (flex r id s (injval (ders s r) c v))"
    by (simp add: flex_append)
  also have "... = decode (retrieve (bders (intern r) s) (injval (ders s r) c v)) r"
    using asm2 IH by simp
  also have "... = decode (retrieve (bder c (bders (intern r) s)) v) r"
    using asm by (simp_all add: bder_retrieve ders_append)
  finally show "Some (flex r id (s @ [c]) v) =
                 decode (retrieve (bders (intern r) (s @ [c])) v) r" by (simp add: bders_append)
qed

definition blexer where
 "blexer r s \<equiv> if bnullable (bders (intern r) s) then
                decode (bmkeps (bders (intern r) s)) r else None"

lemma blexer_correctness:
  shows "blexer r s = lexer r s"
proof -
  { define bds where "bds \<equiv> bders (intern r) s"
    define ds  where "ds \<equiv> ders s r"
    assume asm: "nullable ds"
    have era: "erase bds = ds"
      unfolding ds_def bds_def by simp
    have mke: "\<Turnstile> mkeps ds : ds"
      using asm by (simp add: mkeps_nullable)
    have "decode (bmkeps bds) r = decode (retrieve bds (mkeps ds)) r"
      using bmkeps_retrieve
      using asm era
      using bnullable_correctness by force
    also have "... =  Some (flex r id s (mkeps ds))"
      using mke by (simp_all add: MAIN_decode ds_def bds_def)
    finally have "decode (bmkeps bds) r = Some (flex r id s (mkeps ds))"
      unfolding bds_def ds_def .
  }
  then show "blexer r s = lexer r s"
    unfolding blexer_def lexer_flex
    by (auto simp add: bnullable_correctness[symmetric])
qed

unused_thms

end


theory ValueOntologyTest imports ValueOntology (*** Benzmüller, Fuenmayor & Lomfeld, 2021 ***)
begin
 (*value principles in two opposed quadrants: conflict*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" by simp (*proof*)
lemma "\<lfloor>[RELI\<^sup>x] \<^bold>\<and> [WILL\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" by simp (*proof*)
 (*value principles in two non-opposed quadrants: no conflict*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" nitpick oops (*countermodel*)
 (*value principles in opposed quadrants for different parties: no conflict*)
lemma "\<lfloor>[EQUI\<^sup>x] \<^bold>\<and> [GAIN\<^sup>y] \<^bold>\<rightarrow> (Conflict\<^sup>x \<^bold>\<or> Conflict\<^sup>y)\<rfloor>" nitpick oops (*countermodel*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>y] \<^bold>\<rightarrow> (Conflict\<^sup>x \<^bold>\<or> Conflict\<^sup>y)\<rfloor>" nitpick oops (*countermodel*)
lemma "\<lfloor>[RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>" nitpick nitpick[satisfy,card \<iota>=1] oops (*contingent: countermodel and model*)
 (*value aggregation properties*)
lemma "[A\<^bold>\<oplus>B] w \<longrightarrow> (A \<^bold>\<sqinter> B)\<down> w" by simp
lemma "[A\<^bold>\<oplus>B] w \<longrightarrow> A\<down> w" nitpick nitpick[satisfy] oops (*contingent: countermodel and model*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<prec> [STAB\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x] \<^bold>\<prec> [RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor>" by blast (*proof*)
lemma "\<lfloor>[RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x] \<^bold>\<prec> [WILL\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[STAB\<^sup>x] \<^bold>\<prec> [WILL\<^sup>x]\<rfloor>" by metis (*proof*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<prec> [RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x] \<^bold>\<prec> [STAB\<^sup>x]\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent: countermodel and model*)
lemma "\<lfloor>[STAB\<^sup>x] \<^bold>\<prec> [WILL\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x] \<^bold>\<prec> [WILL\<^sup>x]\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent: countermodel and model*)
end