(*  Title:      ZF/ex/Ramsey.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Ramsey's Theorem (finite exponent 2 version)

Based upon the article
    D Basin and M Kaufmann,
    The Boyer-Moore Prover and Nuprl: An Experimental Comparison.
    In G Huet and G Plotkin, editors, Logical Frameworks.
    (CUP, 1991), pages 89-119

See also
    M Kaufmann,
    An example in NQTHM: Ramsey's Theorem
    Internal Note, Computational Logic, Inc., Austin, Texas 78703
    Available from the author: kaufmann@cli.com

This function compute Ramsey numbers according to the proof given below
(which, does not constrain the base case values at all.

fun ram 0 j = 1
  | ram i 0 = 1
  | ram i j = ram (i-1) j + ram i (j-1)
*)

theory Ramsey imports Main begin

definition
  Symmetric :: "i=>o" where
    "Symmetric(E) == (\<forall>x y. <x,y>:E \<longrightarrow> <y,x>:E)"

definition
  Atleast :: "[i,i]=>o" where -- "not really necessary: ZF defines cardinality"
    "Atleast(n,S) == (\<exists>f. f \<in> inj(n,S))"

definition
  Clique  :: "[i,i,i]=>o" where
    "Clique(C,V,E) == (C \<subseteq> V) & (\<forall>x \<in> C. \<forall>y \<in> C. x\<noteq>y \<longrightarrow> <x,y> \<in> E)"

definition
  Indept  :: "[i,i,i]=>o" where
    "Indept(I,V,E) == (I \<subseteq> V) & (\<forall>x \<in> I. \<forall>y \<in> I. x\<noteq>y \<longrightarrow> <x,y> \<notin> E)"

definition
  Ramsey  :: "[i,i,i]=>o" where
    "Ramsey(n,i,j) == \<forall>V E. Symmetric(E) & Atleast(n,V) \<longrightarrow>
         (\<exists>C. Clique(C,V,E) & Atleast(i,C)) |
         (\<exists>I. Indept(I,V,E) & Atleast(j,I))"

(*** Cliques and Independent sets ***)

lemma Clique0 [intro]: "Clique(0,V,E)"
by (unfold Clique_def, blast)

lemma Clique_superset: "[| Clique(C,V',E);  V'<=V |] ==> Clique(C,V,E)"
by (unfold Clique_def, blast)

lemma Indept0 [intro]: "Indept(0,V,E)"
by (unfold Indept_def, blast)

lemma Indept_superset: "[| Indept(I,V',E);  V'<=V |] ==> Indept(I,V,E)"
by (unfold Indept_def, blast)

(*** Atleast ***)

lemma Atleast0 [intro]: "Atleast(0,A)"
by (unfold Atleast_def inj_def Pi_def function_def, blast)

lemma Atleast_succD:
    "Atleast(succ(m),A) ==> \<exists>x \<in> A. Atleast(m, A-{x})"
apply (unfold Atleast_def)
apply (blast dest: inj_is_fun [THEN apply_type] inj_succ_restrict)
done

lemma Atleast_superset:
    "[| Atleast(n,A);  A \<subseteq> B |] ==> Atleast(n,B)"
by (unfold Atleast_def, blast intro: inj_weaken_type)

lemma Atleast_succI:
    "[| Atleast(m,B);  b\<notin> B |] ==> Atleast(succ(m), cons(b,B))"
apply (unfold Atleast_def succ_def)
apply (blast intro: inj_extend elim: mem_irrefl)
done

lemma Atleast_Diff_succI:
     "[| Atleast(m, B-{x});  x \<in> B |] ==> Atleast(succ(m), B)"
by (blast intro: Atleast_succI [THEN Atleast_superset])

(*** Main Cardinality Lemma ***)

(*The #-succ(0) strengthens the original theorem statement, but precisely
  the same proof could be used!!*)
lemma pigeon2 [rule_format]:
     "m \<in> nat ==>
          \<forall>n \<in> nat. \<forall>A B. Atleast((m#+n) #- succ(0), A \<union> B) \<longrightarrow>
                           Atleast(m,A) | Atleast(n,B)"
apply (induct_tac "m")
apply (blast intro!: Atleast0, simp)
apply (rule ballI)
apply (rename_tac m' n) (*simplifier does NOT preserve bound names!*)
apply (induct_tac "n", auto)
apply (erule Atleast_succD [THEN bexE])
apply (rename_tac n' A B z)
apply (erule UnE)
(**case z \<in> B.  Instantiate the '\<forall>A B' induction hypothesis. **)
apply (drule_tac [2] x1 = A and x = "B-{z}" in spec [THEN spec])
apply (erule_tac [2] mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [3] asm_rl notE Atleast_Diff_succI)+
(*proving the condition*)
prefer 2 apply (blast intro: Atleast_superset)
(**case z \<in> A.  Instantiate the '\<forall>n \<in> nat. \<forall>A B' induction hypothesis. **)
apply (drule_tac x2="succ(n')" and x1="A-{z}" and x=B
       in bspec [THEN spec, THEN spec])
apply (erule nat_succI)
apply (erule mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [2] asm_rl Atleast_Diff_succI notE)+
(*proving the condition*)
apply simp
apply (blast intro: Atleast_superset)
done

(**** Ramsey's Theorem ****)

(** Base cases of induction; they now admit ANY Ramsey number **)

lemma Ramsey0j: "Ramsey(n,0,j)"
by (unfold Ramsey_def, blast)

lemma Ramseyi0: "Ramsey(n,i,0)"
by (unfold Ramsey_def, blast)

(** Lemmas for induction step **)

(*The use of succ(m) here, rather than #-succ(0), simplifies the proof of
  Ramsey_step_lemma.*)
lemma Atleast_partition: "[| Atleast(m #+ n, A);  m \<in> nat;  n \<in> nat |]
      ==> Atleast(succ(m), {x \<in> A. ~P(x)}) | Atleast(n, {x \<in> A. P(x)})"
apply (rule nat_succI [THEN pigeon2], assumption+)
apply (rule Atleast_superset, auto)
done

(*For the Atleast part, proves ~(a \<in> I) from the second premise!*)
lemma Indept_succ:
    "[| Indept(I, {z \<in> V-{a}. <a,z> \<notin> E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,I) |] ==>
     Indept(cons(a,I), V, E) & Atleast(succ(j), cons(a,I))"
apply (unfold Symmetric_def Indept_def)
apply (blast intro!: Atleast_succI)
done

lemma Clique_succ:
    "[| Clique(C, {z \<in> V-{a}. <a,z>:E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,C) |] ==>
     Clique(cons(a,C), V, E) & Atleast(succ(j), cons(a,C))"
apply (unfold Symmetric_def Clique_def)
apply (blast intro!: Atleast_succI)
done

(** Induction step **)

(*Published proofs gloss over the need for Ramsey numbers to be POSITIVE.*)
lemma Ramsey_step_lemma:
   "[| Ramsey(succ(m), succ(i), j);  Ramsey(n, i, succ(j));
       m \<in> nat;  n \<in> nat |] ==> Ramsey(succ(m#+n), succ(i), succ(j))"
apply (unfold Ramsey_def, clarify)
apply (erule Atleast_succD [THEN bexE])
apply (erule_tac P1 = "%z.<x,z>:E" in Atleast_partition [THEN disjE],
       assumption+)
(*case m*)
apply (fast dest!: Indept_succ elim: Clique_superset)
(*case n*)
apply (fast dest!: Clique_succ elim: Indept_superset)
done

(** The actual proof **)

(*Again, the induction requires Ramsey numbers to be positive.*)
lemma ramsey_lemma: "i \<in> nat ==> \<forall>j \<in> nat. \<exists>n \<in> nat. Ramsey(succ(n), i, j)"
apply (induct_tac "i")
apply (blast intro!: Ramsey0j)
apply (rule ballI)
apply (induct_tac "j")
apply (blast intro!: Ramseyi0)
apply (blast intro!: add_type Ramsey_step_lemma)
done

(*Final statement in a tidy form, without succ(...) *)

end


(*  Author:  Gertrud Bauer, Tobias Nipkow  *)

header{* Properties of Graph Utilities *}

theory GraphProps
imports Graph
begin

declare [[linarith_neq_limit = 3]]

lemma final_setFinal[iff]: "final(setFinal f)"
by (simp add:setFinal_def)

lemma eq_setFinal_iff[iff]: "(f = setFinal f) = final f"
proof (induct f)
  case (Face f t)
  then show ?case
    by (cases t) (simp_all add: setFinal_def)
qed

lemma setFinal_eq_iff[iff]: "(setFinal f = f) = final f"
by (blast dest:sym intro:sym)

lemma distinct_vertices[iff]: "distinct(vertices(g::graph))"
by(induct g) simp

subsection{* @{const nextElem} *}

lemma nextElem_append[simp]:
 "y \<notin> set xs \<Longrightarrow> nextElem (xs @ ys) d y = nextElem ys d y"
by(induct xs) auto

lemma nextElem_cases:
"nextElem xs d x = y \<Longrightarrow>
 x \<notin> set xs \<and> y = d \<or>
 xs \<noteq> [] \<and> x = last xs \<and> y = d \<and> x \<notin> set(butlast xs) \<or>
 (\<exists>us vs. xs = us @ [x,y] @ vs \<and> x \<notin> set us)"
apply(induct xs)
 apply simp
apply simp
apply(split if_splits)
 apply(simp split:list.splits)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply simp
apply(erule disjE)
 apply simp
apply(erule disjE)
 apply clarsimp
apply(rule conjI)
 apply clarsimp
apply (clarsimp)
apply(erule_tac x = "a#us" in allE)
apply simp
done

lemma nextElem_notin_butlast[rule_format,simp]:
 "y \<notin> set(butlast xs) \<longrightarrow> nextElem xs x y = x"
by(induct xs) auto

lemma nextElem_in: "nextElem xs x y : set(x#xs)"
apply (induct xs)
 apply simp
apply auto
apply(clarsimp split: list.splits)
apply(clarsimp split: list.splits)
done

lemma nextElem_notin[simp]: "a \<notin> set as \<Longrightarrow> nextElem as c a = c"
by(erule nextElem_append[where ys = "[]", simplified])

lemma nextElem_last[simp]: assumes dist: "distinct xs"
shows "nextElem xs c (last xs) = c"
proof cases
  assume "xs = []" thus ?thesis by simp
next
  let ?xs = "butlast xs @ [last xs]"
  assume xs: "xs \<noteq> []"
  with dist have "distinct ?xs" by simp
  hence notin: "last xs \<notin> set(butlast xs)" by simp
  from xs have "nextElem xs c (last xs) = nextElem ?xs c (last xs)" by simp
  also from notin have "\<dots> = c" by simp
  finally show ?thesis .
qed

lemma prevElem_nextElem:
assumes dist: "distinct xs" and xxs: "x : set xs"
shows "nextElem (rev xs) (last xs) (nextElem xs (hd xs) x) = x"
proof -
  def x' \<equiv> "nextElem xs (hd xs) x"
  hence nE: "nextElem xs (hd xs) x = x'" by simp
  have "xs \<noteq> [] \<and> x = last xs \<and> x' = hd xs \<or> (\<exists>us vs. xs = us @ [x, x'] @ vs)"
    (is "?A \<or> ?B")
    using nextElem_cases[OF nE] xxs by blast
  thus ?thesis
  proof
    assume ?A
    thus ?thesis using dist by(clarsimp simp:neq_Nil_conv)
  next
    assume ?B
    then obtain us vs where [simp]: "xs = us @ [x, x'] @ vs" by blast
    thus ?thesis using dist by simp
  qed
qed

lemma nextElem_prevElem:
 "\<lbrakk> distinct xs; x : set xs \<rbrakk> \<Longrightarrow>
  nextElem xs (hd xs) (nextElem (rev xs) (last xs) x) = x"
apply(cases "xs = []")
 apply simp
using prevElem_nextElem[where xs = "rev xs" and x=x]
apply(simp add:hd_rev last_rev)
done

lemma nextElem_nth:
 "!!i. \<lbrakk>distinct xs; i < length xs \<rbrakk>
   \<Longrightarrow> nextElem xs z (xs!i) = (if length xs = i+1 then z else xs!(i+1))"
apply(induct xs) apply simp
apply(case_tac i)
 apply(simp split:list.split)
apply clarsimp
done

subsection {* @{text nextVertex} *}

lemma nextVertex_in_face'[simp]:
  "vertices f \<noteq> [] \<Longrightarrow> f \<bullet> v \<in> \<V> f"
proof -
  assume f: "vertices f \<noteq> []"
  def c \<equiv> "nextElem (vertices f) (hd (vertices f)) v"
  then have "nextElem (vertices f) (hd (vertices f)) v = c" by auto
  with f show ?thesis
    apply (simp add: nextVertex_def)
    apply (drule_tac nextElem_cases)
    apply(fastforce simp:neq_Nil_conv)
    done
qed

lemma nextVertex_in_face[simp]:
  "v \<in> set (vertices f) \<Longrightarrow> f \<bullet> v \<in> \<V> f"
 by (auto intro: nextVertex_in_face')

lemma nextVertex_prevVertex[simp]:
 "\<lbrakk> distinct(vertices f); v \<in> \<V> f \<rbrakk>
 \<Longrightarrow> f \<bullet> (f\<^bsup>-1\<^esup> \<bullet> v) = v"
by(simp add:prevVertex_def nextVertex_def nextElem_prevElem)

lemma prevVertex_nextVertex[simp]:
 "\<lbrakk> distinct(vertices f); v \<in> \<V> f \<rbrakk>
 \<Longrightarrow> f\<^bsup>-1\<^esup> \<bullet> (f \<bullet> v) = v"
by(simp add:prevVertex_def nextVertex_def prevElem_nextElem)

lemma prevVertex_in_face[simp]:
 "v \<in> \<V> f \<Longrightarrow> f\<^bsup>-1\<^esup> \<bullet> v \<in> \<V> f"
apply(cases "vertices f = []")
 apply simp
using nextElem_in[of "rev (vertices f)" "(last (vertices f))" v]
apply (auto simp add: prevVertex_def)
done

lemma nextVertex_nth:
 "\<lbrakk> distinct(vertices f); i < |vertices f| \<rbrakk> \<Longrightarrow>
  f \<bullet> (vertices f ! i) = vertices f ! ((i+1) mod |vertices f| )"
apply(cases "vertices f = []") apply simp
apply(simp add:nextVertex_def nextElem_nth hd_conv_nth)
done

subsection {* @{text"\<E>"} *}

lemma edges_face_eq:
 "((a,b) \<in> \<E> (f::face)) = ((f \<bullet> a = b) \<and> a \<in> \<V> f)"
by (auto simp add: edges_face_def)

lemma edges_setFinal[simp]: "\<E>(setFinal f) = \<E> f"
by(induct f)(simp add:setFinal_def edges_face_def nextVertex_def)

lemma in_edges_in_vertices:
 "(x,y) \<in> \<E>(f::face) \<Longrightarrow> x \<in> \<V> f \<and> y \<in> \<V> f"
apply(simp add:edges_face_eq nextVertex_def)
apply(cut_tac xs= "vertices f" and x= "hd(vertices f)" and y=x in nextElem_in)
apply(cases "vertices f")
apply(auto)
done

lemma nextVertex_in_edges: "v \<in> \<V> f \<Longrightarrow> (v, f \<bullet> v) \<in> edges f"
by(auto simp:edges_face_def)

lemma prevVertex_in_edges:
 "\<lbrakk>distinct(vertices f); v \<in> \<V> f\<rbrakk> \<Longrightarrow> (f\<^bsup>-1\<^esup> \<bullet> v, v) \<in> edges f"
by(simp add:edges_face_eq)

subsection {* Triangles *}

lemma vertices_triangle:
   "|vertices f| = 3 \<Longrightarrow> a \<in> \<V> f \<Longrightarrow>
  distinct (vertices f) \<Longrightarrow>
  \<V> f = {a, f \<bullet> a, f \<bullet> (f \<bullet> a)}"
proof -
  assume "|vertices f| = 3"
  then obtain a1 a2 a3 where "vertices f = [a1, a2, a3]"
    by (auto dest!:  length3D)
  moreover assume "a \<in> \<V> f"
  moreover assume "distinct (vertices f)"
  ultimately show ?thesis
    by (simp, elim disjE) (auto simp add: nextVertex_def)
qed

(* could be generalized from 3 to n
   but presburger would no longer do the job *)
lemma tri_next3_id:
 "|vertices f| = 3 \<Longrightarrow> distinct(vertices f) \<Longrightarrow> v \<in> \<V> f
  \<Longrightarrow> f \<bullet> (f \<bullet> (f \<bullet> v)) = v"
apply(subgoal_tac "ALL (i::nat) < 3. (((((i+1) mod 3)+1) mod 3)+1) mod 3 = i")
 apply(clarsimp simp:in_set_conv_nth nextVertex_nth)
apply(presburger)
done

lemma triangle_nextVertex_prevVertex:
 "|vertices f| = 3 \<Longrightarrow> a \<in> \<V> f \<Longrightarrow>
  distinct (vertices f) \<Longrightarrow>
  f \<bullet> (f \<bullet> a) = f\<^bsup>-1\<^esup> \<bullet> a"
proof -
  assume "|vertices f| = 3"
  then obtain a1 a2 a3 where "vertices f = [a1, a2, a3]"
    by (auto dest!:length3D)
  moreover assume "a \<in> \<V> f"
  moreover assume "distinct (vertices f)"
  ultimately show ?thesis
    by (simp, elim disjE) (auto simp add: nextVertex_def prevVertex_def)
qed

subsection {* Quadrilaterals *}

lemma vertices_quad:
  "|vertices f| = 4 \<Longrightarrow> a \<in> \<V> f \<Longrightarrow>
  distinct (vertices f) \<Longrightarrow>
  \<V> f = {a, f \<bullet> a, f \<bullet> (f \<bullet> a), f \<bullet> (f \<bullet> (f \<bullet> a))}"
proof -
  assume "|vertices f| = 4"
  then obtain a1 a2 a3 a4 where "vertices f = [a1, a2, a3, a4]"
    by (auto dest!: length4D)
  moreover assume "a \<in> \<V> f"
  moreover assume "distinct (vertices f)"
  ultimately show ?thesis
    by (simp, elim disjE) (auto simp add: nextVertex_def)
qed

lemma quad_next4_id:
 "\<lbrakk> |vertices f| = 4; distinct(vertices f); v \<in> \<V> f \<rbrakk> \<Longrightarrow>
  f \<bullet> (f \<bullet> (f \<bullet> (f \<bullet> v))) = v"
apply(subgoal_tac "ALL (i::nat) < 4.
 (((((((i+1) mod 4)+1) mod 4)+1) mod 4)+1) mod 4 = i")
 apply(clarsimp simp:in_set_conv_nth nextVertex_nth)
apply(presburger)
done

lemma quad_nextVertex_prevVertex:
 "|vertices f| = 4 \<Longrightarrow> a \<in> \<V> f \<Longrightarrow> distinct (vertices f) \<Longrightarrow>
  f \<bullet> (f \<bullet> (f \<bullet> a)) = f\<^bsup>-1\<^esup> \<bullet> a"
proof -
  assume "|vertices f| = 4"
  then obtain a1 a2 a3 a4 where "vertices f = [a1, a2, a3, a4]"
    by (auto dest!: length4D)
  moreover assume "a \<in> \<V> f"
  moreover assume "distinct (vertices f)"
  ultimately show ?thesis
    by (auto) (auto simp add: nextVertex_def prevVertex_def)
qed

(*
lemma C0[dest]: "f \<in> set (facesAt g v) \<Longrightarrow> v \<in> \<V> g"
  by (simp add: facesAt_def split: split_if_asm)
*)

lemma len_faces_sum: "|faces g| = |finals g| + |nonFinals g|"
by(simp add:finals_def nonFinals_def sum_length_filter_compl)

lemma graph_max_final_ex:
 "\<exists>f\<in>set (finals (graph n)). |vertices f| = n"
proof (induct "n")
  case 0 then show ?case by (simp add: graph_def finals_def)
next
  case (Suc n) then show ?case
   by (simp add: graph_def finals_def)
qed

subsection{* No loops *}

lemma distinct_no_loop2:
 "\<lbrakk> distinct(vertices f); v \<in> \<V> f; u \<in> \<V> f; u \<noteq> v \<rbrakk> \<Longrightarrow> f \<bullet> v \<noteq> v"
apply(frule split_list[of v])
apply(clarsimp simp: nextVertex_def neq_Nil_conv hd_append
  split:list.splits split_if_asm)
done

lemma distinct_no_loop1:
 "\<lbrakk> distinct(vertices f); v \<in> \<V> f; |vertices f| > 1 \<rbrakk> \<Longrightarrow> f \<bullet> v \<noteq> v"
apply(subgoal_tac "\<exists>u \<in> \<V> f. u \<noteq> v")
 apply(blast dest:distinct_no_loop2)
apply(cases "vertices f") apply simp
apply(rename_tac a as)
apply (clarsimp simp:neq_Nil_conv)
done

subsection{* @{const between} *}

lemma between_front[simp]:
 "v \<notin> set us \<Longrightarrow> between (u # us @ v # vs) u v = us"
by(simp add:between_def split_def)

lemma between_back:
 "\<lbrakk> v \<notin> set us; u \<notin> set vs; v \<noteq> u \<rbrakk> \<Longrightarrow> between (v # vs @ u # us) u v = us"
by(simp add:between_def split_def)

lemma next_between:
 "\<lbrakk>distinct(vertices f); v \<in> \<V> f; u \<in> \<V> f; f \<bullet> v \<noteq> u \<rbrakk>
  \<Longrightarrow> f \<bullet> v \<in> set(between (vertices f) v u)"
apply(frule split_list[of u])
apply(clarsimp)
apply(erule disjE)
 apply(clarsimp simp:set_between_id nextVertex_def hd_append split:list.split)
apply(erule disjE)
 apply(frule split_list[of v])
 apply(clarsimp simp: between_def split_def nextVertex_def split:list.split)
 apply(clarsimp simp:append_eq_Cons_conv)
apply(frule split_list[of v])
apply(clarsimp simp: between_def split_def nextVertex_def split:list.split)
apply(clarsimp simp: hd_append)
done

lemma next_between2:
 "\<lbrakk> distinct(vertices f); v \<in> \<V> f; u \<in> \<V> f; u \<noteq> v \<rbrakk> \<Longrightarrow>
  v \<in> set(between (vertices f) u (f \<bullet> v))"
apply(frule split_list[of u])
apply(clarsimp)
apply(erule disjE)
 apply(clarsimp simp: nextVertex_def hd_append split:list.split)
 apply(rule conjI)
  apply(clarsimp)
 apply(frule split_list[of v])
 apply(clarsimp simp: between_def split_def split:list.split)
 apply(fastforce simp: append_eq_Cons_conv)
apply(frule split_list[of v])
apply(clarsimp simp: between_def split_def nextVertex_def split:list.splits)
apply(clarsimp simp: hd_append)
apply(erule disjE)
 apply(clarsimp)
apply(frule split_list)
apply(fastforce)
done

(* distinctness seems not to be necessary but simplifies the proof *)
lemma between_next_empty:
 "distinct(vertices f) \<Longrightarrow> between (vertices f) v (f \<bullet> v) = []"
apply(cases "v \<in> \<V> f")
 apply(frule split_list)
 apply(clarsimp simp:between_def split_def nextVertex_def
   neq_Nil_conv hd_append split:list.split)
 apply(clarsimp simp:between_def split_def nextVertex_def)
apply(cases "vertices f")
 apply simp
apply simp
done

lemma unroll_between_next2:
 "\<lbrakk> distinct(vertices f); u \<in> \<V> f; v \<in> \<V> f; u \<noteq> v \<rbrakk> \<Longrightarrow>
  between (vertices f) u (f \<bullet> v) = between (vertices f) u v @ [v]"
using split_between[OF _ _ _ next_between2]
by (simp add: between_next_empty split:split_if_asm)

lemma nextVertex_eq_lemma:
 "\<lbrakk> distinct(vertices f); x \<in> \<V> f; y \<in> \<V> f; x \<noteq> y;
    v \<in> set(x # between (vertices f) x y) \<rbrakk> \<Longrightarrow>
  f \<bullet> v = nextElem (x # between (vertices f) x y @ [y]) z v"
apply(drule split_list[of x])
apply(simp add:nextVertex_def)
apply(erule disjE)
 apply(clarsimp)
 apply(erule disjE)
  apply(drule split_list)
  apply(clarsimp simp add:between_def split_def hd_append split:list.split)
  apply(fastforce simp:append_eq_Cons_conv)
 apply(drule split_list)
 apply(clarsimp simp add:between_def split_def hd_append split:list.split)
 apply(fastforce simp:append_eq_Cons_conv)
apply(clarsimp)
 apply(erule disjE)
 apply(drule split_list[of y])
 apply(clarsimp simp:between_def split_def)
 apply(erule disjE)
  apply(drule split_list[of v])
  apply(fastforce simp: hd_append neq_Nil_conv split:list.split)
 apply(drule split_list[of v])
 apply(clarsimp)
 apply(clarsimp simp: hd_append split:list.split)
 apply(fastforce simp:append_eq_Cons_conv)
apply(drule split_list[of y])
apply(clarsimp simp:between_def split_def)
apply(drule split_list[of v])
apply(clarsimp)
apply(clarsimp simp: hd_append split:list.split)
apply(clarsimp simp:append_eq_Cons_conv)
apply(fastforce simp: hd_append neq_Nil_conv split:list.split)
done

end


(* Title: Domain Quantales
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Component for Recursive Programs\<close>

theory Domain_Quantale
  imports KAD.Modal_Kleene_Algebra

begin

text \<open>This component supports the verification and step-wise refinement of recursive programs
in a partial correctness setting.\<close>

notation
  times (infixl "\<cdot>" 70) and
  bot ("\<bottom>") and
  top ("\<top>") and
  inf (infixl "\<sqinter>" 65) and
  sup (infixl "\<squnion>" 65)
(*
  Inf ("\<Sqinter>_" [900] 900) and
  Sup ("\<Squnion>_" [900] 900)
*)

(*
syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

*)

subsection \<open>Lattice-Ordered Monoids with Domain\<close>

class bd_lattice_ordered_monoid = bounded_lattice + distrib_lattice + monoid_mult +
  assumes left_distrib: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  and right_distrib: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  and bot_annil [simp]: "\<bottom> \<cdot> x = \<bottom>"
  and bot_annir [simp]: "x \<cdot> \<bottom> = \<bottom>"

begin

sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "bot"
  by (standard, auto simp: sup.assoc sup.commute sup_left_commute left_distrib right_distrib sup_absorb1)

sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" bot "(\<le>)" "(<)"
  by (standard, simp add: le_iff_sup, auto)

end

no_notation ads_d ("d")
  and ars_r ("r")
  and antirange_op ("ar _" [999] 1000)

class domain_bdlo_monoid = bd_lattice_ordered_monoid +
  assumes rdv: "(z \<sqinter> x \<cdot> top) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> top"

begin

definition "d x = 1 \<sqinter> x \<cdot> \<top>"

sublocale ds: domain_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "d" "(\<le>)" "(<)"
proof standard
  fix x y
  show "x \<squnion> d x \<cdot> x = d x \<cdot> x"
    by (metis d_def inf_sup_absorb left_distrib mult_1_left mult_1_right rdv sup.absorb_iff1 sup.idem sup.left_commute top_greatest)
  show "d (x \<cdot> d y) = d (x \<cdot> y)"
    by (simp add: d_def inf_absorb2 rdv  mult_assoc)
  show "d x \<squnion> 1 = 1"
    by (simp add: d_def sup.commute)
  show "d bot = bot"
    by (simp add: d_def inf.absorb1 inf.commute)
  show "d (x \<squnion> y) = d x \<squnion> d y"
    by (simp add: d_def inf_sup_distrib1)
qed

end

subsection\<open>Boolean Monoids with Domain\<close>

class boolean_monoid = boolean_algebra + monoid_mult +
  assumes left_distrib': "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  and right_distrib': "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  and bot_annil' [simp]: "\<bottom> \<cdot> x = \<bottom>"
  and bot_annir' [simp]: "x \<cdot> \<bottom> = \<bottom>"

begin

subclass bd_lattice_ordered_monoid
  by (standard, simp_all add: left_distrib' right_distrib')

lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)

end

class domain_boolean_monoid = boolean_monoid +
  assumes rdv': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"

begin

sublocale dblo: domain_bdlo_monoid "1" "(\<cdot>)" "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)" "\<bottom>" "\<top>"
  by (standard, simp add: rdv')

definition "a x = 1 \<sqinter> -(dblo.d x)"

lemma a_d_iff: "a x = 1 \<sqinter> -(x \<cdot> \<top>)"
  by (clarsimp simp: a_def dblo.d_def inf_sup_distrib1)

lemma topr: "-(x \<cdot> \<top>) \<cdot> \<top> = -(x \<cdot> \<top>)"
proof (rule antisym)
  show "-(x \<cdot> \<top>) \<le> -(x \<cdot> \<top>) \<cdot> \<top>"
    by (metis mult_isol_var mult_oner order_refl top_greatest)
  have "-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>) = \<bottom>"
    by simp
  hence "(-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>)) \<cdot> \<top>  = \<bottom>"
    by simp
  hence "-(x \<cdot> \<top>) \<cdot> \<top> \<sqinter> (x \<cdot> \<top>)  = \<bottom>"
    by (metis rdv')
  thus "-(x \<cdot> \<top>) \<cdot> \<top> \<le> -(x \<cdot> \<top>)"
    by (simp add: inf_bot_iff_le)
qed

lemma dd_a: "dblo.d x = a (a x)"
  by (metis a_d_iff dblo.d_def double_compl inf_top.left_neutral mult_1_left rdv' topr)

lemma ad_a [simp]: "a (dblo.d x) = a x"
  by (simp add: a_def)

lemma da_a [simp]: "dblo.d (a x) = a x"
  using ad_a dd_a by auto

lemma a1 [simp]: "a x \<cdot> x = \<bottom>"
proof -
  have "a x \<cdot> x \<cdot> \<top> = \<bottom>"
    by (metis a_d_iff inf_compl_bot mult_1_left rdv' topr)
  then show ?thesis
    by (metis (no_types) dblo.d_def dblo.ds.domain_very_strict inf_bot_right)
qed

lemma a2 [simp]: "a (x \<cdot> y) \<squnion> a (x \<cdot> a (a y)) = a (x \<cdot> a (a y))"
  by (metis a_def dblo.ds.dsr2 dd_a sup.idem)

lemma a3 [simp]: "a (a x) \<squnion> a x = 1"
  by (metis a_def da_a inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)

subclass domain_bdlo_monoid ..

text \<open>The next statement shows that every boolean monoid with domain is an antidomain semiring.
In this setting the domain operation has been defined explicitly.\<close>

sublocale ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  rewrites ad_eq: "ad.ads_d x = d x"
proof -
  show "class.antidomain_semiring a (\<squnion>) (\<cdot>) 1 \<bottom> (\<le>) (<)"
    by (standard, simp_all)
  then interpret ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" .
  show "ad.ads_d x = d x"
    by (simp add: ad.ads_d_def dd_a)
qed

end

subsection\<open>Boolean Monoids with Range\<close>

class range_boolean_monoid = boolean_monoid +
  assumes ldv': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"

begin

definition "r x = 1 \<sqinter> \<top> \<cdot> x"

definition "ar x = 1 \<sqinter> -(r x)"

lemma ar_r_iff: "ar x = 1 \<sqinter> -(\<top> \<cdot> x)"
  by (simp add: ar_def inf_sup_distrib1 r_def)

lemma topl: "\<top>\<cdot>(-(\<top> \<cdot> x)) = -(\<top> \<cdot> x)"
proof (rule antisym)
  show "\<top> \<cdot> - (\<top> \<cdot> x) \<le> - (\<top> \<cdot> x)"
    by (metis bot_annir' compl_inf_bot inf_bot_iff_le ldv')
  show "- (\<top> \<cdot> x) \<le> \<top> \<cdot> - (\<top> \<cdot> x)"
    by (metis inf_le2 inf_top.right_neutral mult_1_left mult_isor)
qed

lemma r_ar: "r x = ar (ar x)"
  by (metis ar_r_iff double_compl inf.commute inf_top.right_neutral ldv' mult_1_right r_def topl)

lemma ar_ar [simp]: "ar (r x) = ar x"
  by (simp add: ar_def ldv' r_def)

lemma rar_ar [simp]: "r (ar x) = ar x"
  using r_ar ar_ar by force

lemma ar1 [simp]: "x \<cdot> ar x = \<bottom>"
proof -
  have "\<top> \<cdot> x \<cdot> ar x = \<bottom>"
    by (metis ar_r_iff inf_compl_bot ldv' mult_oner topl)
  then show ?thesis
    by (metis inf_bot_iff_le inf_le2 inf_top.right_neutral mult_1_left mult_isor mult_oner topl)
qed

lemma ars: "r (r x \<cdot> y) = r (x \<cdot> y)"
  by (metis inf.commute inf_top.right_neutral ldv' mult_oner mult_assoc r_def)

lemma ar2 [simp]: "ar (x \<cdot> y) \<squnion> ar (ar (ar x) \<cdot> y) = ar (ar (ar x) \<cdot> y)"
  by (metis ar_def ars r_ar sup.idem)

lemma ar3 [simp]: "ar (ar x) \<squnion> ar x = 1 "
  by (metis ar_def rar_ar inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)

sublocale ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)"
  rewrites ar_eq: "ar.ars_r x = r x"
proof -
  show "class.antirange_semiring (\<squnion>) (\<cdot>) 1 \<bottom> ar (\<le>) (<)"
    by (standard, simp_all)
  then interpret ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)" .
  show "ar.ars_r x = r x"
    by (simp add: ar.ars_r_def r_ar)
qed

end

subsection \<open>Quantales\<close>

text \<open>This part will eventually move into an AFP quantale entry.\<close>

class quantale = complete_lattice + monoid_mult +
  assumes Sup_distr: "Sup X \<cdot> y = Sup {z. \<exists>x \<in> X. z = x \<cdot> y}"
  and Sup_distl: "x \<cdot> Sup Y = Sup {z. \<exists>y \<in> Y. z = x \<cdot> y}"

begin

lemma bot_annil'' [simp]: "\<bottom> \<cdot> x = \<bottom>"
  using Sup_distr[where X="{}"] by auto

lemma bot_annirr'' [simp]: "x \<cdot> \<bottom> = \<bottom>"
  using Sup_distl[where Y="{}"] by auto

lemma sup_distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  using Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma sup_distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)

sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>"
  by (standard, auto simp: sup.assoc sup.commute sup_left_commute sup_distl sup_distr)

sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  by (standard, simp add: le_iff_sup, auto)

lemma Sup_sup_pred: "x \<squnion> Sup{y. P y} = Sup{y. y = x \<or> P y}"
  apply (rule antisym)
  apply (simp add: Collect_mono Sup_subset_mono Sup_upper)
  using Sup_least Sup_upper le_supI2 by fastforce

definition star :: "'a \<Rightarrow> 'a" where
  "star x = (SUP i. x ^ i)"

lemma star_def_var1: "star x = Sup{y. \<exists>i. y = x ^ i}"
  by (simp add: star_def full_SetCompr_eq)

lemma star_def_var2: "star x = Sup{x ^ i |i. True}"
  by (simp add: star_def full_SetCompr_eq)

lemma star_unfoldl' [simp]: "1 \<squnion> x \<cdot> (star x) = star x"
proof -
  have "1 \<squnion> x \<cdot> (star x) = x ^ 0 \<squnion> x \<cdot> Sup{y. \<exists>i. y = x ^ i}"
    by (simp add: star_def_var1)
  also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
    by (simp add: Sup_distl, metis)
  also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
    using Sup_sup_pred by simp
  also have "... = Sup{y. \<exists>i. y = x ^ i}"
    by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
  finally show ?thesis
    by (simp add: star_def_var1)
qed

lemma star_unfoldr' [simp]: "1 \<squnion> (star x) \<cdot> x = star x"
proof -
  have "1 \<squnion> (star x) \<cdot> x = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i} \<cdot> x"
    by (simp add: star_def_var1)
  also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i \<cdot> x}"
    by (simp add: Sup_distr, metis)
  also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
    using power_Suc2 by simp
   also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
    using Sup_sup_pred by simp
  also have "... = Sup{y. \<exists>i. y = x ^ i}"
    by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
  finally show ?thesis
    by (simp add: star_def_var1)
qed

lemma (in dioid_one_zero) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by simp
  case Suc thus ?case
    by (simp, metis mult.assoc mult_isol order_trans)
qed

lemma (in dioid_one_zero) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (x ^ n) \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by auto
  case Suc
  {
    fix n
    assume "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ n \<le> y"
      and "z + y \<cdot> x \<le> y"
    hence "z \<cdot> x ^ n \<le> y"
      by simp
    also have "z \<cdot> x ^ Suc n = z \<cdot> x \<cdot> x ^ n"
      by (metis mult.assoc power_Suc)
    moreover have "... = (z \<cdot> x ^ n) \<cdot> x"
      by (metis mult.assoc power_commutes)
    moreover have "... \<le> y \<cdot> x"
      by (metis calculation(1) mult_isor)
    moreover have "... \<le> y"
      using \<open>z + y \<cdot> x \<le> y\<close> by simp
    ultimately have "z \<cdot> x ^ Suc n \<le> y" by simp
  }
  thus ?case
    by (metis Suc)
qed

lemma star_inductl': "z \<squnion> x \<cdot> y \<le> y \<Longrightarrow> (star x) \<cdot> z \<le> y"
proof -
  assume "z \<squnion> x \<cdot> y \<le> y"
  hence "\<forall>i. x ^ i \<cdot> z \<le> y"
    by (simp add: power_inductl)
  hence "Sup{w. \<exists>i. w = x ^ i \<cdot> z} \<le> y"
    by (intro Sup_least, fast)
  hence "Sup{w. \<exists>i. w = x ^ i} \<cdot> z \<le> y"
    using Sup_distr Sup_le_iff by auto
  thus "(star x) \<cdot> z \<le> y"
    by (simp add: star_def_var1)
qed

lemma star_inductr': "z \<squnion> y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (star x) \<le> y"
proof -
  assume "z \<squnion> y \<cdot> x \<le> y"
  hence "\<forall>i. z \<cdot> x ^ i  \<le> y"
    by (simp add: power_inductr)
  hence "Sup{w. \<exists>i. w = z \<cdot> x ^ i} \<le> y"
    by (intro Sup_least, fast)
  hence "z \<cdot> Sup{w. \<exists>i. w = x ^ i} \<le> y"
    using Sup_distl Sup_le_iff by auto
  thus "z \<cdot> (star x) \<le> y"
    by (simp add: star_def_var1)
qed

sublocale ka: kleene_algebra "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" star
  by standard (simp_all add: star_inductl' star_inductr')

end

text \<open>Distributive quantales are often assumed to satisfy infinite distributivity laws between
joins and meets, but finite ones suffice for our purposes.\<close>

class distributive_quantale = quantale + distrib_lattice

begin

subclass bd_lattice_ordered_monoid
  by (standard, simp_all add: distrib_left)

lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
(* nitpick [expect=genuine]*)
oops

end

subsection \<open>Domain Quantales\<close>

class domain_quantale = distributive_quantale +
  assumes rdv'': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"

begin

subclass domain_bdlo_monoid
  by (standard, simp add: rdv'')

end

class range_quantale = distributive_quantale +
  assumes ldv'': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"

class boolean_quantale = quantale + complete_boolean_algebra

begin

subclass boolean_monoid
  by (standard, simp_all add: sup_distl)

lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
(*nitpick[expect=genuine]*)
oops

lemma "(1 \<sqinter> -(x \<cdot> \<top>)) \<cdot> x = \<bottom>"
(*nitpick[expect=genuine]*)
oops

end

subsection\<open>Boolean Domain Quantales\<close>

class domain_boolean_quantale = domain_quantale + boolean_quantale

begin

subclass domain_boolean_monoid
  by (standard, simp add: rdv'')

lemma fbox_eq: "ad.fbox x q = Sup{d p |p. d p \<cdot> x \<le> x \<cdot> d q}"
  apply (rule Sup_eqI[symmetric])
  apply clarsimp
  using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
  apply clarsimp
  by (metis ad.fbox_def ad.fbox_demodalisation3 ad.fbox_simp da_a eq_refl)

lemma fdia_eq: "ad.fdia x p = Inf{d q |q. x \<cdot> d p \<le> d q \<cdot> x}"
  apply (rule Inf_eqI[symmetric])
  apply clarsimp
  using ds.fdemodalisation2 apply auto[1]
  apply clarsimp
  by (metis ad.fd_eq_fdia ad.fdia_def da_a double_compl ds.fdemodalisation2 inf_bot_iff_le inf_compl_bot)

text \<open>The specification statement can be defined explicitly.\<close>

definition R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "R p q \<equiv> Sup{x. (d p) \<cdot> x \<le> x \<cdot> d q}"

lemma "x \<le> R p q \<Longrightarrow> d p \<le> ad.fbox x (d q)"
proof (simp add: R_def ad.kat_1_equiv ad.kat_2_equiv)
  assume "x \<le> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>}"
  hence "d p \<cdot> x \<cdot> a q \<le> d p \<cdot> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>} \<cdot> a q "
    using mult_double_iso by blast
  also have "... = Sup{d p \<cdot> x \<cdot> a q |x. d p \<cdot> x \<cdot> a q = \<bottom>}"
    apply (subst Sup_distl)
    apply (subst Sup_distr)
    apply clarsimp
    by metis
  also have "... = \<bottom>"
    by (auto simp: Sup_eqI)
  finally show ?thesis
    using ad.fbox_demodalisation3 ad.kat_3 ad.kat_4 le_bot by blast
qed

lemma "d p \<le> ad.fbox x (d q) \<Longrightarrow> x \<le> R p q"
  apply (simp add: R_def)
  apply (rule Sup_upper)
  apply simp
  using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
done

end

subsection\<open>Relational Model of Boolean Domain Quantales\<close>

interpretation rel_dbq: domain_boolean_quantale Inter Union "(\<inter>)" "(\<subseteq>)" "(\<subset>)" "(\<union>)" "{}" UNIV minus uminus Id "(O)"
  apply (standard, simp_all add: O_assoc)
  by blast +

subsection\<open>Modal Boolean Quantales\<close>

class range_boolean_quantale = range_quantale + boolean_quantale

begin

subclass range_boolean_monoid
  by (standard, simp add: ldv'')

lemma fbox_eq: "ar.bbox x (r q) = Sup{r p |p. x \<cdot> r p \<le> (r q) \<cdot> x}"
  apply (rule Sup_eqI[symmetric])
  apply clarsimp
  using ar.ardual.fbox_demodalisation3 ar.ardual.fbox_simp apply auto[1]
  apply clarsimp
  by (metis ar.ardual.fbox_def ar.ardual.fbox_demodalisation3 eq_refl rar_ar)

lemma fdia_eq: "ar.bdia x (r p) = Inf{r q |q. (r p) \<cdot> x \<le> x \<cdot> r q}"
  apply (rule Inf_eqI[symmetric])
  apply clarsimp
  using ar.ars_r_def ar.ardual.fdemodalisation22 ar.ardual.kat_3_equiv_opp ar.ardual.kat_4_equiv_opp apply auto[1]
  apply clarsimp
  using ar.bdia_def ar.ardual.ds.fdemodalisation2 r_ar by fastforce

end

class modal_boolean_quantale = domain_boolean_quantale + range_boolean_quantale +
  assumes domrange' [simp]: "d (r x) = r x"
  and rangedom' [simp]: "r (d x) = d x"

begin

sublocale mka: modal_kleene_algebra "(\<squnion>)" "(\<cdot>)" 1 \<bottom> "(\<le>)" "(<)" star a ar
  by standard (simp_all add: ar_eq ad_eq)

end

no_notation fbox ("( |_] _)" [61,81] 82)
  and antidomain_semiringl_class.fbox ("( |_] _)" [61,81] 82)

notation ad.fbox ("( |_] _)" [61,81] 82)

subsection \<open>Recursion Rule\<close>

lemma recursion: "mono (f :: 'a \<Rightarrow> 'a :: domain_boolean_quantale) \<Longrightarrow>
  (\<And>x. d p \<le> |x] d q \<Longrightarrow> d p \<le> |f x] d q) \<Longrightarrow>  d p \<le> |lfp f] d q"
  apply (erule lfp_ordinal_induct [where f=f], simp)
  by (auto simp: ad.addual.ardual.fbox_demodalisation3 Sup_distr Sup_distl intro: Sup_mono)

text \<open>We have already tested this rule in the context of test quantales~\cite{ArmstrongGS15}, which is based
on a formalisation of quantales that is currently not in the AFP. The two theories will be merged as
soon as the quantale is available in the AFP.\<close>

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>Missing results\<close>

theory SNF_Missing_Lemmas
  imports
    Hermite.Hermite
    Mod_Type_Connect
    Jordan_Normal_Form.DL_Rank_Submatrix
    "List-Index.List_Index"
begin

text \<open>This theory presents some missing lemmas that are required for the Smith normal form
development. Some of them could be added to different AFP entries, such as the Jordan Normal
Form AFP entry by Ren\'e Thiemann and Akihisa Yamada.

However, not all the lemmas can be added directly, since some imports are required.\<close>

hide_const (open) C
hide_const (open) measure

subsection \<open>Miscellaneous lemmas\<close>

lemma sum_two_rw: "(\<Sum>i = 0..<2. f i) = (\<Sum>i \<in> {0,1::nat}. f i)"
  by (rule sum.cong, auto)

lemma sum_common_left:
  fixes f::"'a \<Rightarrow> 'b::comm_ring_1"
  assumes "finite A"
  shows "sum (\<lambda>i. c * f i) A = c * sum f A"
  by (simp add: mult_hom.hom_sum)

lemma prod3_intro:
  assumes "fst A = a" and "fst (snd A) = b" and "snd (snd A) = c"
  shows "A = (a,b,c)" using assms by auto

subsection \<open>Transfer rules for the HMA\_Connect file of the Perron-Frobenius development\<close>

hide_const (open) HMA_M HMA_I to_hma\<^sub>m from_hma\<^sub>m
hide_fact (open) from_hma\<^sub>m_def from_hma_to_hma\<^sub>m HMA_M_def HMA_I_def dim_row_transfer_rule
                  dim_col_transfer_rule

context
  includes lifting_syntax
begin

lemma HMA_invertible_matrix[transfer_rule]:
  "((HMA_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n ^ 'n \<Rightarrow> _) ===> (=)) invertible_mat invertible"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy[transfer_rule] = "1"
  have eq_dim: "dim_col x = dim_row x"
    using HMA_Connect.dim_col_transfer_rule HMA_Connect.dim_row_transfer_rule rel_xy
    by fastforce
  moreover have "\<exists>A'. y ** A' = Finite_Cartesian_Product.mat 1 \<and> A' ** y = Finite_Cartesian_Product.mat 1"
    if xB: "x * B = 1\<^sub>m (dim_row x)" and Bx: "B * x = 1\<^sub>m (dim_row B)" for B
  proof -
    let ?A' = "HMA_Connect.to_hma\<^sub>m B:: 'a :: comm_ring_1 ^ 'n ^ 'n"
    have rel_BA[transfer_rule]: "HMA_M B ?A'"
      by (metis (no_types, lifting) Bx HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
          from_hma\<^sub>m_def from_hma_to_hma\<^sub>m index_mult_mat(3) index_one_mat(3) rel_xy xB)
    have [simp]: "dim_row B = CARD('n)" using dim_row_transfer_rule rel_BA by blast
    have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
    have "y ** ?A' = Finite_Cartesian_Product.mat 1" using xB by (transfer, simp)
    moreover have "?A' ** y  = Finite_Cartesian_Product.mat 1" using Bx by (transfer, simp)
    ultimately show ?thesis by blast
  qed
  moreover have "\<exists>B. x * B = 1\<^sub>m (dim_row x) \<and> B * x = 1\<^sub>m (dim_row B)"
    if yA: "y ** A' = Finite_Cartesian_Product.mat 1" and Ay: "A' ** y = Finite_Cartesian_Product.mat 1" for A'
  proof -
    let ?B = "(from_hma\<^sub>m A')"
    have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
    have [transfer_rule]: "HMA_M ?B A'" by (simp add: HMA_M_def)
    hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
    have "x * ?B = 1\<^sub>m (dim_row x)" using yA by (transfer', auto)
    moreover have "?B * x = 1\<^sub>m (dim_row ?B)" using Ay by (transfer', auto)
    ultimately show ?thesis by auto
  qed
  ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
qed
end

subsection \<open>Lemmas obtained from HOL Analysis using local type definitions\<close>

thm Cartesian_Space.invertible_mult (*In HOL Analysis*)
thm invertible_iff_is_unit (*In HOL Analysis*)
thm det_non_zero_imp_unit (*In JNF, but only for fields*)
thm mat_mult_left_right_inverse (*In JNF, but only for fields*)

lemma invertible_mat_zero:
  assumes A: "A \<in> carrier_mat 0 0"
  shows "invertible_mat A"
  using A unfolding invertible_mat_def inverts_mat_def one_mat_def times_mat_def scalar_prod_def
    Matrix.row_def col_def carrier_mat_def
  by (auto, metis (no_types, lifting) cong_mat not_less_zero)

lemma invertible_mult_JNF:
  fixes A::"'a::comm_ring_1 mat"
  assumes A: "A\<in>carrier_mat n n" and B: "B\<in>carrier_mat n n"
    and inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
shows "invertible_mat (A*B)"
proof (cases "n = 0")
  case True
  then show ?thesis using assms
    by (simp add: invertible_mat_zero)
next
  case False
  then show ?thesis using
      invertible_mult[where ?'a="'a::comm_ring_1", where ?'b="'n::finite", where ?'c="'n::finite",
      where ?'d="'n::finite", untransferred, cancel_card_constraint, OF assms] by auto
qed

lemma invertible_iff_is_unit_JNF:
  assumes A: "A \<in> carrier_mat n n"
  shows "invertible_mat A \<longleftrightarrow> (Determinant.det A) dvd 1"
proof (cases "n=0")
  case True
  then show ?thesis using det_dim_zero invertible_mat_zero A by auto
next
  case False
  then show ?thesis using invertible_iff_is_unit[untransferred, cancel_card_constraint] A by auto
qed

subsection \<open>Lemmas about matrices, submatrices and determinants\<close>

(*This is a generalization of thm mat_mult_left_right_inverse*)
thm mat_mult_left_right_inverse
lemma mat_mult_left_right_inverse:
  fixes A :: "'a::comm_ring_1 mat"
  assumes A: "A \<in> carrier_mat n n"
    and B: "B \<in> carrier_mat n n" and AB: "A * B = 1\<^sub>m n"
  shows "B * A = 1\<^sub>m n"
proof -
  have "Determinant.det (A * B) = Determinant.det (1\<^sub>m n)" using AB by auto
  hence "Determinant.det A * Determinant.det B = 1"
    using Determinant.det_mult[OF A B] det_one by auto
  hence det_A: "(Determinant.det A) dvd 1" and det_B: "(Determinant.det B) dvd 1"
    using dvd_triv_left dvd_triv_right by metis+
  hence inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
    using A B invertible_iff_is_unit_JNF by blast+
  obtain B' where inv_BB': "inverts_mat B B'" and inv_B'B: "inverts_mat B' B"
    using inv_B unfolding invertible_mat_def by auto
  have B'_carrier: "B' \<in> carrier_mat n n"
    by (metis B inv_B'B inv_BB' carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mult_mat(3) index_one_mat(3) inverts_mat_def)
  have "B * A * B = B" using A AB B by auto
  hence "B * A * (B * B') = B * B'"
    by (smt A AB B B'_carrier assoc_mult_mat carrier_matD(1) inv_BB' inverts_mat_def one_carrier_mat)
  thus ?thesis
    by (metis A B carrier_matD(1) carrier_matD(2) index_mult_mat(3) inv_BB'
        inverts_mat_def right_mult_one_mat')
qed

context comm_ring_1
begin

lemma col_submatrix_UNIV:
assumes "j < card {i. i < dim_col A \<and> i \<in> J}"
shows "col (submatrix A UNIV J) j = col A (pick J j)"
proof (rule eq_vecI)
  show dim_eq:"dim_vec (col (submatrix A UNIV J) j) = dim_vec (col A (pick J j))"
    by (simp add: dim_submatrix(1))
  fix i assume "i < dim_vec (col A (pick J j))"
  show "col (submatrix A UNIV J) j $v i = col A (pick J j) $v i"
    by (smt Collect_cong assms col_def dim_col dim_eq dim_submatrix(1)
        eq_vecI index_vec pick_UNIV submatrix_index)
qed

lemma submatrix_split2: "submatrix A I J = submatrix (submatrix A I UNIV) UNIV J" (is "?lhs = ?rhs")
proof (rule eq_matI)
  show dr: "dim_row ?lhs = dim_row ?rhs"
    by (simp add: dim_submatrix(1))
  show dc: "dim_col ?lhs = dim_col ?rhs"
    by (simp add: dim_submatrix(2))
  fix i j assume i: "i < dim_row ?rhs"
    and j: "j < dim_col ?rhs"
  have "?rhs $$ (i, j) = (submatrix A I UNIV) $$ (pick UNIV i, pick J j)"
  proof (rule submatrix_index)
    show "i < card {i. i < dim_row (submatrix A I UNIV) \<and> i \<in> UNIV}"
      by (metis (full_types) dim_submatrix(1) i)
    show "j < card {j. j < dim_col (submatrix A I UNIV) \<and> j \<in> J}"
      by (metis (full_types) dim_submatrix(2) j)
  qed
  also have "... = A $$ (pick I (pick UNIV i), pick UNIV (pick J j))"
  proof (rule submatrix_index)
    show "pick UNIV i < card {i. i < dim_row A \<and> i \<in> I}"
      by (metis (full_types) dr dim_submatrix(1) i pick_UNIV)
    show "pick J j < card {j. j < dim_col A \<and> j \<in> UNIV}"
      by (metis (full_types) dim_submatrix(2) j pick_le)
  qed
  also have "... = ?lhs $$ (i,j)"
  proof (unfold pick_UNIV, rule submatrix_index[symmetric])
    show "i < card {i. i < dim_row A \<and> i \<in> I}"
      by (metis (full_types) dim_submatrix(1) dr i)
    show "j < card {j. j < dim_col A \<and> j \<in> J}"
      by (metis (full_types) dim_submatrix(2) dc j)
  qed
  finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" ..
qed

lemma submatrix_mult:
  "submatrix (A*B) I J = submatrix A I UNIV * submatrix B UNIV J" (is "?lhs = ?rhs")
proof (rule eq_matI)
  show "dim_row ?lhs = dim_row ?rhs" unfolding submatrix_def by auto
  show "dim_col ?lhs = dim_col ?rhs" unfolding submatrix_def by auto
  fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
  have i1: "i < card {i. i < dim_row (A * B) \<and> i \<in> I}"
    by (metis (full_types) dim_submatrix(1) i index_mult_mat(2))
  have j1: "j < card {j. j < dim_col (A * B) \<and> j \<in> J}"
    by (metis dim_submatrix(2) index_mult_mat(3) j)
  have pi: "pick I i < dim_row A" using i1 pick_le by auto
  have pj: "pick J j < dim_col B" using j1 pick_le by auto
  have row_rw: "Matrix.row (submatrix A I UNIV) i = Matrix.row A (pick I i)"
    using i1 row_submatrix_UNIV by auto
  have col_rw: "col (submatrix B UNIV J) j = col B (pick J j)" using j1 col_submatrix_UNIV by auto
  have "?lhs $$ (i,j) =  (A*B) $$ (pick I i, pick J j)" by (rule submatrix_index[OF i1 j1])
  also have "... = Matrix.row A (pick I i) \<bullet> col B (pick J j)" by (rule index_mult_mat(1)[OF pi pj])
  also have "... = Matrix.row (submatrix A I UNIV) i \<bullet> col (submatrix B UNIV J) j"
    using row_rw col_rw by simp
  also have "... = (?rhs) $$ (i,j)" by (rule index_mult_mat[symmetric], insert i j, auto)
  finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
qed

lemma det_singleton:
  assumes A: "A \<in> carrier_mat 1 1"
  shows "det A = A $$ (0,0)"
  using A unfolding carrier_mat_def Determinant.det_def by auto

lemma submatrix_singleton_index:
  assumes A: "A \<in> carrier_mat n m"
    and an: "a < n" and bm: "b < m"
    shows "submatrix A {a} {b} $$ (0,0) = A $$ (a,b)"
proof -
  have a: "{i. i = a \<and> i < dim_row A} = {a}" using an A unfolding carrier_mat_def by auto
  have b: "{i. i = b \<and> i < dim_col A} = {b}" using bm A unfolding carrier_mat_def by auto
  have "submatrix A {a} {b} $$ (0,0) = A $$ (pick {a} 0,pick {b} 0)"
    by (rule submatrix_index, insert a b, auto)
  moreover have "pick {a} 0 = a" by (auto, metis (full_types) LeastI)
  moreover have "pick {b} 0 = b" by (auto, metis (full_types) LeastI)
  ultimately show ?thesis by simp
qed
end

lemma det_not_inj_on:
  assumes not_inj_on: "\<not> inj_on f {0..<n}"
  shows "det (mat\<^sub>r n n (\<lambda>i. Matrix.row B (f i))) = 0"
proof -
  obtain i j where i: "i<n" and j: "j<n" and fi_fj: "f i = f j" and ij: "i\<noteq>j"
    using not_inj_on unfolding inj_on_def by auto
  show ?thesis
  proof (rule det_identical_rows[OF _ ij i j])
    let ?B="(mat\<^sub>r n n (\<lambda>i. row B (f i)))"
    show "row ?B i = row ?B j"
    proof (rule eq_vecI, auto)
      fix ia assume ia: "ia < n"
      have "row ?B i $ ia = ?B $$ (i, ia)" by (rule index_row(1), insert i ia, auto)
      also have "... = ?B $$ (j, ia)" by (simp add: fi_fj i ia j)
      also have "... = row ?B j $ ia" by (rule index_row(1)[symmetric], insert j ia, auto)
      finally show "row ?B i $ ia = row (mat\<^sub>r n n (\<lambda>i. row B (f i))) j $ ia" by simp
    qed
    show "mat\<^sub>r n n (\<lambda>i. Matrix.row B (f i)) \<in> carrier_mat n n" by auto
  qed
qed

lemma mat_row_transpose: "(mat\<^sub>r nr nc f)\<^sup>T = mat nc nr (\<lambda>(i,j). vec_index (f j) i)"
  by (rule eq_matI, auto)

lemma obtain_inverse_matrix:
  assumes A: "A \<in> carrier_mat n n" and i: "invertible_mat A"
  obtains B where "inverts_mat A B" and "inverts_mat B A" and "B \<in> carrier_mat n n"
proof -
  have "(\<exists>B. inverts_mat A B \<and> inverts_mat B A)" using i unfolding invertible_mat_def by auto
  from this obtain B where AB: "inverts_mat A B" and BA: "inverts_mat B A" by auto
  moreover have "B \<in> carrier_mat n n" using A AB BA unfolding carrier_mat_def inverts_mat_def
    by (auto, metis index_mult_mat(3) index_one_mat(3))+
  ultimately show ?thesis using that by blast
qed

lemma invertible_mat_smult_mat:
  fixes A :: "'a::comm_ring_1 mat"
  assumes inv_A: "invertible_mat A" and k: "k dvd 1"
  shows "invertible_mat (k \<cdot>\<^sub>m A)"
proof -
  obtain n where A: "A \<in> carrier_mat n n" using inv_A unfolding invertible_mat_def by auto
  have det_dvd_1: "Determinant.det A dvd 1" using inv_A invertible_iff_is_unit_JNF[OF A] by auto
  have "Determinant.det (k \<cdot>\<^sub>m A) = k ^ dim_col A * Determinant.det A" by simp
  also have "... dvd 1" by (rule unit_prod, insert k det_dvd_1 dvd_power_same, force+)
  finally show ?thesis using invertible_iff_is_unit_JNF by (metis A smult_carrier_mat)
qed

lemma invertible_mat_one[simp]: "invertible_mat (1\<^sub>m n)"
  unfolding invertible_mat_def using inverts_mat_def by fastforce

lemma four_block_mat_dim0:
  assumes A: "A \<in> carrier_mat n n"
  and B: "B \<in> carrier_mat n 0"
  and C: "C \<in> carrier_mat 0 n"
  and D: "D \<in> carrier_mat 0 0"
shows "four_block_mat A B C D = A"
  unfolding four_block_mat_def using assms by auto

lemma det_four_block_mat_lower_right_id:
  assumes A: "A \<in> carrier_mat m m"
and B: "B = 0\<^sub>m m (n-m)"
and C: "C = 0\<^sub>m (n-m) m"
and D: "D = 1\<^sub>m (n-m)"
and "n>m"
shows "Determinant.det (four_block_mat A B C D) = Determinant.det A"
  using assms
proof (induct n arbitrary: A B C D)
  case 0
  then show ?case by auto
next
  case (Suc n)
  let ?block = "(four_block_mat A B C D)"
  let ?B = "Matrix.mat m (n-m) (\<lambda>(i,j). 0)"
  let ?C = "Matrix.mat (n-m) m (\<lambda>(i,j). 0)"
  let ?D = "1\<^sub>m (n-m)"
  have mat_eq: "(mat_delete ?block n n) = four_block_mat A ?B ?C ?D" (is "?lhs = ?rhs")
  proof (rule eq_matI)
    fix i j assume i: "i < dim_row (four_block_mat A ?B ?C ?D)"
      and j: "j < dim_col (four_block_mat A ?B ?C ?D)"
    let ?f = " (if i < dim_row A then if j < dim_col A then A $$ (i, j) else B $$ (i, j - dim_col A)
     else if j < dim_col A then C $$ (i - dim_row A, j) else D $$ (i - dim_row A, j - dim_col A))"
    let ?g = "(if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?B $$ (i, j - dim_col A)
     else if j < dim_col A then ?C $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
    have "(mat_delete ?block n n) $$ (i,j) = ?block $$ (i,j)"
      using i j Suc.prems unfolding mat_delete_def by auto
    also have "... = ?f"
      by (rule index_mat_four_block, insert Suc.prems i j, auto)
    also have "... = ?g" using i j Suc.prems by auto
    also have "... = four_block_mat A ?B ?C ?D $$ (i,j)"
      by (rule index_mat_four_block[symmetric], insert Suc.prems i j, auto)
    finally show "?lhs $$ (i,j) = ?rhs $$ (i,j)" .
  qed (insert Suc.prems, auto)
  have nn_1: "?block $$ (n, n) = 1" using Suc.prems by auto
  have rw0: "(\<Sum>i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n) = 0"
  proof (rule sum.neutral, rule)
    fix x assume x: "x \<in> {..<n}"
    have block_index: "?block $$ (x,n) = (if x < dim_row A then if n < dim_col A then A $$ (x, n)
      else B $$ (x, n - dim_col A) else if n < dim_col A then C $$ (x - dim_row A, n)
      else D $$ (x - dim_row A, n - dim_col A))"
      by (rule index_mat_four_block, insert Suc.prems x, auto)
    have "four_block_mat A B C D $$ (x,n) = 0" using x Suc.prems by auto
    thus "four_block_mat A B C D $$ (x, n) * Determinant.cofactor (four_block_mat A B C D) x n = 0"
      by simp
  qed
  have "Determinant.det ?block = (\<Sum>i<Suc n. ?block $$ (i, n) * Determinant.cofactor ?block i n)"
    by (rule laplace_expansion_column, insert Suc.prems, auto)
  also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n
    + (\<Sum>i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n)"
    by simp
  also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n" using rw0 by auto
  also have "... = Determinant.cofactor ?block n n" using nn_1 by simp
  also have "... = Determinant.det (mat_delete ?block n n)" unfolding cofactor_def by auto
  also have "... = Determinant.det (four_block_mat A ?B ?C ?D)" using mat_eq by simp
  also have "... = Determinant.det A" (is "Determinant.det ?lhs = Determinant.det ?rhs")
  proof (cases "n = m")
    case True
    have "?lhs = ?rhs" by (rule four_block_mat_dim0, insert Suc.prems True, auto)
    then show ?thesis by simp
  next
    case False
    show ?thesis by (rule Suc.hyps, insert Suc.prems False, auto)
  qed
  finally show ?case .
qed

lemma mult_eq_first_row:
  assumes A: "A \<in> carrier_mat 1 n"
  and B: "B \<in> carrier_mat m n"
  and m0: "m \<noteq> 0"
  and r: "Matrix.row A 0 = Matrix.row B 0"
shows "Matrix.row (A * V) 0 = Matrix.row (B * V) 0"
proof (rule eq_vecI)
  show "dim_vec (Matrix.row (A * V) 0) = dim_vec (Matrix.row (B * V) 0)" using A B r by auto
  fix i assume i: "i < dim_vec (Matrix.row (B * V) 0)"
  have "Matrix.row (A * V) 0 $v i = (A * V) $$ (0,i)" by (rule index_row, insert i A, auto)
  also have "... = Matrix.row A 0 \<bullet> col V i" by (rule index_mult_mat, insert A i, auto)
  also have "... = Matrix.row B 0 \<bullet> col V i" using r by auto
  also have "... = (B * V) $$ (0,i)" by (rule index_mult_mat[symmetric], insert m0 B i, auto)
  also have "... = Matrix.row (B * V) 0 $v i" by (rule index_row[symmetric], insert i B m0, auto)
  finally show "Matrix.row (A * V) 0 $v i = Matrix.row (B * V) 0 $v i" .
qed

lemma smult_mat_mat_one_element:
  assumes A: "A \<in> carrier_mat 1 1" and B: "B \<in> carrier_mat 1 n"
  shows "A * B = A $$ (0,0) \<cdot>\<^sub>m B"
proof (rule eq_matI)
  fix i j assume i: "i < dim_row (A $$ (0, 0) \<cdot>\<^sub>m B)" and j: "j < dim_col (A $$ (0, 0) \<cdot>\<^sub>m B)"
  have i0: "i = 0" using A B i by auto
  have "(A * B) $$ (i, j) =  Matrix.row A i \<bullet> col B j"
    by (rule index_mult_mat, insert i j A B, auto)
  also have "... =  Matrix.row A i $v 0 * col B j $v 0" unfolding scalar_prod_def using B by auto
  also have "... = A$$(i,i) * B$$(i,j)" using A i i0 j by auto
  also have "... = (A $$ (i, i) \<cdot>\<^sub>m B) $$ (i, j)"
    unfolding i by (rule index_smult_mat[symmetric], insert i j B, auto)
  finally show "(A * B) $$ (i, j) = (A $$ (0, 0) \<cdot>\<^sub>m B) $$ (i, j)" using i0 by simp
qed (insert A B, auto)

lemma determinant_one_element:
  assumes A: "A \<in> carrier_mat 1 1" shows "Determinant.det A = A $$ (0,0)"
proof -
  have "Determinant.det A = prod_list (diag_mat A)"
    by (rule det_upper_triangular[OF _ A], insert A, unfold upper_triangular_def, auto)
  also have "... = A $$ (0,0)" using A unfolding diag_mat_def by auto
  finally show ?thesis .
qed

lemma invertible_mat_transpose:
  assumes inv_A: "invertible_mat (A::'a::comm_ring_1 mat)"
  shows "invertible_mat A\<^sup>T"
proof -
  obtain n where A: "A \<in> carrier_mat n n"
    using inv_A unfolding invertible_mat_def square_mat.simps by auto
  hence At: "A\<^sup>T \<in> carrier_mat n n" by simp
  have "Determinant.det A\<^sup>T = Determinant.det A"
    by (metis Determinant.det_def Determinant.det_transpose carrier_matI
        index_transpose_mat(2) index_transpose_mat(3))
  also have "... dvd 1" using invertible_iff_is_unit_JNF[OF A] inv_A by simp
  finally show ?thesis  using invertible_iff_is_unit_JNF[OF At] by auto
qed

lemma dvd_elements_mult_matrix_left:
  assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m n"
  and P: "P \<in> carrier_mat m m"
  and x: "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd A$$(i,j))"
  shows "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd (P*A)$$(i,j))"
proof -
  have "x dvd (P * A) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
  proof -
    have "(P * A) $$ (i, j) =  (\<Sum>ia = 0..<m. Matrix.row P i $v ia * col A j $v ia)"
      unfolding times_mat_def scalar_prod_def using A P j i by auto
    also have "... = (\<Sum>ia = 0..<m. Matrix.row P i $v ia *  A $$ (ia,j))"
      by (rule sum.cong, insert A j, auto)
    also have "x dvd ..." using x by (meson atLeastLessThan_iff dvd_mult dvd_sum j)
    finally show ?thesis .
  qed
  thus ?thesis by auto
qed

lemma dvd_elements_mult_matrix_right:
  assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m n"
  and Q: "Q \<in> carrier_mat n n"
  and x: "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd A$$(i,j))"
  shows "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd (A*Q)$$(i,j))"
proof -
  have "x dvd (A*Q) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
  proof -
    have "(A*Q) $$ (i, j) =  (\<Sum>ia = 0..<n. Matrix.row A i $v ia * col Q j $v ia)"
      unfolding times_mat_def scalar_prod_def using A Q j i by auto
    also have "... = (\<Sum>ia = 0..<n. A $$ (i, ia) * col Q j $v ia)"
      by (rule sum.cong, insert A Q i, auto)
    also have "x dvd ..." using x
      by (meson atLeastLessThan_iff dvd_mult2 dvd_sum i)
    finally show ?thesis .
  qed
  thus ?thesis by auto
qed

lemma dvd_elements_mult_matrix_left_right:
  assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m n"
  and P: "P \<in> carrier_mat m m"
  and Q: "Q \<in> carrier_mat n n"
  and x: "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd A$$(i,j))"
shows "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd (P*A*Q)$$(i,j))"
  using dvd_elements_mult_matrix_left[OF A P x]
  by (meson P A Q dvd_elements_mult_matrix_right mult_carrier_mat)

definition append_cols :: "'a :: zero mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" (infixr "@\<^sub>c" 65)where
  "A @\<^sub>c B = four_block_mat A B (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col B))"

lemma append_cols_carrier[simp,intro]:
  "A \<in> carrier_mat n a \<Longrightarrow> B \<in> carrier_mat n b \<Longrightarrow> (A @\<^sub>c B) \<in> carrier_mat n (a+b)"
  unfolding append_cols_def by auto

lemma append_cols_mult_left:
  assumes A: "A \<in> carrier_mat n a"
  and B: "B \<in> carrier_mat n b"
  and P: "P \<in> carrier_mat n n"
shows "P * (A @\<^sub>c B) = (P*A) @\<^sub>c (P*B)"
proof -
  let ?P = "four_block_mat P (0\<^sub>m n 0) (0\<^sub>m 0 n) (0\<^sub>m 0 0)"
  have "P = ?P" by (rule eq_matI, auto)
  hence "P * (A @\<^sub>c B) = ?P * (A @\<^sub>c B)" by simp
  also have "?P * (A @\<^sub>c B) = four_block_mat (P * A + 0\<^sub>m n 0 * 0\<^sub>m 0 (dim_col A))
  (P * B + 0\<^sub>m n 0 * 0\<^sub>m 0 (dim_col B)) (0\<^sub>m 0 n * A + 0\<^sub>m 0 0 * 0\<^sub>m 0 (dim_col A))
  (0\<^sub>m 0 n * B + 0\<^sub>m 0 0 * 0\<^sub>m 0 (dim_col B))" unfolding append_cols_def
    by (rule mult_four_block_mat, insert A B P, auto)
  also have "... = four_block_mat (P * A) (P * B) (0\<^sub>m 0 (dim_col (P*A))) (0\<^sub>m 0 (dim_col (P*B)))"
    by (rule cong_four_block_mat, insert P, auto)
  also have "... = (P*A) @\<^sub>c (P*B)" unfolding append_cols_def by auto
  finally show ?thesis .
qed

lemma append_cols_mult_right_id:
  assumes A: "(A::'a::semiring_1 mat) \<in> carrier_mat n 1"
  and B: "B \<in> carrier_mat n (m-1)"
  and C: "C = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D"
  and D: "D \<in> carrier_mat (m-1) (m-1)"
shows "(A @\<^sub>c B) * C = A @\<^sub>c (B * D)"
proof -
  let ?C = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D"
  have "(A @\<^sub>c B) * C = (A @\<^sub>c B) * ?C" unfolding C by auto
  also have "... = four_block_mat A B (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col B)) * ?C"
    unfolding append_cols_def by auto
  also have "... = four_block_mat (A * 1\<^sub>m 1 + B * 0\<^sub>m (m - 1) 1) (A * 0\<^sub>m 1 (m - 1) + B * D)
    (0\<^sub>m 0 (dim_col A) * 1\<^sub>m 1 + 0\<^sub>m 0 (dim_col B) * 0\<^sub>m (m - 1) 1)
    (0\<^sub>m 0 (dim_col A) * 0\<^sub>m 1 (m - 1) + 0\<^sub>m 0 (dim_col B) * D)"
    by (rule mult_four_block_mat, insert assms, auto)
  also have "... = four_block_mat A (B * D) (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col (B*D)))"
    by (rule cong_four_block_mat, insert assms, auto)
  also have "... = A @\<^sub>c (B * D)" unfolding append_cols_def by auto
  finally show ?thesis .
qed

lemma append_cols_mult_right_id2:
 assumes A: "(A::'a::semiring_1 mat) \<in> carrier_mat n a"
   and B: "B \<in> carrier_mat n b"
   and C: "C = four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)"
   and D: "D \<in> carrier_mat a a"
shows "(A @\<^sub>c B) * C = (A * D) @\<^sub>c B"
proof -
  let ?C = "four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)"
  have "(A @\<^sub>c B) * C = (A @\<^sub>c B) * ?C" unfolding C by auto
  also have "... = four_block_mat A B (0\<^sub>m 0 a) (0\<^sub>m 0 b) * ?C"
    unfolding append_cols_def using A B by auto
  also have "... = four_block_mat (A * D + B * 0\<^sub>m b a) (A * 0\<^sub>m a b + B * 1\<^sub>m b)
    (0\<^sub>m 0 a * D + 0\<^sub>m 0 b * 0\<^sub>m b a) (0\<^sub>m 0 a * 0\<^sub>m a b + 0\<^sub>m 0 b * 1\<^sub>m b)"
    by (rule mult_four_block_mat, insert A B C D, auto)
  also have "... = four_block_mat (A * D) B (0\<^sub>m 0 (dim_col (A*D))) (0\<^sub>m 0 (dim_col B))"
    by (rule cong_four_block_mat, insert assms, auto)
  also have "... = (A * D) @\<^sub>c B" unfolding append_cols_def by auto
  finally show ?thesis .
qed

lemma append_cols_nth:
  assumes A: "A \<in> carrier_mat n a"
  and B: "B \<in> carrier_mat n b"
  and i: "i<n" and j: "j < a + b"
shows "(A @\<^sub>c B) $$ (i, j) = (if j < dim_col A then A $$(i,j) else B$$(i,j-a))" (is "?lhs = ?rhs")
proof -
  let ?C = "(0\<^sub>m 0 (dim_col A))"
  let ?D = "(0\<^sub>m 0 (dim_col B))"
  have i2: "i < dim_row A + dim_row ?D" using i A by auto
  have j2: "j < dim_col A + dim_col (0\<^sub>m 0 (dim_col B))" using j B A by auto
  have "(A @\<^sub>c B) $$ (i, j) = four_block_mat A B ?C ?D $$ (i, j)"
    unfolding append_cols_def by auto
  also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j)
  else B $$ (i, j - dim_col A) else if j < dim_col A then ?C $$ (i - dim_row A, j)
  else 0\<^sub>m 0 (dim_col B) $$ (i - dim_row A, j - dim_col A))"
    by (rule index_mat_four_block(1)[OF i2 j2])
  also have "... = ?rhs" using i A by auto
  finally show ?thesis .
qed

lemma append_cols_split:
  assumes d: "dim_col A > 0"
  shows "A = mat_of_cols (dim_row A) [col A 0] @\<^sub>c
             mat_of_cols (dim_row A) (map (col A) [1..<dim_col A])" (is "?lhs = ?A1 @\<^sub>c ?A2")
proof (rule eq_matI)
  fix i j assume i: "i < dim_row (?A1 @\<^sub>c ?A2)" and j: "j < dim_col (?A1 @\<^sub>c ?A2)"
  have "(?A1 @\<^sub>c ?A2) $$ (i, j) = (if j < dim_col ?A1 then ?A1 $$(i,j) else ?A2$$(i,j-(dim_col ?A1)))"
    by (rule append_cols_nth, insert i j, auto simp add: append_cols_def)
  also have "... = A $$ (i,j)"
  proof (cases "j< dim_col ?A1")
    case True
    then show ?thesis
      by (metis One_nat_def Suc_eq_plus1 add.right_neutral append_cols_def col_def i
          index_mat_four_block(2) index_vec index_zero_mat(2) less_one list.size(3) list.size(4)
          mat_of_cols_Cons_index_0 mat_of_cols_carrier(2) mat_of_cols_carrier(3))
  next
    case False
    then show ?thesis
      by (metis (no_types, lifting) Suc_eq_plus1 Suc_less_eq Suc_pred add_diff_cancel_right' append_cols_def
          diff_zero i index_col index_mat_four_block(2) index_mat_four_block(3) index_zero_mat(2)
          index_zero_mat(3) j length_map length_upt linordered_semidom_class.add_diff_inverse list.size(3)
          list.size(4) mat_of_cols_carrier(2) mat_of_cols_carrier(3) mat_of_cols_index nth_map_upt
          plus_1_eq_Suc upt_0)
  qed
  finally show "A $$ (i, j) = (?A1 @\<^sub>c ?A2) $$ (i, j)" ..
qed (auto simp add: append_cols_def d)

lemma append_rows_nth:
  assumes A: "A \<in> carrier_mat a n"
  and B: "B \<in> carrier_mat b n"
  and i: "i<a+b" and j: "j < n"
shows "(A @\<^sub>r B) $$ (i, j) = (if i < dim_row A then A $$(i,j) else B$$(i-a,j))" (is "?lhs = ?rhs")
proof -
  let ?C = "(0\<^sub>m (dim_row A) 0)"
  let ?D = "(0\<^sub>m (dim_row B) 0)"
  have i2: "i < dim_row A + dim_row ?D" using i j A B by auto
  have j2: "j < dim_col A + dim_col ?D" using i j A B by auto
  have "(A @\<^sub>r B) $$ (i, j) = four_block_mat A ?C B ?D $$ (i, j)"
    unfolding append_rows_def by auto
  also have "... =  (if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?C $$ (i, j - dim_col A)
   else if j < dim_col A then B $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
    by (rule index_mat_four_block(1)[OF i2 j2])
  also have "... = ?rhs" using i A j B by auto
  finally show ?thesis .
qed

lemma append_rows_split:
  assumes k: "k\<le>dim_row A"
  shows "A = (mat_of_rows (dim_col A) [Matrix.row A i. i \<leftarrow> [0..<k]]) @\<^sub>r
             (mat_of_rows (dim_col A) [Matrix.row A i. i \<leftarrow> [k..<dim_row A]])" (is "?lhs = ?A1 @\<^sub>r ?A2")
proof (rule eq_matI)
  have "(?A1 @\<^sub>r ?A2) \<in> carrier_mat (k + (dim_row A-k)) (dim_col A)"
    by (rule carrier_append_rows, insert k, auto)
  hence A1_A2: "(?A1 @\<^sub>r ?A2) \<in> carrier_mat (dim_row A) (dim_col A)" using k by simp
  thus "dim_row A = dim_row (?A1 @\<^sub>r ?A2)" and "dim_col A = dim_col (?A1 @\<^sub>r ?A2)" by auto
  fix i j assume i: "i < dim_row (?A1 @\<^sub>r ?A2)" and j: "j < dim_col (?A1 @\<^sub>r ?A2)"
  have "(?A1 @\<^sub>r ?A2) $$ (i, j) = (if i < dim_row ?A1 then ?A1 $$(i,j) else ?A2$$(i-(dim_row ?A1),j))"
    by (rule append_rows_nth, insert k i j, auto simp add: append_rows_def)
  also have "... = A $$ (i,j)"
  proof (cases "i<dim_row ?A1")
    case True
    then show ?thesis
      by (metis (no_types, lifting) Matrix.row_def add.left_neutral add.right_neutral append_rows_def
          index_mat(1) index_mat_four_block(3) index_vec index_zero_mat(3) j length_map length_upt
          mat_of_rows_carrier(2,3) mat_of_rows_def nth_map_upt prod.simps(2))
  next
    case False
    let ?xs = "(map (Matrix.row A) [k..<dim_row A])"
    have dim_row_A1: "dim_row ?A1 = k" by auto
    have "?A2 $$ (i-k,j) = ?xs ! (i-k) $v j"
      by (rule mat_of_rows_index, insert i k False A1_A2 j, auto)
    also have "... = A $$ (i,j)" using A1_A2 False i j by auto
    finally show ?thesis using A1_A2 False i j by auto
  qed
  finally show " A $$ (i, j) = (?A1 @\<^sub>r ?A2) $$ (i,j)" by simp
qed

lemma transpose_mat_append_rows:
 assumes A: "A \<in> carrier_mat a n" and B: "B \<in> carrier_mat b n"
 shows "(A @\<^sub>r B)\<^sup>T = A\<^sup>T @\<^sub>c B\<^sup>T"
  by (smt append_cols_def append_rows_def A B carrier_matD(1) index_transpose_mat(3)
      transpose_four_block_mat zero_carrier_mat zero_transpose_mat)

lemma transpose_mat_append_cols:
 assumes A: "A \<in> carrier_mat n a" and B: "B \<in> carrier_mat n b"
 shows "(A @\<^sub>c B)\<^sup>T = A\<^sup>T @\<^sub>r B\<^sup>T"
  by (metis Matrix.transpose_transpose A B carrier_matD(1) carrier_mat_triv
      index_transpose_mat(3) transpose_mat_append_rows)

lemma append_rows_mult_right:
  assumes A: "(A::'a::comm_semiring_1 mat) \<in> carrier_mat a n" and B: "B \<in> carrier_mat b n"
    and Q: "Q\<in> carrier_mat n n"
  shows "(A @\<^sub>r B) * Q = (A * Q) @\<^sub>r (B*Q)"
proof -
  have "transpose_mat ((A @\<^sub>r B) * Q) = Q\<^sup>T * (A @\<^sub>r B)\<^sup>T"
    by (rule transpose_mult, insert A B Q, auto)
  also have "... = Q\<^sup>T * (A\<^sup>T @\<^sub>c B\<^sup>T)" using transpose_mat_append_rows assms by metis
  also have "... = Q\<^sup>T * A\<^sup>T @\<^sub>c Q\<^sup>T * B\<^sup>T"
    using append_cols_mult_left assms by (metis transpose_carrier_mat)
  also have "transpose_mat ... = (A * Q) @\<^sub>r (B*Q)"
    by (smt A B Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def Q
        carrier_mat_triv index_mult_mat(2) index_transpose_mat(2) transpose_four_block_mat
        zero_carrier_mat zero_transpose_mat)
  finally show ?thesis by simp
qed

lemma append_rows_mult_left_id:
  assumes A: "(A::'a::comm_semiring_1 mat) \<in> carrier_mat 1 n"
  and B: "B \<in> carrier_mat (m-1) n"
  and C: "C = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D"
  and D: "D \<in> carrier_mat (m-1) (m-1)"
shows "C * (A @\<^sub>r B) = A @\<^sub>r (D * B)"
proof -
  have "transpose_mat (C * (A @\<^sub>r B)) = (A @\<^sub>r B)\<^sup>T * C\<^sup>T"
    by (metis (no_types, lifting) B C D Matrix.transpose_mult append_rows_def A carrier_matD
        carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2) one_carrier_mat)
  also have "... = (A\<^sup>T @\<^sub>c B\<^sup>T) * C\<^sup>T" using transpose_mat_append_rows[OF A B] by auto
  also have "... = A\<^sup>T @\<^sub>c (B\<^sup>T * D\<^sup>T)" by (rule append_cols_mult_right_id, insert A B C D, auto)
  also have "transpose_mat ... = A @\<^sub>r (D * B)"
    by (smt B D Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def A
        carrier_matD(2) carrier_mat_triv index_mult_mat(3) index_transpose_mat(3)
        transpose_four_block_mat zero_carrier_mat zero_transpose_mat)
  finally show ?thesis by auto
qed

lemma append_rows_mult_left_id2:
 assumes A: "(A::'a::comm_semiring_1 mat) \<in> carrier_mat a n"
   and B: "B \<in> carrier_mat b n"
   and C: "C = four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)"
   and D: "D \<in> carrier_mat a a"
 shows "C * (A @\<^sub>r B) = (D * A) @\<^sub>r B"
proof -
  have "(C * (A @\<^sub>r B))\<^sup>T = (A @\<^sub>r B)\<^sup>T * C\<^sup>T" by (rule transpose_mult, insert assms, auto)
  also have "... = (A\<^sup>T @\<^sub>c B\<^sup>T) * C\<^sup>T" by (metis A B transpose_mat_append_rows)
  also have "... = (A\<^sup>T * D\<^sup>T @\<^sub>c B\<^sup>T)" by (rule append_cols_mult_right_id2, insert assms, auto)
  also have "...\<^sup>T = (D * A) @\<^sub>r B"
    by (metis A B D transpose_mult transpose_transpose mult_carrier_mat transpose_mat_append_rows)
  finally show ?thesis by simp
qed

lemma four_block_mat_preserves_column:
  assumes A: "(A::'a::semiring_1 mat) \<in> carrier_mat n m"
    and B: "B = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) C"
  and C: "C \<in> carrier_mat (m-1) (m-1)"
  and i: "i<n" and m: "0<m"
shows "(A*B) $$ (i,0) = A $$ (i,0)"
proof -
  let ?A1 = "mat_of_cols n [col A 0]"
  let ?A2 = "mat_of_cols n (map (col A) [1..<dim_col A])"
  have n2: "dim_row A = n" using A by auto
  have "A = ?A1 @\<^sub>c ?A2" by (rule append_cols_split[of A, unfolded n2], insert m A, auto)
  hence "A * B = (?A1 @\<^sub>c ?A2) * B" by simp
  also have "... = ?A1 @\<^sub>c (?A2 * C)" by (rule append_cols_mult_right_id[OF _ _ B C], insert A, auto)
  also have "... $$ (i,0) = ?A1 $$ (i,0)" using append_cols_nth by (simp add: append_cols_def i)
  also have "... = A $$ (i,0)"
    by (metis A i carrier_matD(1) col_def index_vec mat_of_cols_Cons_index_0)
  finally show ?thesis .
qed

definition "lower_triangular A = (\<forall>i j. i < j \<and> i < dim_row A \<and> j < dim_col A \<longrightarrow> A $$ (i,j) = 0)"

lemma lower_triangular_index:
  assumes "lower_triangular A" "i<j" "i < dim_row A" "j < dim_col A"
  shows "A $$ (i,j) = 0"
  using assms unfolding lower_triangular_def by auto

lemma commute_multiples_identity:
  assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat n n"
  shows "A * (k \<cdot>\<^sub>m (1\<^sub>m n)) = (k \<cdot>\<^sub>m (1\<^sub>m n)) * A"
proof -
  have "(\<Sum>ia = 0..<n. A $$ (i, ia) * (k * (if ia = j then 1 else 0)))
    = (\<Sum>ia = 0..<n. k * (if i = ia then 1 else 0) * A $$ (ia, j))" (is "?lhs=?rhs")
    if i: "i<n" and j: "j<n" for i j
  proof -
    let ?f = "\<lambda>ia. A $$ (i, ia) * (k * (if ia = j then 1 else 0))"
    let ?g = "\<lambda>ia. k * (if i = ia then 1 else 0) * A $$ (ia, j)"
    have rw0: "(\<Sum>ia \<in> ({0..<n}-{j}). ?f ia) = 0" by (rule sum.neutral, auto)
    have rw0': "(\<Sum>ia \<in> ({0..<n}-{i}). ?g ia) = 0" by (rule sum.neutral, auto)
    have "?lhs = ?f j + (\<Sum>ia \<in> ({0..<n}-{j}). ?f ia)"
      by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove j)
    also have "... = A $$ (i, j) * k" using rw0 by auto
    also have "... = ?g i + (\<Sum>ia \<in> ({0..<n}-{i}). ?g ia)" using rw0' by auto
    also have "... = ?rhs"
      by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove i)
    finally show ?thesis .
  qed
  thus ?thesis using A
  unfolding times_mat_def scalar_prod_def
  by auto (rule eq_matI, auto, smt sum.cong)
qed

(*This lemma is obtained using Mod_Type_Connect, otherwise we cannot prove HMA_I 0 0.
The lelma could also be obtained with no use of transfer rules, proving it directly.*)
lemma det_2:
  assumes A: "A \<in> carrier_mat 2 2"
  shows "Determinant.det A = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
proof -
  let ?A = "(Mod_Type_Connect.to_hma\<^sub>m A)::'a^2^2"
  have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
    unfolding Mod_Type_Connect.HMA_M_def using from_hma_to_hma\<^sub>m A by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_I 0 0"
    unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_0)
  have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 1"
    unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
  have "Determinant.det A = Determinants.det ?A" by (transfer, simp)
  also have "... = ?A $h 1 $h 1 * ?A $h 2 $h 2 - ?A $h 1 $h 2 * ?A $h 2 $h 1" unfolding det_2 by simp
  also have "... = ?A $h 0 $h 0 * ?A $h 1 $h 1 - ?A $h 0 $h 1 * ?A $h 1 $h 0"
    by (smt Groups.mult_ac(2) exhaust_2 semiring_norm(160))
  also have "... = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
    unfolding index_hma_def[symmetric] by (transfer, auto)
  finally show ?thesis .
qed

lemma mat_diag_smult: "mat_diag n (\<lambda> x. (k::'a::comm_ring_1)) = (k \<cdot>\<^sub>m 1\<^sub>m n)"
proof -
  have "mat_diag n (\<lambda> x. k) = mat_diag n (\<lambda> x. k * 1)" by auto
  also have "... = mat_diag n (\<lambda> x. k) * mat_diag n (\<lambda> x. 1)" using mat_diag_diag
    by (simp add: mat_diag_def)
  also have "... = mat_diag n (\<lambda> x. k) * (1\<^sub>m n)" by auto  thm mat_diag_mult_left
  also have "... = Matrix.mat n n (\<lambda>(i, j). k * (1\<^sub>m n) $$ (i, j))" by (rule mat_diag_mult_left, auto)
  also have "... = (k \<cdot>\<^sub>m 1\<^sub>m n)" unfolding smult_mat_def by auto
  finally show ?thesis .
qed

lemma invertible_mat_four_block_mat_lower_right:
  assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat n n" and inv_A: "invertible_mat A"
  shows "invertible_mat (four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 n) (0\<^sub>m n 1) A)"
proof -
  let ?I = "(four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 n) (0\<^sub>m n 1) A)"
  have "Determinant.det ?I = Determinant.det (1\<^sub>m 1) * Determinant.det A"
    by (rule det_four_block_mat_lower_left_zero_col, insert assms, auto)
  also have "... = Determinant.det A" by auto
  finally have "Determinant.det ?I = Determinant.det A" .
  thus ?thesis
    by (metis (no_types, lifting) assms carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
        invertible_iff_is_unit_JNF)
qed

lemma invertible_mat_four_block_mat_lower_right_id:
  assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m m" and B: "B = 0\<^sub>m m (n-m)" and C: "C = 0\<^sub>m (n-m) m"
    and D: "D = 1\<^sub>m (n-m)" and "n>m" and inv_A: "invertible_mat A"
  shows "invertible_mat (four_block_mat A B C D)"
proof -
  have "Determinant.det (four_block_mat A B C D) = Determinant.det A"
    by (rule det_four_block_mat_lower_right_id, insert assms, auto)
  thus ?thesis using inv_A
    by (metis (no_types, lifting) assms(1) assms(4) carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
        invertible_iff_is_unit_JNF)
qed

lemma split_block4_decreases_dim_row:
  assumes E: "(A,B,C,D) = split_block E 1 1"
    and E1: "dim_row E > 1" and E2: "dim_col E > 1"
  shows "dim_row D < dim_row E"
proof -
  have "D \<in> carrier_mat (1 + (dim_row E - 2)) (1 + (dim_col E - 2))"
    by (rule split_block(4)[OF E[symmetric]], insert E1 E2, auto)
  hence "D \<in> carrier_mat (dim_row E - 1) (dim_col E - 1)" using E1 E2 by auto
  thus ?thesis using E1 by auto
qed

lemma inv_P'PAQQ':
  assumes A: "A \<in> carrier_mat n n"
    and P: "P \<in> carrier_mat n n"
    and inv_P: "inverts_mat P' P"
    and inv_Q: "inverts_mat Q Q'"
    and Q: "Q \<in> carrier_mat n n"
    and P': "P' \<in> carrier_mat n n"
    and Q': "Q' \<in> carrier_mat n n"
shows  "(P'*(P*A*Q)*Q') = A"
proof -
  have "(P'*(P*A*Q)*Q') = (P'*(P*A*Q*Q'))"
    by (smt P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mult_mat(2) index_mult_mat(3))
  also have "... = ((P'*P)*A*(Q*Q'))"
    by (smt A P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mult_mat(3) inv_Q inverts_mat_def right_mult_one_mat')
  finally show ?thesis
    by (metis P' Q A inv_P inv_Q carrier_matD(1) inverts_mat_def
        left_mult_one_mat right_mult_one_mat)
qed

lemma
  assumes "U \<in> carrier_mat 2 2" and "V \<in> carrier_mat 2 2" and "A = U * V"
shows mat_mult2_00: "A $$ (0,0) = U $$ (0,0)*V $$ (0,0) + U $$ (0,1)*V $$ (1,0)"
  and mat_mult2_01: "A $$ (0,1) = U $$ (0,0)*V $$ (0,1) + U $$ (0,1)*V $$ (1,1)"
  and mat_mult2_10: "A $$ (1,0) = U $$ (1,0)*V $$ (0,0) + U $$ (1,1)*V $$ (1,0)"
  and mat_mult2_11: "A $$ (1,1) = U $$ (1,0)*V $$ (0,1) + U $$ (1,1)*V $$ (1,1)"
    using assms unfolding times_mat_def Matrix.row_def col_def scalar_prod_def
    using sum_two_rw by auto

subsection\<open>Lemmas about @{text "sorted lists"}, @{text "insort"} and @{text "pick"}\<close>

lemma sorted_distinct_imp_sorted_wrt:
  assumes "sorted xs" and "distinct xs"
  shows "sorted_wrt (<) xs"
  using assms
  by (induct xs, insert le_neq_trans, auto)

lemma sorted_map_strict:
  assumes "strict_mono_on {0..<n} g"
  shows "sorted (map g [0..<n])"
  using assms
  by (induct n, auto simp add: sorted_append strict_mono_on_def less_imp_le)

lemma sorted_list_of_set_map_strict:
  assumes "strict_mono_on {0..<n} g"
  shows "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
  using assms
  proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  note sg = Suc.prems
  have sg_n: "strict_mono_on {0..<n} g" using sg unfolding strict_mono_on_def by auto
  have g_image_rw: "g ` {0..<Suc n} = insert (g n) (g ` {0..<n})"
    by (simp add: set_upt_Suc)
  have "sorted_list_of_set (g ` {0..<Suc n}) = sorted_list_of_set (insert (g n) (g ` {0..<n}))"
    using g_image_rw by simp
  also have "... = insort (g n) (sorted_list_of_set (g ` {0..<n}))"
  proof (rule sorted_list_of_set_insert)
    have "inj_on g {0..<Suc n}" using sg strict_mono_on_imp_inj_on by blast
    thus "g n \<notin> g ` {0..<n}" unfolding inj_on_def by fastforce
  qed (simp)
  also have "... = insort (g n) (map g [0..<n])"
    using Suc.hyps sg unfolding strict_mono_on_def by auto
  also have "... = map g [0..<Suc n]"
  proof (simp, rule sorted_insort_is_snoc)
    show "sorted (map g [0..<n])" by (rule sorted_map_strict[OF sg_n])
    show "\<forall>x\<in>set (map g [0..<n]). x \<le> g n" using sg unfolding strict_mono_on_def
      by (simp add: less_imp_le)
  qed
  finally show ?case .
qed

lemma sorted_nth_strict_mono:
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>i < j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i < xs!j"
  by (simp add: less_le nth_eq_iff_index_eq sorted_iff_nth_mono_less)

lemma sorted_list_of_set_0_LEAST:
  assumes finI: "finite I" and I: "I \<noteq> {}"
  shows "sorted_list_of_set I ! 0 = (LEAST n. n\<in>I)"
proof (rule Least_equality[symmetric])
  show "sorted_list_of_set I ! 0 \<in> I"
    by (metis I Max_in finI gr_zeroI in_set_conv_nth not_less_zero set_sorted_list_of_set)
  fix y assume "y \<in> I"
  thus "sorted_list_of_set I ! 0 \<le> y"
    by (metis eq_iff finI in_set_conv_nth neq0_conv sorted_iff_nth_mono_less
        sorted_list_of_set(1) sorted_sorted_list_of_set)
qed

lemma sorted_list_of_set_eq_pick:
  assumes i: "i < length (sorted_list_of_set I)"
  shows "sorted_list_of_set I ! i = pick I i"
proof -
  have finI: "finite I"
  proof (rule ccontr)
    assume "infinite I"
    hence "length (sorted_list_of_set I) = 0" by auto
    thus False using i by simp
  qed
  show ?thesis
  using i
proof (induct i)
  case 0
  have I: "I \<noteq> {}" using "0.prems" sorted_list_of_set_empty by blast
  show ?case unfolding pick.simps by (rule sorted_list_of_set_0_LEAST[OF finI I])
next
  case (Suc i)
  note x_less = Suc.prems
  show ?case
  proof (unfold pick.simps, rule Least_equality[symmetric], rule conjI)
    show 1: "pick I i < sorted_list_of_set I ! Suc i"
      by (metis Suc.hyps Suc.prems Suc_lessD distinct_sorted_list_of_set find_first_unique lessI
          nat_less_le sorted_sorted_list_of_set sorted_wrt_nth_less)
    show "sorted_list_of_set I ! Suc i \<in> I"
      using Suc.prems finI nth_mem set_sorted_list_of_set by blast
    have rw: "sorted_list_of_set I ! i = pick I i"
      using Suc.hyps Suc_lessD x_less by blast
    have sorted_less: "sorted_list_of_set I ! i < sorted_list_of_set I ! Suc i"
      by (simp add: 1 rw)
    fix y assume y: "y \<in> I \<and> pick I i < y"
    show "sorted_list_of_set I ! Suc i \<le> y"
      by (smt antisym_conv finI in_set_conv_nth less_Suc_eq less_Suc_eq_le nat_neq_iff rw
          sorted_iff_nth_mono_less sorted_list_of_set(1) sorted_sorted_list_of_set x_less y)
  qed
qed
qed

text\<open>$b$ is the position where we add, $a$ the element to be added and $i$ the position
  that is checked\<close>

lemma insort_nth':
  assumes "\<forall>j<b. xs ! j < a" and "sorted xs" and "a \<notin> set xs"
    and "i < length xs + 1" and "i < b"
    and "xs \<noteq> []" and "b < length xs"
  shows "insort a xs ! i = xs ! i"
  using assms
proof (induct xs arbitrary: a b i)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)
  note less = Cons.prems(1)
  note sorted = Cons.prems(2)
  note a_notin = Cons.prems(3)
  note i_length = Cons.prems(4)
  note i_b = Cons.prems(5)
  note b_length = Cons.prems(7)
  show ?case
  proof (cases "a \<le> x")
    case True
    have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
    also have "... =  (x # xs) ! i"
      using Cons.prems(1) Cons.prems(5) True by force
    finally show ?thesis .
  next
    case False note x_less_a = False
    have "insort a (x # xs) ! i = (x # insort a xs) ! i" using False by simp
    also have "... = (x # xs) ! i"
    proof (cases "i = 0")
      case True
      then show ?thesis by auto
    next
      case False
      have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
        by (simp add: False nth_Cons')
      also have "... = xs ! (i-1)"
      proof (rule Cons.hyps)
        show "sorted xs" using sorted by simp
        show "a \<notin> set xs" using a_notin by simp
        show "i - 1 < length xs + 1" using i_length False by auto
        show "xs \<noteq> []" using i_b b_length by force
        show "i - 1 < b - 1" by (simp add: False diff_less_mono i_b leI)
        show "b - 1 < length xs" using b_length i_b by auto
        show "\<forall>j<b - 1. xs ! j < a" using less less_diff_conv by auto
      qed
      also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
      finally show ?thesis .
    qed
    finally show ?thesis .
  qed
qed

lemma insort_nth:
  assumes  "sorted xs" and "a \<notin> set xs"
    and "i < index (insort a xs) a"
    and "xs \<noteq> []"
  shows "insort a xs ! i = xs ! i"
  using assms
proof (induct xs arbitrary: a i)
case Nil
  then show ?case by auto
next
  case (Cons x xs)
  note sorted = Cons.prems(1)
  note a_notin = Cons.prems(2)
  note i_index = Cons.prems(3)
  show ?case
  proof (cases "a \<le> x")
    case True
    have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
    also have "... = (x # xs) ! i"
      using Cons.prems(1) Cons.prems(3) True by force
    finally show ?thesis .
  next
    case False note x_less_a = False
    show ?thesis
    proof (cases "xs = []")
      case True
      have "x \<noteq> a" using False by auto
      then show ?thesis  using True i_index False by auto
    next
      case False note xs_not_empty = False
      have "insort a (x # xs) ! i = (x # insort a xs) ! i" using x_less_a by simp
      also have "... = (x # xs) ! i"
      proof (cases "i = 0")
        case True
        then show ?thesis by auto
      next
        case False note i0 = False
        have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
          by (simp add: False nth_Cons')
        also have "... = xs ! (i-1)"
        proof (rule Cons.hyps[OF _ _ _ xs_not_empty])
          show "sorted xs" using sorted by simp
          show "a \<notin> set xs" using a_notin by simp
          have "index (insort a (x # xs)) a = index ((x # insort a xs)) a"
            using x_less_a by auto
          also have "... = index (insort a xs) a + 1"
            unfolding index_Cons using x_less_a by simp
          finally show "i - 1 < index (insort a xs) a" using False i_index by linarith
        qed
        also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
        finally show ?thesis .
      qed
      finally show ?thesis .
    qed
  qed
qed

lemma insort_nth2:
  assumes "sorted xs" and "a \<notin> set xs"
    and "i < length xs" and "i \<ge> index (insort a xs) a"
    and "xs \<noteq> []"
  shows "insort a xs ! (Suc i) = xs ! i"
  using assms
proof (induct xs arbitrary: a i)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)
  note sorted = Cons.prems(1)
  note a_notin = Cons.prems(2)
  note i_length = Cons.prems(3)
  note index_i = Cons.prems(4)
  show ?case
  proof (cases "a \<le> x")
    case True
    have "insort a (x # xs) ! (Suc i) = (a # x # xs) ! (Suc i)" using True by simp
    also have "... =  (x # xs) ! i"
      using Cons.prems(1) Cons.prems(5) True by force
    finally show ?thesis .
  next
    case False note x_less_a = False
    have "insort a (x # xs) ! (Suc i) = (x # insort a xs) ! (Suc i)" using False by simp
    also have "... = (x # xs) ! i"
    proof (cases "i = 0")
        case True
        then show ?thesis using index_i linear x_less_a by fastforce
      next
        case False note i0 = False
        show ?thesis
        proof -
          have Suc_i: "Suc (i - 1) = i"
            using i0 by auto
          have "(x # insort a xs) ! (Suc i) = (insort a xs) ! i"
            by (simp add: nth_Cons')
          also have "... = (insort a xs) ! Suc (i - 1)" using Suc_i by simp
          also have "... = xs ! (i - 1)"
          proof (rule Cons.hyps)
            show "sorted xs" using sorted by simp
            show "a \<notin> set xs" using a_notin by simp
            show "i - 1 < length xs" using i_length using Suc_i by auto
            thus "xs \<noteq> []" by auto
            have "index (insort a (x # xs)) a = index ((x # insort a xs)) a" using x_less_a by simp
            also have "... = index (insort a xs) a + 1" unfolding index_Cons using x_less_a by simp
            finally show "index (insort a xs) a \<le> i - 1" using index_i i0 by auto
          qed
          also have "... = (x # xs) ! i" using Suc_i by auto
          finally show ?thesis .
        qed
      qed
      finally show ?thesis .
    qed
qed

lemma pick_index:
  assumes a: "a \<in> I" and a'_card: "a' < card I"
  shows "(pick I a' = a) = (index (sorted_list_of_set I) a = a')"
proof -
  have finI: "finite I" using a'_card card.infinite by force
  have length_I: "length (sorted_list_of_set I) = card I"
    by (metis a'_card card.infinite distinct_card distinct_sorted_list_of_set
        not_less_zero set_sorted_list_of_set)
  let ?i = "index (sorted_list_of_set I) a"
  have "(sorted_list_of_set I) ! a' = pick I a'"
    by (rule sorted_list_of_set_eq_pick, auto simp add: finI a'_card length_I)
  moreover have "(sorted_list_of_set I) ! ?i = a"
    by (rule nth_index, simp add: a finI)
  ultimately show ?thesis
    by (metis a'_card distinct_sorted_list_of_set index_nth_id length_I)
qed

end


(*  Title:      ZF/Resid/Confluence.thy
    Author:     Ole Rasmussen
    Copyright   1995  University of Cambridge
*)

theory Confluence imports Reduction begin

definition
  confluence    :: "i\<Rightarrow>o"  where
    "confluence(R) \<equiv>
       \<forall>x y. \<langle>x,y\<rangle> \<in> R \<longrightarrow> (\<forall>z.\<langle>x,z\<rangle> \<in> R \<longrightarrow> (\<exists>u.\<langle>y,u\<rangle> \<in> R \<and> \<langle>z,u\<rangle> \<in> R))"

definition
  strip         :: "o"  where
    "strip \<equiv> \<forall>x y. (x =\<Longrightarrow> y) \<longrightarrow>
                    (\<forall>z.(x =1\<Rightarrow> z) \<longrightarrow> (\<exists>u.(y =1\<Rightarrow> u) \<and> (z=\<Longrightarrow>u)))"

(* ------------------------------------------------------------------------- *)
(*        strip lemmas                                                       *)
(* ------------------------------------------------------------------------- *)

lemma strip_lemma_r:
    "\<lbrakk>confluence(Spar_red1)\<rbrakk>\<Longrightarrow> strip"
  unfolding confluence_def strip_def
apply (rule impI [THEN allI, THEN allI])
apply (erule Spar_red.induct, fast)
apply (fast intro: Spar_red.trans)
done

lemma strip_lemma_l:
    "strip\<Longrightarrow> confluence(Spar_red)"
  unfolding confluence_def strip_def
apply (rule impI [THEN allI, THEN allI])
apply (erule Spar_red.induct, blast)
apply clarify
apply (blast intro: Spar_red.trans)
done

(* ------------------------------------------------------------------------- *)
(*      Confluence                                                           *)
(* ------------------------------------------------------------------------- *)

lemma parallel_moves: "confluence(Spar_red1)"
apply (unfold confluence_def, clarify)
apply (frule simulation)
apply (frule_tac n = z in simulation, clarify)
apply (frule_tac v = va in paving)
apply (force intro: completeness)+
done

lemmas confluence_parallel_reduction =
      parallel_moves [THEN strip_lemma_r, THEN strip_lemma_l]

lemma lemma1: "\<lbrakk>confluence(Spar_red)\<rbrakk>\<Longrightarrow> confluence(Sred)"
by (unfold confluence_def, blast intro: par_red_red red_par_red)

lemmas confluence_beta_reduction =
       confluence_parallel_reduction [THEN lemma1]

(**** Conversion ****)

consts
  Sconv1        :: "i"
  Sconv         :: "i"

abbreviation
  Sconv1_rel (infixl \<open><-1->\<close> 50) where
  "a<-1->b \<equiv> \<langle>a,b\<rangle> \<in> Sconv1"

abbreviation
  Sconv_rel (infixl \<open><-\<longrightarrow>\<close> 50) where
  "a<-\<longrightarrow>b \<equiv> \<langle>a,b\<rangle> \<in> Sconv"

inductive
  domains       "Sconv1" \<subseteq> "lambda*lambda"
  intros
    red1:        "m -1-> n \<Longrightarrow> m<-1->n"
    expl:        "n -1-> m \<Longrightarrow> m<-1->n"
  type_intros    red1D1 red1D2 lambda.intros bool_typechecks

declare Sconv1.intros [intro]

inductive
  domains       "Sconv" \<subseteq> "lambda*lambda"
  intros
    one_step:    "m<-1->n  \<Longrightarrow> m<-\<longrightarrow>n"
    refl:        "m \<in> lambda \<Longrightarrow> m<-\<longrightarrow>m"
    trans:       "\<lbrakk>m<-\<longrightarrow>n; n<-\<longrightarrow>p\<rbrakk> \<Longrightarrow> m<-\<longrightarrow>p"
  type_intros    Sconv1.dom_subset [THEN subsetD] lambda.intros bool_typechecks

declare Sconv.intros [intro]

lemma conv_sym: "m<-\<longrightarrow>n \<Longrightarrow> n<-\<longrightarrow>m"
apply (erule Sconv.induct)
apply (erule Sconv1.induct, blast+)
done

(* ------------------------------------------------------------------------- *)
(*      Church_Rosser Theorem                                                *)
(* ------------------------------------------------------------------------- *)

lemma Church_Rosser: "m<-\<longrightarrow>n \<Longrightarrow> \<exists>p.(m -\<longrightarrow>p) \<and> (n -\<longrightarrow> p)"
apply (erule Sconv.induct)
apply (erule Sconv1.induct)
apply (blast intro: red1D1 redD2)
apply (blast intro: red1D1 redD2)
apply (blast intro: red1D1 redD2)
apply (cut_tac confluence_beta_reduction)
  unfolding confluence_def
apply (blast intro: Sred.trans)
done

end


header{* Right Complemented Monoid *}

theory RightComplementedMonoid
imports LeftComplementedMonoid
begin

class left_pordered_monoid_mult = order + monoid_mult +
  assumes mult_left_mono: "a \<le> b \<Longrightarrow> c * a \<le> c * b"

class integral_left_pordered_monoid_mult = left_pordered_monoid_mult + one_greatest

class right_residuated = ord + times + right_imp +
  assumes right_residual: "(a * x \<le> b) = (x \<le> a r\<rightarrow> b)"

class right_residuated_pordered_monoid = integral_left_pordered_monoid_mult + right_residuated

class right_inf = inf + times + right_imp +
  assumes inf_r_def: "(a \<sqinter> b)  = a * (a r\<rightarrow> b)"

class right_complemented_monoid = right_residuated_pordered_monoid + right_inf +
  assumes left_divisibility: "(a \<le> b) = (\<exists> c . a = b * c)"

sublocale right_complemented_monoid < dual!: left_complemented_monoid "\<lambda> a b . b * a" "op \<sqinter>" "op r\<rightarrow>" 1 "op \<le>" "op <"
  apply unfold_locales
  apply (simp_all add: inf_r_def mult.assoc mult_left_mono)
  apply (simp add: right_residual)
  by (simp add: left_divisibility)

context right_complemented_monoid begin
lemma rcm_D: "a r\<rightarrow> a = 1"
  by (rule dual.lcm_D)

subclass semilattice_inf
    by unfold_locales

lemma right_semilattice_inf: "class.semilattice_inf inf op \<le> op <"
  by unfold_locales

  lemma right_one_inf [simp]: "1 \<sqinter> a = a"
    by simp

  lemma right_one_impl [simp]: "1 r\<rightarrow> a = a"
    by simp

  lemma rcm_A: "a * (a r\<rightarrow> b) = b * (b r\<rightarrow> a)"
    by (rule dual.lcm_A)

  lemma rcm_B: "((b * a) r\<rightarrow> c) = (a r\<rightarrow> (b r\<rightarrow> c))"
    by (rule dual.lcm_B)

  lemma rcm_C: "(a \<le> b) = ((a r\<rightarrow> b) = 1)"
    by (rule dual.lcm_C)
  end

class right_complemented_monoid_nole_algebra = right_imp + one_times + right_inf + less_def +
  assumes right_impl_one [simp]: "a r\<rightarrow> a = 1"
  and right_impl_times: "a * (a r\<rightarrow> b) = b * (b r\<rightarrow> a)"
  and right_impl_ded: "((a * b) r\<rightarrow> c) = (b r\<rightarrow> (a r\<rightarrow> c))"

class right_complemented_monoid_algebra = right_complemented_monoid_nole_algebra +
  assumes right_lesseq: "(a \<le> b) = ((a r\<rightarrow> b) = 1)"
begin
end

sublocale right_complemented_monoid_algebra < dual_algebra!: left_complemented_monoid_algebra "\<lambda> a b . b * a" inf "op r\<rightarrow>" "op \<le>" "op <" 1
  apply (unfold_locales, simp_all)
  by (rule inf_r_def, rule right_impl_times, rule right_impl_ded, rule right_lesseq)

context right_complemented_monoid_algebra begin

subclass right_complemented_monoid
  apply unfold_locales
  apply simp_all
  apply (simp add: dual_algebra.mult.assoc)
  apply (simp add: dual_algebra.mult_right_mono)
  apply (simp add: dual_algebra.left_residual)
  by (simp add: dual_algebra.right_divisibility)
end

lemma (in right_complemented_monoid) right_complemented_monoid: "class.right_complemented_monoid_algebra (op \<le>) (op <) 1 (op *) inf (op r\<rightarrow>)"
  by (unfold_locales, simp_all add: less_le_not_le rcm_A rcm_B rcm_C rcm_D)

(*
sublocale right_complemented_monoid < rcm!: right_complemented_monoid_algebra "op \<le>" "op <" 1 "op *" inf "op r\<rightarrow>"
  by (unfold_locales, simp_all add: less_le_not_le rcm_A rcm_B rcm_C rcm_D)
*)

end