theory ToyList
imports Main
begin

text{*\noindent
HOL already has a predefined theory of lists called @{text List} ---
@{text ToyList} is merely a small fragment of it chosen as an example.
To avoid some ambiguities caused by defining lists twice, we manipulate
the concrete syntax and name space of theory @{theory Main} as follows.
*}

no_notation Nil ("[]") and Cons (infixr "#" 65) and append (infixr "@" 65)
hide_type list
hide_const rev

datatype 'a list = Nil                          ("[]")
                 | Cons 'a "'a list"            (infixr "#" 65)

text{*\noindent
The datatype\index{datatype@\isacommand {datatype} (command)}
\tydx{list} introduces two
constructors \cdx{Nil} and \cdx{Cons}, the
empty~list and the operator that adds an element to the front of a list. For
example, the term \isa{Cons True (Cons False Nil)} is a value of
type @{typ"bool list"}, namely the list with the elements @{term"True"} and
@{term"False"}. Because this notation quickly becomes unwieldy, the
datatype declaration is annotated with an alternative syntax: instead of
@{term[source]Nil} and \isa{Cons x xs} we can write
@{term"[]"}\index{$HOL2list@\isa{[]}|bold} and
@{term"x # xs"}\index{$HOL2list@\isa{\#}|bold}. In fact, this
alternative syntax is the familiar one.  Thus the list \isa{Cons True
(Cons False Nil)} becomes @{term"True # False # []"}. The annotation
\isacommand{infixr}\index{infixr@\isacommand{infixr} (annotation)}
means that @{text"#"} associates to
the right: the term @{term"x # y # z"} is read as @{text"x # (y # z)"}
and not as @{text"(x # y) # z"}.
The @{text 65} is the priority of the infix @{text"#"}.

\begin{warn}
  Syntax annotations can be powerful, but they are difficult to master and
  are never necessary.  You
  could drop them from theory @{text"ToyList"} and go back to the identifiers
  @{term[source]Nil} and @{term[source]Cons}.  Novices should avoid using
  syntax annotations in their own theories.
\end{warn}
Next, two functions @{text"app"} and \cdx{rev} are defined recursively,
in this order, because Isabelle insists on definition before use:
*}

primrec app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
"[] @ ys       = ys" |
"(x # xs) @ ys = x # (xs @ ys)"

primrec rev :: "'a list \<Rightarrow> 'a list" where
"rev []        = []" |
"rev (x # xs)  = (rev xs) @ (x # [])"

text{*\noindent
Each function definition is of the form
\begin{center}
\isacommand{primrec} \textit{name} @{text"::"} \textit{type} \textit{(optional syntax)} \isakeyword{where} \textit{equations}
\end{center}
The equations must be separated by @{text"|"}.
%
Function @{text"app"} is annotated with concrete syntax. Instead of the
prefix syntax @{text"app xs ys"} the infix
@{term"xs @ ys"}\index{$HOL2list@\isa{\at}|bold} becomes the preferred
form.

\index{*rev (constant)|(}\index{append function|(}
The equations for @{text"app"} and @{term"rev"} hardly need comments:
@{text"app"} appends two lists and @{term"rev"} reverses a list.  The
keyword \commdx{primrec} indicates that the recursion is
of a particularly primitive kind where each recursive call peels off a datatype
constructor from one of the arguments.  Thus the
recursion always terminates, i.e.\ the function is \textbf{total}.
\index{functions!total}

The termination requirement is absolutely essential in HOL, a logic of total
functions. If we were to drop it, inconsistencies would quickly arise: the
``definition'' $f(n) = f(n)+1$ immediately leads to $0 = 1$ by subtracting
$f(n)$ on both sides.
% However, this is a subtle issue that we cannot discuss here further.

\begin{warn}
  As we have indicated, the requirement for total functions is an essential characteristic of HOL\@. It is only
  because of totality that reasoning in HOL is comparatively easy.  More
  generally, the philosophy in HOL is to refrain from asserting arbitrary axioms (such as
  function definitions whose totality has not been proved) because they
  quickly lead to inconsistencies. Instead, fixed constructs for introducing
  types and functions are offered (such as \isacommand{datatype} and
  \isacommand{primrec}) which are guaranteed to preserve consistency.
\end{warn}

\index{syntax}%
A remark about syntax.  The textual definition of a theory follows a fixed
syntax with keywords like \isacommand{datatype} and \isacommand{end}.
% (see Fig.~\ref{fig:keywords} in Appendix~\ref{sec:Appendix} for a full list).
Embedded in this syntax are the types and formulae of HOL, whose syntax is
extensible (see \S\ref{sec:concrete-syntax}), e.g.\ by new user-defined infix operators.
To distinguish the two levels, everything
HOL-specific (terms and types) should be enclosed in
\texttt{"}\dots\texttt{"}.
To lessen this burden, quotation marks around a single identifier can be
dropped, unless the identifier happens to be a keyword, for example
\isa{"end"}.
When Isabelle prints a syntax error message, it refers to the HOL syntax as
the \textbf{inner syntax} and the enclosing theory language as the \textbf{outer syntax}.

Comments\index{comment} must be in enclosed in \texttt{(* }and\texttt{ *)}.

\section{Evaluation}
\index{evaluation}

Assuming you have processed the declarations and definitions of
\texttt{ToyList} presented so far, you may want to test your
functions by running them. For example, what is the value of
@{term"rev(True#False#[])"}? Command
*}

value "rev (True # False # [])"

text{* \noindent yields the correct result @{term"False # True # []"}.
But we can go beyond mere functional programming and evaluate terms with
variables in them, executing functions symbolically: *}

value "rev (a # b # c # [])"

text{*\noindent yields @{term"c # b # a # []"}.

\section{An Introductory Proof}
\label{sec:intro-proof}

Having convinced ourselves (as well as one can by testing) that our
definitions capture our intentions, we are ready to prove a few simple
theorems. This will illustrate not just the basic proof commands but
also the typical proof process.

\subsubsection*{Main Goal.}

Our goal is to show that reversing a list twice produces the original
list.
*}

theorem rev_rev [simp]: "rev(rev xs) = xs"

txt{*\index{theorem@\isacommand {theorem} (command)|bold}%
\noindent
This \isacommand{theorem} command does several things:
\begin{itemize}
\item
It establishes a new theorem to be proved, namely @{prop"rev(rev xs) = xs"}.
\item
It gives that theorem the name @{text"rev_rev"}, for later reference.
\item
It tells Isabelle (via the bracketed attribute \attrdx{simp}) to take the eventual theorem as a simplification rule: future proofs involving
simplification will replace occurrences of @{term"rev(rev xs)"} by
@{term"xs"}.
\end{itemize}
The name and the simplification attribute are optional.
Isabelle's response is to print the initial proof state consisting
of some header information (like how many subgoals there are) followed by
@{subgoals[display,indent=0]}
For compactness reasons we omit the header in this tutorial.
Until we have finished a proof, the \rmindex{proof state} proper
always looks like this:
\begin{isabelle}
~1.~$G\sb{1}$\isanewline
~~\vdots~~\isanewline
~$n$.~$G\sb{n}$
\end{isabelle}
The numbered lines contain the subgoals $G\sb{1}$, \dots, $G\sb{n}$
that we need to prove to establish the main goal.\index{subgoals}
Initially there is only one subgoal, which is identical with the
main goal. (If you always want to see the main goal as well,
set the flag \isa{Proof.show_main_goal}\index{*show_main_goal (flag)}
--- this flag used to be set by default.)

Let us now get back to @{prop"rev(rev xs) = xs"}. Properties of recursively
defined functions are best established by induction. In this case there is
nothing obvious except induction on @{term"xs"}:
*}

apply(induct_tac xs)

txt{*\noindent\index{*induct_tac (method)}%
This tells Isabelle to perform induction on variable @{term"xs"}. The suffix
@{term"tac"} stands for \textbf{tactic},\index{tactics}
a synonym for ``theorem proving function''.
By default, induction acts on the first subgoal. The new proof state contains
two subgoals, namely the base case (@{term[source]Nil}) and the induction step
(@{term[source]Cons}):
@{subgoals[display,indent=0,margin=65]}

The induction step is an example of the general format of a subgoal:\index{subgoals}
\begin{isabelle}
~$i$.~{\isasymAnd}$x\sb{1}$~\dots$x\sb{n}$.~{\it assumptions}~{\isasymLongrightarrow}~{\it conclusion}
\end{isabelle}\index{$IsaAnd@\isasymAnd|bold}
The prefix of bound variables \isasymAnd$x\sb{1}$~\dots~$x\sb{n}$ can be
ignored most of the time, or simply treated as a list of variables local to
this subgoal. Their deeper significance is explained in Chapter~\ref{chap:rules}.
The {\it assumptions}\index{assumptions!of subgoal}
are the local assumptions for this subgoal and {\it
  conclusion}\index{conclusion!of subgoal} is the actual proposition to be proved.
Typical proof steps
that add new assumptions are induction and case distinction. In our example
the only assumption is the induction hypothesis @{term"rev (rev list) =
  list"}, where @{term"list"} is a variable name chosen by Isabelle. If there
are multiple assumptions, they are enclosed in the bracket pair
\indexboldpos{\isasymlbrakk}{$Isabrl} and
\indexboldpos{\isasymrbrakk}{$Isabrr} and separated by semicolons.

Let us try to solve both goals automatically:
*}

apply(auto)

txt{*\noindent
This command tells Isabelle to apply a proof strategy called
@{text"auto"} to all subgoals. Essentially, @{text"auto"} tries to
simplify the subgoals.  In our case, subgoal~1 is solved completely (thanks
to the equation @{prop"rev [] = []"}) and disappears; the simplified version
of subgoal~2 becomes the new subgoal~1:
@{subgoals[display,indent=0,margin=70]}
In order to simplify this subgoal further, a lemma suggests itself.
*}
(*<*)
oops
(*>*)

subsubsection{*First Lemma*}

text{*
\indexbold{abandoning a proof}\indexbold{proofs!abandoning}
After abandoning the above proof attempt (at the shell level type
\commdx{oops}) we start a new proof:
*}

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"

txt{*\noindent The keywords \commdx{theorem} and
\commdx{lemma} are interchangeable and merely indicate
the importance we attach to a proposition.  Therefore we use the words
\emph{theorem} and \emph{lemma} pretty much interchangeably, too.

There are two variables that we could induct on: @{term"xs"} and
@{term"ys"}. Because @{text"@"} is defined by recursion on
the first argument, @{term"xs"} is the correct one:
*}

apply(induct_tac xs)

txt{*\noindent
This time not even the base case is solved automatically:
*}

apply(auto)

txt{*
@{subgoals[display,indent=0,goals_limit=1]}
Again, we need to abandon this proof attempt and prove another simple lemma
first. In the future the step of abandoning an incomplete proof before
embarking on the proof of a lemma usually remains implicit.
*}
(*<*)
oops
(*>*)

subsubsection{*Second Lemma*}

text{*
We again try the canonical proof procedure:
*}

lemma app_Nil2 [simp]: "xs @ [] = xs"
apply(induct_tac xs)
apply(auto)

txt{*
\noindent
It works, yielding the desired message @{text"No subgoals!"}:
@{goals[display,indent=0]}
We still need to confirm that the proof is now finished:
*}

done

text{*\noindent
As a result of that final \commdx{done}, Isabelle associates the lemma just proved
with its name. In this tutorial, we sometimes omit to show that final \isacommand{done}
if it is obvious from the context that the proof is finished.

% Instead of \isacommand{apply} followed by a dot, you can simply write
% \isacommand{by}\indexbold{by}, which we do most of the time.
Notice that in lemma @{thm[source]app_Nil2},
as printed out after the final \isacommand{done}, the free variable @{term"xs"} has been
replaced by the unknown @{text"?xs"}, just as explained in
\S\ref{sec:variables}.

Going back to the proof of the first lemma
*}

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"
apply(induct_tac xs)
apply(auto)

txt{*
\noindent
we find that this time @{text"auto"} solves the base case, but the
induction step merely simplifies to
@{subgoals[display,indent=0,goals_limit=1]}
Now we need to remember that @{text"@"} associates to the right, and that
@{text"#"} and @{text"@"} have the same priority (namely the @{text"65"}
in their \isacommand{infixr} annotation). Thus the conclusion really is
\begin{isabelle}
~~~~~(rev~ys~@~rev~list)~@~(a~\#~[])~=~rev~ys~@~(rev~list~@~(a~\#~[]))
\end{isabelle}
and the missing lemma is associativity of @{text"@"}.
*}
(*<*)oops(*>*)

subsubsection{*Third Lemma*}

text{*
Abandoning the previous attempt, the canonical proof procedure
succeeds without further ado.
*}

lemma app_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
apply(induct_tac xs)
apply(auto)
done

text{*
\noindent
Now we can prove the first lemma:
*}

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"
apply(induct_tac xs)
apply(auto)
done

text{*\noindent
Finally, we prove our main theorem:
*}

theorem rev_rev [simp]: "rev(rev xs) = xs"
apply(induct_tac xs)
apply(auto)
done

text{*\noindent
The final \commdx{end} tells Isabelle to close the current theory because
we are finished with its development:%
\index{*rev (constant)|)}\index{append function|)}
*}

end


theory Exercise7p3
imports Bigstep_sseefried
begin

fun deskip :: "com \<Rightarrow> com" where
    "deskip SKIP          = SKIP"
 |  "deskip (Assign v e)  = Assign v e"
 |  "deskip (Seq c1 c2) =
      (case (deskip c1, deskip c2) of
         (SKIP, SKIP)  \<Rightarrow> SKIP
       | (SKIP, q)    \<Rightarrow> q
       | (p, SKIP)    \<Rightarrow> p
       | (p, q)      \<Rightarrow> (p;;q))"
 |  "deskip (If b c1 c2)  =
      (case (deskip c1, deskip c2) of
         (SKIP, SKIP) \<Rightarrow> SKIP
       | (p, q)       \<Rightarrow> If b p q)"
 |  "deskip (While b c)   = While b (deskip c)"

print_theorems

value "deskip (SKIP;; WHILE b DO (x ::= a;; SKIP))"

lemma skip2: "c ;; SKIP \<sim> c"
proof (induction c)
qed auto+

lemma "deskip c \<sim> c"
proof (induction c)
  case (While b c)
  thus "deskip (WHILE b DO c) \<sim> WHILE b DO c" by (simp add: while_equiv)
next
  case (Seq c1 c2)
  have a: "(deskip c1;; deskip c2) \<sim> c1;; c2" using Seq.IH by auto
  (* Use split any time you have a case inside your function definition. *)
  have "(deskip c1;; deskip c2) \<sim> deskip (c1;;c2)" using Seq.IH by (auto split: com.split)
  thus "deskip (c1 ;; c2) \<sim> c1 ;; c2" using a by auto
next
  case (If b c1 c2)
  have a: "If b (deskip c1) (deskip c2) \<sim> If b c1 c2" using If.IH by auto
  (* Use split any time you have a case inside your function definition *)
  have "If b (deskip c1) (deskip c2) \<sim> deskip (If b c1 c2)" using If.IH if_equiv by (auto split: com.split)
  thus "deskip (If b c1 c2) \<sim> If b c1 c2" using a by auto
qed auto+

end


section \<open>IO Automaton\<close>

(*<*)
theory IO_Automaton
imports Trivia
begin
(*>*)

subsection\<open>Preliminaries\<close>

text \<open>Transitions\<close>

datatype ('state,'act,'out) trans =
Trans (srcOf: 'state) (actOf: 'act) (outOf: 'out) (tgtOf: 'state)

type_synonym ('state,'act,'out) trace = "('state,'act,'out) trans list"

locale IO_Automaton =
fixes istate :: "'state" (* initial step *)
  and step :: "'state \<Rightarrow> 'act \<Rightarrow> 'out * 'state"  (* transition function *)
begin

subsection\<open>Reachability and invariance\<close>

(* Reachable states: *)
inductive reach :: "'state \<Rightarrow> bool" where
Istate: "reach istate"
|
Step: "reach s \<Longrightarrow> reach (snd (step s a))"

lemma reach_PairI:
assumes "reach s" and "step s a = (ou, s')"
shows "reach s'"
by (metis Step assms assms snd_eqD)

(* holds at the initial state: *)
definition holdsIstate :: "('state \<Rightarrow> bool) \<Rightarrow> bool" where
"holdsIstate \<phi> \<equiv> \<phi> istate"

(* is invariant: *)
definition invar :: "('state \<Rightarrow> bool) \<Rightarrow> bool" where
"invar \<phi> \<equiv> \<forall> s a. reach s \<and> \<phi> s \<longrightarrow> \<phi> (snd (step s a))"

lemma holdsIstate_invar:
assumes h: "holdsIstate \<phi>" and i: "invar \<phi>" and a: "reach s"
shows "\<phi> s"
using a apply (induct rule: reach.induct)
using h i unfolding holdsIstate_def invar_def by auto

subsection\<open>System traces\<close>

(* The output and effect of an action on a state: *)
definition out :: "'state \<Rightarrow> 'act \<Rightarrow> 'out" where "out s a \<equiv> fst (step s a)"
definition eff :: "'state \<Rightarrow> 'act \<Rightarrow> 'state" where "eff s a \<equiv> snd (step s a)"

primrec validTrans :: "('state,'act,'out) trans \<Rightarrow> bool" where
"validTrans (Trans s a ou s') = (step s a = (ou, s'))"

lemma validTrans:
"validTrans trn =
 (step (srcOf trn) (actOf trn) = (outOf trn, tgtOf trn))"
by (cases trn) auto

(* Traces allowed by the system (starting in any given state) *)
(* Two alternative definitions: growing from the left and growing from the right: *)
inductive valid :: "('state,'act,'out) trace \<Rightarrow> bool" where
Singl[simp,intro!]:
"validTrans trn
 \<Longrightarrow>
 valid [trn]"
|
Cons[intro]:
"\<lbrakk>validTrans trn; tgtOf trn = srcOf (hd tr); valid tr\<rbrakk>
 \<Longrightarrow>
 valid (trn # tr)"

inductive_cases valid_SinglE[elim!]: "valid [trn]"
inductive_cases valid_ConsE[elim]: "valid (trn # tr)"

inductive valid2 :: "('state,'act,'out) trace \<Rightarrow> bool" where
Singl[simp,intro!]:
"validTrans trn
 \<Longrightarrow>
 valid2 [trn]"
|
Rcons[intro]:
"\<lbrakk>valid2 tr; tgtOf (last tr) = srcOf trn; validTrans trn\<rbrakk>
 \<Longrightarrow>
 valid2 (tr ## trn)"

inductive_cases valid2_SinglE[elim!]: "valid2 [trn]"
inductive_cases valid2_RconsE[elim]: "valid2 (tr ## trn)"

lemma Nil_not_valid[simp]: "\<not> valid []"
by (metis valid.simps neq_Nil_conv)

lemma Nil_not_valid2[simp]: "\<not> valid2 []"
by (metis valid2.cases append_Nil butlast.simps butlast_snoc not_Cons_self2)

lemma valid_Rcons:
assumes "valid tr" and "tgtOf (last tr) = srcOf trn" and "validTrans trn"
shows "valid (tr ## trn)"
using assms proof(induct arbitrary: trn)
  case (Cons trn tr trna)
  thus ?case by (cases tr) (auto intro: valid.Cons)
qed(auto intro: valid.intros)

lemma valid_hd_Rcons[simp]:
assumes "valid tr"
shows "hd (tr ## tran) = hd tr"
by (metis Nil_not_valid assms hd_append)

lemma valid2_hd_Rcons[simp]:
assumes "valid2 tr"
shows "hd (tr ## tran) = hd tr"
by (metis Nil_not_valid2 assms hd_append)

lemma valid2_last_Cons[simp]:
assumes "valid2 tr"
shows "last (tran # tr) = last tr"
by (metis Nil_not_valid2 assms last.simps)

lemma valid2_Cons:
assumes "valid2 tr" and "tgtOf trn = srcOf (hd tr)" and "validTrans trn"
shows "valid2 (trn # tr)"
using assms proof(induct arbitrary: trn)
  case Singl  show ?case
  unfolding two_singl_Rcons using Singl
  by (intro valid2.Rcons) (auto intro: valid2.Singl)
next
  case Rcons show ?case
  unfolding append.append_Cons[symmetric] using Rcons by (intro valid2.Rcons) auto
qed

lemma valid_valid2: "valid = valid2"
proof(rule ext, safe)
  fix tr assume "valid tr"  thus "valid2 tr"
  by (induct) (auto intro: valid2.Singl valid2_Cons)
next
  fix tr assume "valid2 tr"  thus "valid tr"
  by (induct) (auto intro: valid.Singl valid_Rcons)
qed

lemmas valid2_valid = valid_valid2[symmetric]

definition validFrom :: "'state \<Rightarrow> ('state,'act,'out) trace \<Rightarrow> bool" where
"validFrom s tr \<equiv> tr = [] \<or> (valid tr \<and> srcOf (hd tr) = s)"

lemma validFrom_Nil[simp,intro!]: "validFrom s []"
unfolding validFrom_def by auto

lemma validFrom_valid[simp,intro]: "valid tr \<and> srcOf (hd tr) = s \<Longrightarrow> validFrom s tr"
unfolding validFrom_def by auto

lemma validFrom_validTrans[intro]:
assumes "validTrans (Trans s a ou s')" and "validFrom s' tr"
shows "validFrom s (Trans s a ou s' # tr)"
using assms unfolding validFrom_def by auto

subsection \<open>Traces versus reachability\<close>

lemma valid_reach_src_tgt:
assumes "valid tr" and "reach (srcOf (hd tr))"
shows "reach (tgtOf (last tr))"
using assms by induct (auto intro: reach_PairI simp: validTrans)

lemma valid_init_reach:
assumes "valid tr" and "srcOf (hd tr) = istate"
shows "reach (tgtOf (last tr))"
using valid_reach_src_tgt assms reach.Istate by metis

lemma Trans_fst_sndI:
"valid [Trans s a (fst (step s a)) (snd (step s a))]"
by (metis valid.Singl surjective_pairing validTrans.simps)

lemma reach_init_valid:
assumes "reach s"
shows
"s = istate
 \<or>
 (\<exists> tr. valid tr \<and> srcOf (hd tr) = istate \<and> tgtOf (last tr) = s)"
using assms proof induction
  case (Step s a)
  thus ?case proof(elim disjE exE conjE)
    assume s: "s = istate"
    let ?ou = "fst (step s a)"  let ?s' = "snd (step s a)"
    show ?thesis using s
    by (intro disjI2 exI[of _ "[Trans s a ?ou ?s']"]) auto
  next
    fix tr assume v: "valid tr" and s: "srcOf (hd tr) = istate" and t: "tgtOf (last tr) = s"
    let ?ou = "fst (step s a)"  let ?s' = "snd (step s a)"
    show ?thesis using v t s
    by (intro disjI2 exI[of _ "tr ## Trans s a ?ou ?s'"]) (auto intro: valid_Rcons)
  qed
qed auto

lemma reach_validFrom:
assumes "reach s'"
shows "\<exists> s tr. s = istate \<and> (s = s' \<or> (validFrom s tr \<and> tgtOf (last tr) = s'))"
using reach_init_valid[OF assms] unfolding validFrom_def by auto

(*<*)

end (* locale IO_Automaton *)

end

(*>*)


(* Author: Alexander Maletzky *)

section \<open>Auto-reducing Lists of Polynomials\<close>

theory Auto_Reduction
  imports Reduction More_MPoly_Type_Class
begin

subsection \<open>Reduction and Monic Sets\<close>

context ordered_term
begin

lemma is_red_monic: "is_red B (monic p) \<longleftrightarrow> is_red B p"
  unfolding is_red_adds_iff keys_monic ..

lemma red_image_monic [simp]: "red (monic ` B) = red B"
proof (rule, rule)
  fix p q
  show "red (monic ` B) p q \<longleftrightarrow> red B p q"
  proof
    assume "red (monic ` B) p q"
    then obtain f t where "f \<in> monic ` B" and *: "red_single p q f t" by (rule red_setE)
    from this(1) obtain g where "g \<in> B" and "f = monic g" ..
    from * have "f \<noteq> 0" by (simp add: red_single_def)
    hence "g \<noteq> 0" by (simp add: monic_0_iff \<open>f = monic g\<close>)
    hence "lc g \<noteq> 0" by (rule lc_not_0)
    have eq: "monom_mult (lc g) 0 f = g" by (simp add: \<open>f = monic g\<close> mult_lc_monic[OF \<open>g \<noteq> 0\<close>])
    from \<open>g \<in> B\<close> show "red B p q"
    proof (rule red_setI)
      from * \<open>lc g \<noteq> 0\<close> have "red_single p q (monom_mult (lc g) 0 f) t" by (rule red_single_mult_const)
      thus "red_single p q g t" by (simp only: eq)
    qed
  next
    assume "red B p q"
    then obtain f t where "f \<in> B" and *: "red_single p q f t" by (rule red_setE)
    from * have "f \<noteq> 0" by (simp add: red_single_def)
    hence "lc f \<noteq> 0" by (rule lc_not_0)
    hence "1 / lc f \<noteq> 0" by simp
    from \<open>f \<in> B\<close> have "monic f \<in> monic ` B" by (rule imageI)
    thus "red (monic ` B) p q"
    proof (rule red_setI)
      from * \<open>1 / lc f \<noteq> 0\<close> show "red_single p q (monic f) t" unfolding monic_def
        by (rule red_single_mult_const)
    qed
  qed
qed

lemma is_red_image_monic [simp]: "is_red (monic ` B) p \<longleftrightarrow> is_red B p"
  by (simp add: is_red_def)

subsection \<open>Minimal Bases and Auto-reduced Bases\<close>

definition is_auto_reduced :: "('t \<Rightarrow>\<^sub>0 'b::field) set \<Rightarrow> bool" where
  "is_auto_reduced B \<equiv> (\<forall>b\<in>B. \<not> is_red (B - {b}) b)"

definition is_minimal_basis :: "('t \<Rightarrow>\<^sub>0 'b::zero) set \<Rightarrow> bool" where
  "is_minimal_basis B \<longleftrightarrow> (0 \<notin> B \<and> (\<forall>p q. p \<in> B \<longrightarrow> q \<in> B \<longrightarrow> p \<noteq> q \<longrightarrow> \<not> lt p adds\<^sub>t lt q))"

lemma is_auto_reducedD:
  assumes "is_auto_reduced B" and "b \<in> B"
  shows "\<not> is_red (B - {b}) b"
  using assms unfolding is_auto_reduced_def by auto

text \<open>The converse of the following lemma is only true if @{term B} is minimal!\<close>
lemma image_monic_is_auto_reduced:
  assumes "is_auto_reduced B"
  shows "is_auto_reduced (monic ` B)"
  unfolding is_auto_reduced_def
proof
  fix b
  assume "b \<in> monic ` B"
  then obtain b' where b_def: "b = monic b'" and "b' \<in> B" ..
  from assms \<open>b' \<in> B\<close> have nred: "\<not> is_red (B - {b'}) b'" by (rule is_auto_reducedD)
  show "\<not> is_red ((monic ` B) - {b}) b"
  proof
    assume red: "is_red ((monic ` B) - {b}) b"
    have "(monic ` B) - {b} \<subseteq> monic ` (B - {b'})" unfolding b_def by auto
    with red have "is_red (monic ` (B - {b'})) b" by (rule is_red_subset)
    hence "is_red (B - {b'}) b'" unfolding b_def is_red_monic is_red_image_monic .
    with nred show False ..
  qed
qed

lemma is_minimal_basisI:
  assumes "\<And>p. p \<in> B \<Longrightarrow> p \<noteq> 0" and "\<And>p q. p \<in> B \<Longrightarrow> q \<in> B \<Longrightarrow> p \<noteq> q \<Longrightarrow> \<not> lt p adds\<^sub>t lt q"
  shows "is_minimal_basis B"
  unfolding is_minimal_basis_def using assms by auto

lemma is_minimal_basisD1:
  assumes "is_minimal_basis B" and "p \<in> B"
  shows "p \<noteq> 0"
  using assms unfolding is_minimal_basis_def by auto

lemma is_minimal_basisD2:
  assumes "is_minimal_basis B" and "p \<in> B" and "q \<in> B" and "p \<noteq> q"
  shows "\<not> lt p adds\<^sub>t lt q"
  using assms unfolding is_minimal_basis_def by auto

lemma is_minimal_basisD3:
  assumes "is_minimal_basis B" and "p \<in> B" and "q \<in> B" and "p \<noteq> q"
  shows "\<not> lt q adds\<^sub>t lt p"
  using assms unfolding is_minimal_basis_def by auto

lemma is_minimal_basis_subset:
  assumes "is_minimal_basis B" and "A \<subseteq> B"
  shows "is_minimal_basis A"
proof (intro is_minimal_basisI)
  fix p
  assume "p \<in> A"
  with \<open>A \<subseteq> B\<close> have "p \<in> B" ..
  with \<open>is_minimal_basis B\<close> show "p \<noteq> 0" by (rule is_minimal_basisD1)
next
  fix p q
  assume "p \<in> A" and "q \<in> A" and "p \<noteq> q"
  from \<open>p \<in> A\<close> and \<open>q \<in> A\<close> have "p \<in> B" and "q \<in> B" using \<open>A \<subseteq> B\<close> by auto
  from \<open>is_minimal_basis B\<close> this \<open>p \<noteq> q\<close> show " \<not> lt p adds\<^sub>t lt q" by (rule is_minimal_basisD2)
qed

lemma nadds_red:
  assumes nadds: "\<And>q. q \<in> B \<Longrightarrow> \<not> lt q adds\<^sub>t lt p" and red: "red B p r"
  shows "r \<noteq> 0 \<and> lt r = lt p"
proof -
  from red obtain q t where "q \<in> B" and rs: "red_single p r q t" by (rule red_setE)
  from rs have "q \<noteq> 0" and "lookup p (t \<oplus> lt q) \<noteq> 0"
    and r_def: "r = p - monom_mult (lookup p (t \<oplus> lt q) / lc q) t q" unfolding red_single_def by simp_all
  have "t \<oplus> lt q \<preceq>\<^sub>t lt p" by (rule lt_max, fact)
  moreover have "t \<oplus> lt q \<noteq> lt p"
  proof
    assume "t \<oplus> lt q = lt p"
    hence "lt q adds\<^sub>t lt p" by (metis adds_term_triv)
    with nadds[OF \<open>q \<in> B\<close>] show False ..
  qed
  ultimately have "t \<oplus> lt q \<prec>\<^sub>t lt p" by simp
  let ?m = "monom_mult (lookup p (t \<oplus> lt q) / lc q) t q"
  from \<open>lookup p (t \<oplus> lt q) \<noteq> 0\<close> lc_not_0[OF \<open>q \<noteq> 0\<close>] have c0: "lookup p (t \<oplus> lt q) / lc q \<noteq> 0" by simp
  from \<open>q \<noteq> 0\<close> c0 have "?m \<noteq> 0" by (simp add: monom_mult_eq_zero_iff)
  have "lt (-?m) = lt ?m" by (fact lt_uminus)
  also have lt1: "lt ?m = t \<oplus> lt q" by (rule lt_monom_mult, fact+)
  finally have lt2: "lt (-?m) = t \<oplus> lt q" .

  show ?thesis
  proof
    show "r \<noteq> 0"
    proof
      assume "r = 0"
      hence "p = ?m" unfolding r_def by simp
      with lt1 \<open>t \<oplus> lt q \<noteq> lt p\<close> show False by simp
    qed
  next
    have "lt (-?m + p) = lt p"
    proof (rule lt_plus_eqI)
      show "lt (-?m) \<prec>\<^sub>t lt p" unfolding lt2 by fact
    qed
    thus "lt r = lt p" unfolding r_def by simp
  qed
qed

lemma nadds_red_nonzero:
  assumes nadds: "\<And>q. q \<in> B \<Longrightarrow> \<not> lt q adds\<^sub>t lt p" and "red B p r"
  shows "r \<noteq> 0"
  using nadds_red[OF assms] by simp

lemma nadds_red_lt:
  assumes nadds: "\<And>q. q \<in> B \<Longrightarrow> \<not> lt q adds\<^sub>t lt p" and "red B p r"
  shows "lt r = lt p"
  using nadds_red[OF assms] by simp

lemma nadds_red_rtrancl_lt:
  assumes nadds: "\<And>q. q \<in> B \<Longrightarrow> \<not> lt q adds\<^sub>t lt p" and rtrancl: "(red B)\<^sup>*\<^sup>* p r"
  shows "lt r = lt p"
  using rtrancl
proof (induct rule: rtranclp_induct)
  case base
  show ?case ..
next
  case (step y z)
  have "lt z = lt y"
  proof (rule nadds_red_lt)
    fix q
    assume "q \<in> B"
    thus "\<not> lt q adds\<^sub>t lt y" unfolding \<open>lt y = lt p\<close> by (rule nadds)
  qed fact
  with \<open>lt y = lt p\<close> show ?case by simp
qed

lemma nadds_red_rtrancl_nonzero:
  assumes nadds: "\<And>q. q \<in> B \<Longrightarrow> \<not> lt q adds\<^sub>t lt p" and "p \<noteq> 0" and rtrancl: "(red B)\<^sup>*\<^sup>* p r"
  shows "r \<noteq> 0"
  using rtrancl
proof (induct rule: rtranclp_induct)
  case base
  show ?case by fact
next
  case (step y z)
  from nadds \<open>(red B)\<^sup>*\<^sup>* p y\<close> have "lt y = lt p" by (rule nadds_red_rtrancl_lt)
  show "z \<noteq> 0"
  proof (rule nadds_red_nonzero)
    fix q
    assume "q \<in> B"
    thus "\<not> lt q adds\<^sub>t lt y" unfolding \<open>lt y = lt p\<close> by (rule nadds)
  qed fact
qed

lemma minimal_basis_red_rtrancl_nonzero:
  assumes "is_minimal_basis B" and "p \<in> B" and "(red (B - {p}))\<^sup>*\<^sup>* p r"
  shows "r \<noteq> 0"
proof (rule nadds_red_rtrancl_nonzero)
  fix q
  assume "q \<in> (B - {p})"
  hence "q \<in> B" and "q \<noteq> p" by auto
  show "\<not> lt q adds\<^sub>t lt p" by (rule is_minimal_basisD2, fact+)
next
  show "p \<noteq> 0" by (rule is_minimal_basisD1, fact+)
qed fact

lemma minimal_basis_red_rtrancl_lt:
  assumes "is_minimal_basis B" and "p \<in> B" and "(red (B - {p}))\<^sup>*\<^sup>* p r"
  shows "lt r = lt p"
proof (rule nadds_red_rtrancl_lt)
  fix q
  assume "q \<in> (B - {p})"
  hence "q \<in> B" and "q \<noteq> p" by auto
  show "\<not> lt q adds\<^sub>t lt p" by (rule is_minimal_basisD2, fact+)
qed fact

lemma is_minimal_basis_replace:
  assumes major: "is_minimal_basis B" and "p \<in> B" and red: "(red (B - {p}))\<^sup>*\<^sup>* p r"
  shows "is_minimal_basis (insert r (B - {p}))"
proof (rule is_minimal_basisI)
  fix q
  assume "q \<in> insert r (B - {p})"
  hence "q = r \<or> q \<in> B \<and> q \<noteq> p" by simp
  thus "q \<noteq> 0"
  proof
    assume "q = r"
    from assms show ?thesis unfolding \<open>q = r\<close> by (rule minimal_basis_red_rtrancl_nonzero)
  next
    assume "q \<in> B \<and> q \<noteq> p"
    hence "q \<in> B" ..
    with major show ?thesis by (rule is_minimal_basisD1)
  qed
next
  fix a b
  assume "a \<in> insert r (B - {p})" and "b \<in> insert r (B - {p})" and "a \<noteq> b"
  from assms have ltr: "lt r = lt p" by (rule minimal_basis_red_rtrancl_lt)
  from \<open>b \<in> insert r (B - {p})\<close> have b: "b = r \<or> b \<in> B \<and> b \<noteq> p" by simp
  from \<open>a \<in> insert r (B - {p})\<close> have "a = r \<or> a \<in> B \<and> a \<noteq> p" by simp
  thus "\<not> lt a adds\<^sub>t lt b"
  proof
    assume "a = r"
    hence lta: "lt a = lt p" using ltr by simp
    from b show ?thesis
    proof
      assume "b = r"
      with \<open>a \<noteq> b\<close> show ?thesis unfolding \<open>a = r\<close> by simp
    next
      assume "b \<in> B \<and> b \<noteq> p"
      hence "b \<in> B" and "p \<noteq> b" by auto
      with major \<open>p \<in> B\<close> have "\<not> lt p adds\<^sub>t lt b" by (rule is_minimal_basisD2)
      thus ?thesis unfolding lta .
    qed
  next
    assume "a \<in> B \<and> a \<noteq> p"
    hence "a \<in> B" and "a \<noteq> p" by simp_all
    from b show ?thesis
    proof
      assume "b = r"
      from major \<open>a \<in> B\<close> \<open>p \<in> B\<close> \<open>a \<noteq> p\<close> have "\<not> lt a adds\<^sub>t lt p" by (rule is_minimal_basisD2)
      thus ?thesis unfolding \<open>b = r\<close> ltr by simp
    next
      assume "b \<in> B \<and> b \<noteq> p"
      hence "b \<in> B" ..
      from major \<open>a \<in> B\<close> \<open>b \<in> B\<close> \<open>a \<noteq> b\<close> show ?thesis by (rule is_minimal_basisD2)
    qed
  qed
qed

subsection \<open>Computing Minimal Bases\<close>

definition comp_min_basis :: "('t \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero) list" where
  "comp_min_basis xs = filter_min (\<lambda>x y. lt x adds\<^sub>t lt y) (filter (\<lambda>x. x \<noteq> 0) xs)"

lemma comp_min_basis_subset': "set (comp_min_basis xs) \<subseteq> {x \<in> set xs. x \<noteq> 0}"
proof -
  have "set (comp_min_basis xs) \<subseteq> set (filter (\<lambda>x. x \<noteq> 0) xs)"
    unfolding comp_min_basis_def by (rule filter_min_subset)
  also have "\<dots> = {x \<in> set xs. x \<noteq> 0}" by simp
  finally show ?thesis .
qed

lemma comp_min_basis_subset: "set (comp_min_basis xs) \<subseteq> set xs"
proof -
  have "set (comp_min_basis xs) \<subseteq> {x \<in> set xs. x \<noteq> 0}" by (rule comp_min_basis_subset')
  also have "... \<subseteq> set xs" by simp
  finally show ?thesis .
qed

lemma comp_min_basis_nonzero: "p \<in> set (comp_min_basis xs) \<Longrightarrow> p \<noteq> 0"
  using comp_min_basis_subset' by blast

lemma comp_min_basis_adds:
  assumes "p \<in> set xs" and "p \<noteq> 0"
  obtains q where "q \<in> set (comp_min_basis xs)" and "lt q adds\<^sub>t lt p"
proof -
  let ?rel = "(\<lambda>x y. lt x adds\<^sub>t lt y)"
  have "transp ?rel" by (auto intro!: transpI dest: adds_term_trans)
  moreover have "reflp ?rel" by (simp add: reflp_def adds_term_refl)
  moreover from assms have "p \<in> set (filter (\<lambda>x. x \<noteq> 0) xs)" by simp
  ultimately obtain q where "q \<in> set (comp_min_basis xs)" and "lt q adds\<^sub>t lt p"
    unfolding comp_min_basis_def by (rule filter_min_relE)
  thus ?thesis ..
qed

lemma comp_min_basis_nadds:
  assumes "p \<in> set (comp_min_basis xs)" and "q \<in> set (comp_min_basis xs)" and "p \<noteq> q"
  shows "\<not> lt q adds\<^sub>t lt p"
proof
  have "transp (\<lambda>x y. lt x adds\<^sub>t lt y)" by (auto intro!: transpI dest: adds_term_trans)
  moreover note assms(2, 1)
  moreover assume "lt q adds\<^sub>t lt p"
  ultimately have "q = p" unfolding comp_min_basis_def by (rule filter_min_minimal)
  with assms(3) show False by simp
qed

lemma comp_min_basis_is_minimal_basis: "is_minimal_basis (set (comp_min_basis xs))"
  by (rule is_minimal_basisI, rule comp_min_basis_nonzero, assumption, rule comp_min_basis_nadds,
      assumption+, simp)

lemma comp_min_basis_distinct: "distinct (comp_min_basis xs)"
  unfolding comp_min_basis_def by (rule filter_min_distinct) (simp add: reflp_def adds_term_refl)

end (* ordered_term *)

subsection \<open>Auto-Reduction\<close>

context gd_term
begin

lemma is_minimal_basis_trd_is_minimal_basis:
  assumes "is_minimal_basis (set (x # xs))" and "x \<notin> set xs"
  shows "is_minimal_basis (set ((trd xs x) # xs))"
proof -
  from assms(1) have "is_minimal_basis (insert (trd xs x) (set (x # xs) - {x}))"
  proof (rule is_minimal_basis_replace, simp)
    from assms(2) have eq: "set (x # xs) - {x} = set xs" by simp
    show "(red (set (x # xs) - {x}))\<^sup>*\<^sup>* x (trd xs x)" unfolding eq by (rule trd_red_rtrancl)
  qed
  also from assms(2) have "... = set ((trd xs x) # xs)" by auto
  finally show ?thesis .
qed

lemma is_minimal_basis_trd_distinct:
  assumes min: "is_minimal_basis (set (x # xs))" and dist: "distinct (x # xs)"
  shows "distinct ((trd xs x) # xs)"
proof -
  let ?y = "trd xs x"
  from min have lty: "lt ?y = lt x"
  proof (rule minimal_basis_red_rtrancl_lt, simp)
    from dist have "x \<notin> set xs" by simp
    hence eq: "set (x # xs) - {x} = set xs" by simp
    show "(red (set (x # xs) - {x}))\<^sup>*\<^sup>* x (trd xs x)" unfolding eq by (rule trd_red_rtrancl)
  qed
  have "?y \<notin> set xs"
  proof
    assume "?y \<in> set xs"
    hence "?y \<in> set (x # xs)" by simp
    with min have "\<not> lt ?y adds\<^sub>t lt x"
    proof (rule is_minimal_basisD2, simp)
      show "?y \<noteq> x"
      proof
        assume "?y = x"
        from dist have "x \<notin> set xs" by simp
        with \<open>?y \<in> set xs\<close> show False unfolding \<open>?y = x\<close> by simp
      qed
    qed
    thus False unfolding lty by (simp add: adds_term_refl)
  qed
  moreover from dist have "distinct xs" by simp
  ultimately show ?thesis by simp
qed

primrec comp_red_basis_aux :: "('t \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::field) list" where
  comp_red_basis_aux_base: "comp_red_basis_aux Nil ys = ys"|
  comp_red_basis_aux_rec: "comp_red_basis_aux (x # xs) ys = comp_red_basis_aux xs ((trd (xs @ ys) x) # ys)"

lemma subset_comp_red_basis_aux: "set ys \<subseteq> set (comp_red_basis_aux xs ys)"
proof (induct xs arbitrary: ys)
  case Nil
  show ?case unfolding comp_red_basis_aux_base ..
next
  case (Cons a xs)
  have "set ys \<subseteq> set ((trd (xs @ ys) a) # ys)" by auto
  also have "... \<subseteq> set (comp_red_basis_aux xs ((trd (xs @ ys) a) # ys))" by (rule Cons.hyps)
  finally show ?case unfolding comp_red_basis_aux_rec .
qed

lemma comp_red_basis_aux_nonzero:
  assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)" and "p \<in> set (comp_red_basis_aux xs ys)"
  shows "p \<noteq> 0"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  show ?case
  proof (rule is_minimal_basisD1)
    from Nil(1) show "is_minimal_basis (set ys)" by simp
  next
    from Nil(3) show "p \<in> set ys" unfolding comp_red_basis_aux_base .
  qed
next
  case (Cons a xs)
  have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
  have "a \<in> set (a # xs @ ys)" by simp
  from Cons(3) have "a \<notin> set (xs @ ys)" unfolding eq by simp
  let ?ys = "trd (xs @ ys) a # ys"
  show ?case
  proof (rule Cons.hyps)
    from Cons(3) have "a \<notin> set (xs @ ys)" unfolding eq by simp
    with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
      by (rule is_minimal_basis_trd_is_minimal_basis)
  next
    from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq
      by (rule is_minimal_basis_trd_distinct)
  next
    from Cons(4) show "p \<in> set (comp_red_basis_aux xs ?ys)" unfolding comp_red_basis_aux_rec .
  qed
qed

lemma comp_red_basis_aux_lt:
  assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)"
  shows "lt ` set (xs @ ys) = lt ` set (comp_red_basis_aux xs ys)"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  show ?case unfolding comp_red_basis_aux_base by simp
next
  case (Cons a xs)
  have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
  from Cons(3) have a: "a \<notin> set (xs @ ys)" unfolding eq by simp
  let ?b = "trd (xs @ ys) a"
  let ?ys = "?b # ys"
  from Cons(2) have "lt ?b = lt a" unfolding eq
  proof (rule minimal_basis_red_rtrancl_lt, simp)
    from a have eq2: "set (a # xs @ ys) - {a} = set (xs @ ys)" by simp
    show "(red (set (a # xs @ ys) - {a}))\<^sup>*\<^sup>* a ?b" unfolding eq2 by (rule trd_red_rtrancl)
  qed
  hence "lt ` set ((a # xs) @ ys) = lt ` set ((?b # xs) @ ys)" by simp
  also have "... = lt ` set (xs @ (?b # ys))" by simp
  finally have eq2: "lt ` set ((a # xs) @ ys) = lt ` set (xs @ (?b # ys))" .
  show ?case unfolding comp_red_basis_aux_rec eq2
  proof (rule Cons.hyps)
    from Cons(3) have "a \<notin> set (xs @ ys)" unfolding eq by simp
    with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
      by (rule is_minimal_basis_trd_is_minimal_basis)
  next
    from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq
      by (rule is_minimal_basis_trd_distinct)
  qed
qed

lemma comp_red_basis_aux_pmdl:
  assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)"
  shows "pmdl (set (comp_red_basis_aux xs ys)) \<subseteq> pmdl (set (xs @ ys))"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  show ?case unfolding comp_red_basis_aux_base by simp
next
  case (Cons a xs)
  have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
  from Cons(3) have a: "a \<notin> set (xs @ ys)" unfolding eq by simp
  let ?b = "trd (xs @ ys) a"
  let ?ys = "?b # ys"
  have "pmdl (set (comp_red_basis_aux xs ?ys)) \<subseteq> pmdl (set (xs @ ?ys))"
  proof (rule Cons.hyps)
    from Cons(3) have "a \<notin> set (xs @ ys)" unfolding eq by simp
    with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
      by (rule is_minimal_basis_trd_is_minimal_basis)
  next
    from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq
      by (rule is_minimal_basis_trd_distinct)
  qed
  also have "... = pmdl (set (?b # xs @ ys))" by simp
  also from a have "... = pmdl (insert ?b (set (a # xs @ ys) - {a}))" by auto
  also have "... \<subseteq> pmdl (set (a # xs @ ys))"
  proof (rule pmdl.replace_span)
    have "a - (trd (xs @ ys) a) \<in> pmdl (set (xs @ ys))" by (rule trd_in_pmdl)
    have "a - (trd (xs @ ys) a) \<in> pmdl (set (a # xs @ ys))"
    proof
      show "pmdl (set (xs @ ys)) \<subseteq> pmdl (set (a # xs @ ys))" by (rule pmdl.span_mono) auto
    qed fact
    hence "- (a - (trd (xs @ ys) a)) \<in> pmdl (set (a # xs @ ys))" by (rule pmdl.span_neg)
    hence "(trd (xs @ ys) a) - a \<in> pmdl (set (a # xs @ ys))" by simp
    hence "((trd (xs @ ys) a) - a) + a \<in> pmdl (set (a # xs @ ys))"
    proof (rule pmdl.span_add)
      show "a \<in> pmdl (set (a # xs @ ys))"
      proof
        show "a \<in> set (a # xs @ ys)" by simp
      qed (rule pmdl.span_superset)
    qed
    thus "trd (xs @ ys) a \<in> pmdl (set (a # xs @ ys))" by simp
  qed
  also have "... = pmdl (set ((a # xs) @ ys))" by simp
  finally show ?case unfolding comp_red_basis_aux_rec .
qed

lemma comp_red_basis_aux_irred:
  assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)"
    and "\<And>y. y \<in> set ys \<Longrightarrow> \<not> is_red (set (xs @ ys) - {y}) y"
    and "p \<in> set (comp_red_basis_aux xs ys)"
  shows "\<not> is_red (set (comp_red_basis_aux xs ys) - {p}) p"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  have "\<not> is_red (set ([] @ ys) - {p}) p"
  proof (rule Nil(3))
    from Nil(4) show "p \<in> set ys" unfolding comp_red_basis_aux_base .
  qed
  thus ?case unfolding comp_red_basis_aux_base by simp
next
  case (Cons a xs)
  have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
  from Cons(3) have a_notin: "a \<notin> set (xs @ ys)" unfolding eq by simp
  from Cons(2) have is_min: "is_minimal_basis (set (a # xs @ ys))" unfolding eq .
  let ?b = "trd (xs @ ys) a"
  let ?ys = "?b # ys"
  have dist: "distinct (?b # (xs @ ys))"
  proof (rule is_minimal_basis_trd_distinct, fact is_min)
    from Cons(3) show "distinct (a # xs @ ys)" unfolding eq .
  qed

  show ?case unfolding comp_red_basis_aux_rec
  proof (rule Cons.hyps)
    from Cons(2) a_notin show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
      by (rule is_minimal_basis_trd_is_minimal_basis)
  next
    from dist show "distinct (xs @ ?ys)" unfolding distinct_reorder .
  next
    fix y
    assume "y \<in> set ?ys"
    hence "y = ?b \<or> y \<in> set ys" by simp
    thus "\<not> is_red (set (xs @ ?ys) - {y}) y"
    proof
      assume "y = ?b"
      from dist have "?b \<notin> set (xs @ ys)" by simp
      hence eq3: "set (xs @ ?ys) - {?b} = set (xs @ ys)" unfolding set_reorder by simp
      have "\<not> is_red (set (xs @ ys)) ?b" by (rule trd_irred)
      thus ?thesis unfolding \<open>y = ?b\<close> eq3 .
    next
      assume "y \<in> set ys"
      hence irred: "\<not> is_red (set ((a # xs) @ ys) - {y}) y" by (rule Cons(4))
      from \<open>y \<in> set ys\<close> a_notin have "y \<noteq> a" by auto
      hence eq3: "set ((a # xs) @ ys) - {y} = {a} \<union> (set (xs @ ys) - {y})" by auto
      from irred have i1: "\<not> is_red {a} y" and i2: "\<not> is_red (set (xs @ ys) - {y}) y"
        unfolding eq3 is_red_union by simp_all
      show ?thesis unfolding set_reorder
      proof (cases "y = ?b")
        case True
        from i2 show "\<not> is_red (set (?b # xs @ ys) - {y}) y" by (simp add: True)
      next
        case False
        hence eq4: "set (?b # xs @ ys) - {y} = {?b} \<union> (set (xs @ ys) - {y})" by auto
        show "\<not> is_red (set (?b # xs @ ys) - {y}) y" unfolding eq4
        proof
          assume "is_red ({?b} \<union> (set (xs @ ys) - {y})) y"
          thus False unfolding is_red_union
          proof
            have ltb: "lt ?b = lt a"
            proof (rule minimal_basis_red_rtrancl_lt, fact is_min)
              show "a \<in> set (a # xs @ ys)" by simp
            next
              from a_notin have eq: "set (a # xs @ ys) - {a} = set (xs @ ys)" by simp
              show "(red (set (a # xs @ ys) - {a}))\<^sup>*\<^sup>* a ?b" unfolding eq by (rule trd_red_rtrancl)
            qed
            assume "is_red {?b} y"
            then obtain t where "t \<in> keys y" and "lt ?b adds\<^sub>t t" unfolding is_red_adds_iff by auto
            with ltb have "lt a adds\<^sub>t t" by simp
            have "is_red {a} y"
              by (rule is_red_addsI, rule, rule is_minimal_basisD1, fact is_min, simp, fact+)
            with i1 show False ..
          next
            assume "is_red (set (xs @ ys) - {y}) y"
            with i2 show False ..
          qed
        qed
      qed
    qed
  next
    from Cons(5) show "p \<in> set (comp_red_basis_aux xs ?ys)" unfolding comp_red_basis_aux_rec .
  qed
qed

lemma comp_red_basis_aux_dgrad_p_set_le:
  assumes "dickson_grading d"
  shows "dgrad_p_set_le d (set (comp_red_basis_aux xs ys)) (set xs \<union> set ys)"
proof (induct xs arbitrary: ys)
  case Nil
  show ?case by (simp, rule dgrad_p_set_le_subset, fact subset_refl)
next
  case (Cons x xs)
  let ?h = "trd (xs @ ys) x"
  have "dgrad_p_set_le d (set (comp_red_basis_aux xs (?h # ys))) (set xs \<union> set (?h # ys))"
    by (fact Cons)
  also have "... = insert ?h (set xs \<union> set ys)" by simp
  also have "dgrad_p_set_le d ... (insert x (set xs \<union> set ys))"
  proof (rule dgrad_p_set_leI_insert)
    show "dgrad_p_set_le d (set xs \<union> set ys) (insert x (set xs \<union> set ys))"
      by (rule dgrad_p_set_le_subset, blast)
  next
    have "(red (set (xs @ ys)))\<^sup>*\<^sup>* x ?h" by (rule trd_red_rtrancl)
    with assms have "dgrad_p_set_le d {?h} (insert x (set (xs @ ys)))"
      by (rule dgrad_p_set_le_red_rtrancl)
    thus "dgrad_p_set_le d {?h} (insert x (set xs \<union> set ys))" by simp
  qed
  finally show ?case by simp
qed

definition comp_red_basis :: "('t \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::field) list"
  where "comp_red_basis xs = comp_red_basis_aux (comp_min_basis xs) []"

lemma comp_red_basis_nonzero:
  assumes "p \<in> set (comp_red_basis xs)"
  shows "p \<noteq> 0"
proof -
  have "is_minimal_basis (set ((comp_min_basis xs) @ []))" by (simp add: comp_min_basis_is_minimal_basis)
  moreover have "distinct ((comp_min_basis xs) @ [])" by (simp add: comp_min_basis_distinct)
  moreover from assms have "p \<in> set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def .
  ultimately show ?thesis by (rule comp_red_basis_aux_nonzero)
qed

lemma pmdl_comp_red_basis_subset: "pmdl (set (comp_red_basis xs)) \<subseteq> pmdl (set xs)"
proof
  fix f
  assume fin: "f \<in> pmdl (set (comp_red_basis xs))"
  have "f \<in> pmdl (set (comp_min_basis xs))"
  proof
    from fin show  "f \<in> pmdl (set (comp_red_basis_aux (comp_min_basis xs) []))"
      unfolding comp_red_basis_def .
  next
    have "pmdl (set (comp_red_basis_aux (comp_min_basis xs) [])) \<subseteq> pmdl (set ((comp_min_basis xs) @ []))"
      by (rule comp_red_basis_aux_pmdl, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
    thus "pmdl (set (comp_red_basis_aux (comp_min_basis xs) [])) \<subseteq> pmdl (set (comp_min_basis xs))"
      by simp
  qed
  also from comp_min_basis_subset have "... \<subseteq> pmdl (set xs)" by (rule pmdl.span_mono)
  finally show "f \<in> pmdl (set xs)" .
qed

lemma comp_red_basis_adds:
  assumes "p \<in> set xs" and "p \<noteq> 0"
  obtains q where "q \<in> set (comp_red_basis xs)" and "lt q adds\<^sub>t lt p"
proof -
  from assms obtain q1 where "q1 \<in> set (comp_min_basis xs)" and "lt q1 adds\<^sub>t lt p"
    by (rule comp_min_basis_adds)
  from \<open>q1 \<in> set (comp_min_basis xs)\<close> have "lt q1 \<in> lt ` set (comp_min_basis xs)" by simp
  also have "... = lt ` set ((comp_min_basis xs) @ [])" by simp
  also have "... = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])"
    by (rule comp_red_basis_aux_lt, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
  finally obtain q where "q \<in> set (comp_red_basis_aux (comp_min_basis xs) [])" and "lt q = lt q1"
    by auto
  show ?thesis
  proof
    show "q \<in> set (comp_red_basis xs)" unfolding comp_red_basis_def by fact
  next
    from \<open>lt q1 adds\<^sub>t lt p\<close> show "lt q adds\<^sub>t lt p" unfolding \<open>lt q = lt q1\<close> .
  qed
qed

lemma comp_red_basis_lt:
  assumes "p \<in> set (comp_red_basis xs)"
  obtains q where "q \<in> set xs" and "q \<noteq> 0" and "lt q = lt p"
proof -
  have eq: "lt ` set ((comp_min_basis xs) @ []) = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])"
    by (rule comp_red_basis_aux_lt, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
  from assms have "lt p \<in> lt ` set (comp_red_basis xs)" by simp
  also have "... = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def ..
  also have "... = lt ` set (comp_min_basis xs)" unfolding eq[symmetric] by simp
  finally obtain q where "q \<in> set (comp_min_basis xs)" and "lt q = lt p" by auto
  show ?thesis
  proof
    show "q \<in> set xs" by (rule, fact, rule comp_min_basis_subset)
  next
    show "q \<noteq> 0" by (rule comp_min_basis_nonzero, fact)
  qed fact
qed

lemma comp_red_basis_is_red: "is_red (set (comp_red_basis xs)) f \<longleftrightarrow> is_red (set xs) f"
proof
  assume "is_red (set (comp_red_basis xs)) f"
  then obtain x t where "x \<in> set (comp_red_basis xs)" and "t \<in> keys f" and "x \<noteq> 0" and "lt x adds\<^sub>t t"
    by (rule is_red_addsE)
  from \<open>x \<in> set (comp_red_basis xs)\<close> obtain y where yin: "y \<in> set xs" and "y \<noteq> 0" and "lt y = lt x"
    by (rule comp_red_basis_lt)
  show "is_red (set xs) f"
  proof (rule is_red_addsI)
    from \<open>lt x adds\<^sub>t t\<close> show "lt y adds\<^sub>t t" unfolding \<open>lt y = lt x\<close> .
  qed fact+
next
  assume "is_red (set xs) f"
  then obtain x t where "x \<in> set xs" and "t \<in> keys f" and "x \<noteq> 0" and "lt x adds\<^sub>t t"
    by (rule is_red_addsE)
  from \<open>x \<in> set xs\<close> \<open>x \<noteq> 0\<close> obtain y where yin: "y \<in> set (comp_red_basis xs)" and "lt y adds\<^sub>t lt x"
    by (rule comp_red_basis_adds)
  show "is_red (set (comp_red_basis xs)) f"
  proof (rule is_red_addsI)
    from \<open>lt y adds\<^sub>t lt x\<close> \<open>lt x adds\<^sub>t t\<close> show "lt y adds\<^sub>t t" by (rule adds_term_trans)
  next
    from yin show "y \<noteq> 0" by (rule comp_red_basis_nonzero)
  qed fact+
qed

lemma comp_red_basis_is_auto_reduced: "is_auto_reduced (set (comp_red_basis xs))"
  unfolding is_auto_reduced_def remove_def
proof (intro ballI)
  fix x
  assume xin: "x \<in> set (comp_red_basis xs)"
  show "\<not> is_red (set (comp_red_basis xs) - {x}) x" unfolding comp_red_basis_def
  proof (rule comp_red_basis_aux_irred, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
    from xin show "x \<in> set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def .
  qed
qed

lemma comp_red_basis_dgrad_p_set_le:
  assumes "dickson_grading d"
  shows "dgrad_p_set_le d (set (comp_red_basis xs)) (set xs)"
proof -
  have "dgrad_p_set_le d (set (comp_red_basis xs)) (set (comp_min_basis xs) \<union> set [])"
    unfolding comp_red_basis_def using assms by (rule comp_red_basis_aux_dgrad_p_set_le)
  also have "... = set (comp_min_basis xs)" by simp
  also from comp_min_basis_subset have "dgrad_p_set_le d ... (set xs)"
    by (rule dgrad_p_set_le_subset)
  finally show ?thesis .
qed

subsection \<open>Auto-Reduction and Monicity\<close>

definition comp_red_monic_basis :: "('t \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::field) list" where
  "comp_red_monic_basis xs = map monic (comp_red_basis xs)"

lemma set_comp_red_monic_basis: "set (comp_red_monic_basis xs) = monic ` (set (comp_red_basis xs))"
  by (simp add: comp_red_monic_basis_def)

lemma comp_red_monic_basis_nonzero:
  assumes "p \<in> set (comp_red_monic_basis xs)"
  shows "p \<noteq> 0"
proof -
  from assms obtain p' where p_def: "p = monic p'" and p': "p' \<in> set (comp_red_basis xs)"
    unfolding set_comp_red_monic_basis ..
  from p' have "p' \<noteq> 0" by (rule comp_red_basis_nonzero)
  thus ?thesis unfolding p_def monic_0_iff .
qed

lemma comp_red_monic_basis_is_monic_set: "is_monic_set (set (comp_red_monic_basis xs))"
  unfolding set_comp_red_monic_basis by (rule image_monic_is_monic_set)

lemma pmdl_comp_red_monic_basis_subset: "pmdl (set (comp_red_monic_basis xs)) \<subseteq> pmdl (set xs)"
  unfolding set_comp_red_monic_basis pmdl_image_monic by (fact pmdl_comp_red_basis_subset)

lemma comp_red_monic_basis_is_auto_reduced: "is_auto_reduced (set (comp_red_monic_basis xs))"
  unfolding set_comp_red_monic_basis by (rule image_monic_is_auto_reduced, rule comp_red_basis_is_auto_reduced)

lemma comp_red_monic_basis_dgrad_p_set_le:
  assumes "dickson_grading d"
  shows "dgrad_p_set_le d (set (comp_red_monic_basis xs)) (set xs)"
proof -
  have "dgrad_p_set_le d (monic ` (set (comp_red_basis xs))) (set (comp_red_basis xs))"
    by (simp add: dgrad_p_set_le_def, fact dgrad_set_le_refl)
  also from assms have "dgrad_p_set_le d ... (set xs)" by (rule comp_red_basis_dgrad_p_set_le)
  finally show ?thesis by (simp add: set_comp_red_monic_basis)
qed

end (* gd_term *)

end (* theory *)


(*  Title:      Cayley_Hamilton/Square_Matrix.thy
    Author:     Johannes Hölzl, TU München *)

theory Square_Matrix
imports
  "HOL-Analysis.Determinants"
  "HOL-Analysis.Cartesian_Euclidean_Space"
begin

lemma smult_axis: "x *s axis i y = axis i (x * y::_::mult_zero)"
  by (simp add: axis_def vec_eq_iff)

typedef ('a, 'n) sq_matrix = "UNIV :: ('n \<Rightarrow> 'n \<Rightarrow> 'a) set"
  morphisms to_fun of_fun
  by (rule UNIV_witness)

syntax "_sq_matrix" :: "type \<Rightarrow> type \<Rightarrow> type" ("(_ ^^/ _)" [15, 16] 15)

parse_translation \<open>
  let
    fun vec t u = Syntax.const @{type_syntax sq_matrix} $ t $ u;
    fun sq_matrix_tr [t, u] =
      (case Term_Position.strip_positions u of
        v as Free (x, _) =>
          if Lexicon.is_tid x then
            vec t (Syntax.const @{syntax_const "_ofsort"} $ v $
              Syntax.const @{class_syntax finite})
          else vec t u
      | _ => vec t u)
  in
    [(@{syntax_const "_sq_matrix"}, K sq_matrix_tr)]
  end
\<close>

setup_lifting type_definition_sq_matrix

lift_definition map_sq_matrix :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a^^'b \<Rightarrow> 'c^^'b" is
  "\<lambda>f M i j. f (M i j)" .

lift_definition from_vec :: "'a^'n^'n \<Rightarrow> 'a^^'n" is
  "\<lambda>M i j. M $ i $ j" .

lift_definition to_vec :: "'a^^'n \<Rightarrow> 'a^'n^'n" is
  "\<lambda>M. \<chi> i j. M i j" .

lemma from_vec_eq_iff: "from_vec M = from_vec N \<longleftrightarrow> M = N"
  by transfer (auto simp: vec_eq_iff fun_eq_iff)

lemma to_vec_from_vec[simp]: "to_vec (from_vec M) = M"
  by transfer (simp add: vec_eq_iff)

lemma from_vec_to_vec[simp]: "from_vec (to_vec M) = M"
  by transfer (simp add: vec_eq_iff fun_eq_iff)

lemma map_sq_matrix_compose[simp]: "map_sq_matrix f (map_sq_matrix g M) = map_sq_matrix (\<lambda>x. f (g x)) M"
  by transfer simp

lemma map_sq_matrix_ident[simp]: "map_sq_matrix (\<lambda>x. x) M = M"
  by transfer (simp add: vec_eq_iff)

lemma map_sq_matrix_cong:
  "M = N \<Longrightarrow> (\<And>i j. f (to_fun N i j) = g (to_fun N i j)) \<Longrightarrow> map_sq_matrix f M = map_sq_matrix g N"
  by transfer simp

lift_definition diag :: "'a::zero \<Rightarrow> 'a^^'n" is
  "\<lambda>k i j. if i = j then k else 0" .

lemma diag_eq_iff: "diag x = diag y \<longleftrightarrow>  x = y"
  by transfer (simp add: fun_eq_iff)

lemma map_sq_matrix_diag[simp]: "f 0 = 0 \<Longrightarrow> map_sq_matrix f (diag c) = diag (f c)"
  by transfer (simp add: fun_eq_iff)

lift_definition smult_sq_matrix :: "'a::times \<Rightarrow> 'a^^'n \<Rightarrow> 'a^^'n" (infixr "*\<^sub>S" 75) is
  "\<lambda>c M i j. c * M i j" .

lemma map_sq_matrix_smult: "c *\<^sub>S map_sq_matrix f A = map_sq_matrix (\<lambda>x. c * f x) A"
  by transfer simp

lemma one_smult[simp]: "(1::_::monoid_mult) *\<^sub>S x = x"
  by transfer simp

lemma smult_diag: "x *\<^sub>S diag y = diag (x * y::_::mult_zero)"
  by transfer (simp add: fun_eq_iff)

instantiation sq_matrix :: (semigroup_add, finite) semigroup_add
begin

lift_definition plus_sq_matrix :: "'a^^'b \<Rightarrow> 'a^^'b \<Rightarrow> 'a^^'b" is
  "\<lambda>A B i j. A i j + B i j" .

instance
  by standard (transfer, simp add: field_simps)

end

lemma map_sq_matrix_add:
  "(\<And>a b. f (a + b) = f a + f b) \<Longrightarrow> map_sq_matrix f (A + B) = map_sq_matrix f A + map_sq_matrix f B"
  by transfer simp

lemma add_map_sq_matrix: "map_sq_matrix f A + map_sq_matrix g A = map_sq_matrix (\<lambda>x. f x + g x) A"
  by transfer simp

instantiation sq_matrix :: (monoid_add, finite) monoid_add
begin

lift_definition zero_sq_matrix :: "'a^^'b" is "\<lambda>i j. 0" .

instance
  by standard (transfer, simp)+

end

lemma diag_0: "diag 0 = 0"
  by transfer simp

lemma diag_0_eq: "diag x = 0 \<longleftrightarrow> x = 0"
  by transfer (simp add: fun_eq_iff)

lemma zero_map_sq_matrix: "f 0 = 0 \<Longrightarrow> map_sq_matrix f 0 = 0"
  by transfer simp

lemma map_sq_matrix_0[simp]: "map_sq_matrix (\<lambda>x. 0) A = 0"
  by transfer simp

instance sq_matrix :: (ab_semigroup_add, finite) ab_semigroup_add
  by standard (transfer, simp add: field_simps)+

instantiation sq_matrix :: (minus, finite) minus
begin

lift_definition minus_sq_matrix :: "'a^^'b \<Rightarrow> 'a^^'b \<Rightarrow> 'a^^'b" is
  "\<lambda>A B i j. A i j - B i j" .

instance ..
end

instantiation sq_matrix :: (group_add, finite) group_add
begin

lift_definition uminus_sq_matrix :: "'a^^'b \<Rightarrow> 'a^^'b" is
  "uminus" .

instance
  by standard (transfer, simp)+

end

lemma map_sq_matrix_diff:
  "(\<And>a b. f (a - b) = f a - f b) \<Longrightarrow> map_sq_matrix f (A - B) = map_sq_matrix f A - map_sq_matrix f B"
  by transfer (simp add: vec_eq_iff)

lemma smult_diff: fixes a :: "'a::comm_ring_1" shows "a *\<^sub>S (A - B) = a *\<^sub>S A - a *\<^sub>S B"
  by transfer (simp add: field_simps)

instance sq_matrix :: (cancel_semigroup_add, finite) cancel_semigroup_add
  by (standard; transfer, simp add: field_simps fun_eq_iff)

instance sq_matrix :: (cancel_ab_semigroup_add, finite) cancel_ab_semigroup_add
  by (standard; transfer, simp add: field_simps)

instance sq_matrix :: (comm_monoid_add, finite) comm_monoid_add
  by (standard; transfer, simp add: field_simps)

lemma map_sq_matrix_sum:
  "f 0 = 0 \<Longrightarrow> (\<And>a b. f (a + b) = f a + f b) \<Longrightarrow>
  map_sq_matrix f (\<Sum>i\<in>I. A i) = (\<Sum>i\<in>I. map_sq_matrix f (A i))"
  by (induction I rule: infinite_finite_induct)
     (auto simp: zero_map_sq_matrix map_sq_matrix_add)

lemma sum_map_sq_matrix: "(\<Sum>i\<in>I. map_sq_matrix (f i) A) = map_sq_matrix (\<lambda>x. \<Sum>i\<in>I. f i x) A"
  by (induction I rule: infinite_finite_induct) (simp_all add: add_map_sq_matrix)

lemma smult_right_add: fixes a :: "'a::ring_1" shows "a *\<^sub>S (x + y) = a *\<^sub>S x + a *\<^sub>S y"
  by transfer (simp add: vec_eq_iff field_simps)

lemma smult_sum: fixes a :: "'a::ring_1" shows "(\<Sum>i\<in>I. a *\<^sub>S f i) = a *\<^sub>S (sum f I)"
  by (induction I rule: infinite_finite_induct)
     (simp_all add: smult_right_add vec_eq_iff)

instance sq_matrix :: (ab_group_add, finite) ab_group_add
  by standard (transfer, simp add: field_simps)+

instantiation sq_matrix :: ("semiring_0", finite) semiring_0
begin

lift_definition times_sq_matrix :: "'a^^'b \<Rightarrow> 'a^^'b \<Rightarrow> 'a^^'b" is
  "\<lambda>M N i j. \<Sum>k\<in>UNIV. M i k * N k j" .

instance
proof
  fix a b c :: "'a^^'b" show "a * b * c = a * (b * c)"
    by transfer
       (auto simp: fun_eq_iff sum_distrib_left sum_distrib_right field_simps intro: sum.swap)
qed (transfer, simp add: vec_eq_iff sum.distrib field_simps)+
end

lemma diag_mult: "diag x * A = x *\<^sub>S A"
  by transfer  (simp add: if_distrib[where f="\<lambda>x. x * a" for a] sum.If_cases)

lemma mult_diag:
  fixes x :: "'a::comm_ring_1"
  shows "A * diag x = x *\<^sub>S A"
  by transfer (simp add: if_distrib[where f="\<lambda>x. a * x" for a] mult.commute sum.If_cases)

lemma smult_mult2: fixes a :: "'a::comm_ring_1" shows "a *\<^sub>S (A * B) = A * (a *\<^sub>S B)"
  by transfer (simp add: sum_distrib_left field_simps)

lemma map_sq_matrix_mult:
  fixes f :: "'a::semiring_1 \<Rightarrow> 'b::semiring_1"
  assumes f: "\<And>a b. f (a + b) = f a + f b" "\<And>a b. f (a * b) = f a * f b" "f 0 = 0"
  shows "map_sq_matrix f (A * B) = map_sq_matrix f A * map_sq_matrix f B"
proof (transfer fixing: f)
  fix A B :: "'c \<Rightarrow> 'c \<Rightarrow> 'a"
  { fix I i j have "f (\<Sum>k\<in>I. A i k * B k j) = (\<Sum>k\<in>I. f (A i k) * f (B k j))"
      by (induction I rule: infinite_finite_induct) (auto simp add: f) }
  then show "(\<lambda>i j. f (\<Sum>k\<in>UNIV. A i k * B k j)) = (\<lambda>i j. \<Sum>k\<in>UNIV. f (A i k) * f (B k j))"
    by simp
qed

lemma from_vec_mult[simp]: "from_vec (M ** N) = from_vec M * from_vec N"
  by transfer (simp add: matrix_matrix_mult_def fun_eq_iff vec_eq_iff)

instantiation sq_matrix :: ("semiring_1", finite) semiring_1
begin

lift_definition one_sq_matrix :: "'a^^'b" is
  "\<lambda>i j. if i = j then 1 else 0" .

instance
  by standard (transfer, simp add: fun_eq_iff sum.If_cases
       if_distrib[where f="\<lambda>x. x * b" for b] if_distrib[where f="\<lambda>x. b * x" for b])+
end

instance sq_matrix :: ("semiring_1", finite) numeral ..

lemma diag_1: "diag 1 = 1"
  by transfer simp

lemma diag_1_eq: "diag x = 1 \<longleftrightarrow> x = 1"
  by transfer (simp add: fun_eq_iff)

instance sq_matrix :: ("ring_1", finite) ring_1
  by standard simp_all

interpretation sq_matrix: vector_space smult_sq_matrix
  by standard (transfer, simp add: vec_eq_iff field_simps)+

instantiation sq_matrix :: (real_vector, finite) real_vector
begin

lift_definition scaleR_sq_matrix :: "real \<Rightarrow> 'a^^'b \<Rightarrow> 'a^^'b" is
  "\<lambda>r A i j. r *\<^sub>R A i j" .

instance
  by standard (transfer, simp add: scaleR_add_right scaleR_add_left)+

end

instance sq_matrix :: ("semiring_1", finite) Rings.dvd ..

lift_definition transpose :: "'a^^'n \<Rightarrow> 'a^^'n" is
  "\<lambda>M i j. M j i" .

lemma transpose_transpose[simp]: "transpose (transpose A) = A"
  by transfer simp

lemma transpose_diag[simp]: "transpose (diag c) = diag c"
  by transfer (simp add: fun_eq_iff)

lemma transpose_zero[simp]: "transpose 0 = 0"
  by transfer simp

lemma transpose_one[simp]: "transpose 1 = 1"
  by transfer (simp add: fun_eq_iff)

lemma transpose_add[simp]: "transpose (A + B) = transpose A + transpose B"
  by transfer simp

lemma transpose_minus[simp]: "transpose (A - B) = transpose A - transpose B"
  by transfer simp

lemma transpose_uminus[simp]: "transpose (- A) = - transpose A"
  by transfer (simp add: fun_eq_iff)

lemma transpose_mult[simp]:
  "transpose (A * B :: 'a::comm_semiring_0^^'n) = transpose B * transpose A"
  by transfer (simp add: field_simps)

lift_definition trace :: "'a::comm_monoid_add^^'n \<Rightarrow> 'a" is
  "\<lambda>M. \<Sum>i\<in>UNIV. M i i" .

lemma trace_diag[simp]: "trace (diag c::'a::semiring_1^^'n) = of_nat CARD('n) * c"
  by transfer simp

lemma trace_0[simp]: "trace 0 = 0"
  by transfer simp

lemma trace_1[simp]: "trace (1::'a::semiring_1^^'n) = of_nat CARD('n)"
  by transfer simp

lemma trace_plus[simp]: "trace (A + B) = trace A + trace B"
  by transfer (simp add: sum.distrib)

lemma trace_minus[simp]: "trace (A - B) = (trace A - trace B::_::ab_group_add)"
  by transfer (simp add: sum_subtractf)

lemma trace_uminus[simp]: "trace (- A) = - (trace A::_::ab_group_add)"
  by transfer (simp add: sum_negf)

lemma trace_smult[simp]: "trace (s *\<^sub>S A) = (s * trace A::_::semiring_0)"
  by transfer (simp add: sum_distrib_left)

lemma trace_transpose[simp]: "trace (transpose A) = trace A"
  by transfer simp

lemma trace_mult_symm:
  fixes A B :: "'a::comm_semiring_0^^'n"
  shows "trace (A * B) = trace (B * A)"
  by transfer (auto intro: sum.swap simp: mult.commute)

lift_definition det :: "'a::comm_ring_1^^'n \<Rightarrow> 'a" is
  "\<lambda>A. (\<Sum>p|p permutes UNIV. of_int (sign p) * (\<Prod>i\<in>UNIV. A i (p i)))" .

lemma det_eq: "det A = (\<Sum>p|p permutes UNIV. of_int (sign p) * (\<Prod>i\<in>UNIV. to_fun A i (p i)))"
  by transfer rule

lemma permutes_UNIV_permutation: "permutation p \<longleftrightarrow> p permutes (UNIV::_::finite)"
  by (auto simp: permutation_permutes permutes_def)

lemma det_0[simp]: "det 0 = 0"
  by transfer (simp add: zero_power)

lemma det_transpose: "det (transpose A) = det A"
  apply transfer
  apply (subst sum_permutations_inverse)
  apply (rule sum.cong[OF refl])
  apply (simp add: sign_inverse permutes_UNIV_permutation)
  apply (subst prod.reindex_bij_betw[symmetric])
  apply (rule permutes_imp_bij)
  apply assumption
  apply (simp add: permutes_inverses)
  done

lemma det_diagonal:
  fixes A :: "'a::comm_ring_1^^'n"
  shows "(\<And>i j. i \<noteq> j \<Longrightarrow> to_fun A i j = 0) \<Longrightarrow> det A = (\<Prod>i\<in>UNIV. to_fun A i i)"
proof transfer
  fix A :: "'n \<Rightarrow> 'n \<Rightarrow> 'a" assume neq: "\<And>i j. i \<noteq> j \<Longrightarrow> A i j = 0"
  let ?pp = "\<lambda>p. of_int (sign p) * (\<Prod>i\<in>UNIV. A i (p i))"

  { fix p :: "'n \<Rightarrow> 'n" assume p: "p permutes UNIV" "p \<noteq> id"
    then obtain i where i: "i \<noteq> p i"
      unfolding id_def by metis
    with neq[OF i] have "(\<Prod>i\<in>UNIV. A i (p i)) = 0"
      by (intro prod_zero) auto }
  then have "(\<Sum>p | p permutes UNIV. ?pp p) = (\<Sum>p\<in>{id}. ?pp p)"
    by (intro sum.mono_neutral_cong_right) (auto intro: permutes_id)
  then show "(\<Sum>p | p permutes UNIV. ?pp p) = (\<Prod>i\<in>UNIV. A i i)"
     by (simp add: sign_id)
qed

lemma det_1[simp]: "det (1::'a::comm_ring_1^^'n) = 1"
  by (subst det_diagonal) (transfer, simp)+

lemma det_lowerdiagonal:
  fixes A :: "'a::comm_ring_1^^'n::{finite,wellorder}"
  shows "(\<And>i j. i < j \<Longrightarrow> to_fun A i j = 0) \<Longrightarrow> det A = (\<Prod>i\<in>UNIV. to_fun A i i)"
proof transfer
  fix A :: "'n \<Rightarrow> 'n \<Rightarrow> 'a" assume ld: "\<And>i j. i < j \<Longrightarrow> A i j = 0"
  let ?pp = "\<lambda>p. of_int (sign p) * (\<Prod>i\<in>UNIV. A i (p i))"

  { fix p :: "'n \<Rightarrow> 'n" assume p: "p permutes UNIV" "p \<noteq> id"
    with permutes_natset_le[OF p(1)] obtain i where i: "p i > i"
      by (metis not_le)
    with ld[OF i] have "(\<Prod>i\<in>UNIV. A i (p i)) = 0"
      by (intro prod_zero) auto }
  then have "(\<Sum>p | p permutes UNIV. ?pp p) = (\<Sum>p\<in>{id}. ?pp p)"
    by (intro sum.mono_neutral_cong_right) (auto intro: permutes_id)
  then show "(\<Sum>p | p permutes UNIV. ?pp p) = (\<Prod>i\<in>UNIV. A i i)"
     by (simp add: sign_id)
qed

lemma det_upperdiagonal:
  fixes A :: "'a::comm_ring_1^^'n::{finite, wellorder}"
  shows "(\<And>i j. j < i \<Longrightarrow> to_fun A i j = 0) \<Longrightarrow> det A = (\<Prod>i\<in>UNIV. to_fun A i i)"
  using det_lowerdiagonal[of "transpose A"]
  unfolding det_transpose transpose.rep_eq .

lift_definition perm_rows :: "'a^^'b \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a^^'b" is
  "\<lambda>M p i j. M (p i) j" .

lift_definition perm_cols :: "'a^^'b \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a^^'b" is
  "\<lambda>M p i j. M i (p j)" .

lift_definition upd_rows :: "'a^^'b \<Rightarrow> 'b set \<Rightarrow> ('b \<Rightarrow> 'a^'b) \<Rightarrow> 'a^^'b" is
  "\<lambda>M S v i j. if i \<in> S then v i $ j else M i j" .

lift_definition upd_cols :: "'a^^'b \<Rightarrow> 'b set \<Rightarrow> ('b \<Rightarrow> 'a^'b) \<Rightarrow> 'a^^'b" is
  "\<lambda>M S v i j. if j \<in> S then v j $ i else M i j" .

lift_definition upd_row :: "'a^^'b \<Rightarrow> 'b \<Rightarrow> 'a^'b \<Rightarrow> 'a^^'b" is
  "\<lambda>M i' v i j. if i = i' then v $ j else M i j" .

lift_definition upd_col :: "'a^^'b \<Rightarrow> 'b \<Rightarrow> 'a^'b \<Rightarrow> 'a^^'b" is
  "\<lambda>M j' v i j. if j = j' then v $ i else M i j" .

lift_definition row :: "'a^^'b \<Rightarrow> 'b \<Rightarrow> 'a^'b" is
  "\<lambda>M i. \<chi> j. M i j" .

lift_definition col :: "'a^^'b \<Rightarrow> 'b \<Rightarrow> 'a^'b" is
  "\<lambda>M j. \<chi> i. M i j" .

lemma perm_rows_transpose: "perm_rows (transpose M) p = transpose (perm_cols M p)"
  by transfer simp

lemma perm_cols_transpose: "perm_cols (transpose M) p = transpose (perm_rows M p)"
  by transfer simp

lemma upd_row_transpose: "upd_row (transpose M) i p = transpose (upd_col M i p)"
  by transfer simp

lemma upd_col_transpose: "upd_col (transpose M) i p = transpose (upd_row M i p)"
  by transfer simp

lemma upd_rows_transpose: "upd_rows (transpose M) i p = transpose (upd_cols M i p)"
  by transfer simp

lemma upd_rows_empty[simp]: "upd_rows M {} f = M"
  by transfer simp

lemma upd_rows_single[simp]: "upd_rows M {i} f = upd_row M i (f i)"
  by transfer (simp add: fun_eq_iff)

lemma upd_cols_single[simp]: "upd_cols M {i} f = upd_col M i (f i)"
  by transfer (simp add: fun_eq_iff)

lemma upd_rows_insert: "upd_rows M (insert i I) f = upd_row (upd_rows M I f) i (f i)"
  by transfer (auto simp: fun_eq_iff)

lemma upd_rows_insert_rev: "upd_rows M (insert i I) f = upd_rows (upd_row M i (f i)) I f"
  by transfer (auto simp: fun_eq_iff)

lemma upd_rows_upd_row_swap: "i \<notin> I \<Longrightarrow> upd_rows (upd_row M i x) I f = upd_row (upd_rows M I f) i x"
  by transfer (simp add: fun_eq_iff)

lemma upd_cols_insert: "upd_cols M (insert i I) f = upd_col (upd_cols M I f) i (f i)"
  by transfer (auto simp: fun_eq_iff)

lemma upd_cols_insert_rev: "upd_cols M (insert i I) f = upd_cols (upd_col M i (f i)) I f"
  by transfer (auto simp: fun_eq_iff)

lemma upd_cols_upd_col_swap: "i \<notin> I \<Longrightarrow> upd_cols (upd_col M i x) I f = upd_col (upd_cols M I f) i x"
  by transfer (simp add: fun_eq_iff)

lemma upd_rows_cong[cong]:
  "M = N \<Longrightarrow> T = S \<Longrightarrow> (\<And>s. s \<in> S =simp=> f s = g s) \<Longrightarrow> upd_rows M T f = upd_rows N S g"
  unfolding simp_implies_def
  by transfer (auto simp: fun_eq_iff)

lemma upd_cols_cong[cong]:
  "M = N \<Longrightarrow> T = S \<Longrightarrow> (\<And>s. s \<in> S =simp=> f s = g s) \<Longrightarrow> upd_cols M T f = upd_cols N S g"
  unfolding simp_implies_def
  by transfer (auto simp: fun_eq_iff)

lemma row_upd_row_If: "row (upd_row M i x) j = (if i = j then x else row M j)"
  by transfer (simp add: vec_eq_iff fun_eq_iff)

lemma row_upd_row[simp]: "row (upd_row M i x) i = x"
  by (simp add: row_upd_row_If)

lemma col_upd_col_If: "col (upd_col M i x) j = (if i = j then x else col M j)"
  by transfer (simp add: vec_eq_iff)

lemma col_upd_col[simp]: "col (upd_col M i x) i = x"
  by (simp add: col_upd_col_If)

lemma upd_row_row[simp]: "upd_row M i (row M i) = M"
  by transfer (simp add: fun_eq_iff)

lemma upd_row_upd_row_cancel[simp]: "upd_row (upd_row M i x) i y = upd_row M i y"
  by transfer (simp add: fun_eq_iff)

lemma upd_col_upd_col_cancel[simp]: "upd_col (upd_col M i x) i y = upd_col M i y"
  by transfer (simp add: fun_eq_iff)

lemma upd_col_col[simp]: "upd_col M i (col M i) = M"
  by transfer (simp add: fun_eq_iff)

lemma row_transpose: "row (transpose M) i = col M i"
  by transfer simp

lemma col_transpose: "col (transpose M) i = row M i"
  by transfer simp

lemma det_perm_cols:
  fixes A :: "'a::comm_ring_1^^'n"
  assumes p: "p permutes UNIV"
  shows "det (perm_cols A p) = of_int (sign p) * det A"
proof (transfer fixing: p)
  fix A :: "'n \<Rightarrow> 'n \<Rightarrow> 'a"
  from p have "(\<Sum>q | q permutes UNIV. of_int (sign q) * (\<Prod>i\<in>UNIV. A i (p (q i)))) =
    (\<Sum>q | q permutes UNIV. of_int (sign (inv p \<circ> q)) * (\<Prod>i\<in>UNIV. A i (q i)))"
    by (intro sum.reindex_bij_witness[where j="\<lambda>q. p \<circ> q" and i="\<lambda>q. inv p \<circ> q"])
       (auto simp: comp_assoc[symmetric] permutes_inv_o permutes_compose permutes_inv)
  with p show "(\<Sum>q | q permutes UNIV. of_int (sign q) * (\<Prod>i\<in>UNIV. A i (p (q i)))) =
      of_int (sign p) * (\<Sum>p | p permutes UNIV. of_int (sign p) * (\<Prod>i\<in>UNIV. A i (p i)))"
    by (auto intro!: sum.cong simp: sum_distrib_left sign_compose permutes_inv sign_inverse permutes_UNIV_permutation)
qed

lemma det_perm_rows:
  fixes A :: "'a::comm_ring_1^^'n"
  assumes p: "p permutes UNIV"
  shows "det (perm_rows A p) = of_int (sign p) * det A"
  using det_perm_cols[OF p, of "transpose A"] by (simp add: det_transpose perm_cols_transpose)

lemma det_row_add: "det (upd_row M i (a + b)) = det (upd_row M i a) + det (upd_row M i b)"
  by transfer (simp add: prod.If_cases sum.distrib[symmetric] field_simps)

lemma det_row_mul: "det (upd_row M i (c *s a)) = c * det (upd_row M i a)"
  by transfer (simp add: prod.If_cases sum_distrib_left field_simps)

lemma det_row_uminus: "det (upd_row M i (- a)) = - det (upd_row M i a)"
  by (simp add: vector_sneg_minus1 det_row_mul)

lemma det_row_minus: "det (upd_row M i (a - b)) = det (upd_row M i a) - det (upd_row M i b)"
  unfolding diff_conv_add_uminus det_row_add det_row_uminus ..

lemma det_row_0: "det (upd_row M i 0) = 0"
  using det_row_mul[of M i 0] by simp

lemma det_row_sum: "det (upd_row M i (\<Sum>s\<in>S. a s)) = (\<Sum>s\<in>S. det (upd_row M i (a s)))"
  by (induction S rule: infinite_finite_induct) (simp_all add: det_row_0 det_row_add)

lemma det_col_add: "det (upd_col M i (a + b)) = det (upd_col M i a) + det (upd_col M i b)"
  using det_row_add[of "transpose M" i a b] by (simp add: upd_row_transpose det_transpose)

lemma det_col_mul: "det (upd_col M i (c *s a)) = c * det (upd_col M i a)"
  using det_row_mul[of "transpose M" i c a] by (simp add: upd_row_transpose det_transpose)

lemma det_col_uminus: "det (upd_col M i (- a)) = - det (upd_col M i a)"
  by (simp add: vector_sneg_minus1 det_col_mul)

lemma det_col_minus: "det (upd_col M i (a - b)) = det (upd_col M i a) - det (upd_col M i b)"
  unfolding diff_conv_add_uminus det_col_add det_col_uminus ..

lemma det_col_0: "det (upd_col M i 0) = 0"
  using det_col_mul[of M i 0] by simp

lemma det_col_sum: "det (upd_col M i (\<Sum>s\<in>S. a s)) = (\<Sum>s\<in>S. det (upd_col M i (a s)))"
  by (induction S rule: infinite_finite_induct) (simp_all add: det_col_0 det_col_add)

(* Proof by Jose Divason *)
lemma det_identical_cols:
  assumes "i \<noteq> i'" shows "col A i = col A i' \<Longrightarrow> det A = 0"
proof (transfer fixing: i i')
  fix A :: "'a \<Rightarrow> 'a \<Rightarrow> 'b" assume "(\<chi> j. A j i) = (\<chi> i. A i i')"
  then have [simp]: "\<And>j q. A j (Fun.swap i i' id (q j)) = A j (q j)"
    by (auto simp: vec_eq_iff swap_def)

  let ?p = "\<lambda>p. of_int (sign p) * (\<Prod>i\<in>UNIV. A i (p i))"
  let ?s = "\<lambda>q. Fun.swap i i' id \<circ> q"
  let ?E = "{p. p permutes UNIV \<and> evenperm p}"

  have [simp]: "inj_on ?s ?E"
    by (auto simp: inj_on_def fun_eq_iff swap_def)

  note p = permutes_UNIV_permutation evenperm_comp permutes_swap_id evenperm_swap permutes_compose
    sign_compose sign_swap_id
  from \<open>i \<noteq> i'\<close> have *: "evenperm q" if "q \<notin> ?s`?E" "q permutes UNIV" for q
    using that by (auto simp add: comp_assoc[symmetric] image_iff p elim!: allE[of _ "?s q"])
  have "(\<Sum>p | p permutes UNIV. ?p p) = (\<Sum>p \<in> ?E \<union> ?s`?E. ?p p)"
    by (auto simp add: permutes_compose permutes_swap_id intro: * sum.cong)
  also have "\<dots> = (\<Sum>p\<in>?E. ?p p) + (\<Sum>p\<in>?s`?E. ?p p)"
    by (intro sum.union_disjoint) (auto simp: p \<open>i \<noteq> i'\<close>)
  also have "(\<Sum>p\<in>?s`?E. ?p p) = (\<Sum>p\<in>?E. - ?p p)"
    using \<open>i \<noteq> i'\<close> by (subst sum.reindex) (auto intro!: sum.cong simp: p)
  finally show "(\<Sum>p | p permutes UNIV. ?p p) = 0"
    by (simp add: sum_negf)
qed

lemma det_identical_rows: "i \<noteq> i' \<Longrightarrow> row A i = row A i' \<Longrightarrow> det A = 0"
  using det_identical_cols[of i i' "transpose A"] by (simp add: det_transpose col_transpose)

lemma det_cols_sum:
  "det (upd_cols M T (\<lambda>i. \<Sum>s\<in>S. a i s)) = (\<Sum>f\<in>T \<rightarrow>\<^sub>E S. det (upd_cols M T (\<lambda>i. a i (f i))))"
proof (induct T arbitrary: M rule: infinite_finite_induct)
  case (insert i T)
  have "(\<Sum>f\<in>insert i T \<rightarrow>\<^sub>E S. det (upd_cols M (insert i T) (\<lambda>i. a i (f i)))) =
    (\<Sum>s\<in>S. \<Sum>f\<in>T \<rightarrow>\<^sub>E S. det (upd_cols (upd_col M i (a i s)) T (\<lambda>i. a i (f i))))"
    unfolding sum.cartesian_product PiE_insert_eq using \<open>i \<notin> T\<close>
    by (subst sum.reindex[OF inj_combinator[OF \<open>i \<notin> T\<close>]])
       (auto intro!: sum.cong arg_cong[where f=det] upd_cols_cong
             simp: upd_cols_insert_rev simp_implies_def)
  also have "\<dots> = det (upd_col (upd_cols M T (\<lambda>i. sum (a i) S)) i (\<Sum>s\<in>S. a i s))"
    unfolding insert(3)[symmetric] by (simp add: upd_cols_upd_col_swap[OF \<open>i \<notin> T\<close>] det_col_sum)
  finally show ?case
    by (simp add: upd_cols_insert)
qed auto

lemma det_rows_sum:
  "det (upd_rows M T (\<lambda>i. \<Sum>s\<in>S. a i s)) = (\<Sum>f\<in>T \<rightarrow>\<^sub>E S. det (upd_rows M T (\<lambda>i. a i (f i))))"
  using det_cols_sum[of "transpose M" T a S] by (simp add: upd_cols_transpose det_transpose)

lemma det_rows_mult: "det (upd_rows M T (\<lambda>i. c i *s a i)) = (\<Prod>i\<in>T. c i) * det (upd_rows M T a)"
  by transfer (simp add: prod.If_cases sum_distrib_left field_simps prod.distrib)

lemma det_cols_mult: "det (upd_cols M T (\<lambda>i. c i *s a i)) = (\<Prod>i\<in>T. c i) * det (upd_cols M T a)"
  using det_rows_mult[of "transpose M" T c a] by (simp add: det_transpose upd_rows_transpose)

lemma det_perm_rows_If: "det (perm_rows B f) = (if f permutes UNIV then of_int (sign f) * det B else 0)"
proof cases
  assume "\<not> f permutes UNIV"
  moreover
  with bij_imp_permutes[of f UNIV] have "\<not> inj f"
    using finite_UNIV_inj_surj[of f] by (auto simp: bij_betw_def)
  then obtain i j where "f i = f j" "i \<noteq> j"
    by (auto simp: inj_on_def)
  moreover
  then have "row (perm_rows B f) i = row (perm_rows B f) j"
    by transfer (auto simp: vec_eq_iff)
  ultimately show ?thesis
    by (simp add: det_identical_rows)
qed (simp add: det_perm_rows)

lemma det_mult: "det (A * B) = det A * det B"
proof -
  have "A * B = upd_rows 0 UNIV (\<lambda>i. \<Sum>j\<in>UNIV. to_fun A i j *s row B j)"
    by transfer simp
  moreover have "\<And>f. upd_rows 0 UNIV (\<lambda>i. Square_Matrix.row B (f i)) = perm_rows B f"
    by transfer simp
  moreover have "det A = (\<Sum>p | p permutes UNIV. of_int (sign p) * (\<Prod>i\<in>UNIV. to_fun A i (p i)))"
    by transfer rule
  ultimately show ?thesis
    by (auto simp add: det_rows_sum det_rows_mult sum_distrib_right det_perm_rows_If
             split: if_split_asm intro!: sum.mono_neutral_cong_right)
qed

lift_definition minor :: "'a^^'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'a::semiring_1^^'b" is
  "\<lambda>A i j k l. if k = i \<and> l = j then 1 else if k = i \<or> l = j then 0 else A k l" .

lemma minor_transpose: "minor (transpose A) i j = transpose (minor A j i)"
  by transfer (auto simp: fun_eq_iff)

lemma minor_eq_row_col: "minor M i j = upd_row (upd_col M j (axis i 1)) i (axis j 1)"
  by transfer (simp add: fun_eq_iff axis_def)

lemma minor_eq_col_row: "minor M i j = upd_col (upd_row M i (axis j 1)) j (axis i 1)"
  by transfer (simp add: fun_eq_iff axis_def)

lemma row_minor: "row (minor M i j) i = axis j 1"
  by (simp add: minor_eq_row_col)

lemma col_minor: "col (minor M i j) j = axis i 1"
  by (simp add: minor_eq_col_row)

lemma det_minor_row':
  "row B i = axis j 1 \<Longrightarrow> det (minor B i j) = det B"
proof (induction "{k. to_fun B k j \<noteq> 0} - {i}" arbitrary: B rule: infinite_finite_induct)
  case empty
  then have "\<And>k. k \<noteq> i \<longrightarrow> to_fun B k j = 0"
    by (auto simp add: card_eq_0_iff)
  with empty.prems have "axis i 1 = col B j"
    by transfer (auto simp: vec_eq_iff axis_def)
  with empty.prems[symmetric] show ?case
    by (simp add: minor_eq_row_col)
next
  case (insert r NZ)
  then have r: "r \<noteq> i" "to_fun B r j \<noteq> 0"
    by auto
  let ?B' = "upd_row B r (row B r - (to_fun B r j) *s row B i)"
  have "det (minor ?B' i j) = det ?B'"
  proof (rule insert.hyps)
    show "NZ = {k. to_fun ?B' k j \<noteq> 0} - {i}"
      using insert.hyps(2,4) insert.prems
      by transfer (auto simp add: axis_def set_eq_iff)
    show "row ?B' i = axis j 1"
      using r insert by (simp add: row_upd_row_If)
  qed
  also have "minor ?B' i j = minor B i j"
    using r insert.prems by transfer (simp add: fun_eq_iff axis_def)
  also have "det ?B' = det B"
    using \<open>r \<noteq> i\<close>
    by (simp add: det_row_minus det_row_mul det_identical_rows[OF \<open>r \<noteq> i\<close>] row_upd_row_If)
  finally show ?case .
qed simp

lemma det_minor_row: "det (minor B i j) = det (upd_row B i (axis j 1))"
proof -
  have "det (minor (upd_row B i (axis j 1)) i j) = det (upd_row B i (axis j 1))"
    by (rule det_minor_row') simp
  then show ?thesis
    by (simp add: minor_eq_col_row)
qed

lemma det_minor_col: "det (minor B i j) = det (upd_col B j (axis i 1))"
  using det_minor_row[of "transpose B" j i]
  by (simp add: minor_transpose det_transpose upd_row_transpose)

lift_definition cofactor :: "'a^^'b \<Rightarrow> 'a::comm_ring_1^^'b" is
  "\<lambda>A i j. det (minor A i j)" .

lemma cofactor_transpose: "cofactor (transpose A) = transpose (cofactor A)"
  by (simp add: cofactor_def minor_transpose det_transpose transpose.rep_eq to_fun_inject[symmetric] of_fun_inverse)

definition "adjugate A = transpose (cofactor A)"

lemma adjugate_transpose: "adjugate (transpose A) = transpose (adjugate A)"
  by (simp add: adjugate_def cofactor_transpose)

theorem adjugate_mult_det: "adjugate A * A = diag (det A)"
proof (intro to_fun_inject[THEN iffD1] fun_eq_iff[THEN iffD2] allI)
  fix i k
  have "to_fun (adjugate A * A) i k = (\<Sum>j\<in>UNIV. to_fun A j k * det (minor A j i))"
    by (simp add: adjugate_def times_sq_matrix.rep_eq transpose.rep_eq cofactor_def mult.commute of_fun_inverse)
  also have "\<dots> = det (upd_col A i (\<Sum>j\<in>UNIV. to_fun A j k *s axis j 1))"
    by (simp add: det_minor_col det_col_mul det_col_sum)
  also have "(\<Sum>j\<in>UNIV. to_fun A j k *s axis j 1) = col A k"
    by transfer (simp add: smult_axis vec_eq_iff, simp add: axis_def sum.If_cases)
  also have "det (upd_col A i (col A k)) = (if i = k then det A else 0)"
    by (auto simp: col_upd_col_If det_identical_cols[of i k])
  also have "\<dots> = to_fun (diag (det A)) i k"
    by (simp add: diag.rep_eq)
  finally show "to_fun (adjugate A * A) i k = to_fun (diag (det A)) i k" .
qed

lemma mult_adjugate_det: "A * adjugate A = diag (det A)"
proof-
  have "transpose (transpose (A * adjugate A)) = transpose (diag (det A))"
    unfolding transpose_mult adjugate_transpose[symmetric] adjugate_mult_det det_transpose ..
  then show ?thesis
    by simp
qed

end