(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar (ZF logic).

    Copyright (C) 2005, 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)
section \<open>Groups 2\<close>

theory Group_ZF_2 imports AbelianGroup_ZF func_ZF EquivClass1

begin

text\<open>This theory continues Group\_ZF.thy and considers lifting the group
  structure to function spaces and projecting the group structure to
  quotient spaces, in particular the quotient qroup.\<close>

subsection\<open>Lifting groups to function spaces\<close>

text\<open>If we have a monoid (group) $G$ than we get a monoid (group)
  structure on a space of functions valued in
  in $G$ by defining $(f\cdot g)(x) := f(x)\cdot g(x)$.
  We call this process ''lifting the monoid (group) to function space''.
  This section formalizes this lifting.\<close>

text\<open>The lifted operation is an operation on the function space.\<close>

lemma (in monoid0) Group_ZF_2_1_L0A:
  assumes A1: "F = f {lifted to function space over} X"
  shows "F : (X\<rightarrow>G)\<times>(X\<rightarrow>G)\<rightarrow>(X\<rightarrow>G)"
proof -
  from monoidAssum have "f : G\<times>G\<rightarrow>G"
    using IsAmonoid_def IsAssociative_def by simp
  with A1 show ?thesis
    using func_ZF_1_L3 group0_1_L3B by auto
qed

text\<open>The result of the lifted operation is in the function space.\<close>

lemma (in monoid0) Group_ZF_2_1_L0:
  assumes A1:"F = f {lifted to function space over} X"
  and A2:"s:X\<rightarrow>G" "r:X\<rightarrow>G"
  shows "F`\<langle> s,r\<rangle> : X\<rightarrow>G"
proof -
  from A1 have "F : (X\<rightarrow>G)\<times>(X\<rightarrow>G)\<rightarrow>(X\<rightarrow>G)"
    using Group_ZF_2_1_L0A
    by simp
  with A2 show ?thesis using apply_funtype
    by simp
qed

text\<open>The lifted monoid operation has a neutral element, namely
  the constant function with the neutral element as the value.\<close>

lemma (in monoid0) Group_ZF_2_1_L1:
  assumes A1: "F = f {lifted to function space over} X"
  and A2: "E = ConstantFunction(X,TheNeutralElement(G,f))"
  shows "E : X\<rightarrow>G \<and> (\<forall>s\<in>X\<rightarrow>G. F`\<langle> E,s\<rangle> = s \<and> F`\<langle> s,E\<rangle> = s)"
proof
  from A2 show T1:"E : X\<rightarrow>G"
    using unit_is_neutral func1_3_L1 by simp
  show "\<forall>s\<in>X\<rightarrow>G. F`\<langle> E,s\<rangle> = s \<and> F`\<langle> s,E\<rangle> = s"
  proof
    fix s assume A3:"s:X\<rightarrow>G"
    from monoidAssum have T2:"f : G\<times>G\<rightarrow>G"
      using IsAmonoid_def IsAssociative_def by simp
    from A3 A1 T1 have
      "F`\<langle> E,s\<rangle> : X\<rightarrow>G" "F`\<langle> s,E\<rangle> : X\<rightarrow>G" "s : X\<rightarrow>G"
      using Group_ZF_2_1_L0 by auto
    moreover from T2 A1 T1 A2 A3 have
      "\<forall>x\<in>X. (F`\<langle> E,s\<rangle>)`(x) = s`(x)"
      "\<forall>x\<in>X. (F`\<langle> s,E\<rangle>)`(x) = s`(x)"
      using func_ZF_1_L4 group0_1_L3B func1_3_L2
	apply_type unit_is_neutral by auto
    ultimately show
      "F`\<langle> E,s\<rangle> = s \<and> F`\<langle> s,E\<rangle> = s"
      using fun_extension_iff by auto
  qed
qed

text\<open>Monoids can be lifted to a function space.\<close>

lemma (in monoid0) Group_ZF_2_1_T1:
  assumes A1: "F = f {lifted to function space over} X"
  shows "IsAmonoid(X\<rightarrow>G,F)"
proof -
  from monoidAssum A1 have
    "F {is associative on} (X\<rightarrow>G)"
    using IsAmonoid_def func_ZF_2_L4 group0_1_L3B
    by auto
  moreover from A1 have
    "\<exists> E \<in> X\<rightarrow>G. \<forall>s \<in> X\<rightarrow>G. F`\<langle> E,s\<rangle> = s \<and> F`\<langle> s,E\<rangle> = s"
    using Group_ZF_2_1_L1 by blast
  ultimately show ?thesis using IsAmonoid_def
    by simp
qed

text\<open>The constant function with the neutral element as the value is the
  neutral element of the lifted monoid.\<close>

lemma Group_ZF_2_1_L2:
  assumes A1: "IsAmonoid(G,f)"
  and A2: "F = f {lifted to function space over} X"
  and A3: "E = ConstantFunction(X,TheNeutralElement(G,f))"
  shows "E = TheNeutralElement(X\<rightarrow>G,F)"
proof -
  from A1 A2 have
     T1:"monoid0(G,f)" and T2:"monoid0(X\<rightarrow>G,F)"
    using monoid0_def monoid0.Group_ZF_2_1_T1
    by auto
  from T1 A2 A3 have
    "E : X\<rightarrow>G \<and> (\<forall>s\<in>X\<rightarrow>G. F`\<langle> E,s\<rangle> = s \<and> F`\<langle> s,E\<rangle> = s)"
    using monoid0.Group_ZF_2_1_L1 by simp
  with T2 show ?thesis
    using monoid0.group0_1_L4 by auto
qed

text\<open>The lifted operation acts on the functions in a natural way defined
  by the monoid operation.\<close>

lemma (in monoid0) lifted_val:
  assumes "F = f {lifted to function space over} X"
  and "s:X\<rightarrow>G"  "r:X\<rightarrow>G"
  and "x\<in>X"
  shows "(F`\<langle>s,r\<rangle>)`(x) = s`(x) \<oplus> r`(x)"
  using monoidAssum assms IsAmonoid_def IsAssociative_def
      group0_1_L3B func_ZF_1_L4
  by auto

text\<open>The lifted operation acts on the functions in a natural way defined
  by the group operation. This is the same as \<open>lifted_val\<close>, but
  in the \<open>group0\<close> context.\<close>

lemma (in group0) Group_ZF_2_1_L3:
  assumes "F = P {lifted to function space over} X"
  and "s:X\<rightarrow>G" "r:X\<rightarrow>G"
  and "x\<in>X"
  shows "(F`\<langle>s,r\<rangle>)`(x) = s`(x)\<cdot>r`(x)"
  using assms group0_2_L1 monoid0.lifted_val by simp

text\<open>In the group0 context we can apply theorems proven in monoid0 context
  to the lifted monoid.\<close>

lemma (in group0) Group_ZF_2_1_L4:
  assumes A1: "F = P {lifted to function space over} X"
  shows "monoid0(X\<rightarrow>G,F)"
proof -
  from A1 show ?thesis
    using group0_2_L1 monoid0.Group_ZF_2_1_T1 monoid0_def
    by simp
qed

text\<open>The compostion of a function $f:X\rightarrow G$ with the group inverse
  is a right inverse for the lifted group.\<close>

lemma (in group0) Group_ZF_2_1_L5:
  assumes A1: "F = P {lifted to function space over} X"
  and A2: "s : X\<rightarrow>G"
  and A3: "i = GroupInv(G,P) O s"
  shows "i: X\<rightarrow>G" and "F`\<langle> s,i\<rangle> = TheNeutralElement(X\<rightarrow>G,F)"
proof -
  let ?E = "ConstantFunction(X,\<one>)"
  have "?E : X\<rightarrow>G"
    using group0_2_L2 func1_3_L1 by simp
  moreover from groupAssum A2 A3 A1 have
    "F`\<langle> s,i\<rangle> :  X\<rightarrow>G" using group0_2_T2 comp_fun
      Group_ZF_2_1_L4 monoid0.group0_1_L1
    by simp
  moreover from groupAssum A2 A3 A1 have
    "\<forall>x\<in>X. (F`\<langle> s,i\<rangle>)`(x) = ?E`(x)"
    using group0_2_T2 comp_fun Group_ZF_2_1_L3
      comp_fun_apply apply_funtype group0_2_L6 func1_3_L2
    by simp
  moreover from groupAssum A1 have
    "?E = TheNeutralElement(X\<rightarrow>G,F)"
    using IsAgroup_def Group_ZF_2_1_L2 by simp
  ultimately show "F`\<langle> s,i\<rangle> = TheNeutralElement(X\<rightarrow>G,F)"
    using fun_extension_iff IsAgroup_def Group_ZF_2_1_L2
    by simp
  from groupAssum A2 A3 show "i: X\<rightarrow>G"
    using group0_2_T2 comp_fun by simp
qed

text\<open>Groups can be lifted to the function space.\<close>

theorem (in group0) Group_ZF_2_1_T2:
  assumes A1: "F = P {lifted to function space over} X"
  shows "IsAgroup(X\<rightarrow>G,F)"
proof -
  from A1 have "IsAmonoid(X\<rightarrow>G,F)"
    using group0_2_L1 monoid0.Group_ZF_2_1_T1
    by simp
  moreover have
    "\<forall>s\<in>X\<rightarrow>G. \<exists>i\<in>X\<rightarrow>G. F`\<langle> s,i\<rangle> = TheNeutralElement(X\<rightarrow>G,F)"
  proof
    fix s assume A2: "s : X\<rightarrow>G"
    let ?i = "GroupInv(G,P) O s"
    from groupAssum A2 have "?i:X\<rightarrow>G"
      using group0_2_T2 comp_fun by simp
    moreover from A1 A2 have
      "F`\<langle> s,?i\<rangle> = TheNeutralElement(X\<rightarrow>G,F)"
      using Group_ZF_2_1_L5 by fast
   ultimately show "\<exists>i\<in>X\<rightarrow>G. F`\<langle> s,i\<rangle> = TheNeutralElement(X\<rightarrow>G,F)"
      by auto
  qed
  ultimately show ?thesis using IsAgroup_def
    by simp
qed

text\<open>What is the group inverse for the lifted group?\<close>

lemma (in group0) Group_ZF_2_1_L6:
  assumes A1: "F = P {lifted to function space over} X"
  shows "\<forall>s\<in>(X\<rightarrow>G). GroupInv(X\<rightarrow>G,F)`(s) = GroupInv(G,P) O s"
proof -
  from A1 have  "group0(X\<rightarrow>G,F)"
    using group0_def Group_ZF_2_1_T2
    by simp
  moreover from A1 have "\<forall>s\<in>X\<rightarrow>G. GroupInv(G,P) O s : X\<rightarrow>G \<and>
    F`\<langle> s,GroupInv(G,P) O s\<rangle> = TheNeutralElement(X\<rightarrow>G,F)"
    using Group_ZF_2_1_L5 by simp
  ultimately have
    "\<forall>s\<in>(X\<rightarrow>G).  GroupInv(G,P) O s = GroupInv(X\<rightarrow>G,F)`(s)"
    by (rule group0.group0_2_L9A)
  thus ?thesis by simp
qed

text\<open>What is the value of the group inverse for the lifted group?\<close>

corollary (in group0) lift_gr_inv_val:
  assumes "F = P {lifted to function space over} X" and
  "s : X\<rightarrow>G" and "x\<in>X"
  shows  "(GroupInv(X\<rightarrow>G,F)`(s))`(x) = (s`(x))\<inverse>"
  using groupAssum assms Group_ZF_2_1_L6 group0_2_T2 comp_fun_apply
  by simp

text\<open>What is the group inverse in a subgroup of the lifted group?\<close>

lemma (in group0) Group_ZF_2_1_L6A:
  assumes A1: "F = P {lifted to function space over} X"
  and A2: "IsAsubgroup(H,F)"
  and A3: "g = restrict(F,H\<times>H)"
  and A4: "s\<in>H"
  shows "GroupInv(H,g)`(s) = GroupInv(G,P) O s"
proof -
  from A1 have T1: "group0(X\<rightarrow>G,F)"
    using group0_def Group_ZF_2_1_T2
    by simp
  with A2 A3 A4 have "GroupInv(H,g)`(s) = GroupInv(X\<rightarrow>G,F)`(s)"
    using group0.group0_3_T1 restrict by simp
  moreover from T1 A1 A2 A4 have
    "GroupInv(X\<rightarrow>G,F)`(s) = GroupInv(G,P) O s"
    using group0.group0_3_L2 Group_ZF_2_1_L6 by blast
  ultimately show ?thesis by simp
qed

text\<open>If a group is abelian, then its lift to a function space is also
  abelian.\<close>

lemma (in group0) Group_ZF_2_1_L7:
  assumes A1: "F = P {lifted to function space over} X"
  and A2: "P {is commutative on} G"
  shows "F {is commutative on} (X\<rightarrow>G)"
proof-
  from A1 A2  have
    "F {is commutative on} (X\<rightarrow>range(P))"
    using group_oper_fun func_ZF_2_L2
    by simp
  moreover from groupAssum have "range(P) = G"
    using group0_2_L1 monoid0.group0_1_L3B
    by simp
  ultimately show ?thesis by simp
qed

subsection\<open>Equivalence relations on groups\<close>

text\<open>The goal of this section is to establish that (under some conditions)
  given an equivalence
  relation on a group or (monoid )we can project the group (monoid)
  structure on the quotient and obtain another group.\<close>

text\<open>The neutral element class is neutral in the projection.\<close>

lemma (in monoid0) Group_ZF_2_2_L1:
  assumes A1: "equiv(G,r)" and A2:"Congruent2(r,f)"
  and A3: "F = ProjFun2(G,r,f)"
  and A4: "e = TheNeutralElement(G,f)"
  shows "r``{e} \<in> G//r \<and>
  (\<forall>c \<in> G//r. F`\<langle> r``{e},c\<rangle> = c \<and>  F`\<langle> c,r``{e}\<rangle> = c)"
proof
  from A4 show T1:"r``{e} \<in> G//r"
    using unit_is_neutral quotientI
    by simp
  show
    "\<forall>c \<in> G//r. F`\<langle> r``{e},c\<rangle> = c \<and>  F`\<langle> c,r``{e}\<rangle> = c"
  proof
    fix c assume A5:"c \<in> G//r"
    then obtain g where D1:"g\<in>G" "c = r``{g}"
      using quotient_def by auto
    with A1 A2 A3 A4 D1 show
      "F`\<langle> r``{e},c\<rangle> = c \<and>  F`\<langle> c,r``{e}\<rangle> = c"
      using unit_is_neutral EquivClass_1_L10 (*group0_1_L3*)
      by simp
  qed
qed

text\<open>The projected structure is a monoid.\<close>

theorem (in monoid0) Group_ZF_2_2_T1:
  assumes A1: "equiv(G,r)" and A2: "Congruent2(r,f)"
  and A3: "F = ProjFun2(G,r,f)"
  shows "IsAmonoid(G//r,F)"
proof -
  let ?E = "r``{TheNeutralElement(G,f)}"
  from A1 A2 A3 have
    "?E \<in> G//r \<and> (\<forall>c\<in>G//r. F`\<langle> ?E,c\<rangle> = c \<and> F`\<langle> c,?E\<rangle> = c)"
    using Group_ZF_2_2_L1 by simp
  hence
    "\<exists>E\<in>G//r. \<forall> c\<in>G//r. F`\<langle> E,c\<rangle> = c \<and> F`\<langle> c,E\<rangle> = c"
    by auto
  with monoidAssum A1 A2 A3 show ?thesis
    using IsAmonoid_def EquivClass_2_T2
    by simp
qed

text\<open>The class of the neutral element is the neutral element of the
  projected monoid.\<close>

lemma Group_ZF_2_2_L1:
  assumes A1: "IsAmonoid(G,f)"
  and A2: "equiv(G,r)" and A3: "Congruent2(r,f)"
  and A4: "F = ProjFun2(G,r,f)"
  and A5: "e = TheNeutralElement(G,f)"
  shows " r``{e} = TheNeutralElement(G//r,F)"
proof -
  from A1 A2 A3 A4 have
    T1:"monoid0(G,f)" and T2:"monoid0(G//r,F)"
    using monoid0_def monoid0.Group_ZF_2_2_T1 by auto
  from T1 A2 A3 A4 A5 have "r``{e} \<in> G//r \<and>
    (\<forall>c \<in> G//r. F`\<langle> r``{e},c\<rangle> = c \<and>  F`\<langle> c,r``{e}\<rangle> = c)"
    using monoid0.Group_ZF_2_2_L1 by simp
  with T2 show ?thesis using monoid0.group0_1_L4
    by auto
qed

text\<open>The projected operation can be defined in terms of the group operation
  on representants in a natural way.\<close>

lemma (in group0) Group_ZF_2_2_L2:
  assumes A1: "equiv(G,r)" and A2: "Congruent2(r,P)"
  and A3: "F = ProjFun2(G,r,P)"
  and A4: "a\<in>G" "b\<in>G"
  shows "F`\<langle> r``{a},r``{b}\<rangle> = r``{a\<cdot>b}"
proof -
  from A1 A2 A3 A4 show ?thesis
    using EquivClass_1_L10 by simp
qed

text\<open>The class of the inverse is a right inverse of the class.\<close>

lemma (in group0) Group_ZF_2_2_L3:
  assumes A1: "equiv(G,r)" and A2: "Congruent2(r,P)"
  and A3: "F = ProjFun2(G,r,P)"
  and A4: "a\<in>G"
  shows "F`\<langle>r``{a},r``{a\<inverse>}\<rangle> = TheNeutralElement(G//r,F)"
proof -
  from A1 A2 A3 A4 have
    "F`\<langle>r``{a},r``{a\<inverse>}\<rangle> = r``{\<one>}"
    using inverse_in_group Group_ZF_2_2_L2 group0_2_L6
    by simp
  with groupAssum A1 A2 A3 show ?thesis
    using IsAgroup_def Group_ZF_2_2_L1 by simp
qed

text\<open>The group structure can be projected to the quotient space.\<close>

theorem (in group0) Group_ZF_3_T2:
  assumes A1: "equiv(G,r)" and A2: "Congruent2(r,P)"
  shows "IsAgroup(G//r,ProjFun2(G,r,P))"
proof -
  let ?F = "ProjFun2(G,r,P)"
  let ?E = "TheNeutralElement(G//r,?F)"
  from groupAssum A1 A2 have "IsAmonoid(G//r,?F)"
    using IsAgroup_def monoid0_def monoid0.Group_ZF_2_2_T1
    by simp
  moreover have
    "\<forall>c\<in>G//r. \<exists>b\<in>G//r. ?F`\<langle> c,b\<rangle> = ?E"
  proof
    fix c assume A3: "c \<in> G//r"
    then obtain g where D1: "g\<in>G"  "c = r``{g}"
      using quotient_def by auto
    let ?b = "r``{g\<inverse>}"
    from D1 have "?b \<in> G//r"
      using inverse_in_group quotientI
      by simp
    moreover from A1 A2 D1 have
      "?F`\<langle> c,?b\<rangle> = ?E"
      using Group_ZF_2_2_L3 by simp
    ultimately show "\<exists>b\<in>G//r. ?F`\<langle> c,b\<rangle> = ?E"
      by auto
  qed
  ultimately show ?thesis
    using IsAgroup_def by simp
qed

text\<open>The group inverse (in the projected group) of a class is the class
  of the inverse.\<close>

lemma (in group0) Group_ZF_2_2_L4:
  assumes A1: "equiv(G,r)" and
  A2: "Congruent2(r,P)" and
  A3: "F = ProjFun2(G,r,P)" and
  A4: "a\<in>G"
  shows "r``{a\<inverse>} = GroupInv(G//r,F)`(r``{a})"
proof -
  from A1 A2 A3 have "group0(G//r,F)"
    using Group_ZF_3_T2 group0_def by simp
  moreover from A4 have
    "r``{a} \<in> G//r"  "r``{a\<inverse>} \<in> G//r"
    using inverse_in_group quotientI by auto
  moreover from A1 A2 A3 A4 have
     "F`\<langle>r``{a},r``{a\<inverse>}\<rangle> = TheNeutralElement(G//r,F)"
    using Group_ZF_2_2_L3 by simp
  ultimately show ?thesis
    by (rule group0.group0_2_L9)
qed

subsection\<open>Normal subgroups and quotient groups\<close>

text\<open>If $H$ is a subgroup of $G$, then for every $a\in G$
  we can cosider the sets $\{a\cdot h. h \in H\}$
  and $\{ h\cdot a. h \in H\}$ (called a left and right ''coset of H'', resp.)
  These sets sometimes form a group, called the ''quotient group''.
  This section discusses the notion of quotient groups.\<close>

text\<open>A normal subgorup $N$ of a group $G$ is such that $aba^{-1}$ belongs to
  $N$ if $a\in G, b\in N$.\<close>

definition
  "IsAnormalSubgroup(G,P,N) \<equiv> IsAsubgroup(N,P) \<and>
  (\<forall>n\<in>N.\<forall>g\<in>G. P`\<langle>  P`\<langle>  g,n \<rangle>,GroupInv(G,P)`(g) \<rangle> \<in> N)"

text\<open>Having a group and a normal subgroup $N$
  we can create another group
  consisting of eqivalence classes of the relation
  $a\sim b \equiv a\cdot b^{-1} \in N$.  We will refer to this relation
  as the quotient group relation. The classes of this relation are in
  fact cosets of subgroup $H$.\<close>

definition
  "QuotientGroupRel(G,P,H) \<equiv>
  {\<langle> a,b\<rangle> \<in> G\<times>G. P`\<langle> a, GroupInv(G,P)`(b)\<rangle> \<in> H}"

text\<open>Next we define the operation in the quotient group as the
  projection of the group operation on the classses of the
  quotient group relation.\<close>

definition
  "QuotientGroupOp(G,P,H) \<equiv> ProjFun2(G,QuotientGroupRel(G,P,H ),P)"

text\<open>Definition of a normal subgroup in a more readable notation.\<close>

lemma (in group0) Group_ZF_2_4_L0:
  assumes "IsAnormalSubgroup(G,P,H)"
  and "g\<in>G" "n\<in>H"
  shows "g\<cdot>n\<cdot>g\<inverse> \<in> H"
  using assms IsAnormalSubgroup_def by simp

text\<open>The quotient group relation is reflexive.\<close>

lemma (in group0) Group_ZF_2_4_L1:
  assumes "IsAsubgroup(H,P)"
  shows "refl(G,QuotientGroupRel(G,P,H))"
  using assms  group0_2_L6 group0_3_L5
    QuotientGroupRel_def refl_def by simp

text\<open>The quotient group relation is symmetric.\<close>

lemma (in group0) Group_ZF_2_4_L2:
  assumes A1:"IsAsubgroup(H,P)"
  shows "sym(QuotientGroupRel(G,P,H))"
proof -
  {
    fix a b assume A2: "\<langle> a,b\<rangle> \<in> QuotientGroupRel(G,P,H)"
    with A1 have "(a\<cdot>b\<inverse>)\<inverse> \<in> H"
      using QuotientGroupRel_def group0_3_T3A
      by simp
    moreover from A2 have "(a\<cdot>b\<inverse>)\<inverse> =  b\<cdot>a\<inverse>"
      using QuotientGroupRel_def group0_2_L12
      by simp
    ultimately have "b\<cdot>a\<inverse> \<in> H" by simp
    with A2 have "\<langle> b,a\<rangle> \<in> QuotientGroupRel(G,P,H)"
      using QuotientGroupRel_def by simp
  }
  then show ?thesis using symI by simp
qed

text\<open>The quotient group relation is transistive.\<close>

lemma (in group0) Group_ZF_2_4_L3A:
  assumes A1: "IsAsubgroup(H,P)" and
  A2: "\<langle> a,b\<rangle> \<in> QuotientGroupRel(G,P,H)" and
  A3: "\<langle> b,c\<rangle> \<in> QuotientGroupRel(G,P,H)"
  shows "\<langle> a,c\<rangle> \<in> QuotientGroupRel(G,P,H)"
proof -
  let ?r = "QuotientGroupRel(G,P,H)"
  from A2 A3 have T1:"a\<in>G" "b\<in>G" "c\<in>G"
    using QuotientGroupRel_def by auto
  from A1 A2 A3 have "(a\<cdot>b\<inverse>)\<cdot>(b\<cdot>c\<inverse>) \<in> H"
    using  QuotientGroupRel_def group0_3_L6
    by simp
  moreover from T1 have
    "a\<cdot>c\<inverse> = (a\<cdot>b\<inverse>)\<cdot>(b\<cdot>c\<inverse>)"
    using group0_2_L14A by blast
  ultimately have "a\<cdot>c\<inverse> \<in> H"
    by simp
  with T1 show ?thesis using QuotientGroupRel_def
    by simp
qed

text\<open>The quotient group relation is an equivalence relation. Note
  we do not need the subgroup to be normal for this to be true.\<close>

lemma (in group0) Group_ZF_2_4_L3: assumes A1:"IsAsubgroup(H,P)"
  shows "equiv(G,QuotientGroupRel(G,P,H))"
proof -
  let ?r = "QuotientGroupRel(G,P,H)"
  from A1 have
     "\<forall>a b c. (\<langle>a, b\<rangle> \<in> ?r  \<and>  \<langle>b, c\<rangle> \<in> ?r \<longrightarrow> \<langle>a, c\<rangle> \<in> ?r)"
    using Group_ZF_2_4_L3A by blast
  then have "trans(?r)"
    using Fol1_L2 by blast
  with A1 show ?thesis
    using Group_ZF_2_4_L1 Group_ZF_2_4_L2
      QuotientGroupRel_def equiv_def
    by auto
qed

text\<open>The next lemma states the essential condition for congruency of
  the group operation with respect to the quotient group relation.\<close>

lemma (in group0) Group_ZF_2_4_L4:
  assumes A1: "IsAnormalSubgroup(G,P,H)"
  and A2: "\<langle>a1,a2\<rangle> \<in> QuotientGroupRel(G,P,H)"
  and A3: "\<langle>b1,b2\<rangle> \<in> QuotientGroupRel(G,P,H)"
  shows "\<langle>a1\<cdot>b1, a2\<cdot>b2\<rangle> \<in> QuotientGroupRel(G,P,H)"
proof -
  from A2 A3 have T1:
    "a1\<in>G"  "a2\<in>G"  "b1\<in>G"  "b2\<in>G"
    "a1\<cdot>b1 \<in> G"  "a2\<cdot>b2 \<in> G"
    "b1\<cdot>b2\<inverse> \<in> H"  "a1\<cdot>a2\<inverse> \<in> H"
    using QuotientGroupRel_def group0_2_L1 monoid0.group0_1_L1
    by auto
  with A1 show ?thesis using
    IsAnormalSubgroup_def group0_3_L6 group0_2_L15
    QuotientGroupRel_def by simp
qed

text\<open>If the subgroup is normal, the group operation is congruent
  with respect to the quotient group relation.\<close>

lemma Group_ZF_2_4_L5A:
  assumes "IsAgroup(G,P)"
  and "IsAnormalSubgroup(G,P,H)"
  shows "Congruent2(QuotientGroupRel(G,P,H),P)"
  using assms group0_def group0.Group_ZF_2_4_L4 Congruent2_def
  by simp

text\<open>The quotient group is indeed a group.\<close>

theorem Group_ZF_2_4_T1:
  assumes "IsAgroup(G,P)" and "IsAnormalSubgroup(G,P,H)"
  shows
  "IsAgroup(G//QuotientGroupRel(G,P,H),QuotientGroupOp(G,P,H))"
  using assms group0_def group0.Group_ZF_2_4_L3 IsAnormalSubgroup_def
    Group_ZF_2_4_L5A group0.Group_ZF_3_T2 QuotientGroupOp_def
  by simp

text\<open>The class (coset) of the neutral element is the neutral
  element of the quotient group.\<close>

lemma Group_ZF_2_4_L5B:
  assumes "IsAgroup(G,P)" and "IsAnormalSubgroup(G,P,H)"
  and "r = QuotientGroupRel(G,P,H)"
  and "e = TheNeutralElement(G,P)"
  shows " r``{e} = TheNeutralElement(G//r,QuotientGroupOp(G,P,H))"
  using assms IsAnormalSubgroup_def group0_def
    IsAgroup_def group0.Group_ZF_2_4_L3 Group_ZF_2_4_L5A
    QuotientGroupOp_def Group_ZF_2_2_L1
  by simp

text\<open>A group element is equivalent to the neutral element iff it is in the
  subgroup we divide the group by.\<close>

lemma (in group0) Group_ZF_2_4_L5C: assumes "a\<in>G"
  shows "\<langle>a,\<one>\<rangle> \<in> QuotientGroupRel(G,P,H) \<longleftrightarrow> a\<in>H"
  using assms QuotientGroupRel_def group_inv_of_one group0_2_L2
  by auto

text\<open>A group element is in $H$ iff its class is the neutral element of
  $G/H$.\<close>

lemma (in group0) Group_ZF_2_4_L5D:
  assumes A1: "IsAnormalSubgroup(G,P,H)" and
  A2: "a\<in>G" and
  A3: "r = QuotientGroupRel(G,P,H)" and
  A4: "TheNeutralElement(G//r,QuotientGroupOp(G,P,H)) = e"
  shows "r``{a} = e \<longleftrightarrow> \<langle>a,\<one>\<rangle> \<in> r"
proof
  assume "r``{a} = e"
  with groupAssum assms have
    "r``{\<one>} = r``{a}" and I: "equiv(G,r)"
    using Group_ZF_2_4_L5B IsAnormalSubgroup_def Group_ZF_2_4_L3
    by auto
  with A2 have "\<langle>\<one>,a\<rangle> \<in> r" using eq_equiv_class
    by simp
  with I show "\<langle>a,\<one>\<rangle> \<in> r" by (rule equiv_is_sym)
next assume "\<langle>a,\<one>\<rangle> \<in> r"
  moreover from A1 A3 have "equiv(G,r)"
    using IsAnormalSubgroup_def Group_ZF_2_4_L3
    by simp
  ultimately have "r``{a} = r``{\<one>}"
    using equiv_class_eq by simp
  with groupAssum A1 A3 A4 show "r``{a} = e"
    using Group_ZF_2_4_L5B by simp
qed

text\<open>The class of $a\in G$ is the neutral
  element of the quotient $G/H$ iff $a\in H$.\<close>

lemma (in group0) Group_ZF_2_4_L5E:
  assumes "IsAnormalSubgroup(G,P,H)" and
  "a\<in>G" and "r = QuotientGroupRel(G,P,H)" and
  "TheNeutralElement(G//r,QuotientGroupOp(G,P,H)) = e"
  shows "r``{a} = e \<longleftrightarrow> a\<in>H"
  using assms Group_ZF_2_4_L5C  Group_ZF_2_4_L5D
  by simp

text\<open>Essential condition to show that every subgroup of an abelian group
  is normal.\<close>

lemma (in group0) Group_ZF_2_4_L5:
  assumes A1: "P {is commutative on} G"
  and A2: "IsAsubgroup(H,P)"
  and A3: "g\<in>G"  "h\<in>H"
  shows "g\<cdot>h\<cdot>g\<inverse> \<in> H"
proof -
  from A2 A3 have T1:"h\<in>G" "g\<inverse> \<in> G"
    using group0_3_L2 inverse_in_group by auto
  with A3 A1 have "g\<cdot>h\<cdot>g\<inverse> = g\<inverse>\<cdot>g\<cdot>h"
    using group0_4_L4A by simp
  with A3 T1 show ?thesis using
    group0_2_L6 group0_2_L2
    by simp
qed

text\<open>Every subgroup of an abelian group is normal. Moreover, the quotient
  group is also abelian.\<close>

lemma Group_ZF_2_4_L6:
  assumes A1: "IsAgroup(G,P)"
  and A2: "P {is commutative on} G"
  and A3: "IsAsubgroup(H,P)"
  shows  "IsAnormalSubgroup(G,P,H)"
  "QuotientGroupOp(G,P,H) {is commutative on} (G//QuotientGroupRel(G,P,H))"
proof -
  from A1 A2 A3 show T1: "IsAnormalSubgroup(G,P,H)" using
    group0_def IsAnormalSubgroup_def group0.Group_ZF_2_4_L5
    by simp
  let ?r = "QuotientGroupRel(G,P,H)"
  from A1 A3 T1 have "equiv(G,?r)" "Congruent2(?r,P)"
    using group0_def group0.Group_ZF_2_4_L3 Group_ZF_2_4_L5A
    by auto
  with A2 show
    "QuotientGroupOp(G,P,H) {is commutative on} (G//QuotientGroupRel(G,P,H))"
    using EquivClass_2_T1 QuotientGroupOp_def
    by simp
qed

text\<open>The group inverse (in the quotient group) of a class (coset) is the class
  of the inverse.\<close>

lemma (in group0) Group_ZF_2_4_L7:
  assumes "IsAnormalSubgroup(G,P,H)"
  and "a\<in>G" and "r = QuotientGroupRel(G,P,H)"
  and "F = QuotientGroupOp(G,P,H)"
  shows "r``{a\<inverse>} = GroupInv(G//r,F)`(r``{a})"
  using groupAssum assms IsAnormalSubgroup_def Group_ZF_2_4_L3
    Group_ZF_2_4_L5A QuotientGroupOp_def Group_ZF_2_2_L4
  by simp

subsection\<open>Function spaces as monoids\<close>

text\<open>On every space of functions $\{f : X\rightarrow X\}$
  we can define a natural
  monoid structure with composition as the operation. This section explores
  this fact.\<close>

text\<open>The next lemma states that composition has a neutral element,
  namely the identity function on $X$
  (the one that maps $x\in X$ into itself).\<close>

lemma Group_ZF_2_5_L1: assumes A1: "F = Composition(X)"
  shows "\<exists>I\<in>(X\<rightarrow>X). \<forall>f\<in>(X\<rightarrow>X). F`\<langle> I,f\<rangle> = f \<and> F`\<langle> f,I\<rangle> = f"
proof-
  let ?I = "id(X)"
  from A1 have
    "?I \<in> X\<rightarrow>X \<and> (\<forall>f\<in>(X\<rightarrow>X). F`\<langle> ?I,f\<rangle> = f \<and> F`\<langle> f,?I\<rangle> = f)"
    using id_type func_ZF_6_L1A by simp
  thus ?thesis by auto
qed

text\<open>The space of functions that map a set $X$ into
  itsef is a monoid with composition as operation and the identity function
  as the neutral element.\<close>

lemma Group_ZF_2_5_L2: shows
  "IsAmonoid(X\<rightarrow>X,Composition(X))"
  "id(X) = TheNeutralElement(X\<rightarrow>X,Composition(X))"
proof -
  let ?I = "id(X)"
  let ?F = "Composition(X)"
  show "IsAmonoid(X\<rightarrow>X,Composition(X))"
    using func_ZF_5_L5 Group_ZF_2_5_L1 IsAmonoid_def
    by auto
  then have "monoid0(X\<rightarrow>X,?F)"
    using monoid0_def by simp
  moreover have
    "?I \<in> X\<rightarrow>X \<and> (\<forall>f\<in>(X\<rightarrow>X). ?F`\<langle> ?I,f\<rangle> = f \<and> ?F`\<langle> f,?I\<rangle> = f)"
    using id_type func_ZF_6_L1A by simp
  ultimately show "?I = TheNeutralElement(X\<rightarrow>X,?F)"
    using monoid0.group0_1_L4 by auto
qed

end


theory Union_Find_ImpHol
imports
  Union_Find_Fun
  "Separation_Logic_Imperative_HOL.Sep_Main"
  "HOL-Library.Code_Target_Numeral"
begin

thm nth_list_update'

subsection \<open>Implementation with Imperative/HOL\<close>
text \<open>In this section, we implement the union-find data-structure with
  two arrays, one holding the next-pointers, and another one holding the size
  information. Note that we do not prove that the array for the
  size information contains any reasonable values, as the correctness of the
  algorithm is not affected by this. We leave it future work to also estimate
  the complexity of the algorithm.
\<close>

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where
  "is_uf R u \<equiv> case u of (s,p) \<Rightarrow>
  \<exists>\<^sub>Al szl. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>aszl
    * \<up>(ufa_invar l \<and> ufa_\<alpha> l = R \<and> length szl = length l)"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n \<equiv> do {
    l \<leftarrow> Array.of_list [0..<n];
    szl \<leftarrow> Array.new n (1::nat);
    return (szl,l)
  }"

lemma uf_init_rule[sep_heap_rules]:
  "<emp> uf_init n <is_uf {(i,i) |i. i<n}>"
  unfolding uf_init_def is_uf_def[abs_def]
  by (sep_auto simp: ufa_init_correct ufa_init_invar)

partial_function (heap) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where [code]:
  "uf_rep_of p i = do {
    n \<leftarrow> Array.nth p i;
    if n=i then return i else uf_rep_of p n
  }"

lemma uf_rep_of_rule[sep_heap_rules]: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>"
  apply (induct rule: rep_of_induct)
  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_refl)

  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_step)
  done

text \<open>We chose a non tail-recursive version here, as it is easier to prove.\<close>
partial_function (heap) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap"
  where [code]:
  "uf_compress i ci p = (
    if i=ci then return ()
    else do {
      ni\<leftarrow>Array.nth p i;
      uf_compress ni ci p;
      Array.upd i ci p;
      return ()
    })"

lemma uf_compress_rule: "\<lbrakk> ufa_invar l; i<length l; ci=rep_of l i \<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_compress i ci p
  <\<lambda>_. \<exists>\<^sub>Al'. p\<mapsto>\<^sub>al' * \<up>(ufa_invar l' \<and> length l' = length l
     \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>"
proof (induction rule: rep_of_induct)
  case (base i) thus ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: rep_of_refl)
    done
next
  case (step i)
  note SS = \<open>ufa_invar l\<close> \<open>i<length l\<close> \<open>l!i\<noteq>i\<close> \<open>ci = rep_of l i\<close>

  from step.IH
  have IH':
    "<p \<mapsto>\<^sub>a l>
       uf_compress (l ! i) (rep_of l i) p
     <\<lambda>_. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' *
        \<up> (ufa_invar l' \<and> length l = length l'
           \<and> (\<forall>i<length l'. rep_of l i = rep_of l' i))
     >"
    apply (simp add: rep_of_idx SS)
    apply (erule
      back_subst[OF _ cong[OF cong[OF arg_cong[where f=hoare_triple]]]])
    apply (auto) [2]
    apply (rule ext)
    apply (rule ent_iffI)
    apply sep_auto+
    done

  show ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: SS)

    apply (rule IH')

    using SS apply (sep_auto (plain))
    using ufa_compress_invar apply fastforce []
    apply simp
    using ufa_compress_aux(2) apply fastforce []
    done
qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where "uf_rep_of_c p i \<equiv> do {
    ci\<leftarrow>uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule[sep_heap_rules]: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_rep_of_c p i <\<lambda>r. \<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l'
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>"
  unfolding uf_rep_of_c_def
  by (sep_auto heap: uf_compress_rule)

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j \<equiv> do {
    let (s,p)=u;
    n\<leftarrow>Array.len p;
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci\<leftarrow>uf_rep_of_c p i;
      cj\<leftarrow>uf_rep_of_c p j;
      return (ci=cj)
    }
  }"

lemma cnv_to_ufa_\<alpha>_eq:
  "\<lbrakk>(\<forall>i<length l. rep_of l' i = rep_of l i); length l = length l'\<rbrakk>
  \<Longrightarrow> (ufa_\<alpha> l = ufa_\<alpha> l')"
  unfolding ufa_\<alpha>_def by auto

lemma uf_cmp_rule[sep_heap_rules]:
  "<is_uf R u> uf_cmp u i j <\<lambda>r. is_uf R u * \<up>(r\<longleftrightarrow>(i,j)\<in>R)>"
  unfolding uf_cmp_def is_uf_def
  apply (sep_auto dest: ufa_\<alpha>_lenD simp: not_le split: prod.split)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (subst ufa_find_correct)
  apply (auto simp add: )
  done

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j \<equiv> do {
    let (s,p)=u;
    ci \<leftarrow> uf_rep_of p i;
    cj \<leftarrow> uf_rep_of p j;
    if (ci=cj) then return (s,p)
    else do {
      si \<leftarrow> Array.nth s ci;
      sj \<leftarrow> Array.nth s cj;
      if si<sj then do {
        Array.upd ci cj p;
        Array.upd cj (si+sj) s;
        return (s,p)
      } else do {
        Array.upd cj ci p;
        Array.upd ci (si+sj) s;
        return (s,p)
      }
    }
  }"

lemma uf_union_rule[sep_heap_rules]: "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u> uf_union u i j <is_uf (per_union R i j)>"
  unfolding uf_union_def
  apply (cases u)
  apply (simp add: is_uf_def[abs_def])
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  done

export_code uf_init uf_cmp uf_union checking SML_imp

export_code uf_init uf_cmp uf_union checking Scala_imp

(*
ML_val {*
  val u = @{code uf_init} 10 ();

  val u = @{code uf_union} u 1 2 ();
  val u = @{code uf_union} u 3 4 ();
  val u = @{code uf_union} u 5 6 ();
  val u = @{code uf_union} u 7 8 ();

  val u = @{code uf_union} u 1 3 ();
  val u = @{code uf_union} u 5 7 ();

  val u = @{code uf_union} u 1 5 ();

  val b = @{code uf_cmp} u 8 4 ();
  val it = u;
*}*)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |                  March 2007               |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_fix
imports CSP_T_law_fp
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

definition
 FIXn :: "nat => ('p => ('p,'a) proc) => ('p => ('p,'a) proc)"
                                                      ("FIX[_] _" [0,1000] 55)
  where
  FIXn_def :  "FIX[n] Pf == ((Pf <<< )^^n) (%q. DIV)"

definition
  FIX  :: "(('p) => ('p,'a) proc) => ('p => ('p,'a) proc)"
                                                      ("FIX _" [1000] 55)
  where
  FIX_def : "FIX Pf == (%p. (!nat n .. ((FIX[n] Pf) p)))"

(* ----- test ----- *
consts
 FIXnrec :: "nat => ('p => ('p,'a) proc) => ('p => ('p,'a) proc)"
                                                      ("FIXrec[_] _" [0,1000] 55)
primrec
     "FIXrec[0] Pf = (%p. DIV)"
 "FIXrec[Suc n] Pf = (%p. (Pf p)<<(FIXrec[n] Pf))"

lemma FIXn_FIXnrec: "FIX[n] Pf = FIXrec[n] Pf"
apply (induct_tac n)
apply (simp_all add: FIXn_def)
done

 * ----- test ----- *)

(*-----------*
 |   noPN    |
 *-----------*)

lemma noPNfun_FIXn: "noPNfun (%p. (FIX[n] Pf)(p))"
apply (simp add: FIXn_def)
apply (induct_tac n)
apply (simp add: noPNfun_def)
apply (simp (no_asm) add: noPNfun_def)
apply (intro allI)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: noPN_Subst_Pf)
done

lemma noPN_FIXn: "noPN ((FIX[n] Pf)p)"
apply (insert noPNfun_FIXn[of _ Pf])
apply (simp add: noPNfun_def)
done

lemma noPN_FIX: "noPN ((FIX Pf) p)"
apply (simp add: FIX_def)
apply (simp add: noPN_FIXn)
done

(*-----------*
 |    Bot    |
 *-----------*)

lemma traces_prod_Bot: "(%p. traces DIV M) = Bot"
apply (simp add: prod_Bot_def)
apply (simp add: fun_eq_iff)
apply (simp add: traces_iff)
apply (simp add: bottom_domT_def)
done

lemma semT_prod_Bot: "(%p. [[DIV]]T) = Bot"
by (simp add: semT_def semTf_def traces_prod_Bot)

(*-----------*
 |   FIX P   |
 *-----------*)

lemma traces_subst_Bot: "traces (P<<(%q. DIV)) M = (traces P) Bot"
apply (induct_tac P)
apply (simp_all add: traces_iff)
apply (simp add: prod_Bot_def)
apply (simp add: bottom_domT_def)
done

lemma traces_iteration_semTfun_Bot:
  "ALL p. traces (((Pf <<<) ^^ n) (%q. DIV) p) M = ([[Pf]]Tfun ^^ n) Bot p"
apply (simp add: semTfun_def)
apply (simp add: semTf_def)
apply (induct_tac n)

(* base *)
apply (simp_all add: traces_iff)
apply (simp add: prod_Bot_def)
apply (simp add: bottom_domT_def)

(* step *)
apply (simp add: Subst_procfun_prod_def)
apply (simp add: traces_subst)
done

lemma traces_FIX:
    "traces ((FIX Pf) p) M
     = UnionT {u. EX n. u = ([[Pf]]Tfun ^^ n) Bot p}"
apply (simp add: FIX_def FIXn_def)
apply (subgoal_tac "{u. EX n. u = ([[Pf]]Tfun ^^ n) Bot p} ~= {}")
apply (rule order_antisym)

 (* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (erule disjE, simp)
 apply (elim conjE exE)
 apply (rule_tac x="traces (((Pf <<<) ^^ n) (%q. DIV) p) M" in exI)
 apply (simp)
 apply (rule_tac x="n" in exI)
 apply (simp add: traces_iteration_semTfun_Bot)

 (* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (rule disjI2)
 apply (elim conjE exE)
 apply (simp)
 apply (rule_tac x="na" in exI)
 apply (simp add: traces_iteration_semTfun_Bot)

by (auto)

(*** [[ ]]T ***)

lemma semT_FIX:
    "[[(FIX Pf) p]]T
     = UnionT {u. EX n. u = ([[Pf]]Tfun ^^ n) Bot p}"
apply (simp add: semT_def semTf_def)
apply (simp add: traces_FIX)
done

(*** FIX is LUB ***)

lemma semT_FIX_isLUB:
   "(%p. [[(FIX Pf) p]]T) isLUB {x. EX n. x = ([[Pf]]Tfun ^^ n) Bot}"
apply (simp add: prod_LUB_decompo)
apply (intro allI)
apply (simp add: proj_fun_def)
apply (simp add: image_def)
apply (simp add: semT_FIX)
apply (subgoal_tac
     "{y. EX x. (EX n. x = ([[Pf]]Tfun ^^ n) Bot) & y = x i} =
      {u. EX n. u = ([[Pf]]Tfun ^^ n) Bot i}")
apply (simp)
apply (rule UnionT_isLUB)
apply (auto)
done

lemma semT_FIX_LUB:
   "(%p. [[(FIX Pf) p]]T) = LUB {x. EX n. x = ([[Pf]]Tfun ^^ n) Bot}"
apply (rule sym)
apply (rule isLUB_LUB)
apply (simp add: semT_FIX_isLUB)
done

lemma semT_FIX_LFP:
   "(%p. [[(FIX Pf) p]]T) = LFP [[Pf]]Tfun"
apply (simp add: semT_FIX_LUB)
apply (simp add: Tarski_thm_LFP_LUB continuous_semTfun)
done

lemma semT_FIX_LFP_p:
   "[[(FIX Pf) p]]T = LFP [[Pf]]Tfun p"
apply (insert semT_FIX_LFP[of Pf])
apply (simp add: fun_eq_iff)
done

lemma semT_FIX_isLFP:
   "(%p. [[(FIX Pf) p]]T) isLFP [[Pf]]Tfun"
apply (simp add: semT_FIX_LFP)
apply (simp add: LFP_is Tarski_thm_EX continuous_semTfun)
done

lemma semT_FIX_LFP_fixed_point:
   "[[Pf]]Tfun (%p. [[(FIX Pf) p]]T) = (%p. [[(FIX Pf) p]]T)"
apply (insert semT_FIX_isLFP[of Pf])
apply (simp add: isLFP_def)
done

lemma semT_FIX_LFP_least:
   "ALL Tf. [[Pf]]Tfun Tf = Tf --> (%p. [[(FIX Pf) p]]T) <= Tf"
apply (insert semT_FIX_isLFP[of Pf])
apply (simp add: isLFP_def)
done

(*=======================================================*
 |                                                       |
 |                        CPO                            |
 |                                                       |
 *=======================================================*)

lemma cspT_FIX_cpo:
  "[| FPmode = CPOmode |
      FPmode = MIXmode ;
      Pf = PNfun |]
  ==> $p =T (FIX Pf)(p)"
apply (simp add: eqT_def)
apply (fold semT_def)
apply (simp add: semT_FIX_LFP_p)
apply (simp add: semT_LFP_cpo)
done

lemma cspT_FIX_cms:
  "[| FPmode = CMSmode ;
      Pf = PNfun ;
      guardedfun (Pf) |]
  ==> $p =T (FIX Pf)(p)"
apply (simp add: eqT_def)
apply (fold semT_def)
apply (simp add: semT_FIX_LFP_p)
apply (simp add: semT_guarded_LFP_UFP)
apply (simp add: semT_UFP_cms)
done

lemma cspT_FIX:
  "[| FPmode = CPOmode |
      FPmode = CMSmode & guardedfun (Pf) |
      FPmode = MIXmode ;
      Pf = PNfun |]
  ==> $p =T (FIX Pf)(p)"
apply (erule disjE)
apply (simp add: cspT_FIX_cpo)
apply (erule disjE)
apply (simp add: cspT_FIX_cms)
apply (simp add: cspT_FIX_cpo)
done

(*==============================================================*
 |                                                              |
 | replace process names by infinite repcicated internal choice |
 |                         rmPN   (FIX)                         |
 |                                                              |
 *==============================================================*)

primrec
   rmPN :: "('p,'a) proc => ('p,'a) proc"
where
  "rmPN(STOP)        = STOP"
 |"rmPN(SKIP)        = SKIP"
 |"rmPN(DIV)         = DIV"
 |"rmPN(a -> P)      = a -> (rmPN P)"
 |"rmPN(? :A -> Pf)  = ? a:A -> (rmPN (Pf a))"
 |"rmPN(P [+] Q)     = (rmPN P) [+] (rmPN Q)"
 |"rmPN(P |~| Q)     = (rmPN P) |~| (rmPN Q)"
 |"rmPN(!! :C .. Pf) = !! c:C .. rmPN (Pf c)"
 |"rmPN(IF b THEN P ELSE Q) = (IF b THEN rmPN(P) ELSE rmPN(Q))"
 |"rmPN(P |[X]| Q)   = (rmPN P) |[X]| (rmPN Q)"
 |"rmPN(P -- X)      = (rmPN P) -- X"
 |"rmPN(P [[r]])     = (rmPN P) [[r]]"
 |"rmPN(P ;; Q)      = (rmPN P) ;; (rmPN Q)"
 |"rmPN(P |. n)      = (rmPN P) |. n"
 |"rmPN($p)          = (FIX PNfun)(p)"

lemma noPN_rmPN: "noPN (rmPN P)"
apply (induct_tac P)
apply (simp_all)
apply (simp add: noPN_FIX)
done

lemma cspT_rmPN_eqT:
  "FPmode = CPOmode |
   FPmode = CMSmode & guardedfun (PNfun::('p=>('p,'a) proc)) |
   FPmode = MIXmode
   ==> (P::('p,'a) proc) =T rmPN(P)"
apply (induct_tac P)
apply (simp_all add: cspT_decompo)
apply (rule cspT_FIX)
apply (simp_all)
done

(*-------------------------------------------------------*
 |                                                       |
 |         FIX expansion (CSP-Prover intro rule)         |
 |                                                       |
 *-------------------------------------------------------*)

lemma traces_FIXn_plus_sub_lm:
 "ALL n m p. traces ((FIX[n] Pf) p) M <= traces ((FIX[n+m] Pf) p) M"
apply (rule)
apply (induct_tac n)
apply (simp add: FIXn_def Subst_procfun_prod_def)
apply (intro allI)
apply (rule)
apply (simp add: in_traces)

apply (rule allI)
apply (simp add: FIXn_def Subst_procfun_prod_def)
apply (drule_tac x="m" in spec)
apply (simp add: traces_subst)
apply (rule allI)
apply (fold order_prod_def)
apply (simp add: mono_traces[simplified mono_def])
done

lemma traces_FIXn_plus_sub:
   "traces ((FIX[n] Pf) p) M <= traces ((FIX[n+m] Pf) p) M"
by (simp add: traces_FIXn_plus_sub_lm)

lemma semT_FIXn_plus_sub:
 "[[(FIX[n] Pf) p]]Tf M <= [[(FIX[n+m] Pf) p]]Tf M"
apply (simp add: semTf_def)
apply (simp add: traces_FIXn_plus_sub)
done

lemma in_traces_FIXn_plus_sub:
  "t :t traces ((FIX[n] Pf) p) M ==> t :t traces ((FIX[n+m] Pf) p) M"
apply (insert traces_FIXn_plus_sub[of n Pf p M m])
by (auto)

(*-----------------------------------------------------*
 |  sometimes FIX[n + f n] is useful more than FIX[n]  |
 *-----------------------------------------------------*)

lemma cspT_FIX_plus_eq:
     "ALL f p. (FIX Pf) p =T[M,M] (!nat n .. ((FIX[n + f n] Pf) p))"
apply (simp add: FIX_def)
apply (simp add: eqT_def)
apply (intro allI)
apply (simp add: semTf_def)
apply (rule order_antisym)

 apply (rule)
 apply (simp add: in_traces)
 apply (rule disjI2)
 apply (elim conjE exE disjE, simp)
 apply (rule_tac x="n" in exI)
 apply (simp add: in_traces_FIXn_plus_sub)

 apply (rule)
 apply (simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp)
 apply (rule disjI2)
 apply (rule_tac x="n + f n" in exI)
 apply (simp)
done

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end


subsection\<open>ND to HC\<close>
theory NDHC
imports ND HC
begin

text\<open>The fundamental difference between the two is that Natural Deduction updates its set of assumptions while Hilbert Calculus does not.
The Deduction Theorem @{thm Deduction_theorem} helps with this.\<close>
theorem NDHC: "\<Gamma> \<turnstile> F \<Longrightarrow> AX10 \<union> \<Gamma> \<turnstile>\<^sub>H F"
proof(induction rule: ND.induct)
  case Ax thus ?case by(auto intro: HC.Ax)
next
  case NotE thus ?case by (meson AX10.intros(9) HC.simps subsetCE sup_ge1)
next
  case (NotI  F \<Gamma>)
  from HC_intros(11) have HC_NotI: "AX10 \<union> \<Gamma> \<turnstile>\<^sub>H A \<^bold>\<rightarrow> \<bottom> \<Longrightarrow> AX10 \<union> \<Gamma> \<turnstile>\<^sub>H \<^bold>\<not> A" for A
    using MP HC_mono by (metis sup_ge1)
  from NotI show ?case using Deduction_theorem[where \<Gamma>="AX10 \<union> \<Gamma>"] HC_NotI by (metis AX100 Un_assoc Un_insert_right)
next
  case (CC F \<Gamma>)
  hence "AX10 \<union> \<Gamma> \<turnstile>\<^sub>H \<^bold>\<not> F \<^bold>\<rightarrow> \<bottom>" using Deduction_theorem[where \<Gamma>="AX10 \<union> \<Gamma>"] by (metis AX100 Un_assoc Un_insert_right)
  thus "AX10 \<union> \<Gamma> \<turnstile>\<^sub>H F" using AX10.intros(10) by (metis HC.simps UnCI)
next
  case (AndE1 \<Gamma> F G) thus ?case by (meson AX10.intros(5) HC.simps UnCI)
next
  case (AndE2 \<Gamma> F G) thus ?case by (meson AX10.intros(6) HC.simps UnCI)
next
  case (AndI \<Gamma> F G) thus ?case by (meson HC_intros(10) HC_mono HC.simps sup_ge1)
next
  case (OrE \<Gamma> F G H)
  from \<open>AX10 \<union> (F \<triangleright> \<Gamma>) \<turnstile>\<^sub>H H\<close> \<open>AX10 \<union> (G \<triangleright> \<Gamma>) \<turnstile>\<^sub>H H\<close> have
       "AX10 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> H" "AX10 \<union> \<Gamma> \<turnstile>\<^sub>H G \<^bold>\<rightarrow> H"
    using Deduction_theorem[where \<Gamma>="AX10 \<union> \<Gamma>"] by (metis AX100 Un_assoc Un_insert_right)+
  with HC_intros(7)[THEN HC_mono[OF _ sup_ge1]] MP
  have "AX10 \<union> \<Gamma> \<turnstile>\<^sub>H  (F \<^bold>\<or> G) \<^bold>\<rightarrow> H" by metis
  with MP \<open>AX10 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<or> G\<close> show ?case  .
next
  case (OrI1 \<Gamma> F G) thus ?case by (meson AX10.intros(2) HC.simps UnCI)
next
  case (OrI2 \<Gamma> F G) thus ?case by (meson AX10.intros(3) HC.simps UnCI)
next
  case (ImpE \<Gamma> F G)
  from MP  \<open>AX10 \<union> \<Gamma> \<turnstile>\<^sub>H F\<close>  \<open>AX10 \<union> \<Gamma> \<turnstile>\<^sub>H F \<^bold>\<rightarrow> G\<close> show ?case .
next
  case (ImpI F \<Gamma> G) thus ?case using Deduction_theorem[where \<Gamma>="AX10 \<union> \<Gamma>"] by (metis AX100 Un_assoc Un_insert_right)
qed

end


theory SimplicialSet
  imports Main
         Gamma
         PointedSet
         "Category3.DualCategory"
         SomeCategoryTheory
begin

locale simplex
begin

definition OrdArr where
  "OrdArr t \<equiv> (partial_magma.arr fin_set.comp t) \<and> (snd (the t) \<noteq> []) \<and>
  (\<forall> i j. i \<le> j \<longrightarrow> j < (length (snd (the t))) \<longrightarrow> get (snd (the t)) i \<le> get (snd (the t)) j)"

interpretation S: subcategory fin_set.comp OrdArr
  unfolding subcategory_def apply (simp add: fin_set.is_category)
  unfolding subcategory_axioms_def apply auto
proof-
  show "\<And>f. OrdArr f \<Longrightarrow> partial_magma.arr fin_set.comp f"
    unfolding OrdArr_def by simp
  fix f
  assume "OrdArr f"
  from this have arr_f: "partial_magma.arr fin_set.comp f" by (simp add: OrdArr_def)
  from \<open>OrdArr f\<close> have f_nn: "snd (the f) \<noteq> []" by (simp add: OrdArr_def)
  from \<open>OrdArr f\<close> have f_monotone : " (\<forall>i j. i \<le> j \<longrightarrow> j < length (snd (the f)) \<longrightarrow> get (snd (the f)) i \<le> get (snd (the f)) j)"
    by (simp add: OrdArr_def)

  have fst_f_nn : "fst (the f) \<noteq> 0"
  proof-
    have "partial_magma.arr fin_set.comp f \<longrightarrow> fin_set.Arr' (the f)"
      unfolding fin_set.comp_def apply (subst classical_category.arr_char)
      using fin_set.is_classical_category apply blast
      by simp
    then have "fin_set.Arr' (the f)" using arr_f by simp
    then have "get (snd (the f)) 0 < fst (the f)" unfolding fin_set.Arr'_def
      using f_nn by blast
    then show "fst (the f) \<noteq> 0" by auto
  qed

  have dom_f : "partial_magma.dom fin_set.comp f = Some (fin_set.Id' (length (snd (the f))))"
    unfolding fin_set.comp_def
    apply (subst classical_category.dom_char)
    using fin_set.is_classical_category apply blast
    using arr_f unfolding fin_set.comp_def by simp

  have dom_length: "length (snd (the (partial_magma.dom fin_set.comp f))) = length (snd (the f))"
    apply (simp add: dom_f)
    unfolding fin_set.Id'_def by simp

  show "OrdArr (partial_magma.dom fin_set.comp f)"
    unfolding OrdArr_def apply auto
    using arr_f apply (simp add: category.arr_dom fin_set.is_category)
  proof-
    assume "snd (the (partial_magma.dom fin_set.comp f)) = []"
    then have "length (snd (the (partial_magma.dom fin_set.comp f))) = 0" by simp
    then show "False" by (simp add: dom_length f_nn)
  next
    fix i j
    assume "j < length (snd (the (partial_magma.dom fin_set.comp f)))"
    then have j_length: "j < length (snd (the f))" by (simp add: dom_length)
    assume "i \<le> j"
    then have i_length: "i < length (snd (the f))" using j_length by auto
    show "get (snd (the (partial_magma.dom fin_set.comp f))) i
           \<le> get (snd (the (partial_magma.dom fin_set.comp f))) j"
      apply (simp add: dom_f)
      unfolding fin_set.Id'_def apply simp
      using i_length j_length apply simp
      using \<open>i \<le> j\<close>.
  qed
  have cod_f : "partial_magma.cod fin_set.comp f = Some (fin_set.Id' (fst (the f)))"
    unfolding fin_set.comp_def
    apply (subst classical_category.cod_char)
    using fin_set.is_classical_category apply blast
    using arr_f unfolding fin_set.comp_def by simp
  have cod_length : "length (snd (the (partial_magma.cod fin_set.comp f))) = fst (the f)"
    apply (simp add: cod_f)
    unfolding fin_set.Id'_def by simp

  show "OrdArr (partial_magma.cod fin_set.comp f)"
    unfolding OrdArr_def apply auto
    using arr_f apply (simp add: category.arr_cod fin_set.is_category)
  proof-
    assume "snd (the (partial_magma.cod fin_set.comp f)) = []"
    then have "length (snd (the (partial_magma.cod fin_set.comp f))) = 0" by simp
    then have "fst (the f) = 0" by (simp add: cod_length)
    then show "False" by (simp add: fst_f_nn)
  next
    fix i j
    assume "j < length (snd (the (partial_magma.cod fin_set.comp f)))"
    then have j_length : "j < fst (the f)" by (simp add: cod_length)
    assume "i \<le> j"
    then have i_length : "i < fst (the f)" using j_length by auto
    then show "get (snd (the (partial_magma.cod fin_set.comp f))) i
           \<le> get (snd (the (partial_magma.cod fin_set.comp f))) j"
      apply (simp add: cod_f)
      unfolding fin_set.Id'_def apply simp
      apply (simp add: get_rev_get i_length j_length)
      using \<open>i \<le> j\<close>.
  qed
  fix g
  assume "OrdArr g"
  then have arr_g: "partial_magma.arr fin_set.comp g" by (simp add: \<open>\<And>f. OrdArr f \<Longrightarrow> partial_magma.arr fin_set.comp f\<close>)

  from \<open>OrdArr g\<close> have g_monotone : "(\<forall>i j. i \<le> j \<longrightarrow> j < length (snd (the g)) \<longrightarrow> get (snd (the g)) i \<le> get (snd (the g)) j)"
    by (simp add: OrdArr_def)
  have dom_g : "partial_magma.dom fin_set.comp g = Some (fin_set.Id' (length (snd (the g))))"
    unfolding fin_set.comp_def
    apply (subst classical_category.dom_char)
    using fin_set.is_classical_category apply blast
    using arr_g unfolding fin_set.comp_def by simp

  assume seq: "partial_magma.cod fin_set.comp f = partial_magma.dom fin_set.comp g"
  then have seq2: " fst (the f) = length (snd (the g))" apply (simp add: cod_f dom_g)
    unfolding fin_set.Id'_def by simp

  have arr_char: "\<And>f. partial_magma.arr fin_set.comp f \<longrightarrow> f \<noteq> None \<and>
        fin_set.Arr' (the f)"
    unfolding fin_set.comp_def
    apply (subst classical_category.arr_char)
    using fin_set.is_classical_category apply blast
    by simp

  have gf_comp: "fin_set.comp g f =  Some (fin_set.Comp' (the g) (the f))"
    unfolding fin_set.comp_def apply (subst classical_category.comp_char)
    using fin_set.is_classical_category apply blast
    using arr_f arr_g arr_char apply simp
    by (simp add: seq2)

  have comp_length : "length (snd (the (fin_set.comp g f))) = length (snd (the f))"
    apply (simp add: gf_comp)
    unfolding fin_set.Comp'_def by simp

  show " OrdArr (fin_set.comp g f)"
    unfolding OrdArr_def apply auto
      apply (simp add: arr_g arr_f category.seqI fin_set.is_category seq)
  proof-
    assume "snd (the (fin_set.comp g f)) = []"
    then have "length (snd (the (fin_set.comp g f))) = 0" by simp
    then have "length (snd (the f)) = 0" by (simp add: comp_length)
    then show "False" by (simp add: f_nn)
  next
    fix i j
    assume "j < length (snd (the (fin_set.comp g f)))"
    then have j_length_f : "j < length (snd (the f))" by (simp add: comp_length)
    assume "i \<le> j"
    then have i_length_f : "i < length (snd (the f))" using j_length_f by auto

    have fi_fj : "get (snd (the f)) i \<le> get (snd (the f)) j"
      apply (subst f_monotone)
      by (simp_all add: \<open>i \<le> j\<close> j_length_f)

    have j_length_g : "get (snd (the f)) j < length (snd (the g))"
    proof-
      have "fin_set.Arr' (the f)" using arr_f by (simp add: arr_char)
      then have "get (snd (the f)) j < fst (the f)"
        unfolding fin_set.Arr'_def by (simp add: j_length_f)
      then show "get (snd (the f)) j < length (snd (the g))" by (simp add: seq2)
    qed

    show "get (snd (the (fin_set.comp g f))) i \<le> get (snd (the (fin_set.comp g f))) j"
      apply (simp add: gf_comp)
      unfolding fin_set.Comp'_def apply simp
      apply (simp add: get_rev_get i_length_f j_length_f)
      apply (subst g_monotone)
      by (simp_all add: fi_fj j_length_g)
  qed
qed

definition d :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat list) option" where
  "d n k = Some (Suc n, rev_get n (\<lambda>x. if x < k then x else Suc x))"

definition comp where "comp \<equiv> dual_category.comp S.comp"

lemma is_category : "category comp"
  unfolding comp_def
  apply (rule_tac dual_category.is_category)
  unfolding dual_category_def
  using S.is_category.

lemma is_dual_category : "dual_category S.comp"
  unfolding dual_category_def
  using S.is_category.

lemma is_subcategory: "subcategory fin_set.comp OrdArr"
  using S.subcategory_axioms.

lemma arr_char: "partial_magma.arr comp f = OrdArr f"
  unfolding comp_def
  unfolding dual_category.arr_char [OF is_dual_category]
  unfolding S.arr_char
  by simp

lemma ide_char: "partial_magma.ide comp b =
     (OrdArr b \<and> b = Some (fin_set.Id' (length (snd (the b)))))"
  unfolding comp_def
  unfolding dual_category.ide_char [OF is_dual_category]
  unfolding S.ide_char
  unfolding S.arr_char
  unfolding fin_set.ide_char
  apply auto
  unfolding OrdArr_def
  unfolding fin_set.arr_char
  by simp

lemma comp_char : assumes arr_gf: "partial_magma.seq comp g f"
  shows "comp g f = Some (fin_set.Comp' (the f) (the g))"
  using arr_gf
  unfolding comp_def
  unfolding dual_category.arr_char [OF is_dual_category]
  unfolding dual_category.comp_char [OF is_dual_category]
  apply (subst S.comp_char)
  unfolding S.seq_char
  apply simp
  unfolding subcategory.arr_char [OF is_subcategory]
  unfolding OrdArr_def
  unfolding fin_set.comp_def
  unfolding classical_category.arr_char [OF fin_set.is_classical_category]
  unfolding classical_category.comp_char [OF fin_set.is_classical_category]
  by meson

lemma ide_D0: "partial_magma.ide comp (Some (1, [0]))"
  unfolding comp_def
  unfolding dual_category.ide_char [OF is_dual_category]
  unfolding subcategory.ide_char [OF is_subcategory]
  unfolding subcategory.arr_char [OF is_subcategory]
  unfolding OrdArr_def
  unfolding fin_set.comp_def
  unfolding classical_category.ide_char [OF fin_set.is_classical_category]
  unfolding classical_category.arr_char [OF fin_set.is_classical_category]
  apply simp
  unfolding fin_set.Arr'_def fin_set.Id'_def
  by simp

lemma ide_Dn : "n > 0 \<Longrightarrow> partial_magma.ide comp (Some (fin_set.Id' n))"
  unfolding comp_def
  unfolding dual_category.ide_char [OF is_dual_category]
  unfolding S.ide_char
  unfolding S.arr_char
  unfolding OrdArr_def
  unfolding fin_set.comp_def
  unfolding classical_category.ide_char [OF fin_set.is_classical_category]
  unfolding classical_category.arr_char [OF fin_set.is_classical_category]
  apply (simp add: classical_category.Arr_Id [OF fin_set.is_classical_category])
  unfolding fin_set.Id'_def apply simp
proof-
  have "0 < n \<Longrightarrow> length (rev_get n (\<lambda>k. k)) \<noteq> length []"
    by simp
  then show "0 < n \<Longrightarrow> rev_get n (\<lambda>k. k) \<noteq> []"
    by force
qed

lemma d_in_hom : assumes "n > 0"
  shows "partial_magma.in_hom comp (d n k) (Some (fin_set.Id' (Suc n))) (Some (fin_set.Id' n))"
  unfolding local.comp_def
  unfolding dual_category.hom_char [OF is_dual_category]
  unfolding S.in_hom_char
  apply safe
  using ide_Dn [OF \<open>0 < n\<close>]
  unfolding local.comp_def
  unfolding dual_category.ide_char [OF is_dual_category] apply simp
  using ide_Dn
  unfolding local.comp_def
  unfolding dual_category.ide_char [OF is_dual_category] apply simp
proof-
  have "S.C.arr (d n k)"
    unfolding d_def
    unfolding fin_set.comp_def classical_category.arr_char [OF fin_set.is_classical_category]
    unfolding fin_set.Arr'_def by simp
  show "S.arr (d n k)"
    unfolding S.arr_char OrdArr_def
    using \<open>S.C.arr (d n k)\<close>
    unfolding d_def apply simp
  proof
    have "length (rev_get n (\<lambda>x. if x < k then x else Suc x)) \<noteq> length []"
      by (simp add: \<open>n > 0\<close>)
    then show "rev_get n (\<lambda>x. if x < k then x else Suc x) = [] \<Longrightarrow> False"
      by force
  qed
  show "S.C.in_hom (d n k) (Some (fin_set.Id' n)) (Some (fin_set.Id' (Suc n)))"
    apply (rule_tac S.C.in_homI)
    using \<open>S.C.arr (d n k)\<close> apply blast
    using \<open>S.C.arr (d n k)\<close>
    unfolding fin_set.comp_def
    unfolding classical_category.dom_char [OF fin_set.is_classical_category]
    apply (simp add: d_def)
    using \<open>S.C.arr (d n k)\<close>
    unfolding fin_set.comp_def
    unfolding classical_category.cod_char [OF fin_set.is_classical_category]
    by (simp add: d_def)
qed

end

context category
begin

fun comp_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "comp_list [] d = d" |
  "comp_list (x # xs) d = C (comp_list xs (cod x)) x"

fun list_seq :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "list_seq [] d c = (ide d \<and> c = d)" |
  "list_seq (x # xs) d c = (arr x \<and> dom x = d \<and> (list_seq xs (cod x) c))"

lemma comp_list_in_hom :
  assumes  "list_seq xs d c"
  shows "in_hom (comp_list xs d) d c"
proof-
  have "list_seq xs d c \<longrightarrow> in_hom (comp_list xs d) d c"
    apply (induction xs arbitrary: d)
    by auto
  from this and assms show ?thesis by simp
qed

end

context simplex
begin

definition inc :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat list) option" where
  "inc k n = Some (n, [k])"

interpretation D: category comp
  using is_category.

lemma inc_in_hom : assumes "k < n"
  shows "D.in_hom (inc k n) (Some (fin_set.Id' n)) (Some (fin_set.Id' 1))"
  apply (rule_tac D.in_homI)
proof-
  show arr: "D.arr (inc k n)"
    unfolding arr_char OrdArr_def fin_set.arr_char
    apply (simp add: inc_def)
    unfolding fin_set.Arr'_def
    by (simp add: \<open>k < n\<close>)
  show "D.dom (inc k n) = Some (fin_set.Id' n)"
    apply (subst dom_char)
    using arr apply simp
    unfolding inc_def by simp
  show "D.cod (inc k n) = Some (fin_set.Id' 1)"
    apply (subst cod_char)
    using arr apply simp
    unfolding inc_def by simp
qed

lemma arr_to_inc : assumes f_in_hom: "D.in_hom f n (Some (fin_set.Id' 1))"
  shows "f = (inc (get (snd (the f)) 0) (fst (the n)))"
proof-
  define k where "k = get (snd (the f)) 0"
  show "f = inc k (fst (the n))"
    apply (rule_tac D.in_homE [OF f_in_hom])
    unfolding inc_def
    unfolding dom_char cod_char
    unfolding arr_char OrdArr_def fin_set.arr_char
    unfolding fin_set.Id'_def
    apply auto
    apply (rule_tac getFaithful)
     apply simp
    unfolding k_def
    by simp
qed

fun d_chain :: "nat list \<Rightarrow> nat \<Rightarrow> (nat \<times> nat list) option list" where
  "d_chain xs n = rev_get (length xs) (\<lambda>k. (d (n - k) (get xs k)))"

lemma d_chain_arr :
  shows "length xs \<le> n \<Longrightarrow> D.list_seq (d_chain xs n) (Some (fin_set.Id' (Suc n)))
          (Some (fin_set.Id' (Suc n - length xs)))"
  apply (induction xs arbitrary: n)
   apply (simp add: ide_Dn)
  apply simp
proof-
  fix a xs n
  assume ind : "(\<And>n. length xs \<le> n \<Longrightarrow>
             D.list_seq (rev_get (length xs) (\<lambda>k. d (n - k) (get xs k)))
              (Some (fin_set.Id' (Suc n))) (Some (fin_set.Id' (Suc n - length xs))))"
  assume "Suc (length xs) \<le> n"
  then have "n > 0" by simp
  from \<open>Suc (length xs) \<le> n\<close> have "length xs \<le> n - 1" by simp
  from this and ind have "D.list_seq (rev_get (length xs) (\<lambda>k. d ((n-1) - k) (get xs k)))
              (Some (fin_set.Id' (Suc (n-1)))) (Some (fin_set.Id' (Suc (n-1) - length xs)))"
    by blast
  then show "D.arr (d n a) \<and>
       D.dom (d n a) = Some (fin_set.Id' (Suc n)) \<and>
       D.list_seq (rev_get (length xs) (\<lambda>k. d (n - Suc k) (get xs k))) (D.cod (d n a))
        (Some (fin_set.Id' (n - length xs)))"
    apply (simp add: \<open>n > 0\<close>)
    unfolding D.in_hom_cod [OF d_in_hom [OF \<open>n > 0\<close>]]
    apply simp
    using d_in_hom [OF \<open>n > 0\<close>] by blast
qed

lemma inc0_to_d_chain:
  shows "inc 0 (Suc n) = D.comp_list (d_chain (rev_get n Suc) n) (Some (fin_set.Id' (Suc n)))"
proof-
  have "length (rev_get n Suc) \<le> n" by simp
  then have in_hom: "D.in_hom (D.comp_list (d_chain (rev_get n Suc) n) (Some (fin_set.Id' (Suc n))))
                   (Some (fin_set.Id' (Suc n))) (Some (fin_set.Id' 1))"
    apply (rule_tac D.comp_list_in_hom)
    using d_chain_arr [OF \<open>length (rev_get n Suc) \<le> n\<close>]
    by simp
  then have arr : "D.arr (D.comp_list (d_chain (rev_get n Suc) n) (Some (fin_set.Id' (Suc n))))"
    by blast
  have EQ: "\<And>xs. (\<forall>k < length xs. 0 < get xs k) \<Longrightarrow> length xs = n \<Longrightarrow>
             (get (snd (the (D.comp_list (d_chain xs n)
                         (Some (fin_set.Id' (Suc n)))))) 0) = 0"
    apply (induction n)
     apply (simp add: fin_set.Id'_def)
  proof-
    fix n
    fix xs :: "nat list"
    assume ind: "(\<And>xs. \<forall>k<length xs. 0 < get xs k \<Longrightarrow>
              length xs = n \<Longrightarrow>
              get (snd (the (D.comp_list (d_chain xs n) (Some (fin_set.Id' (Suc n))))))
               0 = 0)"
    assume "\<forall>k<length xs. 0 < get xs k"
    assume "length xs = Suc n"
    then have "xs \<noteq> []" by auto
    then obtain a ys where a_ys_def : "xs = a # ys"
      apply (cases xs)
      by simp_all
    have "0 < length xs"
      using \<open>length xs = Suc n\<close> by simp
    then have "0 < get xs 0"
      using \<open>\<forall>k<length xs. 0 < get xs k\<close> by simp
    then have "0 < a"
      unfolding a_ys_def by simp
    have EQ: "(get (snd (the (D.comp_list (rev_get (length ys) (\<lambda>k. d (n - k) (get ys k)))
                      (D.cod (d (Suc n) a))))) 0) = 0"
      apply (subst D.in_hom_cod [OF d_in_hom])
       apply simp
      unfolding reverse_equality [OF d_chain.simps]
      apply (rule_tac ind)
      using \<open>\<forall>k<length xs. 0 < get xs k\<close>
      unfolding a_ys_def apply auto
      using \<open>length xs = Suc n\<close>
      unfolding a_ys_def by simp
    have in_hom: "D.in_hom
     (D.comp_list (rev_get (length ys) (\<lambda>k. d (n - k) (get ys k)))
       (Some (fin_set.Id' (Suc n))))
     (Some (fin_set.Id' (Suc n)))
     (Some (fin_set.Id' (Suc n - length ys)))"
      apply (rule_tac D.comp_list_in_hom)
      unfolding reverse_equality [OF d_chain.simps]
      apply (rule_tac d_chain_arr)
      using \<open>length xs = Suc n\<close>
      unfolding a_ys_def by simp

    have seq : "D.seq
     (D.comp_list (rev_get (length ys) (\<lambda>k. d (n - k) (get ys k)))
       (D.cod (d (Suc n) a)))
     (d (Suc n) a)"
      apply (rule_tac D.seqI')
      using d_in_hom apply blast
      apply (subst D.in_hom_cod [OF d_in_hom])
       apply simp
      using in_hom.
    have length_nn: "0 < length
         (snd (the (D.comp_list (rev_get (length ys) (\<lambda>k. d (n - k) (get ys k)))
                     (D.cod (d (Suc n) a)))))"
      apply (subst D.in_hom_cod [OF d_in_hom])
       apply simp
      apply (rule_tac D.in_homE [OF in_hom])
      unfolding arr_char OrdArr_def
      by simp

    show "get (snd (the (D.comp_list (d_chain xs (Suc n))
         (Some (fin_set.Id' (Suc (Suc n))))))) 0 = 0"
      apply simp
      unfolding a_ys_def
      apply simp
      apply (subst comp_char [OF seq])
      unfolding fin_set.Comp'_def
      apply simp
      apply (subst get_rev_get)
      unfolding EQ
      using length_nn apply simp
      unfolding d_def
      using \<open>0 < a \<close>by simp
  qed
  show "inc 0 (Suc n) = D.comp_list (d_chain (rev_get n Suc) n) (Some (fin_set.Id' (Suc n)))"
    apply (subst arr_to_inc [OF in_hom])
    apply (subst EQ)
    by (simp_all add: fin_set.Id'_def)
qed

lemma inc_to_d_chain:
   "k \<le> n \<Longrightarrow> \<exists>xs. length xs = n \<and> inc k (Suc n) = D.comp_list (d_chain xs n) (Some (fin_set.Id' (Suc n)))"
  apply (induction k arbitrary: n)
   apply (subst inc0_to_d_chain)
   apply (rule_tac exI)
proof-
  fix n
  show "length (rev_get n Suc) = n \<and>
         D.comp_list (d_chain (rev_get n Suc) n) (Some (fin_set.Id' (Suc n))) =
         D.comp_list (d_chain (rev_get n Suc) n) (Some (fin_set.Id' (Suc n)))"
    by simp
next
  fix k n
  assume ind : "(\<And>n. k \<le> n \<Longrightarrow>
                \<exists>xs. length xs = n \<and> inc k (Suc n) =
                D.comp_list (d_chain xs n) (Some (fin_set.Id' (Suc n))))"
  assume "Suc k \<le> n"
  then have "k \<le> n - 1" by auto
  from \<open>Suc k \<le> n\<close> have "0 < n" by simp
  obtain xs where "length xs = (n-1) \<and> inc k (Suc (n-1)) =
                D.comp_list (d_chain xs (n-1)) (Some (fin_set.Id' (Suc (n-1))))"
    using ind [OF \<open>k \<le> n - 1\<close>] by auto
  then have xs_def: "length xs = (n-1) \<and> inc k n =
                D.comp_list (d_chain xs (n-1)) (Some (fin_set.Id' n))"
    using \<open>0 < n\<close> by simp
  have EQ: "inc (Suc k) (Suc n) = comp (inc k n) (d n k)"
    apply (subst comp_char)
     apply (rule_tac D.seqI')
      apply (rule_tac d_in_hom [OF \<open>0 < n\<close>])
     apply (rule_tac inc_in_hom)
    using \<open>Suc k \<le> n\<close> apply simp
    unfolding fin_set.Comp'_def inc_def d_def
    apply simp
    apply (subst get_rev_get)
    using \<open>Suc k \<le> n\<close> apply simp
    by simp
  show "\<exists>xs. length xs = n \<and> inc (Suc k) (Suc n) =
                D.comp_list (d_chain xs n) (Some (fin_set.Id' (Suc n)))"
  proof
    show "length (k # xs) = n \<and> inc (Suc k) (Suc n) =
           D.comp_list (d_chain (k # xs) n) (Some (fin_set.Id' (Suc n)))"
      apply simp
      apply (subst conjunct1 [OF xs_def])
      apply (subst EQ)
      apply (simp add: \<open>0 < n\<close>)
      apply (subst conjunct2 [OF xs_def])
      apply (subst D.in_hom_cod [OF d_in_hom])
      using \<open>0 < n\<close> apply simp
      by simp
  qed
qed

lemma in_hom_get_bound :
  assumes in_hom: "D.in_hom f (Some (fin_set.Id' a)) (Some (fin_set.Id' b))"
  and "k < b"
shows "get (snd (the f)) k < a"
proof-
  from in_hom have arr: "D.arr f"
    by blast
  then have bound_rule: "(\<And>n. n<length (snd (the f)) \<Longrightarrow> get (snd (the f)) n < fst (the f))"
    unfolding arr_char OrdArr_def fin_set.arr_char fin_set.Arr'_def
    by simp
  have "get (snd (the f)) k < fst (the f)"
    apply (rule_tac bound_rule)
    using \<open>k < b\<close>
    using D.in_hom_cod [OF in_hom]
    unfolding cod_char [OF arr]
    unfolding fin_set.Id'_def
    by simp
  then show "get (snd (the f)) k < a"
    using D.in_hom_dom [OF in_hom]
    unfolding dom_char [OF arr]
    unfolding fin_set.Id'_def
    by simp
qed

lemma simplicial_identity_d_d :
  assumes "i < j"
  and "0 < n"
  shows "comp (d n i) (d (Suc n) j) =
         comp (d n (j - 1)) (d (Suc n) i)"
  apply (subst comp_char)
   apply (rule_tac D.seqI')
  using d_in_hom apply blast
   apply (rule_tac d_in_hom)
  using \<open>0 < n\<close> apply simp
  apply (subst comp_char)
   apply (rule_tac D.seqI')
  using d_in_hom apply blast
   apply (rule_tac d_in_hom)
  using \<open>0 < n\<close> apply simp
  unfolding fin_set.Comp'_def
  apply auto
   apply (simp add: d_def)
  apply (rule_tac getFaithful)
   apply (simp add: d_def)
  apply simp
  apply (subst get_rev_get)
   apply (simp add: d_def)
proof-
  define m where "m = Suc n"
  fix k
  assume "k < length (snd (the (d n i)))"
  then have "k < n"
    unfolding d_def by simp
  then have "k < m"
    unfolding m_def by simp
  from \<open>k < n\<close> have "Suc k < m"
    unfolding m_def by simp

  show "get (snd (the (d (Suc n) j)))
           (get (snd (the (d n i))) k) =
          get (snd (the (d (Suc n) i)))
           (get (snd (the (d n (j - Suc 0)))) k)"
    unfolding reverse_equality [OF m_def]
    unfolding d_def
    apply (simp add: \<open>k < n\<close> \<open>k < m\<close> \<open>Suc k < m\<close>)
    using \<open>i < j\<close> by auto
qed

end

locale pointed_simplicial_set =
  X: "functor" simplex.comp pointed_set.pointed_set_comp X
  for X :: "(nat \<times> nat list) option \<Rightarrow> 'a pointed_set.parr option"
begin

lemma is_functor: "functor simplex.comp pointed_set.pointed_set_comp X"
  using X.functor_axioms.

interpretation simplex.

definition simplices :: "nat \<Rightarrow> 'a pointed_set" where
  "simplices n = pointed_set.Dom' (the (X (Some (fin_set.Id' (Suc n)))))"

lemma simplices_obj : "pointed_set.Obj' (simplices n)"
  using X.preserves_ide [OF ide_Dn]
  unfolding simplices_def
  unfolding pointed_set.ide_char
  unfolding pointed_set.Arr'_def
  by simp

definition pi0prerelation :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "pi0prerelation x y = (x \<in> snd (simplices 0) \<and> y \<in> snd (simplices 0) \<and>
                     (\<exists> z \<in> snd (simplices 1).
                      fst (the (X (d 1 0))) z = x \<and>
                      fst (the (X (d 1 1))) z = y ))"

definition pi0relation :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "pi0relation = generated_equiv_rel (snd (simplices 0)) pi0prerelation"

end

end


(* Author: Alexander Maletzky *)

section \<open>More Properties of Power-Products and Multivariate Polynomials\<close>

theory More_MPoly
  imports Prelims Polynomials.MPoly_Type_Class_Ordered
begin

subsection \<open>Power-Products\<close>

lemma (in comm_powerprod) minus_plus': "s adds t \<Longrightarrow> u + (t - s) = (u + t) - s"
  using add_commute minus_plus by auto

context ulcs_powerprod
begin

lemma lcs_alt_2:
  assumes "a + x = b + y"
  shows "lcs x y = (b + y) - gcs a b"
proof -
  have "a + (lcs x y + gcs a b) = lcs (a + x) (a + y) + gcs a b" by (simp only: lcs_plus_left ac_simps)
  also have "... = lcs (b + y) (a + y) + gcs a b" by (simp only: assms)
  also have "... = (lcs a b + y) + gcs a b" by (simp only: lcs_plus_right lcs_comm)
  also have "... = (gcs a b + lcs a b) + y" by (simp only: ac_simps)
  also have "... = a + (b + y)" by (simp only: gcs_plus_lcs, simp add: ac_simps)
  finally have "(lcs x y + gcs a b) - gcs a b = (b + y) - gcs a b" by simp
  thus ?thesis by simp
qed

corollary lcs_alt_1:
  assumes "a + x = b + y"
  shows "lcs x y = (a + x) - gcs a b"
proof -
  have "lcs x y = lcs y x" by (simp only: lcs_comm)
  also from assms[symmetric] have "... = (a + x) - gcs b a" by (rule lcs_alt_2)
  also have "... = (a + x) - gcs a b" by (simp only: gcs_comm)
  finally show ?thesis .
qed

corollary lcs_minus_1:
  assumes "a + x = b + y"
  shows "lcs x y - x = a - gcs a b"
  by (simp add: lcs_alt_1[OF assms] diff_right_commute)

corollary lcs_minus_2:
  assumes "a + x = b + y"
  shows "lcs x y - y = b - gcs a b"
  by (simp add: lcs_alt_2[OF assms] diff_right_commute)

lemma gcs_minus:
  assumes "u adds s" and "u adds t"
  shows "gcs (s - u) (t - u) = gcs s t - u"
proof -
  from assms have "gcs s t = gcs ((s - u) + u) ((t - u) + u)" by (simp add: minus_plus)
  also have "... = gcs (s - u) (t - u) + u" by (simp only: gcs_plus_right)
  finally show ?thesis by simp
qed

corollary gcs_minus_gcs: "gcs (s - (gcs s t)) (t - (gcs s t)) = 0"
  by (simp add: gcs_minus gcs_adds gcs_adds_2)

end (* ulcs_powerprod *)

subsection \<open>Miscellaneous\<close>

lemma poly_mapping_rangeE:
  assumes "c \<in> Poly_Mapping.range p"
  obtains k where "k \<in> keys p" and "c = lookup p k"
  using assms by (transfer, auto)

lemma poly_mapping_range_nonzero: "0 \<notin> Poly_Mapping.range p"
  by (transfer, auto)

lemma (in term_powerprod) Keys_range_vectorize_poly: "Keys (Poly_Mapping.range (vectorize_poly p)) = pp_of_term ` keys p"
proof
  show "Keys (Poly_Mapping.range (vectorize_poly p)) \<subseteq> pp_of_term ` keys p"
  proof
    fix t
    assume "t \<in> Keys (Poly_Mapping.range (vectorize_poly p))"
    then obtain q where "q \<in> Poly_Mapping.range (vectorize_poly p)" and "t \<in> keys q" by (rule in_KeysE)
    from this(1) obtain k where q: "q = lookup (vectorize_poly p) k" by (metis DiffE imageE range.rep_eq)
    with \<open>t \<in> keys q\<close> have "term_of_pair (t, k) \<in> keys p"
      by (metis in_keys_iff lookup_proj_poly lookup_vectorize_poly)
    hence "pp_of_term (term_of_pair (t, k)) \<in> pp_of_term ` keys p" by (rule imageI)
    thus "t \<in> pp_of_term ` keys p" by (simp only: pp_of_term_of_pair)
  qed
next
  show "pp_of_term ` keys p \<subseteq> Keys (Poly_Mapping.range (vectorize_poly p))"
  proof
    fix t
    assume "t \<in> pp_of_term ` keys p"
    then obtain x where "x \<in> keys p" and "t = pp_of_term x" ..
    from this(2) have "term_of_pair (t, component_of_term x) = x" by (simp add: term_of_pair_pair)
    with \<open>x \<in> keys p\<close> have "lookup p (term_of_pair (t, component_of_term x)) \<noteq> 0"
      by (simp add: in_keys_iff)
    hence "lookup (proj_poly (component_of_term x) p) t \<noteq> 0" by (simp add: lookup_proj_poly)
    hence t: "t \<in> keys (proj_poly (component_of_term x) p)"
      by (simp add: in_keys_iff)
    from \<open>x \<in> keys p\<close> have "component_of_term x \<in> keys (vectorize_poly p)"
      by (simp add: keys_vectorize_poly)
    from t show "t \<in> Keys (Poly_Mapping.range (vectorize_poly p))"
    proof (rule in_KeysI)
      have "proj_poly (component_of_term x) p = lookup (vectorize_poly p) (component_of_term x)"
        by (simp only: lookup_vectorize_poly)
      also from \<open>component_of_term x \<in> keys (vectorize_poly p)\<close>
      have "... \<in> Poly_Mapping.range (vectorize_poly p)" by (rule in_keys_lookup_in_range)
      finally show "proj_poly (component_of_term x) p \<in> Poly_Mapping.range (vectorize_poly p)" .
    qed
  qed
qed

subsection \<open>@{const ordered_term.lt} and @{const ordered_term.higher}\<close>

context ordered_term
begin

lemma lt_lookup_vectorize: "punit.lt (lookup (vectorize_poly p) (component_of_term (lt p))) = lp p"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: vectorize_zero min_term_def pp_of_term_of_pair)
next
  case False
  show ?thesis
  proof (rule punit.lt_eqI_keys)
    from False have "lt p \<in> keys p" by (rule lt_in_keys)
    thus "lp p \<in> keys (lookup (vectorize_poly p) (component_of_term (lt p)))"
      by (simp add: lookup_vectorize_poly keys_proj_poly)
  next
    fix t
    assume "t \<in> keys (lookup (vectorize_poly p) (component_of_term (lt p)))"
    also have "... = pp_of_term ` {x\<in>keys p. component_of_term x = component_of_term (lt p)}"
      by (simp only: lookup_vectorize_poly keys_proj_poly)
    finally obtain v where "v \<in> keys p" and 1: "component_of_term v = component_of_term (lt p)"
      and t: "t = pp_of_term v" by auto
    from this(1) have "v \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
    show "t \<preceq> lp p"
    proof (rule ccontr)
      assume "\<not> t \<preceq> lp p"
      hence "lp p \<prec> pp_of_term v" by (simp add: t)
      hence "lp p \<noteq> pp_of_term v" and "lp p \<preceq> pp_of_term v" by simp_all
      note this(2)
      moreover from 1 have "component_of_term (lt p) \<le> component_of_term v" by simp
      ultimately have "lt p \<preceq>\<^sub>t v" by (rule ord_termI)
      with \<open>v \<preceq>\<^sub>t lt p\<close> have "v = lt p" by (rule ord_term_lin.antisym)
      with \<open>lp p \<noteq> pp_of_term v\<close> show False by simp
    qed
  qed
qed

lemma lower_higher_zeroI: "u \<preceq>\<^sub>t v \<Longrightarrow> lower (higher p v) u = 0"
  by (simp add: lower_eq_zero_iff lookup_higher_when)

lemma lookup_minus_higher: "lookup (p - higher p v) u = (lookup p u when u \<preceq>\<^sub>t v)"
  by (auto simp: lookup_minus lookup_higher_when when_def)

lemma keys_minus_higher: "keys (p - higher p v) = {u \<in> keys p. u \<preceq>\<^sub>t v}"
  by (rule set_eqI, simp add: lookup_minus_higher conj_commute flip: lookup_not_eq_zero_eq_in_keys)

lemma lt_minus_higher: "v \<in> keys p \<Longrightarrow> lt (p - higher p v) = v"
  by (rule lt_eqI_keys, simp_all add: keys_minus_higher)

lemma lc_minus_higher: "v \<in> keys p \<Longrightarrow> lc (p - higher p v) = lookup p v"
  by (simp add: lc_def lt_minus_higher lookup_minus_higher)

lemma tail_minus_higher: "v \<in> keys p \<Longrightarrow> tail (p - higher p v) = lower p v"
  by (rule poly_mapping_eqI, simp add: lookup_tail_when lt_minus_higher lookup_lower_when lookup_minus_higher cong: when_cong)

end (* ordered_term *)

subsection \<open>@{const gd_term.dgrad_p_set}\<close>

lemma (in gd_term) dgrad_p_set_closed_mult_scalar:
  assumes "dickson_grading d" and "p \<in> punit.dgrad_p_set d m" and "r \<in> dgrad_p_set d m"
  shows "p \<odot> r \<in> dgrad_p_set d m"
proof (rule dgrad_p_setI)
  fix v
  assume "v \<in> keys (p \<odot> r)"
  then obtain t u where "t \<in> keys p" and "u \<in> keys r" and v: "v = t \<oplus> u"
    by (rule in_keys_mult_scalarE)
  from assms(2) \<open>t \<in> keys p\<close> have "d t \<le> m" by (rule punit.dgrad_p_setD[simplified])
  moreover from assms(3) \<open>u \<in> keys r\<close> have "d (pp_of_term u) \<le> m" by (rule dgrad_p_setD)
  ultimately have "d (t + pp_of_term u) \<le> m" using assms(1) by (simp add: dickson_gradingD1)
  thus "d (pp_of_term v) \<le> m" by (simp only: v pp_of_term_splus)
qed

subsection \<open>Regular Sequences\<close>

definition is_regular_sequence :: "('a::comm_powerprod \<Rightarrow>\<^sub>0 'b::comm_ring_1) list \<Rightarrow> bool"
  where "is_regular_sequence fs \<longleftrightarrow> (\<forall>j<length fs. \<forall>q. q * fs ! j \<in> ideal (set (take j fs)) \<longrightarrow>
                                                      q \<in> ideal (set (take j fs)))"

lemma is_regular_sequenceD:
  "is_regular_sequence fs \<Longrightarrow> j < length fs \<Longrightarrow> q * fs ! j \<in> ideal (set (take j fs)) \<Longrightarrow>
    q \<in> ideal (set (take j fs))"
  by (simp add: is_regular_sequence_def)

lemma is_regular_sequence_Nil: "is_regular_sequence []"
  by (simp add: is_regular_sequence_def)

lemma is_regular_sequence_snocI:
  assumes "\<And>q. q * f \<in> ideal (set fs) \<Longrightarrow> q \<in> ideal (set fs)" and "is_regular_sequence fs"
  shows "is_regular_sequence (fs @ [f])"
proof (simp add: is_regular_sequence_def, intro impI allI)
  fix j q
  assume 1: "j < Suc (length fs)" and 2: "q * (fs @ [f]) ! j \<in> ideal (set (take j fs))"
  show "q \<in> ideal (set (take j fs))"
  proof (cases "j = length fs")
    case True
    from 2 have "q * f \<in> ideal (set fs)" by (simp add: True)
    hence "q \<in> ideal (set fs)" by (rule assms(1))
    thus ?thesis by (simp add: True)
  next
    case False
    with 1 have "j < length fs" by simp
    with 2 have "q * fs ! j \<in> ideal (set (take j fs))" by (simp add: nth_append)
    with assms(2) \<open>j < length fs\<close> show "q \<in> ideal (set (take j fs))" by (rule is_regular_sequenceD)
  qed
qed

lemma is_regular_sequence_snocD:
  assumes "is_regular_sequence (fs @ [f])"
  shows "\<And>q. q * f \<in> ideal (set fs) \<Longrightarrow> q \<in> ideal (set fs)"
    and "is_regular_sequence fs"
proof -
  fix q
  assume 1: "q * f \<in> ideal (set fs)"
  note assms
  moreover have "length fs < length (fs @ [f])" by simp
  moreover from 1 have "q * (fs @ [f]) ! (length fs) \<in> ideal (set (take (length fs) (fs @ [f])))"
    by simp
  ultimately have "q \<in> ideal (set (take (length fs) (fs @ [f])))" by (rule is_regular_sequenceD)
  thus "q \<in> ideal (set fs)" by simp
next
  show "is_regular_sequence fs" unfolding is_regular_sequence_def
  proof (intro impI allI)
    fix j q
    assume 1: "j < length fs" and 2: "q * fs ! j \<in> ideal (set (take j fs))"
    note assms
    moreover from 1 have "j < length (fs @ [f])" by simp
    moreover from 1 2 have "q * (fs @ [f]) ! j \<in> ideal (set (take j (fs @ [f])))"
      by (simp add: nth_append)
    ultimately have "q \<in> ideal (set (take j (fs @ [f])))" by (rule is_regular_sequenceD)
    with 1 show "q \<in> ideal (set (take j fs))" by simp
  qed
qed

lemma is_regular_sequence_removeAll_zero:
  assumes "is_regular_sequence fs"
  shows "is_regular_sequence (removeAll 0 fs)"
  using assms
proof (induct fs rule: rev_induct)
  case Nil
  show ?case by (simp add: is_regular_sequence_Nil)
next
  case (snoc f fs)
  have "set (removeAll 0 fs) = set fs - {0}" by simp
  also have "ideal ... = ideal (set fs)" by (fact ideal.span_Diff_zero)
  finally have eq: "ideal (set (removeAll 0 fs)) = ideal (set fs)" .
  from snoc(2) have *: "is_regular_sequence fs" by (rule is_regular_sequence_snocD)
  show ?case
  proof (simp, intro conjI impI)
    show "is_regular_sequence (removeAll 0 fs @ [f])"
    proof (rule is_regular_sequence_snocI)
      fix q
      assume "q * f \<in> ideal (set (removeAll 0 fs))"
      hence "q * f \<in> ideal (set fs)" by (simp only: eq)
      with snoc(2) have "q \<in> ideal (set fs)" by (rule is_regular_sequence_snocD)
      thus "q \<in> ideal (set (removeAll 0 fs))" by (simp only: eq)
    next
      from * show "is_regular_sequence (removeAll 0 fs)" by (rule snoc.hyps)
    qed
  next
    from * show "is_regular_sequence (removeAll 0 fs)" by (rule snoc.hyps)
  qed
qed

lemma is_regular_sequence_remdups:
  assumes "is_regular_sequence fs"
  shows "is_regular_sequence (rev (remdups (rev fs)))"
  using assms
proof (induct fs rule: rev_induct)
  case Nil
  show ?case by (simp add: is_regular_sequence_Nil)
next
  case (snoc f fs)
  from snoc(2) have *: "is_regular_sequence fs" by (rule is_regular_sequence_snocD)
  show ?case
  proof (simp, intro conjI impI)
    show "is_regular_sequence (rev (remdups (rev fs)) @ [f])"
    proof (rule is_regular_sequence_snocI)
      fix q
      assume "q * f \<in> ideal (set (rev (remdups (rev fs))))"
      hence "q * f \<in> ideal (set fs)" by simp
      with snoc(2) have "q \<in> ideal (set fs)" by (rule is_regular_sequence_snocD)
      thus "q \<in> ideal (set (rev (remdups (rev fs))))" by simp
    next
      from * show "is_regular_sequence (rev (remdups (rev fs)))" by (rule snoc.hyps)
    qed
  next
    from * show "is_regular_sequence (rev (remdups (rev fs)))" by (rule snoc.hyps)
  qed
qed

end (* theory *)