(*  Title:      HOL/MicroJava/DFA/Err.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section \<open>The Error Type\<close>

theory Err
imports Semilat
begin

datatype 'a err = Err | OK 'a

type_synonym 'a ebinop = "'a \<Rightarrow> 'a \<Rightarrow> 'a err"
type_synonym 'a esl = "'a set * 'a ord * 'a ebinop"

primrec ok_val :: "'a err \<Rightarrow> 'a" where
  "ok_val (OK x) = x"

definition lift :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)" where
"lift f e == case e of Err \<Rightarrow> Err | OK x \<Rightarrow> f x"

definition lift2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a err \<Rightarrow> 'b err \<Rightarrow> 'c err" where
"lift2 f e1 e2 ==
 case e1 of Err  \<Rightarrow> Err
          | OK x \<Rightarrow> (case e2 of Err \<Rightarrow> Err | OK y \<Rightarrow> f x y)"

definition le :: "'a ord \<Rightarrow> 'a err ord" where
"le r e1 e2 ==
        case e2 of Err \<Rightarrow> True |
                   OK y \<Rightarrow> (case e1 of Err \<Rightarrow> False | OK x \<Rightarrow> x <=_r y)"

definition sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a err \<Rightarrow> 'b err \<Rightarrow> 'c err)" where
"sup f == lift2(%x y. OK(x +_f y))"

definition err :: "'a set \<Rightarrow> 'a err set" where
"err A == insert Err {x . \<exists>y\<in>A. x = OK y}"

definition esl :: "'a sl \<Rightarrow> 'a esl" where
"esl == %(A,r,f). (A,r, %x y. OK(f x y))"

definition sl :: "'a esl \<Rightarrow> 'a err sl" where
"sl == %(A,r,f). (err A, le r, lift2 f)"

abbreviation
  err_semilat :: "'a esl \<Rightarrow> bool"
  where "err_semilat L == semilat(Err.sl L)"

primrec strict :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)" where
  "strict f Err    = Err"
| "strict f (OK x) = f x"

lemma strict_Some [simp]:
  "(strict f x = OK y) = (\<exists> z. x = OK z \<and> f z = OK y)"
  by (cases x, auto)

lemma not_Err_eq:
  "(x \<noteq> Err) = (\<exists>a. x = OK a)"
  by (cases x) auto

lemma not_OK_eq:
  "(\<forall>y. x \<noteq> OK y) = (x = Err)"
  by (cases x) auto

lemma unfold_lesub_err:
  "e1 <=_(le r) e2 == le r e1 e2"
  by (simp add: lesub_def)

lemma le_err_refl:
  "\<forall>x. x <=_r x \<Longrightarrow> e <=_(Err.le r) e"
apply (unfold lesub_def Err.le_def)
apply (simp split: err.split)
done

lemma le_err_trans [rule_format]:
  "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e3 \<longrightarrow> e1 <=_(le r) e3"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_trans)
done

lemma le_err_antisym [rule_format]:
  "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e1 \<longrightarrow> e1=e2"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_antisym)
done

lemma OK_le_err_OK:
  "(OK x <=_(le r) OK y) = (x <=_r y)"
  by (simp add: unfold_lesub_err le_def)

lemma order_le_err [iff]:
  "order(le r) = order r"
apply (rule iffI)
 apply (subst Semilat.order_def)
 apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
              intro: order_trans OK_le_err_OK [THEN iffD1])
apply (subst Semilat.order_def)
apply (blast intro: le_err_refl le_err_trans le_err_antisym
             dest: order_refl)
done

lemma le_Err [iff]:  "e <=_(le r) Err"
  by (simp add: unfold_lesub_err le_def)

lemma Err_le_conv [iff]:
 "Err <=_(le r) e  = (e = Err)"
  by (simp add: unfold_lesub_err le_def  split: err.split)

lemma le_OK_conv [iff]:
  "e <=_(le r) OK x  =  (\<exists>y. e = OK y & y <=_r x)"
  by (simp add: unfold_lesub_err le_def split: err.split)

lemma OK_le_conv:
 "OK x <=_(le r) e  =  (e = Err | (\<exists>y. e = OK y & x <=_r y))"
  by (simp add: unfold_lesub_err le_def split: err.split)

lemma top_Err [iff]: "top (le r) Err"
  by (simp add: top_def)

lemma OK_less_conv [rule_format, iff]:
  "OK x <_(le r) e = (e=Err | (\<exists>y. e = OK y & x <_r y))"
  by (simp add: lesssub_def lesub_def le_def split: err.split)

lemma not_Err_less [rule_format, iff]:
  "~(Err <_(le r) x)"
  by (simp add: lesssub_def lesub_def le_def split: err.split)

lemma semilat_errI [intro]:
  assumes semilat: "semilat (A, r, f)"
  shows "semilat(err A, Err.le r, lift2(%x y. OK(f x y)))"
  using semilat
  apply (simp only: semilat_Def closed_def plussub_def lesub_def
    lift2_def Err.le_def err_def)
  apply (simp split: err.split)
  done

lemma err_semilat_eslI_aux:
  assumes semilat: "semilat (A, r, f)"
  shows "err_semilat(esl(A,r,f))"
  apply (unfold sl_def esl_def)
  apply (simp add: semilat_errI[OF semilat])
  done

lemma err_semilat_eslI [intro, simp]:
 "\<And>L. semilat L \<Longrightarrow> err_semilat(esl L)"
by(simp add: err_semilat_eslI_aux split_tupled_all)

lemma acc_err [simp, intro!]:  "acc r \<Longrightarrow> acc(le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: err.split)
apply clarify
apply (case_tac "Err \<in> Q")
 apply blast
apply (erule_tac x = "{a . OK a \<in> Q}" in allE)
apply (case_tac "x")
 apply fast
apply blast
done

lemma Err_in_err [iff]: "Err \<in> err A"
  by (simp add: err_def)

lemma Ok_in_err [iff]: "(OK x \<in> err A) = (x\<in>A)"
  by (auto simp add: err_def)

subsection \<open>lift\<close>

lemma lift_in_errI:
  "\<lbrakk> e \<in> err S; \<forall>x\<in>S. e = OK x \<longrightarrow> f x \<in> err S \<rbrakk> \<Longrightarrow> lift f e \<in> err S"
apply (unfold lift_def)
apply (simp split: err.split)
apply blast
done

lemma Err_lift2 [simp]:
  "Err +_(lift2 f) x = Err"
  by (simp add: lift2_def plussub_def)

lemma lift2_Err [simp]:
  "x +_(lift2 f) Err = Err"
  by (simp add: lift2_def plussub_def split: err.split)

lemma OK_lift2_OK [simp]:
  "OK x +_(lift2 f) OK y = x +_f y"
  by (simp add: lift2_def plussub_def split: err.split)

subsection \<open>sup\<close>

lemma Err_sup_Err [simp]:
  "Err +_(Err.sup f) x = Err"
  by (simp add: plussub_def Err.sup_def Err.lift2_def)

lemma Err_sup_Err2 [simp]:
  "x +_(Err.sup f) Err = Err"
  by (simp add: plussub_def Err.sup_def Err.lift2_def split: err.split)

lemma Err_sup_OK [simp]:
  "OK x +_(Err.sup f) OK y = OK(x +_f y)"
  by (simp add: plussub_def Err.sup_def Err.lift2_def)

lemma Err_sup_eq_OK_conv [iff]:
  "(Err.sup f ex ey = OK z) = (\<exists>x y. ex = OK x & ey = OK y & f x y = z)"
apply (unfold Err.sup_def lift2_def plussub_def)
apply (rule iffI)
 apply (simp split: err.split_asm)
apply clarify
apply simp
done

lemma Err_sup_eq_Err [iff]:
  "(Err.sup f ex ey = Err) = (ex=Err | ey=Err)"
apply (unfold Err.sup_def lift2_def plussub_def)
apply (simp split: err.split)
done

subsection \<open>semilat (err A) (le r) f\<close>

lemma semilat_le_err_Err_plus [simp]:
  "\<lbrakk> x \<in> err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> Err +_f x = Err"
  by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
                   Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])

lemma semilat_le_err_plus_Err [simp]:
  "\<lbrakk> x \<in> err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> x +_f Err = Err"
  by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
                   Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])

lemma semilat_le_err_OK1:
  "\<lbrakk> x \<in> A; y \<in> A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
  \<Longrightarrow> x <=_r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub1 [OF Semilat.intro])
done

lemma semilat_le_err_OK2:
  "\<lbrakk> x \<in> A; y \<in> A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
  \<Longrightarrow> y <=_r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub2 [OF Semilat.intro])
done

lemma eq_order_le:
  "\<lbrakk> x=y; order r \<rbrakk> \<Longrightarrow> x <=_r y"
apply (unfold Semilat.order_def)
apply blast
done

lemma OK_plus_OK_eq_Err_conv [simp]:
  assumes "x \<in> A" and "y \<in> A" and "semilat(err A, le r, fe)"
  shows "((OK x) +_fe (OK y) = Err) = (\<not>(\<exists>z\<in>A. x <=_r z & y <=_r z))"
proof -
  have plus_le_conv3: "\<And>A x y z f r.
    \<lbrakk> semilat (A,r,f); x +_f y <=_r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk>
    \<Longrightarrow> x <=_r z \<and> y <=_r z"
    by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "(OK x) +_fe (OK y)")
   apply assumption
  apply (rename_tac z)
  apply (subgoal_tac "OK z \<in> err A")
  apply (drule eq_order_le)
    apply (erule Semilat.orderI [OF Semilat.intro])
   apply (blast dest: plus_le_conv3)
  apply (erule subst)
  apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
  done
qed

subsection \<open>semilat (err (Union AS))\<close>

(* FIXME? *)
lemma all_bex_swap_

text \<open>
  If \<^term>\<open>AS = {}\<close> the thm collapses to
  \<^prop>\<open>order r & closed {Err} f & Err +_f Err = Err\<close>
  which may not hold
\<close>
lemma err_semilat_UnionI:
  "\<lbrakk> \<forall>A\<in>AS. err_semilat(A, r, f); AS \<noteq> {};
      \<forall>A\<in>AS. \<forall>B\<in>AS. A\<noteq>B \<longrightarrow> (\<forall>a\<in>A. \<forall>b\<in>B. \<not> a <=_r b & a +_f b = Err) \<rbrakk>
  \<Longrightarrow> err_semilat (\<Union>AS, r, f)"
apply (unfold semilat_def sl_def)
apply (simp add: closed_err_Union_lift2I)
apply (rule conjI)
 apply blast
apply (simp add: err_def)
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply (rule conjI)
 apply clarify
 apply (rename_tac A a u B b)
 apply (case_tac "A = B")
  apply simp
 apply simp
apply clarify
apply (rename_tac A ya yb B yd z C c a b)
apply (case_tac "A = B")
 apply (case_tac "A = C")
  apply simp
 apply (rotate_tac -1)
 apply simp
apply (rotate_tac -1)
apply (case_tac "B = C")
 apply simp
apply (rotate_tac -1)
apply simp
done

end


(* Author: Hauke Brinkop and Tobias Nipkow *)

section \<open>Pairing Heaps\<close>

subsection \<open>Binary Tree Representation\<close>

theory Pairing_Heap_Tree_Analysis
imports
  Pairing_Heap.Pairing_Heap_Tree
  Amortized_Framework
  Priority_Queue_ops_merge
  Lemmas_log
begin

text
\<open>Verification of logarithmic bounds on the amortized complexity of
pairing heaps \cite{FredmanSST86,Brinkop}.\<close>

fun len :: "'a tree \<Rightarrow> nat" where
  "len Leaf = 0"
| "len (Node _ _ r) = 1 + len r"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
  "\<Phi> Leaf = 0"
| "\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + log 2 (1 + size l + size r)"

lemma link_size[simp]: "size (link h) = size h"
  by (cases h rule: link.cases) simp_all

lemma size_pass\<^sub>1: "size (pass\<^sub>1 h) = size h"
  by (induct h rule: pass\<^sub>1.induct) simp_all

lemma size_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> size (merge h1 h2) = size h1 + size h2"
  by (simp split: tree.splits)

lemma \<Delta>\<Phi>_insert: "is_root h \<Longrightarrow> \<Phi> (insert x h) - \<Phi> h \<le> log 2  (size h + 1)"
  by (simp split: tree.splits)

lemma \<Delta>\<Phi>_merge:
  assumes "h1 = Node lx x Leaf" "h2 = Node ly y Leaf"
  shows "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (size h1 + size h2) + 1"
proof -
  let ?hs = "Node lx x (Node ly y Leaf)"
  have "\<Phi> (merge h1 h2) = \<Phi> (link ?hs)" using assms by simp
  also have "\<dots> = \<Phi> lx + \<Phi> ly + log 2 (size lx + size ly + 1) + log 2 (size lx + size ly + 2)"
    by (simp add: algebra_simps)
  also have "\<dots> = \<Phi> lx + \<Phi> ly + log 2 (size lx + size ly + 1) + log 2 (size h1 + size h2)"
     using assms by simp
  finally have "\<Phi> (merge h1 h2) = \<dots>" .
  have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 =
   log 2 (size lx + size ly + 1) + log 2 (size h1 + size h2)
   - log 2 (size lx + 1) - log 2 (size ly + 1)"
     using assms by (simp add: algebra_simps)
  also have "\<dots> \<le> log 2 (size h1 + size h2) + 1"
    using ld_le_2ld[of "size lx" "size ly"] assms by (simp add: algebra_simps)
  finally show ?thesis .
qed

fun upperbound :: "'a tree \<Rightarrow> real" where
  "upperbound Leaf = 0"
| "upperbound (Node _ _ Leaf) = 0"
| "upperbound (Node lx _ (Node ly _ Leaf)) = 2*log 2 (size lx + size ly + 2)"
| "upperbound (Node lx _ (Node ly _ ry)) = 2*log 2 (size lx + size ly + size ry + 2)
    - 2*log 2 (size ry) - 2 + upperbound ry"

lemma \<Delta>\<Phi>_pass1_upperbound: "\<Phi> (pass\<^sub>1 hs) - \<Phi> hs  \<le> upperbound hs"
proof (induction hs rule: upperbound.induct)
  case (3 lx x ly y)
  have "log 2  (size lx + size ly + 1) - log 2  (size ly + 1)
    \<le> log 2 (size lx + size ly + 1)" by simp
  also have "\<dots> \<le> log 2 (size lx + size ly + 2)" by simp
  also have "\<dots> \<le> 2*\<dots>" by simp
  finally show ?case by (simp add: algebra_simps)
next
  case (4 lx x ly y lz z rz)
  let ?ry = "Node lz z rz"
  let ?rx = "Node ly y ?ry"
  let ?h = "Node lx x ?rx"
  let ?t ="log 2 (size lx + size ly + 1) - log 2 (size ly + size ?ry + 1)"
  have "\<Phi> (pass\<^sub>1 ?h) - \<Phi> ?h \<le> ?t + upperbound ?ry"
    using "4.IH" by (simp add: size_pass\<^sub>1 algebra_simps)
  moreover have "log 2 (size lx + size ly + 1) + 2 * log 2 (size ?ry) + 2
    \<le> 2 * log 2 (size ?h) + log 2 (size ly + size ?ry + 1)" (is "?l \<le> ?r")
  proof -
    have "?l \<le> 2 * log 2 (size lx + size ly + size ?ry + 1) + log 2 (size ?ry)"
      using ld_sum_inequality [of "size lx + size ly + 1" "size ?ry"] by simp
    also have "\<dots> \<le> 2 * log 2 (size lx + size ly + size ?ry + 2) + log 2 (size ?ry)"
      by simp
    also have "\<dots> \<le> ?r" by simp
    finally show ?thesis .
  qed
  ultimately show ?case by simp
qed simp_all

lemma \<Delta>\<Phi>_pass1: assumes "hs \<noteq> Leaf"
  shows "\<Phi> (pass\<^sub>1 hs) - \<Phi> hs \<le> 2*log 2 (size hs) - len hs + 2"
proof -
  from assms have "upperbound hs \<le> 2*log 2 (size hs) - len hs + 2"
    by (induct hs rule: upperbound.induct) (simp_all add: algebra_simps)
  thus ?thesis using \<Delta>\<Phi>_pass1_upperbound [of "hs"] order_trans by blast
qed

lemma \<Delta>\<Phi>_pass2: "hs \<noteq> Leaf \<Longrightarrow> \<Phi> (pass\<^sub>2 hs) - \<Phi> hs \<le> log 2 (size hs)"
proof (induction hs)
  case (Node lx x rx)
  thus ?case
  proof (cases rx)
    case 1: (Node ly y ry)
    let ?h = "Node lx x rx"
    obtain la a where 2: "pass\<^sub>2 rx = Node la a Leaf"
      using pass\<^sub>2_struct 1 by force
    hence 3: "size rx = size \<dots>" using size_pass\<^sub>2 by metis
    have link: "\<Phi>(link(Node lx x (pass\<^sub>2 rx))) - \<Phi> lx - \<Phi> (pass\<^sub>2 rx) =
          log 2 (size lx + size rx + 1) + log 2 (size lx + size rx) - log 2 (size rx)"
      using 2 3 by (simp add: algebra_simps)
    have "\<Phi> (pass\<^sub>2 ?h) - \<Phi> ?h =
        \<Phi> (link (Node lx x (pass\<^sub>2 rx))) - \<Phi> lx - \<Phi> rx - log 2 (size lx + size rx + 1)"
      by (simp)
    also have "\<dots> = \<Phi> (pass\<^sub>2 rx) - \<Phi> rx + log 2 (size lx + size rx) - log 2 (size rx)"
      using link by linarith
    also have "\<dots> \<le> log 2 (size lx + size rx)"
      using Node.IH 1 by simp
    also have "\<dots> \<le> log 2 (size ?h)" using 1 by simp
    finally show ?thesis .
  qed simp
qed simp

lemma \<Delta>\<Phi>_mergepairs: assumes "hs \<noteq> Leaf"
  shows "\<Phi> (merge_pairs hs) - \<Phi> hs \<le> 3 * log 2 (size hs) - len hs + 2"
proof -
  have "pass\<^sub>1 hs \<noteq> Leaf" by (metis assms eq_size_0 size_pass\<^sub>1)
  with assms \<Delta>\<Phi>_pass1[of hs] \<Delta>\<Phi>_pass2[of "pass\<^sub>1 hs"]
  show ?thesis by (auto simp add: size_pass\<^sub>1 pass12_merge_pairs)
qed

lemma \<Delta>\<Phi>_del_min: assumes "lx \<noteq> Leaf"
shows "\<Phi> (del_min (Node lx x Leaf)) - \<Phi> (Node lx x Leaf)
  \<le> 3*log 2 (size lx) - len lx + 2"
proof -
  let ?h = "Node lx x Leaf"
  let ?\<Delta>\<Phi>\<^sub>1 = "\<Phi> lx - \<Phi> ?h"
  let ?\<Delta>\<Phi>\<^sub>2 = "\<Phi>(pass\<^sub>2(pass\<^sub>1 lx)) - \<Phi> lx"
  let ?\<Delta>\<Phi> = "\<Phi> (del_min ?h) - \<Phi> ?h"
  have "lx \<noteq> Leaf \<Longrightarrow> \<Phi>(pass\<^sub>2(pass\<^sub>1 lx)) - \<Phi> (pass\<^sub>1 lx) \<le> log 2  (size lx)"
    using \<Delta>\<Phi>_pass2 [of "pass\<^sub>1 lx"] by(metis eq_size_0 size_pass\<^sub>1)
  moreover have "lx \<noteq> Leaf \<Longrightarrow> \<Phi> (pass\<^sub>1 lx) - \<Phi> lx \<le>  2*\<dots> - len lx + 2"
    using \<Delta>\<Phi>_pass1 by metis
  moreover have "?\<Delta>\<Phi> \<le> ?\<Delta>\<Phi>\<^sub>2" by simp
  ultimately show ?thesis using assms by linarith
qed

lemma is_root_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> is_root (merge h1 h2)"
by (simp split: tree.splits)

lemma is_root_insert: "is_root h \<Longrightarrow> is_root (insert x h)"
by (simp split: tree.splits)

lemma is_root_del_min:
  assumes "is_root h" shows "is_root (del_min h)"
proof (cases h)
  case [simp]: (Node lx x rx)
  have "rx = Leaf" using assms by simp
  thus ?thesis
  proof (cases lx)
    case (Node ly y ry)
    then obtain la a ra where "pass\<^sub>1 lx = Node a la ra"
      using pass\<^sub>1_struct by blast
    moreover obtain lb b where "pass\<^sub>2 \<dots> = Node b lb Leaf"
      using pass\<^sub>2_struct by blast
    ultimately show ?thesis using assms by simp
  qed simp
qed simp

lemma pass\<^sub>1_len: "len (pass\<^sub>1 h) \<le> len h"
by (induct h rule: pass\<^sub>1.induct) simp_all

fun exec :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec Del_min [h] = del_min h" |
"exec (Insert x) [h] = insert x h" |
"exec Merge [h1,h2] = merge h1 h2"

fun t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 :: "'a tree \<Rightarrow> nat" where
  "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 Leaf = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (Node _ _ Leaf) = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (Node _ _ (Node _ _ ry)) = t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 ry + 1"

fun t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 :: "'a tree \<Rightarrow> nat" where
  "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 Leaf = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (Node _ _ rx) = t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 rx + 1"

fun cost :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
  "cost Empty [] = 1"
| "cost Del_min [Leaf] = 1"
| "cost Del_min [Node lx _  _] = t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 lx) + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 lx"
| "cost (Insert a) _ = 1"
| "cost Merge _ = 1"

fun U :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> real" where
  "U Empty [] = 1"
| "U (Insert a) [h] = log 2 (size h + 1) + 1"
| "U Del_min [h] = 3*log 2 (size h + 1) + 4"
| "U Merge [h1,h2] = log 2 (size h1 + size h2 + 1) + 2"

interpretation Amortized
where arity = arity and exec = exec and cost = cost and inv = is_root
and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (1 _ f) thus ?case using is_root_insert is_root_del_min is_root_merge
    by (cases f) (auto simp: numeral_eq_Suc)
next
  case (2 s) show ?case by (induct s) simp_all
next
  case (3 ss f) show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case (Insert x)
    then obtain h where "ss = [h]" "is_root h" using 3 by auto
    thus ?thesis using Insert \<Delta>\<Phi>_insert 3 by auto
  next
    case [simp]: (Del_min)
    then obtain h where [simp]: "ss = [h]" using 3 by auto
    show ?thesis
    proof (cases h)
      case [simp]: (Node lx x rx)
      have "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 lx) + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 lx \<le> len lx + 2"
        by (induct lx rule: pass\<^sub>1.induct) simp_all
      hence "cost f ss \<le> \<dots>" by simp
      moreover have "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size h + 1) - len lx + 2"
      proof (cases lx)
        case [simp]: (Node ly y ry)
        have "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size lx) - len lx + 2"
          using  \<Delta>\<Phi>_del_min[of "lx" "x"] 3 by simp
        also have "\<dots> \<le> 3*log 2 (size h + 1) - len lx + 2" by fastforce
        finally show ?thesis by blast
      qed (insert 3, simp)
      ultimately show ?thesis by auto
    qed simp
  next
    case [simp]: Merge
    then obtain h1 h2 where [simp]: "ss = [h1,h2]" and 1: "is_root h1" "is_root h2"
      using 3 by (auto simp: numeral_eq_Suc)
    show ?thesis
    proof (cases h1)
      case Leaf thus ?thesis by (cases h2) auto
    next
      case h1: Node
      show ?thesis
      proof (cases h2)
        case Leaf thus ?thesis using h1 by simp
      next
        case h2: Node
        have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (real (size h1 + size h2)) + 1"
          apply(rule \<Delta>\<Phi>_merge) using h1 h2 1 by auto
        also have "\<dots> \<le> log 2 (size h1 + size h2 + 1) + 1" by (simp add: h1)
        finally show ?thesis by(simp add: algebra_simps)
      qed
    qed
  qed
qed

end


theory Basics
imports
  HOL.Set_Interval
  HOL.Semiring_Normalization
  HOL.Real_Vector_Spaces
  HOL.Power
  HOL.Complex
  Jordan_Normal_Form.Jordan_Normal_Form

begin

section \<open>Basic Set-Theoretic Results\<close>

lemma set_2_atLeast0 [simp]: "{0..<2::nat} = {0,1}" by auto

lemma set_2: "{..<2::nat} = {0,1}" by auto

lemma set_4_atLeast0 [simp]:"{0..<4::nat} = {0,1,2,3}" by auto

lemma set_4: "{..<4::nat} = {0,1,2,3}" by auto

lemma set_4_disj [simp]:
  fixes i:: nat
  assumes "i < 4"
  shows "i = 0 \<or> i = 1 \<or> i = 2 \<or> i = 3"
  using assms by auto

lemma set_8_atLeast0 [simp]: "{0..<8::nat} = {0,1,2,3,4,5,6,7}" by auto

lemma index_is_2 [simp]: "\<forall>i::nat. i \<noteq> Suc 0 \<longrightarrow> i \<noteq> 3 \<longrightarrow> 0 < i \<longrightarrow> i < 4 \<longrightarrow> i = 2" by simp

lemma index_sl_four [simp]: "\<forall>i::nat. i < 4 \<longrightarrow> i = 0 \<or> i = 1 \<or> i = 2 \<or> i = 3" by auto

section \<open>Basic Arithmetic Results\<close>

lemma index_div_eq [simp]:
  fixes i::nat
  shows "i\<in>{a*b..<(a+1)*b} \<Longrightarrow> i div b = a"
proof-
  fix i::nat
  assume a:"i\<in>{a*b..<(a+1)*b}"
  then have "i div b \<ge> a"
    by (metis Suc_eq_plus1 atLeastLessThan_iff le_refl semiring_normalization_rules(7) split_div')
  moreover have "i div b < a+1"
    using a by (simp add: less_mult_imp_div_less)
  ultimately show "i div b = a" by simp
qed

lemma index_mod_eq [simp]:
  fixes i::nat
  shows "i\<in>{a*b..<(a+1)*b} \<Longrightarrow> i mod b = i-a*b"
  by (simp add: modulo_nat_def)

lemma sqr_of_cmod_of_prod:
  shows "(cmod (z1 * z2))\<^sup>2 = (cmod z1)\<^sup>2 * (cmod z2)\<^sup>2"
  by (simp add: norm_mult power_mult_distrib)

lemma less_power_add_imp_div_less [simp]:
  fixes i m n:: nat
  assumes "i < 2^(m+n)"
  shows "i div 2^n < 2^m"
  using assms by (simp add: less_mult_imp_div_less power_add)

lemma div_mult_mod_eq_minus:
  fixes i j:: nat
  shows "(i div 2^n) * 2^n + i mod 2^n - (j div 2^n) * 2^n - j mod 2^n = i - j"
  by (simp add: div_mult_mod_eq algebra_simps)

lemma neq_imp_neq_div_or_mod:
  fixes i j:: nat
  assumes "i \<noteq> j"
  shows "i div 2^n \<noteq> j div 2^n \<or> i mod 2^n \<noteq> j mod 2^n"
  using assms div_mult_mod_eq_minus
  by (metis add.right_neutral cancel_div_mod_rules(2))

lemma index_one_mat_div_mod:
  assumes "i < 2^(m+n)" and "j < 2^(m+n)"
  shows "((1\<^sub>m(2^m) $$ (i div 2^n, j div 2^n))::complex) * 1\<^sub>m(2^n) $$ (i mod 2^n, j mod 2^n) = 1\<^sub>m(2^(m+n)) $$ (i, j)"
proof (cases "i = j")
  case True
  then show ?thesis by(simp add: assms)
next
  case c1:False
  have "i div 2^n \<noteq> j div 2^n \<or> i mod 2^n \<noteq> j mod 2^n"
    using c1 neq_imp_neq_div_or_mod by simp
  then have "1\<^sub>m (2^m) $$ (i div 2^n, j div 2^n) = 0 \<or> 1\<^sub>m (2^n) $$ (i mod 2^n, j mod 2^n) = 0"
    using assms by simp
  then show ?thesis
    using assms by (simp add: c1)
qed

lemma sqr_of_sqrt_2 [simp]:
  fixes z:: "complex"
  shows "z * 2 / (complex_of_real (sqrt 2) * complex_of_real (sqrt 2)) = z"
  by(metis nonzero_mult_div_cancel_right norm_numeral of_real_numeral of_real_power power2_eq_square
real_norm_def real_sqrt_abs real_sqrt_power zero_neq_numeral)

lemma two_div_sqrt_two [simp]:
  shows "2 * complex_of_real (sqrt (1/2)) = complex_of_real (sqrt 2)"
  apply(auto simp add: real_sqrt_divide algebra_simps)
  by (metis divide_eq_0_iff nonzero_mult_div_cancel_left sqr_of_sqrt_2)

lemma two_div_two [simp]:
  shows "2 div Suc (Suc 0) = 1" by simp

lemma two_mod_two [simp]:
  shows "2 mod Suc (Suc 0) = 0" by (simp add: numeral_2_eq_2)

lemma three_div_two [simp]:
  shows "3 div Suc (Suc 0) = 1" by (simp add: numeral_3_eq_3)

lemma three_mod_two [simp]:
  shows "3 mod Suc (Suc 0) = 1" by (simp add: mod_Suc numeral_3_eq_3)

section \<open>Basic Results on Matrices\<close>

lemma index_matrix_prod [simp]:
  assumes "i < dim_row A" and "j < dim_col B" and "dim_col A = dim_row B"
  shows "(A * B) $$ (i,j) = (\<Sum>k<dim_row B. (A $$ (i,k)) * (B $$ (k,j)))"
  using assms apply(simp add: scalar_prod_def atLeast0LessThan).

section \<open>Basic Results on Sums\<close>

lemma sum_insert [simp]:
  assumes "x \<notin> F" and "finite F"
  shows "(\<Sum>y\<in>insert x F. P y) = (\<Sum>y\<in>F. P y) + P x"
  using assms insert_def by(simp add: add.commute)

lemma sum_of_index_diff [simp]:
  fixes f:: "nat \<Rightarrow> 'a::comm_monoid_add"
  shows "(\<Sum>i\<in>{a..<a+b}. f(i-a)) = (\<Sum>i\<in>{..<b}. f(i))"
proof (induction b)
  case 0
  then show ?case by simp
next
  case (Suc b)
  then show ?case by simp
qed

section \<open>Basic Results Involving the Exponential Function.\<close>

lemma exp_of_real_cnj:
  fixes x ::real
  shows "cnj (exp (\<i> * x)) = exp (-(\<i> * x))"
proof
  show "Re (cnj (exp (\<i> * x))) = Re (exp (-(\<i> * x)))"
    using Re_exp by simp
  show "Im (cnj (exp (\<i> * x))) = Im (exp (-(\<i> * x)))"
    using Im_exp by simp
qed

lemma exp_of_real_cnj2:
  fixes x ::real
  shows "cnj (exp (-(\<i> * x))) = exp (\<i> * x)"
proof
  show "Re (cnj (exp (-(\<i> * x)))) = Re (exp (\<i> * x))"
    using Re_exp by simp
  show "Im (cnj (exp (-(\<i> * x)))) = Im (exp (\<i> * x))"
    using Im_exp by simp
qed

lemma exp_of_half_pi:
  fixes x:: real
  assumes "x = pi/2"
  shows "exp (\<i> * complex_of_real x) = \<i>"
  using assms cis_conv_exp cis_pi_half by fastforce

lemma exp_of_minus_half_pi:
  fixes x:: real
  assumes "x = pi/2"
  shows "exp (-(\<i> * complex_of_real x)) = -\<i>"
  using assms cis_conv_exp cis_minus_pi_half by fastforce

lemma exp_of_real:
  fixes x:: real
  shows "exp (\<i> * x) = cos x + \<i> * (sin x)"
proof
  show "Re (exp (\<i> * x)) = Re ((cos x) + \<i> * (sin x))"
    using Re_exp by simp
  show "Im (exp (\<i> * x)) = Im ((cos x) + \<i> * (sin x))"
    using Im_exp by simp
qed

lemma exp_of_real_inv:
  fixes x:: real
  shows "exp (-(\<i> * x)) = cos x - \<i> * (sin x)"
proof
  show "Re (exp (-(\<i> * x))) = Re ((cos x) - \<i> * (sin x))"
    using Re_exp by simp
  show "Im (exp (-(\<i> * x))) = Im ((cos x) - \<i> * (sin x))"
    using Im_exp by simp
qed

section \<open>Basic Results with Trigonometric Functions.\<close>

subsection \<open>Basic Inequalities\<close>

lemma sin_squared_le_one:
  fixes x:: real
  shows "(sin x)\<^sup>2 \<le> 1"
  using abs_sin_le_one abs_square_le_1 by blast

lemma cos_squared_le_one:
  fixes x:: real
  shows "(cos x)\<^sup>2 \<le> 1"
  using abs_cos_le_one abs_square_le_1 by blast

subsection \<open>Basic Equalities\<close>

lemma sin_of_quarter_pi:
  fixes x:: real
  assumes "x = pi/2"
  shows "sin (x/2) = (sqrt 2)/2"
  by (auto simp add: assms sin_45)

lemma cos_of_quarter_pi:
  fixes x:: real
  assumes "x = pi/2"
  shows "cos (x/2) = (sqrt 2)/2"
  by (auto simp add: assms cos_45)

end


theory STL
  imports Complex_Main STLLoss_max_min

begin

datatype cterm = Get int | Add cterm cterm | Mult cterm cterm | Uminus cterm | Divide cterm cterm

datatype 'v constraint = cMu "cterm \<Rightarrow> 'v \<Rightarrow> real" cterm real | cNot "'v constraint"
  | cAnd "'v constraint" "'v constraint" | cUntil real real "'v constraint" "'v constraint"

datatype rconstraint = crMu cterm real | crNot rconstraint
  | crAnd rconstraint rconstraint | crUntil real real rconstraint rconstraint

fun subconstraint :: "'v constraint \<Rightarrow> 'v constraint \<Rightarrow> bool" where
"subconstraint c (cMu f ct r) = (c = cMu f ct r)"
| "subconstraint c (cNot c1) = (c = (cNot c1) \<or> c = c1 \<or> subconstraint c c1)"
| "subconstraint c (cAnd c1 c2) = (c = (cAnd c1 c2) \<or> c = c1 \<or> c = c2 \<or> subconstraint c c1 \<or> subconstraint c c2)"
| "subconstraint c (cUntil x y c1 c2) = (c = (cUntil x y c1 c2) \<or> c = c1 \<or> c = c2 \<or> subconstraint c c1 \<or> subconstraint c c2)"

fun valid_constraint :: "real \<Rightarrow> 'v constraint \<Rightarrow> bool" where
"valid_constraint l (cMu f ct r) = (l \<ge> 0)"
| "valid_constraint l (cNot c) = (valid_constraint l c)"
| "valid_constraint l (cAnd c1 c2) = ((valid_constraint l c1 \<and> valid_constraint l c2))"
| "valid_constraint l (cUntil x y c1 c2) =
  (x \<le> l \<and> y \<le> l \<and> x \<ge> 0 \<and> y \<ge> 0 \<and>
    (valid_constraint (l-x) c1
    \<and> valid_constraint (l-y) c1
    \<and> valid_constraint (l-x) c2
    \<and> valid_constraint (l-y) c2))"

lemma vc_l:
  assumes "valid_constraint l c"
  shows "l\<ge>0"
proof (insert assms, induct c)
  case (cMu f ct r)
  then show ?case
    using valid_constraint.simps(1)
    by blast
next
  case (cAnd c1 c2)
  then show ?case
    by simp
next
  case (cNot c)
  then show ?case
    by simp
next
  case (cUntil x y c1 c2)
  then show ?case
    using valid_constraint.simps(4)
    by force
qed

lemma vc_longer:
  fixes l r :: real and c :: "'v constraint"
  assumes "r\<ge>0" "valid_constraint l c"
  shows "valid_constraint (l+r) c"
proof (insert assms, induct c arbitrary:  l r)
  case (cMu f ct r)
  then show ?case
    using valid_constraint.simps(1)
    by auto
next
  case (cNot c)
  then show ?case
    using valid_constraint.simps(2)
    by blast
next
  case (cAnd c)
  then show ?case
    using valid_constraint.simps(3)
    by blast
next
  case (cUntil x y c1 c2)
  then have "(x \<le> l \<and> y \<le> l \<and> x \<ge> 0 \<and> y \<ge> 0 \<and>
    (valid_constraint (l-x) c1
    \<and> valid_constraint (l-y) c1
    \<and> valid_constraint (l-x) c2
    \<and> valid_constraint (l-y) c2))"
    using valid_constraint.simps(4)
    by force
  then have "(x \<le> l+r \<and> y \<le> l+r \<and> x \<ge> 0 \<and> y \<ge> 0 \<and>
    (valid_constraint (l+r-x) c1
    \<and> valid_constraint (l+r-y) c1
    \<and> valid_constraint (l+r-x) c2
    \<and> valid_constraint (l+r-y) c2))"
    using cUntil.hyps(1) cUntil.hyps(2) cUntil.prems(1)
    by (smt (verit, ccfv_SIG))
  then show ?case
    using valid_constraint.simps(4)
    by blast
qed

lemma vc_subconstraint:
  fixes l :: real and c c1 :: "'v constraint"
  assumes "valid_constraint l c" "subconstraint c' c"
  shows "valid_constraint l c'"
proof (insert assms, induction c)
  case (cMu f ct r)
  then show ?case
    using subconstraint.simps(1) valid_constraint.simps(1)
    by force
next
  case (cNot c)
  then show ?case
    using subconstraint.simps(2) valid_constraint.simps(2)
    by auto
next
  case (cAnd c1 c2)
  then show ?case
    using subconstraint.simps(3) valid_constraint.simps(3)
    by auto
next
  case (cUntil x y c1 c2)
  then show ?case
    using subconstraint.simps(4) valid_constraint.simps(4) vc_longer diff_add_cancel
    by metis
qed

fun evalvc :: "(real \<Rightarrow> 'v) \<Rightarrow> real \<Rightarrow> 'v constraint \<Rightarrow> bool" where
"evalvc t l (cMu f ct r) = (valid_constraint l (cMu f ct r) \<and> ((f ct (t 0)) > r))"
| "evalvc t l (cNot c) = (valid_constraint l (cNot c) \<and> (\<not>(evalvc t l c)))"
| "evalvc t l (cAnd c1 c2) = (valid_constraint l (cAnd c1 c2) \<and>
  ((evalvc t l c1) \<and> (evalvc t l c2)))"
| "evalvc t l (cUntil x y c1 c2) =
  (valid_constraint l (cUntil x y c1 c2) \<and> (\<exists>t'\<ge>x. t'\<le>y \<and> evalvc (\<lambda>r. t (r+t')) (l-t') c2
    \<and> (\<forall>t''. t''\<ge>0\<and>t''\<le>t' \<longrightarrow> evalvc (\<lambda>r. t (r+t'')) (l-t'') c1)))"

fun eval :: "(real \<Rightarrow> 'v) \<Rightarrow> real \<Rightarrow> 'v constraint \<Rightarrow> bool" where
"eval t l (cMu f ct r) = ((f ct (t 0)) > r)"
| "eval t l (cNot c) = (\<not>(eval t l c))"
| "eval t l (cAnd c1 c2) = ((eval t l c1) \<and> (eval t l c2))"
| "eval t l (cUntil x y c1 c2) = (\<exists>t'\<ge>x. t'\<le>y \<and> t'\<le>l \<and> eval (\<lambda>r. t (r+t')) (l-t') c2
    \<and> (\<forall>t''. t''\<ge>0\<and>t''\<le>t' \<longrightarrow> eval (\<lambda>r. t (r+t'')) (l-t'') c1))"

lemma evalvc_vc:
  assumes "evalvc t l c"
  shows "valid_constraint l c"
  using evalvc.simps assms constraint.exhaust
  by metis

definition cTrue :: "'v constraint" where
"cTrue = cMu (\<lambda>ct r. 1) (Get 0) 0"

lemma cTrue_vc:"valid_constraint l cTrue = (l\<ge>0)"
  using valid_constraint.simps(1) cTrue_def
  by metis

lemma cTrue_evalvc: "evalvc t l cTrue = (l\<ge>0)"
  using cTrue_def evalvc.simps(1) zero_less_one cTrue_vc
  by metis

lemma cTrue_eval:"eval t l cTrue"
  using cTrue_def eval.simps(1) zero_less_one
  by metis

definition cOr :: "'v constraint \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint" where
"cOr c1 c2 = cNot (cAnd (cNot c1) (cNot c2))"

lemma cOr_vc:"valid_constraint l (cOr c1 c2) = (valid_constraint l c1 \<and> valid_constraint l c2)"
  using valid_constraint.simps(2,3) cOr_def
  by metis

lemma cOr_evalvc:"evalvc t l (cOr c1 c2) = (valid_constraint l (cOr c1 c2) \<and> (evalvc t l c1 \<or> evalvc t l c2))"
  using valid_constraint.simps(2,3) cOr_def evalvc.simps(2,3)
  by metis

lemma cOr_eval:"eval t l (cOr c1 c2) = (eval t l c1 \<or> eval t l c2)"
  using cOr_def eval.simps(2,3)
  by metis

definition cImplies :: "'v constraint \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint" where
"cImplies c1 c2 = cOr (cNot c1) c2"

lemma cImplies_vc:"valid_constraint l (cImplies c1 c2) = (valid_constraint l c1 \<and> valid_constraint l c2)"
  using valid_constraint.simps(2,3) cImplies_def cOr_def
  by metis

lemma cImplies_evalvc:"evalvc t l (cImplies c1 c2) = (valid_constraint l (cImplies c1 c2) \<and> (evalvc t l c1 \<longrightarrow> evalvc t l c2))"
  using valid_constraint.simps(2,3) cOr_def evalvc.simps(2,3) cImplies_def
  by metis

lemma cImplies_eval:"eval t l (cImplies c1 c2) = (eval t l c1 \<longrightarrow> eval t l c2)"
  using cImplies_def eval.simps(2) cOr_eval
  by metis

definition cEventually :: "real \<Rightarrow> real \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint" where
"cEventually x y c = cUntil x y cTrue c"

lemma cEventually_vc: "valid_constraint l (cEventually x y c) =
  (x \<le> l \<and> y \<le> l \<and> x \<ge> 0 \<and> y \<ge> 0 \<and>
    (valid_constraint (l-x) c
    \<and> valid_constraint (l-y) c))"
  using cEventually_def valid_constraint.simps(4) cTrue_vc vc_l
  by metis

lemma cEventually_vc': "valid_constraint l (cEventually x y c) = valid_constraint l (cUntil x y cTrue c)"
  using cEventually_def
  by metis

lemma cEventually_evalvc: "evalvc t l (cEventually x y c) = (valid_constraint l (cEventually x y c)
  \<and> (\<exists>t'\<ge>x. t'\<le>y \<and> evalvc (\<lambda>r. t (r+t')) (l-t') c))"
proof -
  have "evalvc t l (cEventually x y c) = evalvc t l (cUntil x y cTrue c)"
    using cEventually_def
    by metis
  then have 1:"evalvc t l (cEventually x y c) = (valid_constraint l (cEventually x y c)
      \<and> (\<exists>t'\<ge>x. t'\<le>y \<and> evalvc (\<lambda>r. t (r+t')) (l-t') c
      \<and> (\<forall>t''. t''\<ge>0\<and>t''\<le>t' \<longrightarrow> evalvc (\<lambda>r. t (r+t'')) (l-t'') cTrue)))"
    using evalvc.simps(4) cEventually_vc' cEventually_vc valid_constraint.simps(4)
    by blast
  then show ?thesis
  proof -
    have 2:"evalvc t l (cEventually x y c) = (valid_constraint l (cEventually x y c)
    \<and> (\<exists>t'\<ge>x. t'\<le>y \<and> evalvc (\<lambda>r. t (r+t')) (l-t') c
    \<and> t'\<le>l))"
      using 1 cTrue_evalvc valid_constraint.simps(4) cTrue_def cEventually_vc
      by (smt (verit, ccfv_threshold))
    then have "\<forall>t'. evalvc (\<lambda>r. t (r+t')) (l-t') c \<longrightarrow> l-t'\<ge>0"
      using evalvc_vc vc_l
      by metis
    then show ?thesis
      using 2
      by auto
  qed
qed

lemma cEventually_eval: "eval t l (cEventually x y c) = (\<exists>t'\<ge>x. t'\<le>y \<and> t'\<le>l \<and> eval (\<lambda>r. t (r+t')) (l-t') c)"
  using cTrue_eval eval.simps(4) cEventually_def
  by metis

definition cAlways :: "real \<Rightarrow> real \<Rightarrow> 'v constraint \<Rightarrow> 'v constraint" where
"cAlways x y c = cNot (cEventually x y (cNot c))"

lemma cAlways_vc:"valid_constraint l (cAlways x y c) =
  (x \<le> l \<and> y \<le> l \<and> x \<ge> 0 \<and> y \<ge> 0 \<and>
    (valid_constraint (l-x) c
    \<and> valid_constraint (l-y) c))"
  using cAlways_def cEventually_vc valid_constraint.simps cTrue_vc vc_l
  by (smt (verit, del_insts))

lemma cAlways_evalvc:"evalvc t l (cAlways x y c) =
  (valid_constraint l (cAlways x y c) \<and> (\<forall>t'\<ge>x. t'\<le>y \<longrightarrow> evalvc (\<lambda>r. t (r+t')) (l-t') c))"
proof -
  have "evalvc t l (cAlways x y c)
    = (valid_constraint l (cAlways x y c)
      \<and> (\<not>(evalvc t l (cEventually x y (cNot c)))))"
    using cAlways_def evalvc.simps(2)
    by metis
  then have "evalvc t l (cAlways x y c)
    = (valid_constraint l (cAlways x y c)
      \<and> (\<not>(\<exists>t'\<ge>x. t'\<le>y \<and> evalvc (\<lambda>r. t (r+t')) (l-t') (cNot c))))"
    using cEventually_evalvc cAlways_vc cEventually_vc valid_constraint.simps(2)
    by blast
  then have 1:"evalvc t l (cAlways x y c)
    = (valid_constraint l (cAlways x y c)
      \<and> (\<not>(\<exists>t'\<ge>x. t'\<le>y \<and> valid_constraint (l-t') c \<and> (\<not>(evalvc (\<lambda>r. t (r+t')) (l-t') c)))))"
    using evalvc.simps(2) valid_constraint.simps(2)
    by blast
  then have "evalvc t l (cAlways x y c)
    = (valid_constraint l (cAlways x y c)
      \<and> (\<not>(\<exists>t'\<ge>x. t'\<le>y \<and> valid_constraint (l-x) c \<and> (\<not>(evalvc (\<lambda>r. t (r+t')) (l-t') c)))))"
    using vc_longer add_0 add_diff_cancel_left' add_le_cancel_left cAlways_vc diff_add_cancel
    by (metis 1)
  then have "evalvc t l (cAlways x y c)
    = (valid_constraint l (cAlways x y c)
      \<and> (\<not>(\<exists>t'\<ge>x. t'\<le>y \<and> (\<not>(evalvc (\<lambda>r. t (r+t')) (l-t') c)))))"
    using cAlways_vc
    by blast
  then have "evalvc t l (cAlways x y c)
    = (valid_constraint l (cAlways x y c)
      \<and> ((\<forall>t'\<ge>x. \<not>(t'\<le>y \<and> (\<not>(evalvc (\<lambda>r. t (r+t')) (l-t') c))))))"
    by blast
  then show ?thesis
    by blast
qed

lemma cAlways_eval:"eval t l (cAlways x y c) = (\<forall>t'\<ge>x. t'\<le>y \<and> t'\<le>l \<longrightarrow> eval (\<lambda>r. t (r+t')) (l-t') c)"
proof -
  have "eval t l (cAlways x y c) = (\<not>(\<exists>t'\<ge>x. t'\<le>y \<and> t'\<le>l \<and> eval (\<lambda>r. t (r+t')) (l-t') (cNot c)))"
    using cEventually_eval cAlways_def eval.simps(2)
    by metis
  then show ?thesis
    using eval.simps(2)
    by blast
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_33
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun min :: "Nat => Nat => Nat" where
"min (Z) z = Z"
| "min (S z2) (Z) = Z"
| "min (S z2) (S y1) = S (min z2 y1)"

fun t2 :: "Nat => Nat => bool" where
"t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((x (min a b) a) = (t2 a b))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_relaxedprefix_is_prefix_3
imports "../../Test_Base"
begin

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

datatype It = A | B | C

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

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) z = True"
| "isPrefix (cons2 z2 x2) (nil2) = False"
| "isPrefix (cons2 z2 x2) (cons2 x3 x4) =
     ((z2 = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) z = True"
| "isRelaxedPrefix (cons2 z2 (nil2)) z = True"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z2 = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

theorem property0 :
  "isRelaxedPrefix (x xs (cons2 y (nil2))) (x xs ys)"
  oops

end


(* *)
theory Qrev
  imports "$HIPSTER_HOME/IsaHipster"
begin

(*setup Tactic_Data.set_sledge_induct_sledge*)

(* Hard exercise  *)
fun qrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "qrev [] acc  = acc"
| "qrev (x#xs) acc = qrev xs (x#acc)"

hipster rev qrev
lemma lemma_a [thy_expl]: "rev y @ z = qrev y z"
  apply (induct y arbitrary: z)
  apply simp
  apply (metis append.assoc append_Cons append_eq_append_conv2 append_self_conv qrev.simps(2) rev.simps(2))
  done

lemma lemma_aa [thy_expl]: "x2 @ z @ [y] = rev (y # qrev z (rev x2))"
  apply (induct x2 arbitrary: z)
  apply (metis append_Nil2 lemma_a rev.simps(1) rev.simps(2) rev_rev_ident self_append_conv2)
  apply (metis (no_types, lifting) append_Cons lemma_a rev.simps(2) rev_append rev_eq_Cons_iff rev_singleton_conv)
  done

  theorem hardExercise: "rev xs = qrev xs Nil"
  sledgehammer
  by (metis append_Nil2 lemma_a)
end


(*
    File:        Infinite.thy
    Time-stamp:  <2020-06-22T04:22:53Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory Infinite imports ZF.Finite ZF.Cardinal begin

definition Infinite :: "i => o" where
  "Infinite(X) == ALL F: Fin(X). X ~= F"

lemma InfiniteI:
  "[| !! x. [| x: Fin(X); x = X |] ==> False |] ==> Infinite(X)"
apply (unfold Infinite_def)
apply blast
done

lemma InfiniteI2:
  "X ~: Fin(X) ==> Infinite(X)"
apply (unfold Infinite_def)
apply blast
done

lemma Infinite_imp_not_empty:
  "Infinite(X) ==> X ~= 0"
apply (unfold Infinite_def)
apply (drule bspec)
by (rule Fin.intros)

lemma neq_subset_imp_bex_not_mem:
  "[| A ~= B; B <= A |] ==> EX x: A. x ~: B"
apply (rule swap)
apply (erule contrapos)
apply (rule equalityI)
apply (assumption, assumption)
apply (rule subsetI)
apply (rule swap)
apply (rule_tac [2] bexI)
apply assumption+
done

lemma InfiniteD:
  "[| Infinite(X); F: Fin(X) |] ==> EX x: X. x ~: F"
apply (unfold Infinite_def)
(* apply blast *)
apply (drule bspec)
apply assumption
apply (drule FinD)
apply (erule neq_subset_imp_bex_not_mem)
apply assumption
done

lemmas InfiniteE = InfiniteD [THEN bexE]

lemma Infinite_not_Finite_iff: "Infinite(X) <-> ~ Finite(X)"
apply (simp add: Infinite_def Finite_Fin_iff)
apply blast
done

end


(*  File:       Elimination_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Elimination Module\<close>

theory Elimination_Module
  imports Evaluation_Function
          Electoral_Module
begin

text
\<open>This is the elimination module. It rejects a set of alternatives only if these
are not all alternatives. The alternatives potentially to be rejected are put
in a so-called elimination set. These are all alternatives that score below
a preset threshold value that depends on the specific voting rule.\<close>

subsection \<open>Definition\<close>

type_synonym Threshold_Value = nat

type_synonym Threshold_Relation = "nat \<Rightarrow> nat \<Rightarrow> bool"

type_synonym 'a Electoral_Set = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set"

fun elimination_set :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Set" where
 "elimination_set e t r A p = {a \<in> A . r (e a A p) t }"

fun elimination_module :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Module" where
  "elimination_module e t r A p =
      (if (elimination_set e t r A p) \<noteq> A
        then ({}, (elimination_set e t r A p), A - (elimination_set e t r A p))
        else ({},{},A))"

subsection \<open>Common Eliminators\<close>

fun less_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "less_eliminator e t A p = elimination_module e t (<) A p"

fun max_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "max_eliminator e A p =
    less_eliminator e (Max {e x A p | x. x \<in> A}) A p"

fun leq_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "leq_eliminator e t A p = elimination_module e t (\<le>) A p"

fun min_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "min_eliminator e A p =
    leq_eliminator e (Min {e x A p | x. x \<in> A}) A p"

fun average :: "'a Evaluation_Function \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                    Threshold_Value" where
  "average e A p = (\<Sum>x \<in> A. e x A p) div (card A)"

fun less_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "less_average_eliminator e A p = less_eliminator e (average e A p) A p"

fun leq_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "leq_average_eliminator e A p = leq_eliminator e (average e A p) A p"

subsection \<open>Soundness\<close>

lemma elim_mod_sound[simp]: "electoral_module (elimination_module e t r)"
proof (unfold electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  have "set_equals_partition A (elimination_module e t r A p)"
    by auto
  thus "well_formed A (elimination_module e t r A p)"
    by simp
qed

lemma less_elim_sound[simp]: "electoral_module (less_eliminator e t)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < t} \<union> A = A"
    by safe
qed

lemma leq_elim_sound[simp]: "electoral_module (leq_eliminator e t)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> t} \<union> A = A"
    by safe
qed

lemma max_elim_sound[simp]: "electoral_module (max_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < Max {e x A p |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < Max {e x A p |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma min_elim_sound[simp]: "electoral_module (min_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> Min {e x A p |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> Min {e x A p |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma less_avg_elim_sound[simp]: "electoral_module (less_average_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < (\<Sum>x\<in>A. e x A p) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < (\<Sum>x\<in>A. e x A p) div card A} \<union> A = A"
    by safe
qed

lemma leq_avg_elim_sound[simp]: "electoral_module (leq_average_eliminator e)"
  unfolding electoral_module_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> (\<Sum>x\<in>A. e x A p) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> (\<Sum>x\<in>A. e x A p) div card A} \<union> A = A"
    by safe
qed

subsection \<open>Non-Electing\<close>

lemma elim_mod_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (elimination_module e t r )"
  by (simp add: non_electing_def)

lemma less_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (less_eliminator e t)"
  using elim_mod_non_electing profile less_elim_sound
  by (simp add: non_electing_def)

lemma leq_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (leq_eliminator e t)"
proof -
  have "non_electing (elimination_module e t (\<le>))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma max_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (max_eliminator e)"
proof -
  have "non_electing (elimination_module e t (<))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma min_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (min_eliminator e)"
proof -
  have "non_electing (elimination_module e t (<))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma less_avg_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (less_average_eliminator e)"
proof -
  have "non_electing (elimination_module e t (<))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

lemma leq_avg_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (leq_average_eliminator e)"
proof -
  have "non_electing (elimination_module e t (\<le>))"
    by (simp add: non_electing_def)
  thus ?thesis
    by (simp add: non_electing_def)
qed

subsection \<open>Inference Rules\<close>

(*** If the used evaluation function is Condorcet rating,
     max-eliminator is Condorcet compatible. ***)
theorem cr_eval_imp_ccomp_max_elim[simp]:
  assumes
    profile: "finite_profile A p" and
    rating: "condorcet_rating e"
  shows
    "condorcet_compatibility (max_eliminator e)"
  unfolding condorcet_compatibility_def
proof (auto)
  have f1:
    "\<And>A p w x. condorcet_winner A p w \<Longrightarrow>
      finite A \<Longrightarrow> w \<in> A \<Longrightarrow> e w A p < Max {e x A p |x. x \<in> A} \<Longrightarrow>
        x \<in> A \<Longrightarrow> e x A p < Max {e x A p |x. x \<in> A}"
    using rating
    by (simp add: cond_winner_imp_max_eval_val)
  thus
    "\<And>A p w x.
      profile A p \<Longrightarrow> w \<in> A \<Longrightarrow>
        \<forall>x\<in>A - {w}.
          card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)} \<Longrightarrow>
              finite A \<Longrightarrow> e w A p < Max {e x A p | x. x \<in> A} \<Longrightarrow>
                x \<in> A \<Longrightarrow> e x A p < Max {e x A p | x. x \<in> A}"
    by simp
qed

lemma cr_eval_imp_dcc_max_elim_helper1:
  assumes
    f_prof: "finite_profile A p" and
    rating: "condorcet_rating e" and
    winner: "condorcet_winner A p w"
  shows "elimination_set e (Max {e x A p | x. x \<in> A}) (<) A p = A - {w}"
proof (safe, simp_all, safe)
  assume
    w_in_A: "w \<in> A" and
    max: "e w A p < Max {e x A p |x. x \<in> A}"
  show "False"
    using cond_winner_imp_max_eval_val
          rating winner f_prof max
    by fastforce
next
  fix
    x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    not_max: "\<not> e x A p < Max {e y A p |y. y \<in> A}"
  show "x = w"
    using non_cond_winner_not_max_eval x_in_A
          rating winner f_prof not_max
    by (metis (mono_tags, lifting))
qed

(*
  If the used evaluation function is Condorcet rating, max-eliminator
  is defer-Condorcet-consistent.
*)
theorem cr_eval_imp_dcc_max_elim[simp]:
  assumes rating: "condorcet_rating e"
  shows "defer_condorcet_consistency (max_eliminator e)"
  unfolding defer_condorcet_consistency_def
proof (safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    finite: "finite A"
  let ?trsh = "(Max {e y A p | y. y \<in> A})"
  show
    "max_eliminator e A p =
      ({},
        A - defer (max_eliminator e) A p,
        {a \<in> A. condorcet_winner A p a})"
  proof (cases "elimination_set e (?trsh) (<) A p \<noteq> A")
    case True
    have profile: "finite_profile A p"
      using winner
      by simp
    with rating winner have 0:
      "(elimination_set e ?trsh (<) A p) = A - {w}"
      using cr_eval_imp_dcc_max_elim_helper1
      by (metis (mono_tags, lifting))
    have
      "max_eliminator e A p =
        ({},
          (elimination_set e ?trsh (<) A p),
          A - (elimination_set e ?trsh (<) A p))"
      using True
      by simp
    also have "... = ({}, A - {w}, A - (A - {w}))"
      using "0"
      by presburger
    also have "... = ({}, A - {w}, {w})"
      using winner
      by auto
    also have "... = ({},A - defer (max_eliminator e) A p, {w})"
      using calculation
      by auto
    also have
      "... =
        ({},
          A - defer (max_eliminator e) A p,
          {d \<in> A. condorcet_winner A p d})"
      using cond_winner_unique3 winner Collect_cong
      by (metis (no_types, lifting))
    finally show ?thesis
      using finite winner
      by metis
  next
    case False
    thus ?thesis
    proof -
      have f1:
        "finite A \<and> profile A p \<and> w \<in> A \<and> (\<forall>a. a \<notin> A - {w} \<or> wins w p a)"
        using winner
        by auto
      hence
        "?trsh = e w A p"
        using rating winner
        by (simp add: cond_winner_imp_max_eval_val)
      hence False
        using f1 False
        by auto
      thus ?thesis
        by simp
    qed
  qed
qed

end


(*  Title:      HOL/ex/Lagrange.thy
    Author:     Tobias Nipkow
    Copyright   1996 TU Muenchen
*)

section {* A lemma for Lagrange's theorem *}

theory Lagrange imports Main begin

text {* This theory only contains a single theorem, which is a lemma
in Lagrange's proof that every natural number is the sum of 4 squares.
Its sole purpose is to demonstrate ordered rewriting for commutative
rings.

The enterprising reader might consider proving all of Lagrange's
theorem.  *}

definition sq :: "'a::times => 'a" where "sq x == x*x"

text {* The following lemma essentially shows that every natural
number is the sum of four squares, provided all prime numbers are.
However, this is an abstract theorem about commutative rings.  It has,
a priori, nothing to do with nat. *}

lemma Lagrange_lemma: fixes x1 :: "'a::comm_ring" shows
  "(sq x1 + sq x2 + sq x3 + sq x4) * (sq y1 + sq y2 + sq y3 + sq y4) =
   sq (x1*y1 - x2*y2 - x3*y3 - x4*y4)  +
   sq (x1*y2 + x2*y1 + x3*y4 - x4*y3)  +
   sq (x1*y3 - x2*y4 + x3*y1 + x4*y2)  +
   sq (x1*y4 + x2*y3 - x3*y2 + x4*y1)"
by (simp only: sq_def algebra_simps)

text {* A challenge by John Harrison. Takes about 12s on a 1.6GHz machine. *}

lemma fixes p1 :: "'a::comm_ring" shows
  "(sq p1 + sq q1 + sq r1 + sq s1 + sq t1 + sq u1 + sq v1 + sq w1) *
   (sq p2 + sq q2 + sq r2 + sq s2 + sq t2 + sq u2 + sq v2 + sq w2)
    = sq (p1*p2 - q1*q2 - r1*r2 - s1*s2 - t1*t2 - u1*u2 - v1*v2 - w1*w2) +
      sq (p1*q2 + q1*p2 + r1*s2 - s1*r2 + t1*u2 - u1*t2 - v1*w2 + w1*v2) +
      sq (p1*r2 - q1*s2 + r1*p2 + s1*q2 + t1*v2 + u1*w2 - v1*t2 - w1*u2) +
      sq (p1*s2 + q1*r2 - r1*q2 + s1*p2 + t1*w2 - u1*v2 + v1*u2 - w1*t2) +
      sq (p1*t2 - q1*u2 - r1*v2 - s1*w2 + t1*p2 + u1*q2 + v1*r2 + w1*s2) +
      sq (p1*u2 + q1*t2 - r1*w2 + s1*v2 - t1*q2 + u1*p2 - v1*s2 + w1*r2) +
      sq (p1*v2 + q1*w2 + r1*t2 - s1*u2 - t1*r2 + u1*s2 + v1*p2 - w1*q2) +
      sq (p1*w2 - q1*v2 + r1*u2 + s1*t2 - t1*s2 - u1*r2 + v1*q2 + w1*p2)"
by (simp only: sq_def algebra_simps)

end