(*  Title:      HOL/Library/Char_ord.thy
    Author:     Norbert Voelker, Florian Haftmann
*)

section {* Order on characters *}

theory Char_ord
imports Main
begin

instantiation nibble :: linorder
begin

definition
  "n \<le> m \<longleftrightarrow> nat_of_nibble n \<le> nat_of_nibble m"

definition
  "n < m \<longleftrightarrow> nat_of_nibble n < nat_of_nibble m"

instance proof
qed (auto simp add: less_eq_nibble_def less_nibble_def not_le nat_of_nibble_eq_iff)

end

instantiation nibble :: distrib_lattice
begin

definition
  "(inf \<Colon> nibble \<Rightarrow> _) = min"

definition
  "(sup \<Colon> nibble \<Rightarrow> _) = max"

instance proof
qed (auto simp add: inf_nibble_def sup_nibble_def max_min_distrib2)

end

instantiation char :: linorder
begin

definition
  "c1 \<le> c2 \<longleftrightarrow> nat_of_char c1 \<le> nat_of_char c2"

definition
  "c1 < c2 \<longleftrightarrow> nat_of_char c1 < nat_of_char c2"

instance proof
qed (auto simp add: less_eq_char_def less_char_def nat_of_char_eq_iff)

end

lemma less_eq_char_Char:
  "Char n1 m1 \<le> Char n2 m2 \<longleftrightarrow> n1 < n2 \<or> n1 = n2 \<and> m1 \<le> m2"
proof -
  {
    assume "nat_of_nibble n1 * 16 + nat_of_nibble m1
      \<le> nat_of_nibble n2 * 16 + nat_of_nibble m2"
    then have "nat_of_nibble n1 \<le> nat_of_nibble n2"
    using nat_of_nibble_less_16 [of m1] nat_of_nibble_less_16 [of m2] by auto
  }
  note * = this
  show ?thesis
    using nat_of_nibble_less_16 [of m1] nat_of_nibble_less_16 [of m2]
    by (auto simp add: less_eq_char_def nat_of_char_Char less_eq_nibble_def less_nibble_def not_less nat_of_nibble_eq_iff dest: *)
qed

lemma less_char_Char:
  "Char n1 m1 < Char n2 m2 \<longleftrightarrow> n1 < n2 \<or> n1 = n2 \<and> m1 < m2"
proof -
  {
    assume "nat_of_nibble n1 * 16 + nat_of_nibble m1
      < nat_of_nibble n2 * 16 + nat_of_nibble m2"
    then have "nat_of_nibble n1 \<le> nat_of_nibble n2"
    using nat_of_nibble_less_16 [of m1] nat_of_nibble_less_16 [of m2] by auto
  }
  note * = this
  show ?thesis
    using nat_of_nibble_less_16 [of m1] nat_of_nibble_less_16 [of m2]
    by (auto simp add: less_char_def nat_of_char_Char less_eq_nibble_def less_nibble_def not_less nat_of_nibble_eq_iff dest: *)
qed

instantiation char :: distrib_lattice
begin

definition
  "(inf \<Colon> char \<Rightarrow> _) = min"

definition
  "(sup \<Colon> char \<Rightarrow> _) = max"

instance proof
qed (auto simp add: inf_char_def sup_char_def max_min_distrib2)

end

instantiation String.literal :: linorder
begin

context includes literal.lifting begin
lift_definition less_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool" is "ord.lexordp op <" .
lift_definition less_eq_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool" is "ord.lexordp_eq op <" .

instance
proof -
  interpret linorder "ord.lexordp_eq op <" "ord.lexordp op < :: string \<Rightarrow> string \<Rightarrow> bool"
    by(rule linorder.lexordp_linorder[where less_eq="op \<le>"])(unfold_locales)
  show "PROP ?thesis"
    by(intro_classes)(transfer, simp add: less_le_not_le linear)+
qed

end
end

lemma less_literal_code [code]:
  "op < = (\<lambda>xs ys. ord.lexordp op < (String.explode xs) (String.explode ys))"
by(simp add: less_literal.rep_eq fun_eq_iff)

lemma less_eq_literal_code [code]:
  "op \<le> = (\<lambda>xs ys. ord.lexordp_eq op < (String.explode xs) (String.explode ys))"
by(simp add: less_eq_literal.rep_eq fun_eq_iff)

lifting_update literal.lifting
lifting_forget literal.lifting

text {* Legacy aliasses *}

lemmas nibble_less_eq_def = less_eq_nibble_def
lemmas nibble_less_def = less_nibble_def
lemmas char_less_eq_def = less_eq_char_def
lemmas char_less_def = less_char_def
lemmas char_less_eq_simp = less_eq_char_Char
lemmas char_less_simp = less_char_Char

end


(*  Title:      Simple Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SimpleGroups
imports
  SubgroupsAndNormalSubgroups
  Secondary_Sylow.SndSylow
  SndIsomorphismGrp
begin

section \<open>Simple Groups\<close>

locale simple_group = group +
  assumes order_gt_one:"order G > 1"
  assumes no_real_normal_subgroup:"\<And>H. H \<lhd> G \<Longrightarrow> (H = carrier G \<or> H = {\<one>})"

lemma (in simple_group) is_simple_group: "simple_group G" by (rule simple_group_axioms)

text \<open>Simple groups are non-trivial.\<close>

lemma (in simple_group) simple_not_triv: "carrier G \<noteq> {\<one>}" using order_gt_one unfolding order_def by auto

text \<open>Every group of prime order is simple\<close>

lemma (in group) prime_order_simple:
  assumes prime:"prime (order G)"
  shows "simple_group G"
proof
  from prime show "1 < order G" unfolding prime_nat_iff by auto
next
  fix H
  assume "H \<lhd> G"
  hence HG:"subgroup H G" unfolding normal_def by simp
  hence "card H dvd order G" by (rule card_subgrp_dvd)
  with prime have "card H = 1 \<or> card H = order G" unfolding prime_nat_iff by simp
  thus "H = carrier G \<or> H = {\<one>}"
  proof
    assume "card H = 1"
    moreover from HG have "\<one> \<in> H" by (metis subgroup.one_closed)
    ultimately show ?thesis by (auto simp: card_Suc_eq)
  next
    assume "card H = order G"
    moreover from HG have "H \<subseteq> carrier G" unfolding subgroup_def by simp
    moreover from prime have "card (carrier G) > 1" unfolding order_def prime_nat_iff ..
    hence "finite (carrier G)" by (auto simp:card_ge_0_finite)
    ultimately show ?thesis unfolding order_def by (metis card_subset_eq)
  qed
qed

text \<open>Being simple is a property that is preserved by isomorphisms.\<close>

lemma (in simple_group) iso_simple:
  assumes H:"group H"
  assumes iso:"\<phi> \<in> iso G H"
  shows "simple_group H"
unfolding simple_group_def simple_group_axioms_def using assms(1)
proof (auto del: equalityI)
  from iso have "order G = order H" unfolding iso_def order_def using bij_betw_same_card by auto
  with order_gt_one show "Suc 0 < order H" by simp
next
  have inv_iso:"(inv_into (carrier G) \<phi>) \<in> iso H G" using iso
    by (simp add: iso_set_sym)
  fix N
  assume NH:"N \<lhd> H" and Nneq1:"N \<noteq> {\<one>\<^bsub>H\<^esub>}"
  then interpret Nnormal: normal N H by simp
  define M where "M = (inv_into (carrier G) \<phi>) ` N"
  hence MG:"M \<lhd> G" using inv_iso NH H by (metis is_group iso_normal_subgroup)
  have surj:"\<phi> ` carrier G = carrier H" using iso unfolding iso_def bij_betw_def by simp
  hence MN:"\<phi> ` M = N" unfolding M_def using Nnormal.subset image_inv_into_cancel by metis
  moreover have "M \<noteq> {\<one>}"
  proof(rule notI)
    assume "M = {\<one>}"
    hence "\<phi> ` M = {\<phi> \<one>}" by (metis (full_types) image_empty image_insert)
    hence "\<phi> ` M = {\<one>\<^bsub>H\<^esub>}" by (metis (lifting) Nnormal.is_subgroup MN calculation singleton_iff subgroup.one_closed)
    thus False using Nneq1 MN by simp
  qed
  hence "M = carrier G" using no_real_normal_subgroup MG by auto
  ultimately show "N = carrier H" using surj by simp
qed

text \<open>As a corollary of this: Factorizing a group by itself does not result in a simple group!\<close>

lemma (in group) self_factor_not_simple:"\<not> simple_group (G Mod (carrier G))"
proof
  assume assm:"simple_group (G Mod (carrier G))"
  have "group (G\<lparr>carrier :=  {\<one>}\<rparr>)" by (metis subgroup_imp_group triv_subgroup)
  with assm self_factor_iso simple_group.iso_simple have "simple_group (G\<lparr>carrier := {\<one>}\<rparr>)" by auto
  thus "False" using simple_group.simple_not_triv by force
qed

end


theory Contexts
imports "../Nominal"
begin

text \<open>

  We show here that the Plotkin-style of defining
  beta-reduction (based on congruence rules) is
  equivalent to the Felleisen-Hieb-style representation
  (based on contexts).

  The interesting point in this theory is that contexts
  do not contain any binders. On the other hand the operation
  of filling a term into a context produces an alpha-equivalent
  term.

\<close>

atom_decl name

text \<open>
  Lambda-Terms - the Lam-term constructor binds a name
\<close>

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text \<open>
  Contexts - the lambda case in contexts does not bind
  a name, even if we introduce the notation [_]._ for CLam.
\<close>

nominal_datatype ctx =
    Hole ("\<box>" 1000)
  | CAppL "ctx" "lam"
  | CAppR "lam" "ctx"
  | CLam "name" "ctx"  ("CLam [_]._" [100,100] 100)

text \<open>Capture-Avoiding Substitution\<close>

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

text \<open>
  Filling is the operation that fills a term into a hole.
  This operation is possibly capturing.
\<close>

nominal_primrec
  filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
by (rule TrueI)+

text \<open>
  While contexts themselves are not alpha-equivalence classes, the
  filling operation produces an alpha-equivalent lambda-term.
\<close>

lemma alpha_test:
  shows "x\<noteq>y \<Longrightarrow> (CLam [x].\<box>) \<noteq> (CLam [y].\<box>)"
  and   "(CLam [x].\<box>)\<lbrakk>Var x\<rbrakk> = (CLam [y].\<box>)\<lbrakk>Var y\<rbrakk>"
by (auto simp add: alpha ctx.inject lam.inject calc_atm fresh_atm)

text \<open>The composition of two contexts.\<close>

nominal_primrec
 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _" [100,100] 100)
where
  "\<box> \<circ> E' = E'"
| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
by (rule TrueI)+

lemma ctx_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: ctx.induct) (auto)

text \<open>Beta-reduction via contexts in the Felleisen-Hieb style.\<close>

inductive
  ctx_red :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>x _" [80,80] 80)
where
  xbeta[intro]: "E\<lbrakk>App (Lam [x].t) t'\<rbrakk> \<longrightarrow>x E\<lbrakk>t[x::=t']\<rbrakk>"

text \<open>Beta-reduction via congruence rules in the Plotkin style.\<close>

inductive
  cong_red :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>o _" [80,80] 80)
where
  obeta[intro]: "App (Lam [x].t) t' \<longrightarrow>o t[x::=t']"
| oapp1[intro]: "t \<longrightarrow>o t' \<Longrightarrow> App t t2 \<longrightarrow>o App t' t2"
| oapp2[intro]: "t \<longrightarrow>o t' \<Longrightarrow> App t2 t \<longrightarrow>o App t2 t'"
| olam[intro]:  "t \<longrightarrow>o t' \<Longrightarrow> Lam [x].t \<longrightarrow>o Lam [x].t'"

text \<open>The proof that shows both relations are equal.\<close>

lemma cong_red_in_ctx:
  assumes a: "t \<longrightarrow>o t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>o E\<lbrakk>t'\<rbrakk>"
using a
by (induct E rule: ctx.induct) (auto)

lemma ctx_red_in_ctx:
  assumes a: "t \<longrightarrow>x t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>x E\<lbrakk>t'\<rbrakk>"
using a
by (induct) (auto simp add: ctx_compose[symmetric])

theorem ctx_red_implies_cong_red:
  assumes a: "t \<longrightarrow>x t'"
  shows "t \<longrightarrow>o t'"
using a by (induct) (auto intro: cong_red_in_ctx)

theorem cong_red_implies_ctx_red:
  assumes a: "t \<longrightarrow>o t'"
  shows "t \<longrightarrow>x t'"
using a
proof (induct)
  case (obeta x t' t)
  have "\<box>\<lbrakk>App (Lam [x].t) t'\<rbrakk> \<longrightarrow>x \<box>\<lbrakk>t[x::=t']\<rbrakk>" by (rule xbeta)
  then show  "App (Lam [x].t) t' \<longrightarrow>x t[x::=t']" by simp
qed (metis ctx_red_in_ctx filling.simps)+ (* found by SledgeHammer *)

lemma ctx_existence:
  assumes a: "t \<longrightarrow>o t'"
  shows "\<exists>C s s'. t = C\<lbrakk>s\<rbrakk> \<and> t' = C\<lbrakk>s'\<rbrakk> \<and> s \<longrightarrow>o s'"
using a
by (induct) (metis cong_red.intros filling.simps)+

end


theory LTLEq
  imports Main "HOL-Library.Lattice_Syntax"
begin

section \<open> Helper Lemmas \<close>

lemma All_add_Suc2:
  fixes n :: nat
  shows \<open>(\<forall>x. P (n + x)) \<longleftrightarrow> P n \<and> (\<forall>x. P (Suc (n + x)))\<close>
  by (metis Suc_funpow add.commute add_eq_if funpow_swap1)

lemma Ex_Suc2:
  fixes n :: nat
  shows \<open>(\<exists>i. P i) = (P 0 \<or> (\<exists>i. P (Suc i)))\<close>
  using zero_induct by blast

subsection \<open> Helpful Boolean Algebra Lemmas \<close>

context boolean_algebra
begin

(* A bit of notational trickery *)

abbreviation (input) bool_proves :: \<open>['a,'a] \<Rightarrow> bool\<close> (infix \<open>\<turnstile>\<close> 50) where
  \<open>p \<turnstile> q \<equiv> p \<le> q\<close>

abbreviation (input) bool_impl :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infixr \<open>\<rightarrow>\<close> 60) where
  \<open>p \<rightarrow> q \<equiv> -p \<squnion> q\<close>

abbreviation (input) bool_iff :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infixr \<open>\<leftrightarrow>\<close> 60) where
  \<open>p \<leftrightarrow> q \<equiv> (p \<rightarrow> q) \<sqinter> (q \<rightarrow> p)\<close>

lemma impl_top_as_inf: \<open>p \<rightarrow> q = \<top> \<longleftrightarrow> p \<sqinter> q = p\<close>
  by (metis compl_inf inf_compl_bot inf_compl_bot_left1 inf_le2 inf_sup_distrib1
      inf_top.right_neutral sup.absorb2 sup_cancel_left2)

lemma impl_top_as_sup: \<open>p \<rightarrow> q = \<top> \<longleftrightarrow> p \<squnion> q = q\<close>
  by (metis impl_top_as_inf inf.orderI le_iff_sup sup_compl_top_left1)

lemma internalise_le: \<open>p \<turnstile> q \<longleftrightarrow> p \<rightarrow> q = top\<close>
  by (simp add: impl_top_as_sup le_iff_sup)

lemma bool_impl_galois: \<open>a \<turnstile> b \<rightarrow> c \<longleftrightarrow> a \<sqinter> b \<turnstile> c\<close>
  by (simp add: internalise_le sup.assoc)

lemma bool_impl_galois_deduct: \<open>top \<turnstile> b \<rightarrow> c \<longleftrightarrow> b \<turnstile> c\<close>
  by (simp add: internalise_le sup.assoc)

lemma bool_iff_eq_eq: \<open>top \<turnstile> p \<leftrightarrow> q \<longleftrightarrow> (p = q)\<close>
  by (metis impl_top_as_inf inf_absorb2 inf_le2 inf_top.right_neutral)

end

section \<open> LTL \<close>

text \<open>
  The main LTL operations, without any definitions.
  I include all of them, instead of defining some of them, because the axiomatisations disagree
  about which ones are primary.
\<close>

class ltl_ops = boolean_algebra +
  fixes ltl_next :: \<open>'a \<Rightarrow> 'a\<close> (\<open>\<circle>_\<close> [75] 75)
  fixes ltl_until :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infix \<open>\<U>\<close> 73)
  fixes ltl_weakuntil :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infix \<open>\<W>\<close> 73)
  fixes ltl_globally :: \<open>'a \<Rightarrow> 'a\<close> (\<open>\<box>_\<close> [75] 75)
  fixes ltl_finally  :: \<open>'a \<Rightarrow> 'a\<close> (\<open>\<diamond>_\<close> [75] 75)
begin

definition ltl_modalimpl :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infix \<open>\<Rightarrow>\<close> 63) where
  \<open>p \<Rightarrow> q \<equiv> \<box>(p \<rightarrow> q)\<close>

definition ltl_modaliff :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infix \<open>\<Leftrightarrow>\<close> 63) where
  \<open>p \<Leftrightarrow> q \<equiv> \<box>(p \<leftrightarrow> q)\<close>

lemma modalimpl_refl[simp]: \<open>\<top> \<turnstile> \<box>\<top> \<Longrightarrow> \<top> \<turnstile> p \<Rightarrow> p\<close>
  by (simp add: ltl_modalimpl_def)

lemma modaliff_refl[simp]: \<open>\<top> \<turnstile> \<box>\<top> \<Longrightarrow> \<top> \<turnstile> p \<Leftrightarrow> p\<close>
  by (simp add: ltl_modaliff_def)

end

subsection \<open> Axiomatisation 1: Equational \<close>

text \<open>
  This axiomatisation is modified from Manna and Pnueli's axiomatisation from
    The Temporal Logic of Reactive and Concurrent Systems (1991)
  which is replicated in von Karger's
    An Algebraic Approach to Temporal Logic (1995).
  (See also Axiomatisation 2).
\<close>

class ltl_algebra_eq = ltl_ops +
  assumes ltl_globally_def: \<open>\<box> p = p \<W> \<bottom>\<close>
  assumes ltl_finally_def: \<open>\<diamond> p = -(\<box>(-p))\<close>
  assumes ltl_until_def: \<open>p \<U> q = p \<W> q \<sqinter> \<diamond>q\<close>

  assumes fx0_globally_implies: \<open>\<box>p \<sqinter> p = \<box>p\<close>
  assumes fx1_next_selfdual: \<open>-(\<circle>p) = \<circle>(-p)\<close>
  assumes fx2_next_disj_distrib: \<open>\<circle>(p \<squnion> q) = \<circle>p \<squnion> \<circle>q\<close>
  assumes fx3_generalisation: \<open>\<box>(\<box>(p \<rightarrow> q) \<rightarrow> (\<box>p \<rightarrow> \<box>q)) = top\<close>
  assumes fx4_globally_next: \<open>\<box>p \<sqinter> \<box>(\<circle>p) = \<box>p\<close>
  assumes fx5_globally_impl_next_impl_globally: \<open>\<box>(p \<rightarrow> \<circle>p) \<sqinter> \<box>(p \<rightarrow> \<box>p) = \<box>(p \<rightarrow> \<circle>p)\<close>
  assumes fx6_weakuntil_unfolding: \<open>p \<W> q = q \<squnion> (p \<sqinter> \<circle>(p \<W> q))\<close>
  assumes fx7_globally_implies_weak: \<open>\<box>p \<sqinter> (p \<W> q) = \<box>p\<close>
begin

lemma generalisation: \<open>p = \<top> \<Longrightarrow> \<box>p = \<top>\<close>
  by (metis fx3_generalisation sup_top_right)

lemma fx3_equivalence0:
  \<open>(\<forall>p q. \<box>(\<diamond>(p \<sqinter> -q) \<squnion> (\<diamond>(-p) \<squnion> \<box>q)) = top)
    \<longleftrightarrow>
    (\<forall>p q. \<box>(\<box>(p \<rightarrow> q) \<rightarrow> (\<box>p \<rightarrow> \<box>q)) = top)\<close>
  by (simp add: ltl_finally_def)

lemma fx3_equivalence1:
  \<open>(\<forall>p q. \<box>(\<diamond>(p \<sqinter> -q) \<squnion> (\<diamond>(-p) \<squnion> \<box>q)) = top)
    \<longleftrightarrow>
    (\<forall>p q. \<box>(\<diamond>(-p \<sqinter> -q) \<squnion> (\<diamond>p \<squnion> \<box>q)) = top)\<close>
  by (metis double_compl)

lemma global_theorem_eq_theorem: \<open>top \<turnstile> \<box>p \<longleftrightarrow> top \<turnstile> p\<close>
  by (metis fx0_globally_implies fx3_generalisation inf.commute inf_top.right_neutral top_le)

lemma deduce_finally: \<open>p \<turnstile> \<diamond>p\<close>
  by (simp add: compl_le_swap1 fx0_globally_implies inf.orderI ltl_finally_def)

lemma globally_impl_le_distrib: \<open>\<box>(p \<rightarrow> q) \<turnstile> \<box>p \<rightarrow> \<box>q\<close>
  using global_theorem_eq_theorem bool_impl_galois_deduct fx3_generalisation
  by fastforce

lemma next_imlp_distrib[simp]: \<open>\<circle>(p \<rightarrow> q) = \<circle>p \<rightarrow> \<circle>q\<close>
  by (simp add: fx1_next_selfdual fx2_next_disj_distrib)

lemma next_conj_distrib[simp]: \<open>\<circle>(p \<sqinter> q) = \<circle>p \<sqinter> \<circle>q\<close>
  by (metis compl_inf double_compl fx1_next_selfdual next_imlp_distrib)

lemma globally_unfolding: \<open>\<box>p = p \<sqinter> \<circle>(\<box>p)\<close>
  using fx6_weakuntil_unfolding
  by (metis ltl_globally_def sup_bot_left)

lemma finally_unfolding: \<open>\<diamond>p = p \<squnion> \<circle>(\<diamond>p)\<close>
  by (metis globally_unfolding compl_sup double_compl fx1_next_selfdual ltl_finally_def)

lemma until_unfolding: \<open>p \<U> q = q \<squnion> (p \<sqinter> \<circle>(p \<U> q))\<close>
  apply (simp only: ltl_until_def)
  apply (subst fx6_weakuntil_unfolding)
  apply (simp add: inf.assoc sup_inf_distrib1 finally_unfolding[symmetric])
  done

lemma globally_top[simp]: \<open>\<box>\<top> = \<top>\<close>
  by (simp add: global_theorem_eq_theorem top_le)

lemma globally_bot[simp]: \<open>\<box>\<bottom> = \<bottom>\<close>
  by (metis globally_unfolding inf_bot_left)

lemma finally_top[simp]: \<open>\<diamond>\<top> = \<top>\<close>
  by (simp add: ltl_finally_def)

lemma finally_bot[simp]: \<open>\<diamond>\<bottom> = \<bottom>\<close>
  by (simp add: ltl_finally_def)

lemma globally_monotone:
  \<open>p \<turnstile> q \<Longrightarrow> \<box>p \<turnstile> \<box>q\<close>
  by (metis global_theorem_eq_theorem globally_top bool_impl_galois_deduct fx3_generalisation
      internalise_le)

lemma finally_monotone:
  \<open>p \<turnstile> q \<Longrightarrow> \<diamond>p \<turnstile> \<diamond>q\<close>
  by (simp add: globally_monotone ltl_finally_def)

lemma globally_conj_distrib: \<open>\<box>(p \<sqinter> q) = \<box>p \<sqinter> \<box>q\<close>
  oops

lemma globally_disj_left: \<open>\<box>p \<turnstile> \<box>(p \<squnion> q)\<close>
  by (simp add: globally_monotone)

lemma globally_disj_right: \<open>\<box>q \<turnstile> \<box>(p \<squnion> q)\<close>
  by (simp add: globally_monotone)

lemma finally_disj_distrib: \<open>\<diamond>(p \<squnion> q) = \<diamond>p \<squnion> \<diamond>q\<close>
  oops

lemma finally_conj_left: \<open>\<diamond>(p \<sqinter> q) \<turnstile> \<diamond>p\<close>
  by (simp add: finally_monotone)

lemma finally_conj_right: \<open>\<diamond>(p \<sqinter> q) \<turnstile> \<diamond>q\<close>
  by (simp add: finally_monotone)

lemma globally_idem: \<open>\<box>\<box>p = \<box>p\<close>
  by (metis deduce_finally finally_top global_theorem_eq_theorem globally_unfolding
      bool_impl_galois_deduct fx0_globally_implies fx5_globally_impl_next_impl_globally
      impl_top_as_inf inf.right_idem inf_absorb2)

lemma finally_idem: \<open>\<diamond>\<diamond>p = \<diamond>p\<close>
  by (simp add: globally_idem ltl_finally_def)

lemma globally_finally_eq_globally_until: \<open>\<box>p \<sqinter> \<diamond>q = \<box>p \<sqinter> p \<U> q\<close>
  by (metis fx7_globally_implies_weak inf.assoc ltl_until_def)

lemma negweakuntil_unfolding: \<open>-(q \<W> r) = -r \<sqinter> (-q \<squnion> \<circle>-(q \<W> r))\<close>
  by (metis compl_inf compl_sup fx1_next_selfdual fx6_weakuntil_unfolding)

lemma globally_induction: \<open>p \<turnstile> q \<Longrightarrow> p \<turnstile> \<circle>p \<Longrightarrow> p \<turnstile> \<box>q\<close>
  by (metis global_theorem_eq_theorem globally_disj_right globally_top bool_impl_galois_deduct
      fx5_globally_impl_next_impl_globally inf_top_left internalise_le sup.absorb1 transp_le
      transpD)

lemma weakuntil_induction:
  assumes ih: \<open>p \<turnstile> r \<squnion> (q \<sqinter> \<circle>p)\<close>
  shows \<open>p \<turnstile> q \<W> r\<close>
proof -
  have \<open>p \<sqinter> -(q \<W> r) \<turnstile> \<box>q\<close>
  proof (rule globally_induction)
    have l0: \<open>-(q \<W> r) \<turnstile> -r \<sqinter> (-q \<squnion> \<circle>-(q \<W> r))\<close>
      using negweakuntil_unfolding by auto
    then show g0: \<open>p \<sqinter> -(q \<W> r) \<turnstile> q\<close>
      using ih
      by (metis bool_impl_galois compl_le_swap1 inf.absorb2 inf.cobounded1
          inf.coboundedI1 sup_mono)

    have \<open>-(q \<W> r) \<turnstile> -q \<squnion> \<circle>-(q \<W> r)\<close>
      by (metis inf_le2 negweakuntil_unfolding)
    then have l1: \<open>p \<sqinter> -(q \<W> r) \<turnstile> -q \<squnion> \<circle>-(q \<W> r)\<close>
      using inf.coboundedI2 by blast

    have \<open>p \<sqinter> -(q \<W> r) \<turnstile> \<circle>-(q \<W> r)\<close>
      using g0 l1
      and bool_impl_galois inf.absorb_iff2 inf_commute
      by auto
    moreover have \<open>p \<sqinter> -(q \<W> r) \<turnstile> \<circle>p\<close>
      using inf.mono[OF ih l0] inf_sup_distrib2 by auto
    ultimately show \<open>p \<sqinter> -(q \<W> r) \<turnstile> \<circle>(p \<sqinter> -(q \<W> r))\<close>
      by simp
  qed
  moreover have \<open>\<box>q \<turnstile> q \<W> r\<close>
    by (simp add: fx7_globally_implies_weak inf.orderI)
  ultimately have \<open>p \<sqinter> -(q \<W> r) \<turnstile> q \<W> r\<close>
    using order_trans by blast
  then show ?thesis
    using le_iff_sup sup_inf_distrib2 by auto
qed

lemma gleft_wuntil_eq_sup: \<open>\<box>p \<W> q = \<box>p \<squnion> q\<close>
  by (metis globally_idem globally_unfolding fx6_weakuntil_unfolding fx7_globally_implies_weak
      inf.assoc sup.commute next_conj_distrib)

lemma weakuntil_absorb_globally: \<open>p \<W> q \<squnion> \<box>p = p \<W> q\<close>
  by (simp add: fx7_globally_implies_weak inf.orderI sup_absorb1)

lemma weakuntil_left_conj_distrib: \<open>(p \<sqinter> q) \<W> r = (p \<W> r) \<sqinter> (q \<W> r)\<close>
proof (intro order.antisym inf.boundedI)
  show \<open>(p \<sqinter> q) \<W> r \<turnstile> p \<W> r\<close>
    apply (rule weakuntil_induction)
    apply (subst fx6_weakuntil_unfolding)
    apply (metis inf_sup_distrib2 le_sup_iff sup.coboundedI2 sup_ge1 sup_inf_absorb)
    done
next
  show \<open>(p \<sqinter> q) \<W> r \<turnstile> q \<W> r\<close>
    apply (rule weakuntil_induction)
    apply (subst fx6_weakuntil_unfolding)
    apply (metis eq_iff inf_le2 sup_mono inf.assoc)
    done
next
  show \<open>p \<W> r \<sqinter> q \<W> r \<turnstile> (p \<sqinter> q) \<W> r\<close>
    apply (rule weakuntil_induction)
    apply clarsimp
    apply (subst fx6_weakuntil_unfolding)
    apply (simp add: sup_inf_distrib1)
    apply (intro conjI)
    apply (simp add: inf.assoc)
      apply (metis dual_order.trans fx6_weakuntil_unfolding inf.assoc inf.left_commute inf_commute
        inf_le1 sup_commute sup_inf_distrib1)
     apply (simp add: inf.assoc inf.coboundedI2)
    apply (metis dual_order.trans fx6_weakuntil_unfolding inf.assoc inf.left_commute inf_commute
        inf_le2 sup_inf_distrib1)
    done
qed

lemma weakuntil_right_disj_distrib: \<open>p \<W> (q \<squnion> r) = (p \<W> q) \<sqinter> (p \<W> r)\<close>
  oops

lemma until_pseudotransitive: \<open>(p \<U> q) \<sqinter> (-q \<U> r) \<turnstile> p \<U> r\<close>
  oops

lemma globally_next_comm[simp]: \<open>\<circle>\<box>p = \<box>\<circle>p\<close>
  oops

lemma finally_next_comm[simp]: \<open>\<circle>\<diamond>p = \<diamond>\<circle>p\<close>
  oops

lemma next_weakuntil_distrib[simp]: \<open>\<circle>(p \<W> q) = \<circle>p \<W> \<circle>q\<close>
  oops

lemma weakuntil_left_idem: \<open>p \<W> (p \<W> q) = p \<W> q\<close>
  oops

lemma weakuntil_right_idem: \<open>(p \<W> q) \<W> q = p \<W> q\<close>
  oops

lemma until_left_idem: \<open>p \<U> (p \<U> q) = p \<U> q\<close>
  oops

lemma until_right_idem: \<open>(p \<U> q) \<U> q = p \<U> q\<close>
  oops

lemma possibly_reccurence_eq_recurrence: \<open>\<diamond>\<box>\<diamond>p = \<box>\<diamond>p\<close>
  oops

lemma globally_persistence_eq_persistence: \<open>\<box>\<diamond>\<box>p = \<diamond>\<box>p\<close>
  oops

text \<open>Things I can't yet prove\<close>

lemma \<open>p \<W> q \<turnstile> \<box>p \<squnion> (\<diamond>-p \<sqinter> \<diamond>q)\<close>
  oops

lemma finally_globally_eq_finally_weakuntil: \<open>\<diamond>q \<squnion> \<box>p = \<diamond>q \<squnion> p \<W> q\<close>
  apply (intro order.antisym sup.boundedI)
     apply simp
    apply (simp add: sup.assoc sup.orderI weakuntil_absorb_globally)
   apply simp
  oops

lemma until_eq_weakuntil_and_poss: \<open>p \<W> q = p \<U> q \<squnion> \<box>p\<close>
  oops
(*
proof -
  have \<open>p \<U> q \<squnion> \<box>p = p \<W> q \<sqinter> \<diamond>q \<squnion> \<box>p\<close>
    by (simp add: ltl_until_def)
  also have \<open>... = p \<W> q \<sqinter> (\<diamond>q \<squnion> \<box>p)\<close>
    by (simp add: sup_inf_distrib2 weakuntil_absorb_globally)
  also have \<open>... = p \<W> q\<close>
    by (metis finally_globally_eq_finally_weakuntil inf.orderE sup_ge2)
  finally show ?thesis
    by (simp add: ltl_until_def)
qed
*)

end

subsection \<open> Axiomatisation 2 \<close>

text \<open>
  This axiomatisation is modified from Manna and Pnueli's axiomatisation from
    The Temporal Logic of Reactive and Concurrent Systems (1991)
  which is replicated in von Karger's
    An Algebraic Approach to Temporal Logic (1995).
\<close>
class ltl_algebra_manna_pnueli = ltl_ops +
  assumes ltl_globally_def: \<open>\<box> p = p \<W> \<bottom>\<close>
  assumes ltl_finally_def:  \<open>\<diamond> p = -(\<box>(-p))\<close>
  assumes ltl_until_def:    \<open>p \<U> q = p \<W> q \<sqinter> \<diamond>q\<close>

  assumes fx0_globally_implies:     \<open>\<top> \<turnstile> \<box>p \<rightarrow> p\<close>
  assumes fx1_next_selfdual:        \<open>\<top> \<turnstile> -(\<circle>p) \<Leftrightarrow> \<circle>(-p)\<close>
  assumes fx2_next_imlp_distrib:    \<open>\<top> \<turnstile> \<circle>(p \<rightarrow> q) \<Leftrightarrow> (\<circle>p \<rightarrow> \<circle>q)\<close>
  assumes fx3_generalisation: \<open>\<top> \<turnstile> \<box>(p \<rightarrow> q) \<Rightarrow> (\<box>p \<rightarrow> \<box>q)\<close>
  assumes fx4_globally_next:        \<open>\<top> \<turnstile> \<box>p \<rightarrow> \<box>(\<circle>p)\<close>
  assumes fx5_globally_induction:   \<open>\<top> \<turnstile> (p \<Rightarrow> \<circle>p) \<rightarrow> (p \<Rightarrow> \<box>p)\<close>
  assumes fx6_weakuntil_unfolding:  \<open>\<top> \<turnstile> p \<W> q \<Leftrightarrow> q \<squnion> (p \<sqinter> \<circle>(p \<W> q))\<close>
  assumes fx7_globally_impl_wuntil: \<open>\<top> \<turnstile> \<box>p \<Rightarrow> p \<W> q\<close>
begin

lemma globally_deduct: \<open>\<box>p \<turnstile> p\<close>
  using bool_impl_galois_deduct fx0_globally_implies by auto

lemma global_theorem_eq_theorem: \<open>\<top> \<turnstile> \<box>p \<longleftrightarrow> \<top> \<turnstile> p\<close>
  by (metis fx0_globally_implies fx3_generalisation internalise_le ltl_modalimpl_def
      top.ordering_top_axioms ordering_top.extremum_unique)

lemma p_modaliff_q_then_eq: \<open>top \<turnstile> p \<Leftrightarrow> q \<Longrightarrow> (p = q)\<close>
  using fx0_globally_implies
  by (metis antisym impl_top_as_inf inf_le2 inf_top.right_neutral ltl_modaliff_def)

lemma modaliff_eq_eq: \<open>top \<turnstile> p \<Leftrightarrow> q \<longleftrightarrow> (p = q)\<close>
  by (simp add: bool_impl_galois_deduct eq_iff global_theorem_eq_theorem ltl_modaliff_def)

lemma \<open>top \<turnstile> p \<Leftrightarrow> q \<longleftrightarrow> top \<turnstile> p \<leftrightarrow> q\<close>
  by (simp add: global_theorem_eq_theorem ltl_modaliff_def)

lemma modal_theorem_galois: \<open>p \<turnstile> q \<longleftrightarrow> top \<turnstile> p \<Rightarrow> q\<close>
  by (simp add: bool_impl_galois_deduct global_theorem_eq_theorem ltl_modalimpl_def)

lemma global_global_impl_distrib:
  \<open>\<top> \<turnstile> \<box>(\<box>(p \<rightarrow> q) \<rightarrow> \<box>p \<rightarrow> \<box>q)\<close>
  using fx3_generalisation ltl_modalimpl_def by auto

lemma global_global_next_deduce:
  \<open>\<box>p \<turnstile> \<box>\<circle>p\<close>
  using bool_impl_galois_deduct fx4_globally_next by blast

lemma self_impl_next_deduce_self_impl_globally:
  \<open>\<box>(p \<rightarrow> \<circle>p) \<turnstile> \<box>(p \<rightarrow> \<box>p)\<close>
  using bool_impl_galois_deduct fx5_globally_induction ltl_modalimpl_def by auto

lemma globally_deduce_weakuntil:
  \<open>\<box>p \<turnstile> p \<W> q\<close>
  using fx7_globally_impl_wuntil modal_theorem_galois by auto

lemma next_disj_distrib: \<open>\<circle>(p \<squnion> q) = \<circle>p \<squnion> \<circle>q\<close>
  by (metis double_compl fx1_next_selfdual fx2_next_imlp_distrib p_modaliff_q_then_eq)

text \<open>
  This equivalence is straightforward, as my equational rules
   are just rewritten versions of the Manna-Pnueli axioms.
\<close>
interpretation manna_pnueli_is_an_ltl_algebra: ltl_algebra_eq
  apply (unfold_locales)
            apply (simp add: ltl_globally_def)
           apply (simp add: ltl_finally_def)
          apply (simp add: ltl_until_def)
         apply (simp add: globally_deduct inf.absorb1)
        apply (simp add: fx1_next_selfdual p_modaliff_q_then_eq)
       apply (simp add: next_disj_distrib)
      apply (simp add: global_global_impl_distrib antisym)
     apply (simp add: global_global_next_deduce inf.absorb1)
    apply (simp add: self_impl_next_deduce_self_impl_globally inf.absorb1)
   apply (simp add: fx6_weakuntil_unfolding p_modaliff_q_then_eq inf.absorb1)
  apply (simp add: globally_deduce_weakuntil inf.absorb1)
  done

end

context ltl_algebra_eq
begin

interpretation ltl_algebra_proves_manna_pnueli_axioms: ltl_algebra_manna_pnueli
  apply (unfold_locales)
            apply (simp add: ltl_globally_def)
           apply (simp add: ltl_finally_def)
          apply (simp add: ltl_until_def)
         apply (simp add: fx0_globally_implies impl_top_as_inf internalise_le)
        apply (metis compl_sup_top eq_refl fx1_next_selfdual globally_top inf.semilattice_axioms
      ltl_modaliff_def semilattice.idem)
       apply (metis compl_sup_top eq_iff fx0_globally_implies generalisation ltl_modaliff_def
      next_imlp_distrib)
      apply (simp add: fx3_generalisation ltl_modalimpl_def)
     apply (metis fx4_globally_next inf_le2 internalise_le top_greatest)
    apply (simp add: fx5_globally_impl_next_impl_globally impl_top_as_inf internalise_le
      ltl_modalimpl_def)
   apply (metis eq_refl fx6_weakuntil_unfolding globally_top inf.semilattice_axioms
      internalise_le ltl_modaliff_def semilattice.idem)
  apply (metis fx7_globally_implies_weak globally_top impl_top_as_inf ltl_modalimpl_def
      top_greatest)
  done

end

subsection \<open> Axiomatisation 3 \<close>

text \<open>
  This axiomatisation from Gabbay, Pnueli, Shelah, and Stavi's
    Temporal Analysis of Fairness
  and is the second axiomatisation they present
\<close>

class ltl_algebra_gpss2 = ltl_ops +
  assumes ltl_finally_def: \<open>\<diamond> p = -(\<box>(-p))\<close>
  assumes ltl_until_def: \<open>p \<U> q = p \<W> q \<sqinter> \<diamond>q\<close>

  assumes kripke_g: \<open>\<top> \<turnstile> \<box>(p \<rightarrow> q) \<rightarrow> \<box>p \<rightarrow> \<box>q\<close>
  assumes x_selfdual: \<open>\<top> \<turnstile> -(\<circle>p) \<leftrightarrow> \<circle>(-p)\<close>
  assumes kripke_x: \<open>\<top> \<turnstile> \<circle>(p \<rightarrow> q) \<rightarrow> \<circle>p \<rightarrow> \<circle>q\<close>
  assumes g_unfolding: \<open>\<top> \<turnstile> \<box>p \<leftrightarrow> p \<sqinter> \<circle>\<box>p\<close>
  assumes selfnext_is_selfg: \<open>\<top> \<turnstile> \<box>(p \<rightarrow> \<circle>p) \<rightarrow> \<box>(p \<rightarrow> \<box>p)\<close>
  assumes wuntil_finally: \<open>\<top> \<turnstile> \<box>p \<rightarrow> p \<W> q\<close>
  assumes wuntil_unfolding: \<open>\<top> \<turnstile> p \<W> q \<leftrightarrow> q \<squnion> (p \<sqinter> \<circle>(p \<W> q))\<close>
  assumes generalisation: \<open>\<top> \<turnstile> p \<Longrightarrow> \<top> \<turnstile> \<box>p\<close>
begin

text \<open> Make the axioms nicer to work with\<close>

lemma kripke_g_deduct: \<open>\<box>(p \<rightarrow> q) \<turnstile> \<box>p \<rightarrow> \<box>q\<close>
  using bool_impl_galois_deduct kripke_g top_boolI by blast

lemma x_selfdual_eq: \<open>-(\<circle>p) = \<circle>(-p)\<close>
  using bool_iff_eq_eq x_selfdual by blast

lemma kripke_x_deduct: \<open>\<circle>(p \<rightarrow> q) \<turnstile> \<circle>p \<rightarrow> \<circle>q\<close>
  using bool_impl_galois_deduct kripke_x by blast

lemma g_unfolding_eq: \<open>\<box>p = p \<sqinter> \<circle>\<box>p\<close>
  using bool_iff_eq_eq g_unfolding by blast

lemma selfnext_is_selfg_deduct: \<open>\<box>(p \<rightarrow> \<circle>p) \<turnstile> \<box>(p \<rightarrow> \<box>p)\<close>
  using internalise_le selfnext_is_selfg by auto

lemma wuntil_finally_deduct_deduct: \<open>\<box>p \<turnstile> p \<W> q\<close>
  using internalise_le wuntil_finally by auto

lemma wuntil_unfolding_eq: \<open>p \<W> q = q \<squnion> (p \<sqinter> \<circle>(p \<W> q))\<close>
  using bool_iff_eq_eq wuntil_unfolding by blast

subsubsection \<open> Derived Lemmas \<close>

lemma necessitation: \<open>\<top> \<turnstile> \<box>p \<Longrightarrow> \<top> \<turnstile> p\<close>
  by (metis bool_iff_eq_eq g_unfolding inf_eq_top_iff top_le)

lemma global_theorem_iff_theorem: \<open>\<top> \<turnstile> \<box>p \<longleftrightarrow> \<top> \<turnstile> p\<close>
  by (metis generalisation necessitation top_le)

lemma globally_induction: \<open>a \<turnstile> b \<Longrightarrow> a \<turnstile> \<circle>a \<Longrightarrow> a \<turnstile> \<box>b\<close>
  by (metis g_unfolding_eq global_theorem_iff_theorem kripke_g_deduct bool_impl_galois_deduct
      impl_top_as_inf inf.left_idem internalise_le selfnext_is_selfg_deduct)

lemma finally_induction: \<open>a \<turnstile> b \<Longrightarrow> \<circle>b \<turnstile> b \<Longrightarrow> \<diamond>a \<turnstile> b\<close>
  by (metis compl_mono double_compl globally_induction ltl_finally_def x_selfdual_eq)

paragraph \<open> Idempotence \<close>

lemma globally_idem: \<open>\<box>\<box>p = \<box>p\<close>
proof (rule antisym)
  show \<open>\<box>\<box>p \<turnstile> \<box>p\<close>
    by (metis g_unfolding_eq inf.cobounded1)
next
  have \<open>\<box>p \<turnstile> \<circle>\<box>p\<close>
    by (metis g_unfolding_eq inf_le2)
  then show \<open>\<box>p \<turnstile> \<box>\<box>p\<close>
    by (simp add: globally_induction)
qed

lemma finally_idem: \<open>\<diamond>\<diamond>p = \<diamond>p\<close>
  by (simp add: globally_idem ltl_finally_def)

paragraph \<open> Next \<close>

lemma next_true[simp]: \<open>\<circle>\<top> = \<top>\<close>
  by (metis g_unfolding_eq global_theorem_iff_theorem inf_top.left_neutral top_unique)

lemma next_false[simp]: \<open>\<circle>\<bottom> = \<bottom>\<close>
  by (metis compl_top_eq next_true x_selfdual_eq)

lemma globally_next_push_in: \<open>\<circle>\<box>p \<turnstile> \<box>\<circle>p\<close>
proof (rule globally_induction)
  show \<open>\<circle>\<box>p \<le> \<circle>p\<close>
    by (metis g_unfolding_eq kripke_x_deduct bool_impl_galois_deduct inf.cobounded1 internalise_le
        next_true)
next
  show \<open>\<circle>\<box>p \<le> \<circle>\<circle>\<box>p\<close>
    by (metis g_unfolding_eq kripke_x_deduct bool_impl_galois_deduct inf_le2 internalise_le
        next_true)
qed

lemma globally_next_push_out: \<open>\<box>\<circle>p \<turnstile> \<circle>\<box>p\<close>
  oops

lemma globally_next_commute: \<open>\<box>\<circle>p = \<circle>\<box>p\<close>
  oops

lemma finally_next_commute: \<open>\<diamond>\<circle>p = \<diamond>\<box>p\<close>
  oops

paragraph \<open> Globally Distribution \<close>

lemma globally_proves_next_globally: \<open>\<box>p \<turnstile> \<circle>\<box>p\<close>
  by (metis g_unfolding_eq globally_idem inf.orderI)

lemma globally_true[simp]: \<open>\<box>\<top> = \<top>\<close>
  by (simp add: global_theorem_iff_theorem top_le)

lemma globally_false[simp]: \<open>\<box>\<bottom> = \<bottom>\<close>
  by (metis g_unfolding_eq inf_bot_left)

subparagraph \<open> Conjunction \<close>

lemma globally_conj_split_left: \<open>\<box>(p \<sqinter> q) \<turnstile> \<box>p\<close>
  by (metis g_unfolding_eq globally_proves_next_globally globally_induction inf_le1 le_infI1)

lemma globally_conj_split_right: \<open>\<box>(p \<sqinter> q) \<turnstile> \<box>q\<close>
  by (metis g_unfolding_eq globally_proves_next_globally globally_induction inf_le2 le_infI1)

lemma globally_distrib_conj_split: \<open>\<box>(p \<sqinter> q) \<turnstile> \<box>p \<sqinter> \<box>q\<close>
  using globally_conj_split_left globally_conj_split_right
  by simp

lemma globally_distrib_conj_combine: \<open>\<box>p \<sqinter> \<box>q \<turnstile> \<box>(p \<sqinter> q)\<close>
  oops

lemma globally_distrib_conj: \<open>\<box>(p \<sqinter> q) = \<box>p \<sqinter> \<box>q\<close>
  oops

subparagraph \<open> Disjunction \<close>

lemma globally_distrib_disj_combine_left: \<open>\<box>p \<turnstile> \<box>(p \<squnion> q)\<close>
  by (metis g_unfolding_eq globally_proves_next_globally globally_induction le_infI1 sup_ge1)

lemma globally_distrib_disj_combine_right: \<open>\<box>q \<turnstile> \<box>(p \<squnion> q)\<close>
  by (metis g_unfolding_eq globally_proves_next_globally globally_induction le_infI1 sup_ge2)

lemma globally_distrib_disj_combine: \<open>\<box>p \<squnion> \<box>q \<turnstile> \<box>(p \<squnion> q)\<close>
  using globally_distrib_disj_combine_left globally_distrib_disj_combine_right
  by simp

paragraph \<open> Finally Distribution \<close>

lemma finally_false[simp]: \<open>\<diamond>\<bottom> = \<bottom>\<close>
  by (simp add: ltl_finally_def)

lemma finally_true[simp]: \<open>\<diamond>\<top> = \<top>\<close>
  by (simp add: ltl_finally_def)

subparagraph \<open> Disjunction \<close>

lemma finally_distrib_disj_split: \<open>\<diamond>(p \<squnion> q) \<turnstile> \<diamond>p \<squnion> \<diamond>q\<close>
  oops

lemma finally_distrib_disj_combine: \<open>\<diamond>p \<squnion> \<diamond>q \<turnstile> \<diamond>(p \<squnion> q)\<close>
  using globally_distrib_conj_split ltl_finally_def by auto

subparagraph \<open> Conjunction \<close>

lemma finally_conj_split_left: \<open>\<diamond>(p \<sqinter> q) \<turnstile> \<diamond>p\<close>
sledgehammer
  by (metis g_unfolding_eq globally_proves_next_globally compl_mono globally_induction
      inf.cobounded1 inf.coboundedI1 ltl_finally_def)

lemma finally_conj_split_right: \<open>\<diamond>(p \<sqinter> q) \<turnstile> \<diamond>q\<close>
  by (metis g_unfolding_eq globally_proves_next_globally compl_mono globally_induction
      inf.cobounded2 inf.coboundedI1 ltl_finally_def)

lemma finally_distrib_conj_split: \<open>\<diamond>(p \<sqinter> q) \<turnstile> \<diamond>p \<sqinter> \<diamond>q\<close>
  by (simp add: finally_conj_split_left finally_conj_split_right)

paragraph \<open> Next Distribution \<close>

subparagraph \<open> Disjunction \<close>

lemma next_disj_distrib_split: \<open>\<circle>(p \<squnion> q) \<turnstile> \<circle>p \<squnion> \<circle>q\<close>
    by (metis kripke_x_deduct double_compl x_selfdual_eq)

lemma next_disj_distrib_combine: \<open>\<circle>p \<squnion> \<circle>q \<turnstile> \<circle>(p \<squnion> q)\<close>
  oops

subparagraph \<open> Conjunction \<close>

lemma next_conj_distrib_split: \<open>\<circle>(p \<sqinter> q) \<turnstile> \<circle>p \<sqinter> \<circle>q\<close>
  oops

lemma next_conj_distrib_combine: \<open>\<circle>p \<sqinter> \<circle>q \<turnstile> \<circle>(p \<sqinter> q)\<close>
  using kripke_x_deduct compl_le_compl_iff x_selfdual_eq by fastforce

paragraph \<open> Weak Until \<close>

lemma globally_as_wuntil: \<open>\<box>p = p \<W> \<bottom>\<close>
proof (rule antisym)
  show \<open>\<box>p \<turnstile> p \<W> \<bottom>\<close>
    by (simp add: wuntil_finally_deduct_deduct)
next
  have \<open>p \<W> \<bottom> \<turnstile> p\<close>
    by (metis inf.cobounded1 sup_bot_left wuntil_unfolding_eq)
  moreover have \<open>p \<W> \<bottom> \<turnstile> \<circle>(p \<W> \<bottom>)\<close>
    by (metis inf_le2 sup_bot.left_neutral wuntil_unfolding_eq)
  ultimately show \<open>p \<W> \<bottom> \<turnstile> \<box>p\<close>
    by (force intro: globally_induction)
qed

lemma glob_weakuntil_fin_eq_disj: \<open>\<box>p \<W> q = \<box>p \<squnion> q\<close>
proof -
  have \<open>\<box>p \<W> q = (\<box>p \<W> q) \<squnion> \<box>p\<close>
    by (metis sup.order_iff wuntil_finally_deduct_deduct globally_idem)
  also have \<open>... =  q \<squnion> (\<box>p \<sqinter> \<circle>(\<box>p \<W> q)) \<squnion> \<box>p\<close>
    by (metis wuntil_unfolding_eq)
  also have \<open>... =  (\<box>p \<squnion> (\<box>p \<sqinter> \<circle>(\<box>p \<W> q))) \<squnion> q\<close>
    using sup.assoc sup.commute by auto
  also have \<open>... =  \<box>p \<squnion> q\<close>
    by (metis sup_inf_absorb)
  finally show ?thesis .
qed

lemma weakuntil_fin_eq_disj: \<open>p \<W> \<diamond>q = \<box>p \<squnion> \<diamond>q\<close>
  oops

lemma weakuntil_induction: \<open>p \<turnstile> r \<squnion> (q \<sqinter> \<circle>p) \<Longrightarrow> p \<turnstile> q \<W> r\<close>
  oops

paragraph \<open> Globally + Finally \<close>

lemma globally_conj_finally_eq_globally: \<open>\<box>p \<sqinter> \<diamond>p = \<box>p\<close>
  by (metis g_unfolding_eq compl_inf impl_top_as_inf inf_cancel_left1 ltl_finally_def sup_compl_top)

lemma globally_disj_finally_eq_finally: \<open>\<box>p \<squnion> \<diamond>p = \<diamond>p\<close>
  by (simp add: globally_conj_finally_eq_globally inf.orderI sup.absorb2)

paragraph \<open> Manna-Pnueli Axioms \<close>

lemma fx0_globally_implies: \<open>\<top> \<turnstile> \<box>p \<rightarrow> p\<close>
  by (metis g_unfolding_eq bool_impl_galois_deduct inf.cobounded1)

lemma fx1_next_selfdual: \<open>\<top> \<turnstile> -(\<circle>p) \<Leftrightarrow> \<circle>(-p)\<close>
  by (simp add: x_selfdual_eq)

lemma fx2_next_imlp_distrib: \<open>\<top> \<turnstile> \<circle>(p \<rightarrow> q) \<Leftrightarrow> (\<circle>p \<rightarrow> \<circle>q)\<close>
  sorry

lemma fx3_generalisation: \<open>\<top> \<turnstile> \<box>(p \<rightarrow> q) \<Rightarrow> (\<box>p \<rightarrow> \<box>q)\<close>
  by (simp add: generalisation kripke_g ltl_modalimpl_def)

lemma fx4_globally_next: \<open>\<top> \<turnstile> \<box>p \<rightarrow> \<box>(\<circle>p)\<close>
  by (metis g_unfolding_eq globally_next_push_in bool_impl_galois_deduct le_infI2)

lemma fx5_globally_induction: \<open>\<top> \<turnstile> (p \<Rightarrow> \<circle>p) \<rightarrow> (p \<Rightarrow> \<box>p)\<close>
  by (simp add: ltl_modalimpl_def selfnext_is_selfg)

lemma fx6_weakuntil_unfolding: \<open>\<top> \<turnstile> p \<W> q \<Leftrightarrow> q \<squnion> (p \<sqinter> \<circle>(p \<W> q))\<close>
  using wuntil_unfolding_eq by fastforce

lemma fx7_globally_impl_wuntil: \<open>\<top> \<turnstile> \<box>p \<Rightarrow> p \<W> q\<close>
  by (simp add: generalisation ltl_modalimpl_def wuntil_finally)

interpretation gpss2_proves_manna_pnueli_axioms: ltl_algebra_manna_pnueli
 apply (unfold_locales)
            apply (simp add: globally_as_wuntil)
           apply (simp add: ltl_finally_def)
          apply (simp add: ltl_until_def)
         apply (simp add: fx0_globally_implies)
        apply (simp add: fx1_next_selfdual)
       apply (simp add: fx2_next_imlp_distrib)
      apply (simp add: fx3_generalisation)
     apply (simp add: fx4_globally_next)
    apply (simp add: fx5_globally_induction)
   apply (simp add: fx6_weakuntil_unfolding)
  apply (simp add: fx7_globally_impl_wuntil)
  done

end

context  ltl_algebra_manna_pnueli
begin

lemma globally_unfolding: \<open>\<box>p = p \<sqinter> \<circle>\<box>p\<close>
  by (metis fx6_weakuntil_unfolding ltl_globally_def p_modaliff_q_then_eq sup_bot.left_neutral)

interpretation manna_pnueli_proves_gpss2_axioms: ltl_algebra_gpss2
  apply (unfold_locales)
  apply (simp add: ltl_finally_def)
          apply (simp add: ltl_until_def)
         apply (metis global_global_impl_distrib global_theorem_eq_theorem)
        apply (metis bool_iff_eq_eq fx1_next_selfdual modaliff_eq_eq)
       apply (metis compl_sup_top eq_iff fx2_next_imlp_distrib modaliff_eq_eq)
      apply (subst bool_iff_eq_eq, metis globally_unfolding)
     apply (simp add: bool_impl_galois_deduct self_impl_next_deduce_self_impl_globally)
    apply (simp add: bool_impl_galois_deduct globally_deduce_weakuntil)
   apply (simp only: bool_iff_eq_eq fx6_weakuntil_unfolding p_modaliff_q_then_eq)
  apply (simp add: global_theorem_eq_theorem)
  done

end

(* TODO
subsection \<open> Axiomatisation 4 \<close>

text \<open>
  This axiomatisation from Gabbay, Pnueli, Shelah, and Stavi's
    Temporal Analysis of Fairness
  and is the first axiomatisation they present
\<close>

class ltl_algebra_gpss1 = ltl_ops +
  fixes ltl_xuntil :: \<open>['a,'a] \<Rightarrow> 'a\<close> (infix \<open>\<U>\<^sup>+\<close> 73)
  fixes ltl_xglobally :: \<open>'a \<Rightarrow> 'a\<close> (\<open>\<box>\<^sup>+_\<close> [75] 75)
  fixes ltl_xfinally :: \<open>'a \<Rightarrow> 'a\<close> (\<open>\<diamond>\<^sup>+_\<close> [75] 75)

  assumes xfinally_def: \<open>\<diamond>\<^sup>+ p = -(\<box>\<^sup>+-p)\<close>

  assumes kripke_g: \<open>\<top> \<turnstile> \<box>(p \<rightarrow> q) \<rightarrow> \<box>p \<rightarrow> \<box>q = \<top>\<close>
  assumes x_selfdual: \<open>-(\<circle>p) = \<circle>(-p)\<close>
  assumes kripke_x: \<open>\<circle>(p \<rightarrow> q) \<rightarrow> \<circle>p \<rightarrow> \<circle>q = \<top>\<close>
  assumes g_unfolding: \<open>\<box>p = p \<sqinter> \<circle>\<box>p\<close>
  assumes selfnext_is_selfg: \<open>\<box>(p \<rightarrow> \<circle>p) \<rightarrow> \<box>(p \<rightarrow> \<box>p) = \<top>\<close>
  assumes until_finally: \<open>p \<U> q \<rightarrow> \<diamond>q = \<top>\<close>
  assumes until_unfolding: \<open>p \<U> q = q \<squnion> (p \<sqinter> \<circle>(p \<U> q))\<close>
  assumes generalisation: \<open>p = \<top> \<Longrightarrow> \<box>p = \<top>\<close>
begin
end

*)

subsection \<open> Axiomatisation 5 \<close>

text \<open>
  Kröger and Merz's axiomatisation from
\<close>

(* Kröger-Merz *)
class km_ltl_algebra = ltl_ops +
  assumes ltl_finally_def: \<open>\<diamond> p = -(\<box>(-p))\<close>
  assumes x_selfdual: \<open>-(\<circle>p) = \<circle>(-p)\<close>

  assumes kripke_x: \<open>\<top> \<turnstile> \<circle>(p \<rightarrow> q) \<rightarrow> \<circle>p \<rightarrow> \<circle>q\<close>
  assumes g_unfolding: \<open>\<top> \<turnstile> \<box>p \<rightarrow> p \<sqinter> \<circle>\<box>p\<close>

  assumes next_derive: \<open>\<top> \<turnstile> p \<Longrightarrow> \<top> \<turnstile> \<circle>p\<close>
  assumes globally_induction: \<open>\<And>a b. a \<turnstile> b \<Longrightarrow> a \<turnstile> \<circle>a \<Longrightarrow> a \<turnstile> \<box>b\<close>

  assumes weakuntil_finally: \<open>\<top> \<turnstile> \<box>p \<rightarrow> p \<W> q\<close>
  assumes weakuntil_unfolding: \<open>p \<W> q = q \<squnion> (p \<sqinter> \<circle>(p \<W> q))\<close>
begin

lemma next_distrib_backwards: \<open>\<top> \<turnstile> (\<circle>p \<rightarrow> \<circle>q) \<rightarrow> \<circle>(p \<rightarrow> q)\<close>
proof -
  have A0: \<open>\<top> \<turnstile> \<circle>(-(p \<rightarrow> q) \<rightarrow> p)\<close>
    by (simp add: next_derive sup.assoc sup.left_commute)

  have \<open>\<top> \<turnstile> -(\<circle>(p \<rightarrow> q)) \<rightarrow> \<circle>p\<close>
    by (metis A0 internalise_le kripke_x top_le x_selfdual)
  moreover have \<open>\<top> \<turnstile> -(\<circle>(p \<rightarrow> q)) \<rightarrow> -(\<circle>q)\<close>
    by (metis A0 abel_semigroup.commute compl_top_eq double_compl internalise_le kripke_x
        sup.abel_semigroup_axioms sup_bot.left_neutral sup_ge2)
  ultimately show ?thesis
    by (metis bool_impl_galois compl_le_compl_iff compl_le_swap2 inf_top_left
        sup_least)
qed

lemma weakuntil_induction: \<open>p \<turnstile> r \<squnion> (q \<sqinter> \<circle>p) \<Longrightarrow> p \<turnstile> q \<W> r\<close>
  oops

end

subsection \<open> Model Soundness \<close>

lemma add_one_step_induction:
  fixes n :: nat
  shows \<open>\<forall>i. P (n + i) \<longrightarrow> P (Suc (n + i)) \<Longrightarrow> P (n + i) \<Longrightarrow> P (n + i + j)\<close>
  by (induct j) (simp add: add.assoc)+

lemma model_helper_weakuntil_unfolding:
  fixes n :: nat
  shows \<open>((\<exists>j. Q (n + j) \<and> (\<forall>i<j. P (n + i))) \<or> (\<forall>i. P (n + i))) =
          (Q n \<or> P n \<and> ((\<exists>j. Q (Suc (n + j)) \<and> (\<forall>i<j. P (Suc (n + i)))) \<or> (\<forall>i. P (Suc (n + i)))))\<close>
proof -
  have \<open>((\<exists>j. Q (n + j) \<and> (\<forall>i<j. P (n + i))) \<or> (\<forall>i. P (n + i)))
        = ((\<exists>j. Q (n + j) \<and> (\<forall>i<j. P (n + i))) \<or> P n \<and> (\<forall>i. P (Suc (n + i))))\<close>
    by (metis All_add_Suc2)
  also have \<open>... = (Q n \<or> (\<exists>i. Q (Suc (n + i)) \<and> P n \<and> (\<forall>ia<i. P (Suc (n + ia)))) \<or> P n \<and> (\<forall>i. P (Suc (n + i))))\<close>
    by (subst Ex_Suc2, simp add: All_less_Suc2)
  finally show ?thesis
    by blast
qed

interpretation ltl_algebra_eq
  \<open>\<lambda>p q :: 'a \<Rightarrow> nat \<Rightarrow> bool. \<lambda>s n. p s n - q s n\<close>
  \<open>\<lambda>p. \<lambda>s n. - p s n\<close>
  \<open>\<lambda>p q. \<lambda>s n. p s n \<and> q s n\<close>
  \<open>\<lambda>p q. \<forall>s n. p s n \<turnstile> q s n\<close>
  \<open>\<lambda>x y. ((\<forall>s n. x s n \<turnstile> y s n) \<and> \<not> (\<forall>s n. y s n \<turnstile> x s n))\<close>
  \<open>\<lambda>p q. \<lambda>s n. p s n \<or> q s n\<close>
  \<open>\<lambda>s n. False\<close>
  \<open>\<lambda>s n. True\<close>
  \<open>\<lambda>p. \<lambda>s n. p s (n+1)\<close>
  \<open>\<lambda>p q. \<lambda>s n. (\<exists>j. q s (n+j) \<and> (\<forall>i<j. p s (n+i)))\<close>
  \<open>\<lambda>p q. \<lambda>s n. (\<exists>j. q s (n+j) \<and> (\<forall>i<j. p s (n+i))) \<or> (\<forall>i. p s (n+i))\<close>
  \<open>\<lambda>p. \<lambda>s n. \<forall>i. p s (n+i)\<close>
  \<open>\<lambda>p. \<lambda>s n. \<exists>i. p s (n+i)\<close>
  apply (unfold_locales)
                      apply force+
         apply (metis add.right_neutral)
        apply force
       apply force
      apply force
     apply (metis Suc_eq_plus1 add_Suc_right)
    apply (force simp add: add_one_step_induction)
   apply (simp add: model_helper_weakuntil_unfolding)
  apply force
  done

end


(*  Title:      HOL/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports Main
begin

text \<open>
  Curiously, combinators do not include free variables.

  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

datatype comb = K
              | S
              | Ap comb comb (infixl "\<bullet>" 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

inductive_set contract :: "(comb*comb) set"
  and contract_rel1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sup>1" 50)
where
  "x \<rightarrow>\<^sup>1 y == (x,y) \<in> contract"
| K:     "K\<bullet>x\<bullet>y \<rightarrow>\<^sup>1 x"
| S:     "S\<bullet>x\<bullet>y\<bullet>z \<rightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
| Ap1:   "x\<rightarrow>\<^sup>1y \<Longrightarrow> x\<bullet>z \<rightarrow>\<^sup>1 y\<bullet>z"
| Ap2:   "x\<rightarrow>\<^sup>1y \<Longrightarrow> z\<bullet>x \<rightarrow>\<^sup>1 z\<bullet>y"

abbreviation
  contract_rel :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<rightarrow>" 50) where
  "x \<rightarrow> y == (x,y) \<in> contract\<^sup>*"

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

inductive_set parcontract :: "(comb*comb) set"
  and parcontract_rel1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<Rrightarrow>\<^sup>1" 50)
where
  "x \<Rrightarrow>\<^sup>1 y == (x,y) \<in> parcontract"
| refl:  "x \<Rrightarrow>\<^sup>1 x"
| K:     "K\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 x"
| S:     "S\<bullet>x\<bullet>y\<bullet>z \<Rrightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
| Ap:    "[| x\<Rrightarrow>\<^sup>1y;  z\<Rrightarrow>\<^sup>1w |] ==> x\<bullet>z \<Rrightarrow>\<^sup>1 y\<bullet>w"

abbreviation
  parcontract_rel :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<Rrightarrow>" 50) where
  "x \<Rrightarrow> y == (x,y) \<in> parcontract\<^sup>*"

text \<open>
  Misc definitions.
\<close>

definition
  I :: comb where
  "I = S\<bullet>K\<bullet>K"

definition
  diamond   :: "('a * 'a)set \<Rightarrow> bool" where
    \<comment>\<open>confluence; Lambda/Commutation treats this more abstractly\<close>
  "diamond(r) = (\<forall>x y. (x,y) \<in> r -->
                  (\<forall>y'. (x,y') \<in> r -->
                    (\<exists>z. (y,z) \<in> r & (y',z) \<in> r)))"

subsection \<open>Reflexive/Transitive closure preserves Church-Rosser property\<close>

text\<open>So does the Transitive closure, with a similar proof\<close>

text\<open>Strip lemma.
   The induction hypothesis covers all but the last diamond of the strip.\<close>
lemma diamond_strip_lemmaE [rule_format]:
    "[| diamond(r);  (x,y) \<in> r\<^sup>* |] ==>
          \<forall>y'. (x,y') \<in> r --> (\<exists>z. (y',z) \<in> r\<^sup>* & (y,z) \<in> r)"
apply (unfold diamond_def)
apply (erule rtrancl_induct)
apply (meson rtrancl_refl)
apply (meson rtrancl_trans r_into_rtrancl)
done

lemma diamond_rtrancl: "diamond(r) \<Longrightarrow> diamond(r\<^sup>*)"
apply (simp (no_asm_simp) add: diamond_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule rtrancl_induct, blast)
apply (meson rtrancl_trans r_into_rtrancl diamond_strip_lemmaE)
done

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
      K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

declare contract.K [intro!] contract.S [intro!]
declare contract.Ap1 [intro] contract.Ap2 [intro]

lemma I_contract_E [elim!]: "I \<rightarrow>\<^sup>1 z \<Longrightarrow> P"
by (unfold I_def, blast)

lemma K1_contractD [elim!]: "K\<bullet>x \<rightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' & x \<rightarrow>\<^sup>1 x')"
by blast

lemma Ap_reduce1 [intro]: "x \<rightarrow> y \<Longrightarrow> x\<bullet>z \<rightarrow> y\<bullet>z"
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_trans)+
done

lemma Ap_reduce2 [intro]: "x \<rightarrow> y \<Longrightarrow> z\<bullet>x \<rightarrow> z\<bullet>y"
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_trans)+
done

text \<open>Counterexample to the diamond property for @{term "x \<rightarrow>\<^sup>1 y"}\<close>

lemma not_diamond_contract: "~ diamond(contract)"
by (unfold diamond_def, metis S_contractE contract.K)

subsection \<open>Results about Parallel Contraction\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract.intros [intro]

(*** Basic properties of parallel contraction ***)

subsection \<open>Basic properties of parallel contraction\<close>

lemma K1_parcontractD [dest!]: "K\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' & x \<Rrightarrow>\<^sup>1 x')"
by blast

lemma S1_parcontractD [dest!]: "S\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = S\<bullet>x' & x \<Rrightarrow>\<^sup>1 x')"
by blast

lemma S2_parcontractD [dest!]:
     "S\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x' y'. z = S\<bullet>x'\<bullet>y' & x \<Rrightarrow>\<^sup>1 x' & y \<Rrightarrow>\<^sup>1 y')"
by blast

text\<open>The rules above are not essential but make proofs much faster\<close>

text\<open>Church-Rosser property for parallel contraction\<close>
lemma diamond_parcontract: "diamond parcontract"
apply (unfold diamond_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule parcontract.induct, fast+)
done

text \<open>
  \<^medskip>
  Equivalence of @{prop "p \<rightarrow> q"} and @{prop "p \<Rrightarrow> q"}.
\<close>

lemma contract_subset_parcontract: "contract \<subseteq> parcontract"
by (auto, erule contract.induct, blast+)

text\<open>Reductions: simply throw together reflexivity, transitivity and
  the one-step reductions\<close>

declare r_into_rtrancl [intro]  rtrancl_trans [intro]

(*Example only: not used*)
lemma reduce_I: "I\<bullet>x \<rightarrow> x"
by (unfold I_def, blast)

lemma parcontract_subset_reduce: "parcontract \<subseteq> contract\<^sup>*"
by (auto, erule parcontract.induct, blast+)

lemma reduce_eq_parreduce: "contract\<^sup>* = parcontract\<^sup>*"
by (metis contract_subset_parcontract parcontract_subset_reduce rtrancl_subset)

theorem diamond_reduce: "diamond(contract\<^sup>*)"
by (simp add: reduce_eq_parreduce diamond_rtrancl diamond_parcontract)

end


(*
  File:    Pseudo_Remainder_Sequence.thy
  Author:  Wenda Li
*)

section \<open>An implementation for calculating pseudo remainder sequences\<close>

theory Pseudo_Remainder_Sequence
  imports Sturm_Tarski
    "HOL-Computational_Algebra.Computational_Algebra"

    (*TODO: we should consider to move this to the standard library*)
    "Polynomial_Interpolation.Ring_Hom_Poly"
begin

subsection \<open>Misc\<close>

function spmods :: "'a::idom poly \<Rightarrow> 'a poly \<Rightarrow> ('a poly) list" where
  "spmods p q= (if p=0 then [] else
      let
        m=(if even(degree p+1-degree q) then -1 else -lead_coeff q)
      in
        Cons p (spmods q (smult m (pseudo_mod p q))))"
by auto
termination
 apply (relation "measure (\<lambda>(p,q).if p=0 then 0 else if q=0 then 1 else 2+degree q)")
 by (simp_all add: degree_pseudo_mod_less)

declare spmods.simps[simp del]

lemma spmods_0[simp]:
  "spmods 0 q = []"
  "spmods p 0 = (if p=0 then [] else [p])"
by (auto simp:spmods.simps)

lemma spmods_nil_eq:"spmods p q = [] \<longleftrightarrow> (p=0)"
  by (metis list.distinct(1) spmods.elims)

lemma changes_poly_at_alternative:
  "changes_poly_at ps a= changes (map (\<lambda>p. sign(poly p a)) ps)"
  "changes_poly_at ps a= changes (map (\<lambda>p. sgn(poly p a)) ps)"
  unfolding changes_poly_at_def
  subgoal by (subst changes_map_sign_eq) (auto simp add:comp_def)
  subgoal by (subst changes_map_sgn_eq) (auto simp add:comp_def)
  done

lemma smods_smult_length:
  assumes "a\<noteq>0" "b\<noteq>0"
  shows "length (smods p q) = length (smods (smult a p) (smult b q))" using assms
proof (induct "smods p q"  arbitrary:p q a b )
  case Nil
  thus ?case by (simp split:if_splits)
next
  case (Cons x xs)
  hence "p\<noteq>0" by auto
  define r where "r\<equiv>- (p mod q)"
  have "smods q r = xs" using Cons.hyps(2) `p\<noteq>0` unfolding r_def by auto
  hence "length (smods q r) = length (smods (smult b q) (smult a r))"
    using Cons.hyps(1)[of q r b a] Cons by auto
  moreover have "smult a p\<noteq>0" using `a\<noteq>0` `p\<noteq>0` by auto
  moreover have "-((smult a p) mod (smult b q)) = (smult a r)"
    by (simp add: Cons.prems(2) mod_smult_left mod_smult_right r_def)
  ultimately show ?case
    unfolding r_def by auto
qed

lemma smods_smult_nth[rule_format]:
  fixes p q::"real poly"
  assumes "a\<noteq>0" "b\<noteq>0"
  defines "xs\<equiv>smods p q" and "ys\<equiv>smods (smult a p) (smult b q)"
  shows "\<forall>n<length xs. ys!n = (if even n then smult a (xs!n)  else smult b (xs!n))" using assms
proof (induct "smods p q"  arbitrary:p q a b xs ys)
  case Nil
  thus ?case by (simp split:if_splits)
next
  case (Cons x xs)
  hence "p\<noteq>0" by auto
  define r where "r\<equiv>- (p mod q)"
  have xs:"xs=smods q r" "p#xs=smods p q" using Cons.hyps(2) `p\<noteq>0` unfolding r_def by auto
  define ys where "ys\<equiv>smods (smult b q) (smult a r)"
  have "- ((smult a p) mod (smult b q)) = smult a r"
    by (simp add: Cons.hyps(4) mod_smult_left mod_smult_right r_def)
  hence ys:"smult a p # ys = smods (smult a p) (smult b q)" using `p\<noteq>0` `a\<noteq>0`
    unfolding ys_def r_def by auto
  have hyps:"\<And>n. n<length xs \<Longrightarrow> ys ! n = (if even n then smult b (xs ! n) else smult a (xs ! n))"
    using Cons.hyps(1)[of q r b a,folded xs ys_def] `a\<noteq>0` `b\<noteq>0` by auto
  thus ?case
    apply (fold xs ys)
    apply auto
    by (case_tac n,auto)+
qed

lemma smods_smult_sgn_map_eq:
  fixes x::real
  assumes "m>0"
  defines "f\<equiv>\<lambda>p. sgn(poly p x)"
  shows "map f (smods p (smult m q)) = map f (smods p q)"
        "map sgn_pos_inf (smods p (smult m q)) = map sgn_pos_inf (smods p q)"
        "map sgn_neg_inf (smods p (smult m q)) = map sgn_neg_inf (smods p q)"
proof -
  define xs ys where "xs\<equiv>smods p q" and "ys\<equiv>smods p (smult m q)"
  have "m\<noteq>0" using `m>0` by simp
  have len_eq:"length xs =length ys"
    using smods_smult_length[of 1 m] `m>0` unfolding xs_def ys_def by auto
  moreover have
    "(map f xs) ! i = (map f ys) ! i"
    "(map sgn_pos_inf xs) ! i = (map sgn_pos_inf ys) ! i"
    "(map sgn_neg_inf xs) ! i = (map sgn_neg_inf ys) ! i"
     when "i<length xs" for i
  proof -
    note nth_eq=smods_smult_nth[OF one_neq_zero `m\<noteq>0`,of _ p q,unfolded smult_1_left,
        folded xs_def ys_def,OF `i<length xs` ]
    then show "map f xs ! i = map f ys ! i"
          "(map sgn_pos_inf xs) ! i = (map sgn_pos_inf ys) ! i"
          "(map sgn_neg_inf xs) ! i = (map sgn_neg_inf ys) ! i"
      using that
      unfolding f_def using len_eq `m>0`
      by (auto simp add:sgn_mult sgn_pos_inf_def sgn_neg_inf_def lead_coeff_smult)
  qed
  ultimately show "map f (smods p (smult m q)) = map f (smods p q)"
    "map sgn_pos_inf (smods p (smult m q)) = map sgn_pos_inf (smods p q)"
    "map sgn_neg_inf (smods p (smult m q)) = map sgn_neg_inf (smods p q)"
    apply (fold xs_def ys_def)
    by (auto intro: nth_equalityI)
qed

lemma changes_poly_at_smods_smult:
  assumes "m>0"
  shows "changes_poly_at (smods p (smult m q)) x =changes_poly_at (smods p q) x "
  using smods_smult_sgn_map_eq[OF `m>0`]
  by (metis changes_poly_at_alternative(2))

lemma spmods_smods_sgn_map_eq:
  fixes p q::"real poly" and x::real
  defines "f\<equiv>\<lambda>p. sgn (poly p x)"
  shows "map f (smods p q) = map f (spmods p q)"
        "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
        "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
proof (induct "spmods p q" arbitrary:p q)
  case Nil
  hence "p=0" using spmods_nil_eq by metis
  thus "map f (smods p q) = map f (spmods p q)"
       "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
       "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
    by auto
next
  case (Cons p' xs)
  hence "p\<noteq>0" by auto
  define r where "r\<equiv>- (p mod q)"
  define exp where " exp\<equiv>degree p +1 - degree q"
  define m where "m\<equiv>(if even exp then 1 else lead_coeff q)
      * (lead_coeff q ^ exp)"
  have xs1:"p#xs=spmods p q"
    by (metis (no_types) Cons.hyps(4) list.distinct(1) list.inject  spmods.simps)
  have xs2:"xs=spmods q (smult m r)" when "q\<noteq>0"
  proof -
    define m' where  "m'\<equiv>if even exp then - 1 else - lead_coeff q"
    have "smult m' (pseudo_mod p q) = smult m r"
      unfolding m_def m'_def r_def
      apply (subst pseudo_mod_mod[symmetric])
      using that exp_def by auto
    thus ?thesis using `p\<noteq>0` xs1 unfolding r_def
      by (simp add:spmods.simps[of p q,folded exp_def, folded m'_def] del:spmods.simps)
  qed
  define ys where "ys\<equiv>smods q r"
  have ys:"p#ys=smods p q" using `p\<noteq>0` unfolding ys_def r_def by auto
  have qm:"q\<noteq>0 \<Longrightarrow> m>0"
    using `p\<noteq>0` unfolding m_def
    apply auto
    subgoal by (simp add: zero_less_power_eq)
    subgoal using zero_less_power_eq by fastforce
    done
  show "map f (smods p q) = map f (spmods p q)"
  proof (cases "q\<noteq>0")
    case True
    then have "map f (spmods q (smult m r)) = map f (smods q r)"
      using smods_smult_sgn_map_eq(1)[of m x q r,folded f_def] qm
        Cons.hyps(1)[OF xs2,folded f_def]
      by simp
    thus ?thesis
      apply (fold xs1 xs2[OF True] ys ys_def)
      by auto
  next
    case False
    thus ?thesis by auto
  qed
  show "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
  proof (cases "q\<noteq>0")
    case True
    then have "map sgn_pos_inf (spmods q (smult m r)) = map sgn_pos_inf (smods q r)"
      using Cons.hyps(2)[OF xs2,folded f_def] qm[OF True]
        smods_smult_sgn_map_eq(2)[of m  q r,folded f_def] by auto
    thus ?thesis
      apply (fold xs1 xs2[OF True] ys ys_def)
      by (simp add:f_def)
  next
    case False
    thus ?thesis by auto
  qed
  show "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
  proof (cases "q\<noteq>0")
    case True
    then have "map sgn_neg_inf (spmods q (smult m r)) = map sgn_neg_inf (smods q r)"
      using Cons.hyps(3)[OF xs2,folded f_def] qm[OF True]
        smods_smult_sgn_map_eq(3)[of m  q r,folded f_def] by auto
    thus ?thesis
      apply (fold xs1 xs2[OF True] ys ys_def)
      by (simp add:f_def)
  next
    case False
    thus ?thesis by auto
  qed
qed

subsection \<open>Converting @{typ "rat poly"} to @{typ "int poly"} by clearing the denominators\<close>

definition int_of_rat::"rat \<Rightarrow> int" where
  "int_of_rat = inv of_int"

lemma of_rat_inj[simp]: "inj of_rat"
by (simp add: linorder_injI)

lemma (in ring_char_0) of_int_inj[simp]: "inj of_int"
  by (simp add: inj_on_def)

lemma int_of_rat_id: "int_of_rat o of_int = id"
  unfolding int_of_rat_def
  by auto

lemma int_of_rat_0[simp]:"int_of_rat 0 = 0"
  by (metis id_apply int_of_rat_id o_def of_int_0)

lemma int_of_rat_inv:"r\<in>\<int> \<Longrightarrow> of_int (int_of_rat r) = r"
unfolding int_of_rat_def
by (simp add: Ints_def f_inv_into_f)

lemma int_of_rat_0_iff:"x\<in>\<int> \<Longrightarrow> int_of_rat x = 0 \<longleftrightarrow> x = 0"
using int_of_rat_inv by force

definition de_lcm::"rat poly \<Rightarrow> int" where
  "de_lcm p = Lcm(set(map (\<lambda>x. snd (quotient_of x)) (coeffs p)))"

lemma de_lcm_pCons:"de_lcm (pCons a p) = lcm (snd (quotient_of a)) (de_lcm p)"
  unfolding de_lcm_def
  by (cases "a=0\<and>p=0",auto)

lemma de_lcm_0[simp]:"de_lcm 0 = 1" unfolding de_lcm_def by auto

lemma de_lcm_pos[simp]:"de_lcm p > 0"
  apply (induct p)
  apply (auto simp add:de_lcm_pCons)
  by (metis lcm_pos_int less_numeral_extra(3) quotient_of_denom_pos')+

lemma de_lcm_ints:
  fixes x::rat
  shows "x\<in>set (coeffs p) \<Longrightarrow> rat_of_int (de_lcm p) * x \<in> \<int>"
proof (induct p)
  case 0
  then show ?case by auto
next
  case (pCons a p)
  define a1 a2 where "a1\<equiv>fst (quotient_of a)" and "a2\<equiv>snd (quotient_of a)"
  have a:"a=(rat_of_int a1)/(rat_of_int a2)" and "a2>0"
    using quotient_of_denom_pos'[of a] unfolding a1_def a2_def
    by (auto simp add: quotient_of_div)
  define mp1 where "mp1\<equiv>a2 div gcd (de_lcm p) a2"
  define mp2 where "mp2\<equiv>de_lcm p div gcd a2 (de_lcm p) "
  have lcm_times1:"lcm a2 (de_lcm p) = de_lcm p * mp1"
    using lcm_altdef_int[of "de_lcm p" a2,folded mp1_def] `a2>0`
    unfolding mp1_def
    apply (subst div_mult_swap)
    by (auto simp add: abs_of_pos gcd.commute lcm_altdef_int mult.commute)
  have lcm_times2:"lcm a2 (de_lcm p) = a2 * mp2"
    using lcm_altdef_int[of a2 "de_lcm p",folded mp1_def] `a2>0`
    unfolding mp2_def by (subst div_mult_swap, auto simp add:abs_of_pos)
  show ?case
  proof (cases "x \<in> set (coeffs p)")
    case True
    show ?thesis using pCons(2)[OF True]
      by (smt Ints_mult Ints_of_int a2_def de_lcm_pCons lcm_times1
            mult.assoc mult.commute of_int_mult)
  next
    case False
    then have "x=a"
      using pCons cCons_not_0_eq coeffs_pCons_eq_cCons insert_iff list.set(2) not_0_cCons_eq
      by fastforce
    show ?thesis unfolding `x=a` de_lcm_pCons
      apply (fold a2_def,unfold a)
      by (simp add: de_lcm_pCons lcm_times2 of_rat_divide)
  qed
qed

definition clear_de::"rat poly \<Rightarrow> int poly" where
  "clear_de p = (SOME q. (map_poly of_int q) = smult (of_int (de_lcm p)) p)"

lemma clear_de:"of_int_poly(clear_de p) = smult (of_int (de_lcm p)) p"
proof -
  have "\<exists>q. (of_int_poly q) = smult (of_int (de_lcm p)) p"
  proof (induct p)
    case 0
    show ?case by (metis map_poly_0 smult_0_right)
  next
    case (pCons a p)
    then obtain q1::"int poly" where q1:"of_int_poly q1 = smult (rat_of_int (de_lcm p)) p"
      by auto
    define a1 a2 where "a1\<equiv>fst (quotient_of a)" and "a2\<equiv>snd (quotient_of a)"
    have a:"a=(rat_of_int a1)/ (rat_of_int a2)" and "a2>0"
        using quotient_of_denom_pos' quotient_of_div
        unfolding a1_def a2_def by auto
    define mp1 where "mp1\<equiv>a2 div gcd (de_lcm p) a2"
    define mp2 where "mp2\<equiv>de_lcm p div gcd a2 (de_lcm p) "
    have lcm_times1:"lcm a2 (de_lcm p) = de_lcm p * mp1"
      using lcm_altdef_int[of "de_lcm p" a2,folded mp1_def] `a2>0`
      unfolding mp1_def
      by (subst div_mult_swap, auto simp add: abs_of_pos gcd.commute lcm_altdef_int mult.commute)
    have lcm_times2:"lcm a2 (de_lcm p) = a2 * mp2"
      using lcm_altdef_int[of a2 "de_lcm p",folded mp1_def] `a2>0`
      unfolding mp2_def by (subst div_mult_swap, auto simp add:abs_of_pos)
    define q2 where "q2\<equiv>pCons (mp2 * a1) (smult mp1 q1)"
    have "of_int_poly q2 = smult (rat_of_int (de_lcm (pCons a p))) (pCons a p)" using `a2>0`
      apply (simp add:de_lcm_pCons )
      apply (fold a2_def)
      apply (unfold a)
      apply (subst lcm_times2,subst lcm_times1)
      by (simp add: Polynomial.map_poly_pCons mult.commute of_int_hom.map_poly_hom_smult q1 q2_def)
    then show ?case by auto
  qed
  then show ?thesis unfolding clear_de_def  by (meson someI_ex)
qed

lemma clear_de_0[simp]:"clear_de 0 = 0"
  using clear_de[of 0] by auto

lemma [code abstract]: "coeffs (clear_de p) =
    (let lcm = de_lcm p in map (\<lambda>x. int_of_rat (of_int lcm * x)) (coeffs p))"
proof -
  define mul where "mul\<equiv>rat_of_int (de_lcm p)"
  have "map_poly int_of_rat (of_int_poly q) = q" for q
    apply (subst map_poly_map_poly)
    by (auto simp add:int_of_rat_id)
  then have clear_eq:"clear_de p = map_poly int_of_rat (smult (of_int (de_lcm p)) p)"
    using arg_cong[where f="map_poly int_of_rat",OF clear_de]
    by auto
  show ?thesis
  proof (cases "p=0")
    case True
    then show ?thesis by auto
  next
    case False
    define g where "g\<equiv>(\<lambda>x. int_of_rat (rat_of_int (de_lcm p) * x))"
    have "de_lcm p \<noteq> 0" using de_lcm_pos by (metis less_irrefl)
    moreover have "last (coeffs p) \<noteq>0"
      by (simp add: False last_coeffs_eq_coeff_degree)
    have False when asm:"last (map g (coeffs p)) =0"
    proof -
      have "coeffs p \<noteq>[]" using False by auto
      hence "g (last (coeffs p)) = 0" using asm last_map[of "coeffs p" g] by auto
      hence "last (coeffs p) = 0"
        unfolding g_def using `coeffs p \<noteq>[]` `de_lcm p \<noteq> 0`
        apply (subst (asm) int_of_rat_0_iff)
        by (auto intro!: de_lcm_ints )
      thus False using `last (coeffs p) \<noteq>0` by simp
    qed
    ultimately show ?thesis
      apply (auto simp add: coeffs_smult clear_eq comp_def smult_conv_map_poly map_poly_map_poly coeffs_map_poly)
      apply (fold g_def)
      by (metis False Ring_Hom_Poly.coeffs_map_poly coeffs_eq_Nil last_coeffs_eq_coeff_degree
          last_map)
    qed
qed

subsection \<open>Sign variations for pseudo-remainder sequences\<close>

locale order_hom =
  fixes hom :: "'a :: ord \<Rightarrow> 'b :: ord"
  assumes hom_less: "x < y \<longleftrightarrow> hom x < hom y"
   and hom_less_eq: "x \<le> y \<longleftrightarrow> hom x \<le> hom y"

locale linordered_idom_hom = order_hom hom + inj_idom_hom hom
  for hom :: "'a :: linordered_idom \<Rightarrow> 'b :: linordered_idom"
begin

lemma sgn_sign:"sgn (hom x) = of_int (sign x)"
  by (simp add: sign_def hom_less sgn_if)

end

locale hom_pseudo_smods= comm_semiring_hom hom
    + r1:linordered_idom_hom R\<^sub>1 + r2:linordered_idom_hom R\<^sub>2
  for hom::"'a::linordered_idom \<Rightarrow> 'b::{comm_semiring_1,linordered_idom}"
    and R\<^sub>1::"'a \<Rightarrow> real"
    and R\<^sub>2::"'b \<Rightarrow> real" +
  assumes R_hom:"R\<^sub>1 x = R\<^sub>2 (hom x)"
begin

(*
  hom    R2

'a \<rightarrow> 'b \<rightarrow> real
      rat/float
int
p
      x
*)

lemma map_poly_R_hom_commute:
  "poly (map_poly R\<^sub>1 p) (R\<^sub>2 x) = R\<^sub>2 (poly (map_poly hom p) x)"
apply (induct p)
using r2.hom_add r2.hom_mult R_hom by auto

definition changes_hpoly_at::"'a poly list \<Rightarrow> 'b \<Rightarrow> int" where
  "changes_hpoly_at ps a= changes (map (\<lambda>p. eval_poly hom p a) ps)"

lemma changes_hpoly_at_Nil[simp]: "changes_hpoly_at [] a = 0"
  unfolding changes_hpoly_at_def by simp

definition changes_itv_spmods:: "'b \<Rightarrow> 'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
  "changes_itv_spmods a b p q= (let ps = spmods p q in
        changes_hpoly_at ps a - changes_hpoly_at ps b)"

definition changes_gt_spmods:: "'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
  "changes_gt_spmods a p q= (let ps = spmods p q in
        changes_hpoly_at ps a - changes_poly_pos_inf ps)"

definition changes_le_spmods:: "'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
  "changes_le_spmods b p q= (let ps = spmods p q in
        changes_poly_neg_inf ps - changes_hpoly_at ps b)"

definition changes_R_spmods:: "'a poly \<Rightarrow> 'a poly \<Rightarrow>  int" where
  "changes_R_spmods p q= (let ps= spmods p q in changes_poly_neg_inf ps
      - changes_poly_pos_inf ps)"

lemma changes_spmods_smods:
  shows "changes_itv_spmods a b p q
    = changes_itv_smods (R\<^sub>2 a) (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
  and "changes_R_spmods p q = changes_R_smods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
  and "changes_gt_spmods a p q = changes_gt_smods (R\<^sub>2 a) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
  and "changes_le_spmods b p q = changes_le_smods (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
proof -
  define pp qq where "pp = map_poly R\<^sub>1 p" and "qq = map_poly R\<^sub>1 q"

  have spmods_eq:"spmods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q) = map (map_poly R\<^sub>1) (spmods p q)"
  proof (induct "spmods p q" arbitrary:p q )
    case Nil
    thus ?case by (metis list.simps(8) map_poly_0 spmods_nil_eq)
  next
    case (Cons p' xs)
    hence "p\<noteq>0" by auto
    define m where "m\<equiv>(if even (degree p + 1 - degree q) then - 1 else - lead_coeff q)"
    define r where "r\<equiv>smult m (pseudo_mod p q)"
    have xs1:"p#xs=spmods p q"
      by (metis (no_types) Cons.hyps(2) list.distinct(1) list.inject  spmods.simps)
    have xs2:"xs=spmods q r" using xs1 \<open>p\<noteq>0\<close> r_def
      by (auto simp add:spmods.simps[of p q,folded exp_def,folded m_def])
    define ys where "ys\<equiv>spmods (map_poly R\<^sub>1 q) (map_poly R\<^sub>1 r)"
    have ys:"(map_poly R\<^sub>1 p)#ys=spmods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
      using \<open>p\<noteq>0\<close> unfolding ys_def r_def
      apply (subst (2) spmods.simps)
      unfolding m_def by (auto simp:r1.pseudo_mod_hom hom_distribs)
    show ?case using Cons.hyps(1)[OF xs2]
      apply (fold xs1 xs2 ys ys_def)
      by auto
  qed

  have changes_eq_at:"changes_poly_at (smods pp qq) (R\<^sub>2 x) = changes_hpoly_at (spmods p q) x"
    (is "?L=?R")
    for x
  proof -
    define ff where "ff = (\<lambda>p. sgn (poly p (R\<^sub>2 x)))"
    have "?L = changes (map ff (smods pp qq))"
      using changes_poly_at_alternative unfolding ff_def by blast
    also have "... = changes (map ff (spmods pp qq))"
      unfolding ff_def using spmods_smods_sgn_map_eq by simp
    also have "... = changes (map ff (map (map_poly R\<^sub>1) (spmods p q)))"
      unfolding pp_def qq_def using spmods_eq by simp
    also have "... = ?R"
    proof -
      have "ff \<circ> map_poly R\<^sub>1 = sign \<circ> (\<lambda>p. eval_poly hom p x)"
        unfolding ff_def comp_def
        by (simp add: map_poly_R_hom_commute poly_map_poly_eval_poly  r2.sgn_sign)
      then show ?thesis
        unfolding changes_hpoly_at_def
        apply (subst (2) changes_map_sign_of_int_eq)
        by (simp add:comp_def)
    qed
    finally show ?thesis .
  qed

  have changes_eq_neg_inf:
    "changes_poly_neg_inf (smods pp qq) = changes_poly_neg_inf (spmods p q)"
    (is "?L=?R")
  proof -
    have "?L = changes (map sgn_neg_inf (map (map_poly R\<^sub>1) (spmods p q)))"
      unfolding changes_poly_neg_inf_def spmods_smods_sgn_map_eq
      by (simp add: spmods_eq[folded pp_def qq_def])
    also have "... = changes (map (sgn_neg_inf \<circ> (map_poly R\<^sub>1)) (spmods p q))"
      using map_map by simp
    also have "... = changes (map ((sign:: _ \<Rightarrow> real) \<circ> sgn_neg_inf) (spmods p q))"
    proof -
      have "(sgn_neg_inf \<circ> (map_poly R\<^sub>1)) = of_int o sign \<circ> sgn_neg_inf"
        unfolding sgn_neg_inf_def comp_def
        by (auto simp:r1.sgn_sign)
      then show ?thesis by (simp add:comp_def)
    qed
    also have "... = changes (map sgn_neg_inf (spmods p q))"
      apply (subst (2) changes_map_sign_of_int_eq)
      by (simp add:comp_def)
    also have "... = ?R"
      unfolding changes_poly_neg_inf_def by simp
    finally show ?thesis .
  qed

  have changes_eq_pos_inf:
    "changes_poly_pos_inf (smods pp qq) = changes_poly_pos_inf (spmods p q)"
    (is "?L=?R")
  proof -
    have "?L = changes (map sgn_pos_inf (map (map_poly R\<^sub>1) (spmods p q)))"
      unfolding changes_poly_pos_inf_def spmods_smods_sgn_map_eq
      by (simp add: spmods_eq[folded pp_def qq_def])
    also have "... = changes (map (sgn_pos_inf \<circ> (map_poly R\<^sub>1)) (spmods p q))"
      using map_map by simp
    also have "... = changes (map ((sign:: _ \<Rightarrow> real) \<circ> sgn_pos_inf) (spmods p q))"
    proof -
      have "(sgn_pos_inf \<circ> (map_poly R\<^sub>1)) = of_int o sign \<circ> sgn_pos_inf"
        unfolding sgn_pos_inf_def comp_def
        by (auto simp:r1.sgn_sign)
      then show ?thesis by (auto simp:comp_def)
    qed
    also have "... = changes (map sgn_pos_inf (spmods p q))"
      apply (subst (2) changes_map_sign_of_int_eq)
      by (simp add:comp_def)
    also have "... = ?R"
      unfolding changes_poly_pos_inf_def by simp
    finally show ?thesis .
  qed

  show "changes_itv_spmods a b p q
          = changes_itv_smods (R\<^sub>2 a) (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_itv_spmods_def changes_itv_smods_def
    using changes_eq_at by (simp add: Let_def pp_def qq_def)
  show "changes_R_spmods p q = changes_R_smods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_R_spmods_def changes_R_smods_def Let_def
    using changes_eq_neg_inf changes_eq_pos_inf
    by (simp add: pp_def qq_def)
  show "changes_gt_spmods a p q = changes_gt_smods
                (R\<^sub>2 a) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_gt_spmods_def changes_gt_smods_def Let_def
    using changes_eq_at changes_eq_pos_inf
    by (simp add: pp_def qq_def)
  show "changes_le_spmods b p q = changes_le_smods
                (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_le_spmods_def changes_le_smods_def Let_def
    using changes_eq_at changes_eq_neg_inf
    by (simp add: pp_def qq_def)
qed

end

end


theory Lists
  imports Permutation
begin

no_notation Set.image (infixr "`" 90)
  and times (infixr ";" 60)

(* Swap in lists preserve permutation *)
lemma id_take_n_1_nth_drop: "\<lbrakk>0 < j; j < length A\<rbrakk> \<Longrightarrow> A = take (j - 1) A @ A ! (j - 1) # A ! j # drop (j + 1) A"
  apply (subgoal_tac "A ! (j - 1) # A ! j # drop (j + 1) A = drop (j - 1) A")
  apply simp
proof -
  assume a1: "j < length A"
  assume a2: "0 < j"
  have "Suc j = j + 1"
    by presburger
  thus "A ! (j - 1) # A ! j # drop (j + 1) A = drop (j - 1) A"
    using a2 a1 by (metis (no_types) Cons_nth_drop_Suc Suc_diff_1 less_eq_Suc_le less_le_not_le)
qed

lemma take_swap: "j < length A \<Longrightarrow> take (j - 1) (A [j := A ! (j - 1), j - 1 := A ! j]) = take (j - 1) A"
by auto

lemma drop_swap: "0 < j \<Longrightarrow> drop (j + 1) (A [j := A ! (j - 1), j - 1 := A ! j]) = drop (j + 1) A"
by simp

lemma perm_swap_list: "\<lbrakk>0 < j; j < length A\<rbrakk> \<Longrightarrow> A [j := A ! (j - 1), j - 1 := A ! j] <~~> A"
proof -
  let ?A' = "(A [j := A ! (j - 1), j - 1 := A ! j])"
  assume assms: "0 < j" "j < length A"
  hence "?A' = take (j - 1) ?A' @ ?A' ! (j - 1) # ?A' ! j # drop (j + 1) ?A'"
    by (metis id_take_n_1_nth_drop length_list_update)
  also have "... = take (j - 1) A @ A ! j # A ! (j - 1) # drop (j + 1) A" using assms
    by (simp del: Nat.One_nat_def)
  finally show ?thesis
    by (metis perm_swap assms id_take_n_1_nth_drop)
qed

(* Array is sorted except in one place *)
definition sorted_but :: "('a :: ord) list \<Rightarrow> nat \<Rightarrow> bool" where
  "sorted_but A k \<equiv> \<forall>i j. i \<le> j \<and> j < length A \<and> i \<noteq> k \<and> k \<noteq> j \<longrightarrow> A ! i \<le> A ! j"

(* Sorted list lemmas *)
lemma sorted_singleton: "A \<noteq> [] \<Longrightarrow> sorted (take 1 A)"
  by simp

lemma take_sorted_equals_nth_mono: "n \<le> length A \<Longrightarrow> (\<forall>i j. i \<le> j \<and> j < n \<longrightarrow> A ! i \<le> A ! j) \<longleftrightarrow> sorted (take n A)"
  using sorted_equals_nth_mono by fastforce

lemma take_sorted_1: "\<lbrakk>sorted (take n A); n < length A; i \<le> j; j < n\<rbrakk> \<Longrightarrow> A ! i \<le> A ! j"
  using less_imp_le_nat take_sorted_equals_nth_mono by blast

lemma sorted_butI: "sorted A \<Longrightarrow> sorted_but A k"
  by (metis sorted_but_def sorted_nth_mono)

lemma take_sorted_butI: "sorted (take n A) \<Longrightarrow> sorted_but (take (Suc n) A) n"
  by (unfold sorted_equals_nth_mono sorted_but_def, auto)

lemma sorted_butE: "\<lbrakk>sorted_but A k; k + 1 < length A; A ! (k - 1) \<le> A ! k; A ! k \<le> A ! (k + 1)\<rbrakk> \<Longrightarrow> sorted A"
  apply (unfold sorted_equals_nth_mono sorted_but_def, auto)
  by (smt Suc_le_mono Suc_pred diff_le_self eq_iff leD le_0_eq le_less_Suc_eq le_less_linear le_less_trans)

lemma take_sorted_butE_0: "\<lbrakk>sorted_but (take n A) 0; A ! 0 \<le> A ! 1\<rbrakk> \<Longrightarrow> sorted (take n A)"
  by (smt One_nat_def Suc_eq_plus1 Suc_lessI length_greater_0_conv length_take min.absorb2 nat_le_linear nth_take order_refl sorted.Nil sorted_butE sorted_singleton take_all zero_diff)

lemma take_sorted_butE: "\<lbrakk>sorted_but (take n A) k; k < n; A ! (k - 1) \<le> A ! k; A ! k \<le> A ! (k + 1)\<rbrakk> \<Longrightarrow> sorted (take n A)"
  apply (unfold sorted_equals_nth_mono sorted_but_def, auto)
  by (smt Suc_pred eq_iff le_0_eq le_less_linear lessI less_eq_Suc_le less_le_trans order.strict_iff_order)

lemma take_sorted_butE_n: "\<lbrakk>sorted_but (take (Suc n) A) n; A ! (n - 1) \<le> A ! n\<rbrakk> \<Longrightarrow> sorted (take (Suc n) A)"
  apply (unfold sorted_equals_nth_mono sorted_but_def, auto)
  by (smt Suc_le_mono Suc_pred diff_le_self eq_iff leD le_0_eq le_less_Suc_eq le_less_linear le_less_trans)

end