(*  Title:      HOL/Matrix_LP/SparseMatrix.thy
    Author:     Steven Obua
*)

theory SparseMatrix
imports Matrix
begin

type_synonym 'a spvec = "(nat * 'a) list"
type_synonym 'a spmat = "'a spvec spvec"

definition sparse_row_vector :: "('a::ab_group_add) spvec \<Rightarrow> 'a matrix"
  where "sparse_row_vector arr = foldl (% m x. m + (singleton_matrix 0 (fst x) (snd x))) 0 arr"

definition sparse_row_matrix :: "('a::ab_group_add) spmat \<Rightarrow> 'a matrix"
  where "sparse_row_matrix arr = foldl (% m r. m + (move_matrix (sparse_row_vector (snd r)) (int (fst r)) 0)) 0 arr"

code_datatype sparse_row_vector sparse_row_matrix

lemma sparse_row_vector_empty [simp]: "sparse_row_vector [] = 0"
  by (simp add: sparse_row_vector_def)

lemma sparse_row_matrix_empty [simp]: "sparse_row_matrix [] = 0"
  by (simp add: sparse_row_matrix_def)

lemmas [code] = sparse_row_vector_empty [symmetric]

lemma foldl_distrstart: "\<forall>a x y. (f (g x y) a = g x (f y a)) \<Longrightarrow> (foldl f (g x y) l = g x (foldl f y l))"
  by (induct l arbitrary: x y, auto)

lemma sparse_row_vector_cons[simp]:
  "sparse_row_vector (a # arr) = (singleton_matrix 0 (fst a) (snd a)) + (sparse_row_vector arr)"
  apply (induct arr)
  apply (auto simp add: sparse_row_vector_def)
  apply (simp add: foldl_distrstart [of "\<lambda>m x. m + singleton_matrix 0 (fst x) (snd x)" "\<lambda>x m. singleton_matrix 0 (fst x) (snd x) + m"])
  done

lemma sparse_row_vector_append[simp]:
  "sparse_row_vector (a @ b) = (sparse_row_vector a) + (sparse_row_vector b)"
  by (induct a) auto

lemma nrows_spvec[simp]: "nrows (sparse_row_vector x) <= (Suc 0)"
  apply (induct x)
  apply (simp_all add: add_nrows)
  done

lemma sparse_row_matrix_cons: "sparse_row_matrix (a#arr) = ((move_matrix (sparse_row_vector (snd a)) (int (fst a)) 0)) + sparse_row_matrix arr"
  apply (induct arr)
  apply (auto simp add: sparse_row_matrix_def)
  apply (simp add: foldl_distrstart[of "\<lambda>m x. m + (move_matrix (sparse_row_vector (snd x)) (int (fst x)) 0)"
    "% a m. (move_matrix (sparse_row_vector (snd a)) (int (fst a)) 0) + m"])
  done

lemma sparse_row_matrix_append: "sparse_row_matrix (arr@brr) = (sparse_row_matrix arr) + (sparse_row_matrix brr)"
  apply (induct arr)
  apply (auto simp add: sparse_row_matrix_cons)
  done

primrec sorted_spvec :: "'a spvec \<Rightarrow> bool"
where
  "sorted_spvec [] = True"
| sorted_spvec_step: "sorted_spvec (a#as) = (case as of [] \<Rightarrow> True | b#bs \<Rightarrow> ((fst a < fst b) & (sorted_spvec as)))"

primrec sorted_spmat :: "'a spmat \<Rightarrow> bool"
where
  "sorted_spmat [] = True"
| "sorted_spmat (a#as) = ((sorted_spvec (snd a)) & (sorted_spmat as))"

declare sorted_spvec.simps [simp del]

lemma sorted_spvec_empty[simp]: "sorted_spvec [] = True"
by (simp add: sorted_spvec.simps)

lemma sorted_spvec_cons1: "sorted_spvec (a#as) \<Longrightarrow> sorted_spvec as"
apply (induct as)
apply (auto simp add: sorted_spvec.simps)
done

lemma sorted_spvec_cons2: "sorted_spvec (a#b#t) \<Longrightarrow> sorted_spvec (a#t)"
apply (induct t)
apply (auto simp add: sorted_spvec.simps)
done

lemma sorted_spvec_cons3: "sorted_spvec(a#b#t) \<Longrightarrow> fst a < fst b"
apply (auto simp add: sorted_spvec.simps)
done

lemma sorted_sparse_row_vector_zero[rule_format]: "m <= n \<Longrightarrow> sorted_spvec ((n,a)#arr) \<longrightarrow> Rep_matrix (sparse_row_vector arr) j m = 0"
apply (induct arr)
apply (auto)
apply (frule sorted_spvec_cons2,simp)+
apply (frule sorted_spvec_cons3, simp)
done

lemma sorted_sparse_row_matrix_zero[rule_format]: "m <= n \<Longrightarrow> sorted_spvec ((n,a)#arr) \<longrightarrow> Rep_matrix (sparse_row_matrix arr) m j = 0"
  apply (induct arr)
  apply (auto)
  apply (frule sorted_spvec_cons2, simp)
  apply (frule sorted_spvec_cons3, simp)
  apply (simp add: sparse_row_matrix_cons)
  done

primrec minus_spvec :: "('a::ab_group_add) spvec \<Rightarrow> 'a spvec"
where
  "minus_spvec [] = []"
| "minus_spvec (a#as) = (fst a, -(snd a))#(minus_spvec as)"

primrec abs_spvec :: "('a::lattice_ab_group_add_abs) spvec \<Rightarrow> 'a spvec"
where
  "abs_spvec [] = []"
| "abs_spvec (a#as) = (fst a, \<bar>snd a\<bar>)#(abs_spvec as)"

lemma sparse_row_vector_minus:
  "sparse_row_vector (minus_spvec v) = - (sparse_row_vector v)"
  apply (induct v)
  apply (simp_all add: sparse_row_vector_cons)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply simp
  done

instance matrix :: (lattice_ab_group_add_abs) lattice_ab_group_add_abs
  apply standard
  unfolding abs_matrix_def
  apply rule
  done
  (*FIXME move*)

lemma sparse_row_vector_abs:
  "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (abs_spvec v) = \<bar>sparse_row_vector v\<bar>"
  apply (induct v)
  apply simp_all
  apply (frule_tac sorted_spvec_cons1, simp)
  apply (simp only: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply auto
  apply (subgoal_tac "Rep_matrix (sparse_row_vector v) 0 a = 0")
  apply (simp)
  apply (rule sorted_sparse_row_vector_zero)
  apply auto
  done

lemma sorted_spvec_minus_spvec:
  "sorted_spvec v \<Longrightarrow> sorted_spvec (minus_spvec v)"
  apply (induct v)
  apply (simp)
  apply (frule sorted_spvec_cons1, simp)
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spvec_abs_spvec:
  "sorted_spvec v \<Longrightarrow> sorted_spvec (abs_spvec v)"
  apply (induct v)
  apply (simp)
  apply (frule sorted_spvec_cons1, simp)
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

definition "smult_spvec y = map (% a. (fst a, y * snd a))"

lemma smult_spvec_empty[simp]: "smult_spvec y [] = []"
  by (simp add: smult_spvec_def)

lemma smult_spvec_cons: "smult_spvec y (a#arr) = (fst a, y * (snd a)) # (smult_spvec y arr)"
  by (simp add: smult_spvec_def)

fun addmult_spvec :: "('a::ring) \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec"
where
  "addmult_spvec y arr [] = arr"
| "addmult_spvec y [] brr = smult_spvec y brr"
| "addmult_spvec y ((i,a)#arr) ((j,b)#brr) = (
    if i < j then ((i,a)#(addmult_spvec y arr ((j,b)#brr)))
    else (if (j < i) then ((j, y * b)#(addmult_spvec y ((i,a)#arr) brr))
    else ((i, a + y*b)#(addmult_spvec y arr brr))))"
(* Steven used termination "measure (% (y, a, b). length a + (length b))" *)

lemma addmult_spvec_empty1[simp]: "addmult_spvec y [] a = smult_spvec y a"
  by (induct a) auto

lemma addmult_spvec_empty2[simp]: "addmult_spvec y a [] = a"
  by (induct a) auto

lemma sparse_row_vector_map: "(\<forall>x y. f (x+y) = (f x) + (f y)) \<Longrightarrow> (f::'a\<Rightarrow>('a::lattice_ring)) 0 = 0 \<Longrightarrow>
  sparse_row_vector (map (% x. (fst x, f (snd x))) a) = apply_matrix f (sparse_row_vector a)"
  apply (induct a)
  apply (simp_all add: apply_matrix_add)
  done

lemma sparse_row_vector_smult: "sparse_row_vector (smult_spvec y a) = scalar_mult y (sparse_row_vector a)"
  apply (induct a)
  apply (simp_all add: smult_spvec_cons scalar_mult_add)
  done

lemma sparse_row_vector_addmult_spvec: "sparse_row_vector (addmult_spvec (y::'a::lattice_ring) a b) =
  (sparse_row_vector a) + (scalar_mult y (sparse_row_vector b))"
  apply (induct y a b rule: addmult_spvec.induct)
  apply (simp add: scalar_mult_add smult_spvec_cons sparse_row_vector_smult singleton_matrix_add)+
  done

lemma sorted_smult_spvec: "sorted_spvec a \<Longrightarrow> sorted_spvec (smult_spvec y a)"
  apply (auto simp add: smult_spvec_def)
  apply (induct a)
  apply (auto simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spvec_addmult_spvec_helper: "\<lbrakk>sorted_spvec (addmult_spvec y ((a, b) # arr) brr); aa < a; sorted_spvec ((a, b) # arr);
  sorted_spvec ((aa, ba) # brr)\<rbrakk> \<Longrightarrow> sorted_spvec ((aa, y * ba) # addmult_spvec y ((a, b) # arr) brr)"
  apply (induct brr)
  apply (auto simp add: sorted_spvec.simps)
  done

lemma sorted_spvec_addmult_spvec_helper2:
 "\<lbrakk>sorted_spvec (addmult_spvec y arr ((aa, ba) # brr)); a < aa; sorted_spvec ((a, b) # arr); sorted_spvec ((aa, ba) # brr)\<rbrakk>
       \<Longrightarrow> sorted_spvec ((a, b) # addmult_spvec y arr ((aa, ba) # brr))"
  apply (induct arr)
  apply (auto simp add: smult_spvec_def sorted_spvec.simps)
  done

lemma sorted_spvec_addmult_spvec_helper3[rule_format]:
  "sorted_spvec (addmult_spvec y arr brr) \<longrightarrow> sorted_spvec ((aa, b) # arr) \<longrightarrow> sorted_spvec ((aa, ba) # brr)
     \<longrightarrow> sorted_spvec ((aa, b + y * ba) # (addmult_spvec y arr brr))"
  apply (induct y arr brr rule: addmult_spvec.induct)
  apply (simp_all add: sorted_spvec.simps smult_spvec_def split:list.split)
  done

lemma sorted_addmult_spvec: "sorted_spvec a \<Longrightarrow> sorted_spvec b \<Longrightarrow> sorted_spvec (addmult_spvec y a b)"
  apply (induct y a b rule: addmult_spvec.induct)
  apply (simp_all add: sorted_smult_spvec)
  apply (rule conjI, intro strip)
  apply (case_tac "~(i < j)")
  apply (simp_all)
  apply (frule_tac as=brr in sorted_spvec_cons1)
  apply (simp add: sorted_spvec_addmult_spvec_helper)
  apply (intro strip | rule conjI)+
  apply (frule_tac as=arr in sorted_spvec_cons1)
  apply (simp add: sorted_spvec_addmult_spvec_helper2)
  apply (intro strip)
  apply (frule_tac as=arr in sorted_spvec_cons1)
  apply (frule_tac as=brr in sorted_spvec_cons1)
  apply (simp)
  apply (simp_all add: sorted_spvec_addmult_spvec_helper3)
  done

fun mult_spvec_spmat :: "('a::lattice_ring) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spmat  \<Rightarrow> 'a spvec"
where
  "mult_spvec_spmat c [] brr = c"
| "mult_spvec_spmat c arr [] = c"
| "mult_spvec_spmat c ((i,a)#arr) ((j,b)#brr) = (
     if (i < j) then mult_spvec_spmat c arr ((j,b)#brr)
     else if (j < i) then mult_spvec_spmat c ((i,a)#arr) brr
     else mult_spvec_spmat (addmult_spvec a c b) arr brr)"

lemma sparse_row_mult_spvec_spmat[rule_format]: "sorted_spvec (a::('a::lattice_ring) spvec) \<longrightarrow> sorted_spvec B \<longrightarrow>
  sparse_row_vector (mult_spvec_spmat c a B) = (sparse_row_vector c) + (sparse_row_vector a) * (sparse_row_matrix B)"
proof -
  have comp_1: "!! a b. a < b \<Longrightarrow> Suc 0 <= nat ((int b)-(int a))" by arith
  have not_iff: "!! a b. a = b \<Longrightarrow> (~ a) = (~ b)" by simp
  have max_helper: "!! a b. ~ (a <= max (Suc a) b) \<Longrightarrow> False"
    by arith
  {
    fix a
    fix v
    assume a:"a < nrows(sparse_row_vector v)"
    have b:"nrows(sparse_row_vector v) <= 1" by simp
    note dummy = less_le_trans[of a "nrows (sparse_row_vector v)" 1, OF a b]
    then have "a = 0" by simp
  }
  note nrows_helper = this
  show ?thesis
    apply (induct c a B rule: mult_spvec_spmat.induct)
    apply simp+
    apply (rule conjI)
    apply (intro strip)
    apply (frule_tac as=brr in sorted_spvec_cons1)
    apply (simp add: algebra_simps sparse_row_matrix_cons)
    apply (simplesubst Rep_matrix_zero_imp_mult_zero)
    apply (simp)
    apply (rule disjI2)
    apply (intro strip)
    apply (subst nrows)
    apply (rule  order_trans[of _ 1])
    apply (simp add: comp_1)+
    apply (subst Rep_matrix_zero_imp_mult_zero)
    apply (intro strip)
    apply (case_tac "k <= j")
    apply (rule_tac m1 = k and n1 = i and a1 = a in ssubst[OF sorted_sparse_row_vector_zero])
    apply (simp_all)
    apply (rule disjI2)
    apply (rule nrows)
    apply (rule order_trans[of _ 1])
    apply (simp_all add: comp_1)

    apply (intro strip | rule conjI)+
    apply (frule_tac as=arr in sorted_spvec_cons1)
    apply (simp add: algebra_simps)
    apply (subst Rep_matrix_zero_imp_mult_zero)
    apply (simp)
    apply (rule disjI2)
    apply (intro strip)
    apply (simp add: sparse_row_matrix_cons)
    apply (case_tac "i <= j")
    apply (erule sorted_sparse_row_matrix_zero)
    apply (simp_all)
    apply (intro strip)
    apply (case_tac "i=j")
    apply (simp_all)
    apply (frule_tac as=arr in sorted_spvec_cons1)
    apply (frule_tac as=brr in sorted_spvec_cons1)
    apply (simp add: sparse_row_matrix_cons algebra_simps sparse_row_vector_addmult_spvec)
    apply (rule_tac B1 = "sparse_row_matrix brr" in ssubst[OF Rep_matrix_zero_imp_mult_zero])
    apply (auto)
    apply (rule sorted_sparse_row_matrix_zero)
    apply (simp_all)
    apply (rule_tac A1 = "sparse_row_vector arr" in ssubst[OF Rep_matrix_zero_imp_mult_zero])
    apply (auto)
    apply (rule_tac m=k and n = j and a = a and arr=arr in sorted_sparse_row_vector_zero)
    apply (simp_all)
    apply (drule nrows_notzero)
    apply (drule nrows_helper)
    apply (arith)

    apply (subst Rep_matrix_inject[symmetric])
    apply (rule ext)+
    apply (simp)
    apply (subst Rep_matrix_mult)
    apply (rule_tac j1=j in ssubst[OF foldseq_almostzero])
    apply (simp_all)
    apply (intro strip, rule conjI)
    apply (intro strip)
    apply (drule_tac max_helper)
    apply (simp)
    apply (auto)
    apply (rule zero_imp_mult_zero)
    apply (rule disjI2)
    apply (rule nrows)
    apply (rule order_trans[of _ 1])
    apply (simp)
    apply (simp)
    done
qed

lemma sorted_mult_spvec_spmat[rule_format]:
  "sorted_spvec (c::('a::lattice_ring) spvec) \<longrightarrow> sorted_spmat B \<longrightarrow> sorted_spvec (mult_spvec_spmat c a B)"
  apply (induct c a B rule: mult_spvec_spmat.induct)
  apply (simp_all add: sorted_addmult_spvec)
  done

primrec mult_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
where
  "mult_spmat [] A = []"
| "mult_spmat (a#as) A = (fst a, mult_spvec_spmat [] (snd a) A)#(mult_spmat as A)"

lemma sparse_row_mult_spmat:
  "sorted_spmat A \<Longrightarrow> sorted_spvec B \<Longrightarrow>
   sparse_row_matrix (mult_spmat A B) = (sparse_row_matrix A) * (sparse_row_matrix B)"
  apply (induct A)
  apply (auto simp add: sparse_row_matrix_cons sparse_row_mult_spvec_spmat algebra_simps move_matrix_mult)
  done

lemma sorted_spvec_mult_spmat[rule_format]:
  "sorted_spvec (A::('a::lattice_ring) spmat) \<longrightarrow> sorted_spvec (mult_spmat A B)"
  apply (induct A)
  apply (auto)
  apply (drule sorted_spvec_cons1, simp)
  apply (case_tac A)
  apply (auto simp add: sorted_spvec.simps)
  done

lemma sorted_spmat_mult_spmat:
  "sorted_spmat (B::('a::lattice_ring) spmat) \<Longrightarrow> sorted_spmat (mult_spmat A B)"
  apply (induct A)
  apply (auto simp add: sorted_mult_spvec_spmat)
  done

fun add_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec"
where
(* "measure (% (a, b). length a + (length b))" *)
  "add_spvec arr [] = arr"
| "add_spvec [] brr = brr"
| "add_spvec ((i,a)#arr) ((j,b)#brr) = (
     if i < j then (i,a)#(add_spvec arr ((j,b)#brr))
     else if (j < i) then (j,b) # add_spvec ((i,a)#arr) brr
     else (i, a+b) # add_spvec arr brr)"

lemma add_spvec_empty1[simp]: "add_spvec [] a = a"
by (cases a, auto)

lemma sparse_row_vector_add: "sparse_row_vector (add_spvec a b) = (sparse_row_vector a) + (sparse_row_vector b)"
  apply (induct a b rule: add_spvec.induct)
  apply (simp_all add: singleton_matrix_add)
  done

fun add_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
where
(* "measure (% (A,B). (length A)+(length B))" *)
  "add_spmat [] bs = bs"
| "add_spmat as [] = as"
| "add_spmat ((i,a)#as) ((j,b)#bs) = (
    if i < j then
      (i,a) # add_spmat as ((j,b)#bs)
    else if j < i then
      (j,b) # add_spmat ((i,a)#as) bs
    else
      (i, add_spvec a b) # add_spmat as bs)"

lemma add_spmat_Nil2[simp]: "add_spmat as [] = as"
by(cases as) auto

lemma sparse_row_add_spmat: "sparse_row_matrix (add_spmat A B) = (sparse_row_matrix A) + (sparse_row_matrix B)"
  apply (induct A B rule: add_spmat.induct)
  apply (auto simp add: sparse_row_matrix_cons sparse_row_vector_add move_matrix_add)
  done

lemmas [code] = sparse_row_add_spmat [symmetric]
lemmas [code] = sparse_row_vector_add [symmetric]

lemma sorted_add_spvec_helper1[rule_format]: "add_spvec ((a,b)#arr) brr = (ab, bb) # list \<longrightarrow> (ab = a | (brr \<noteq> [] & ab = fst (hd brr)))"
  proof -
    have "(\<forall>x ab a. x = (a,b)#arr \<longrightarrow> add_spvec x brr = (ab, bb) # list \<longrightarrow> (ab = a | (ab = fst (hd brr))))"
      by (induct brr rule: add_spvec.induct) (auto split:if_splits)
    then show ?thesis
      by (case_tac brr, auto)
  qed

lemma sorted_add_spmat_helper1[rule_format]: "add_spmat ((a,b)#arr) brr = (ab, bb) # list \<longrightarrow> (ab = a | (brr \<noteq> [] & ab = fst (hd brr)))"
  proof -
    have "(\<forall>x ab a. x = (a,b)#arr \<longrightarrow> add_spmat x brr = (ab, bb) # list \<longrightarrow> (ab = a | (ab = fst (hd brr))))"
      by (rule add_spmat.induct) (auto split:if_splits)
    then show ?thesis
      by (case_tac brr, auto)
  qed

lemma sorted_add_spvec_helper: "add_spvec arr brr = (ab, bb) # list \<Longrightarrow> ((arr \<noteq> [] & ab = fst (hd arr)) | (brr \<noteq> [] & ab = fst (hd brr)))"
  apply (induct arr brr rule: add_spvec.induct)
  apply (auto split:if_splits)
  done

lemma sorted_add_spmat_helper: "add_spmat arr brr = (ab, bb) # list \<Longrightarrow> ((arr \<noteq> [] & ab = fst (hd arr)) | (brr \<noteq> [] & ab = fst (hd brr)))"
  apply (induct arr brr rule: add_spmat.induct)
  apply (auto split:if_splits)
  done

lemma add_spvec_commute: "add_spvec a b = add_spvec b a"
by (induct a b rule: add_spvec.induct) auto

lemma add_spmat_commute: "add_spmat a b = add_spmat b a"
  apply (induct a b rule: add_spmat.induct)
  apply (simp_all add: add_spvec_commute)
  done

lemma sorted_add_spvec_helper2: "add_spvec ((a,b)#arr) brr = (ab, bb) # list \<Longrightarrow> aa < a \<Longrightarrow> sorted_spvec ((aa, ba) # brr) \<Longrightarrow> aa < ab"
  apply (drule sorted_add_spvec_helper1)
  apply (auto)
  apply (case_tac brr)
  apply (simp_all)
  apply (drule_tac sorted_spvec_cons3)
  apply (simp)
  done

lemma sorted_add_spmat_helper2: "add_spmat ((a,b)#arr) brr = (ab, bb) # list \<Longrightarrow> aa < a \<Longrightarrow> sorted_spvec ((aa, ba) # brr) \<Longrightarrow> aa < ab"
  apply (drule sorted_add_spmat_helper1)
  apply (auto)
  apply (case_tac brr)
  apply (simp_all)
  apply (drule_tac sorted_spvec_cons3)
  apply (simp)
  done

lemma sorted_spvec_add_spvec[rule_format]: "sorted_spvec a \<longrightarrow> sorted_spvec b \<longrightarrow> sorted_spvec (add_spvec a b)"
  apply (induct a b rule: add_spvec.induct)
  apply (simp_all)
  apply (rule conjI)
  apply (clarsimp)
  apply (frule_tac as=brr in sorted_spvec_cons1)
  apply (simp)
  apply (subst sorted_spvec_step)
  apply (clarsimp simp: sorted_add_spvec_helper2 split: list.split)
  apply (clarify)
  apply (rule conjI)
  apply (clarify)
  apply (frule_tac as=arr in sorted_spvec_cons1, simp)
  apply (subst sorted_spvec_step)
  apply (clarsimp simp: sorted_add_spvec_helper2 add_spvec_commute split: list.split)
  apply (clarify)
  apply (frule_tac as=arr in sorted_spvec_cons1)
  apply (frule_tac as=brr in sorted_spvec_cons1)
  apply (simp)
  apply (subst sorted_spvec_step)
  apply (simp split: list.split)
  apply (clarsimp)
  apply (drule_tac sorted_add_spvec_helper)
  apply (auto simp: neq_Nil_conv)
  apply (drule sorted_spvec_cons3)
  apply (simp)
  apply (drule sorted_spvec_cons3)
  apply (simp)
  done

lemma sorted_spvec_add_spmat[rule_format]: "sorted_spvec A \<longrightarrow> sorted_spvec B \<longrightarrow> sorted_spvec (add_spmat A B)"
  apply (induct A B rule: add_spmat.induct)
  apply (simp_all)
  apply (rule conjI)
  apply (intro strip)
  apply (simp)
  apply (frule_tac as=bs in sorted_spvec_cons1)
  apply (simp)
  apply (subst sorted_spvec_step)
  apply (simp split: list.split)
  apply (clarify, simp)
  apply (simp add: sorted_add_spmat_helper2)
  apply (clarify)
  apply (rule conjI)
  apply (clarify)
  apply (frule_tac as=as in sorted_spvec_cons1, simp)
  apply (subst sorted_spvec_step)
  apply (clarsimp simp: sorted_add_spmat_helper2 add_spmat_commute split: list.split)
  apply (clarsimp)
  apply (frule_tac as=as in sorted_spvec_cons1)
  apply (frule_tac as=bs in sorted_spvec_cons1)
  apply (simp)
  apply (subst sorted_spvec_step)
  apply (simp split: list.split)
  apply (clarify, simp)
  apply (drule_tac sorted_add_spmat_helper)
  apply (auto simp:neq_Nil_conv)
  apply (drule sorted_spvec_cons3)
  apply (simp)
  apply (drule sorted_spvec_cons3)
  apply (simp)
  done

lemma sorted_spmat_add_spmat[rule_format]: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (add_spmat A B)"
  apply (induct A B rule: add_spmat.induct)
  apply (simp_all add: sorted_spvec_add_spvec)
  done

fun le_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> bool"
where
(* "measure (% (a,b). (length a) + (length b))" *)
  "le_spvec [] [] = True"
| "le_spvec ((_,a)#as) [] = (a <= 0 & le_spvec as [])"
| "le_spvec [] ((_,b)#bs) = (0 <= b & le_spvec [] bs)"
| "le_spvec ((i,a)#as) ((j,b)#bs) = (
    if (i < j) then a <= 0 & le_spvec as ((j,b)#bs)
    else if (j < i) then 0 <= b & le_spvec ((i,a)#as) bs
    else a <= b & le_spvec as bs)"

fun le_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> bool"
where
(* "measure (% (a,b). (length a) + (length b))" *)
  "le_spmat [] [] = True"
| "le_spmat ((i,a)#as) [] = (le_spvec a [] & le_spmat as [])"
| "le_spmat [] ((j,b)#bs) = (le_spvec [] b & le_spmat [] bs)"
| "le_spmat ((i,a)#as) ((j,b)#bs) = (
    if i < j then (le_spvec a [] & le_spmat as ((j,b)#bs))
    else if j < i then (le_spvec [] b & le_spmat ((i,a)#as) bs)
    else (le_spvec a b & le_spmat as bs))"

definition disj_matrices :: "('a::zero) matrix \<Rightarrow> 'a matrix \<Rightarrow> bool" where
  "disj_matrices A B \<longleftrightarrow>
    (\<forall>j i. (Rep_matrix A j i \<noteq> 0) \<longrightarrow> (Rep_matrix B j i = 0)) & (\<forall>j i. (Rep_matrix B j i \<noteq> 0) \<longrightarrow> (Rep_matrix A j i = 0))"

declare [[simp_depth_limit = 6]]

lemma disj_matrices_contr1: "disj_matrices A B \<Longrightarrow> Rep_matrix A j i \<noteq> 0 \<Longrightarrow> Rep_matrix B j i = 0"
   by (simp add: disj_matrices_def)

lemma disj_matrices_contr2: "disj_matrices A B \<Longrightarrow> Rep_matrix B j i \<noteq> 0 \<Longrightarrow> Rep_matrix A j i = 0"
   by (simp add: disj_matrices_def)

lemma disj_matrices_add: "disj_matrices A B \<Longrightarrow> disj_matrices C D \<Longrightarrow> disj_matrices A D \<Longrightarrow> disj_matrices B C \<Longrightarrow>
  (A + B <= C + D) = (A <= C & B <= (D::('a::lattice_ab_group_add) matrix))"
  apply (auto)
  apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
  apply (intro strip)
  apply (erule conjE)+
  apply (drule_tac j=j and i=i in spec2)+
  apply (case_tac "Rep_matrix B j i = 0")
  apply (case_tac "Rep_matrix D j i = 0")
  apply (simp_all)
  apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
  apply (intro strip)
  apply (erule conjE)+
  apply (drule_tac j=j and i=i in spec2)+
  apply (case_tac "Rep_matrix A j i = 0")
  apply (case_tac "Rep_matrix C j i = 0")
  apply (simp_all)
  apply (erule add_mono)
  apply (assumption)
  done

lemma disj_matrices_zero1[simp]: "disj_matrices 0 B"
by (simp add: disj_matrices_def)

lemma disj_matrices_zero2[simp]: "disj_matrices A 0"
by (simp add: disj_matrices_def)

lemma disj_matrices_commute: "disj_matrices A B = disj_matrices B A"
by (auto simp add: disj_matrices_def)

lemma disj_matrices_add_le_zero: "disj_matrices A B \<Longrightarrow>
  (A + B <= 0) = (A <= 0 & (B::('a::lattice_ab_group_add) matrix) <= 0)"
by (rule disj_matrices_add[of A B 0 0, simplified])

lemma disj_matrices_add_zero_le: "disj_matrices A B \<Longrightarrow>
  (0 <= A + B) = (0 <= A & 0 <= (B::('a::lattice_ab_group_add) matrix))"
by (rule disj_matrices_add[of 0 0 A B, simplified])

lemma disj_matrices_add_x_le: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
  (A <= B + C) = (A <= C & 0 <= (B::('a::lattice_ab_group_add) matrix))"
by (auto simp add: disj_matrices_add[of 0 A B C, simplified])

lemma disj_matrices_add_le_x: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
  (B + A <= C) = (A <= C &  (B::('a::lattice_ab_group_add) matrix) <= 0)"
by (auto simp add: disj_matrices_add[of B A 0 C,simplified] disj_matrices_commute)

lemma disj_sparse_row_singleton: "i <= j \<Longrightarrow> sorted_spvec((j,y)#v) \<Longrightarrow> disj_matrices (sparse_row_vector v) (singleton_matrix 0 i x)"
  apply (simp add: disj_matrices_def)
  apply (rule conjI)
  apply (rule neg_imp)
  apply (simp)
  apply (intro strip)
  apply (rule sorted_sparse_row_vector_zero)
  apply (simp_all)
  apply (intro strip)
  apply (rule sorted_sparse_row_vector_zero)
  apply (simp_all)
  done

lemma disj_matrices_x_add: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (A::('a::lattice_ab_group_add) matrix) (B+C)"
  apply (simp add: disj_matrices_def)
  apply (auto)
  apply (drule_tac j=j and i=i in spec2)+
  apply (case_tac "Rep_matrix B j i = 0")
  apply (case_tac "Rep_matrix C j i = 0")
  apply (simp_all)
  done

lemma disj_matrices_add_x: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (B+C) (A::('a::lattice_ab_group_add) matrix)"
  by (simp add: disj_matrices_x_add disj_matrices_commute)

lemma disj_singleton_matrices[simp]: "disj_matrices (singleton_matrix j i x) (singleton_matrix u v y) = (j \<noteq> u | i \<noteq> v | x = 0 | y = 0)"
  by (auto simp add: disj_matrices_def)

lemma disj_move_sparse_vec_mat[simplified disj_matrices_commute]:
  "j <= a \<Longrightarrow> sorted_spvec((a,c)#as) \<Longrightarrow> disj_matrices (move_matrix (sparse_row_vector b) (int j) i) (sparse_row_matrix as)"
  apply (auto simp add: disj_matrices_def)
  apply (drule nrows_notzero)
  apply (drule less_le_trans[OF _ nrows_spvec])
  apply (subgoal_tac "ja = j")
  apply (simp add: sorted_sparse_row_matrix_zero)
  apply (arith)
  apply (rule nrows)
  apply (rule order_trans[of _ 1 _])
  apply (simp)
  apply (case_tac "nat (int ja - int j) = 0")
  apply (case_tac "ja = j")
  apply (simp add: sorted_sparse_row_matrix_zero)
  apply arith+
  done

lemma disj_move_sparse_row_vector_twice:
  "j \<noteq> u \<Longrightarrow> disj_matrices (move_matrix (sparse_row_vector a) j i) (move_matrix (sparse_row_vector b) u v)"
  apply (auto simp add: disj_matrices_def)
  apply (rule nrows, rule order_trans[of _ 1], simp, drule nrows_notzero, drule less_le_trans[OF _ nrows_spvec], arith)+
  done

lemma le_spvec_iff_sparse_row_le[rule_format]: "(sorted_spvec a) \<longrightarrow> (sorted_spvec b) \<longrightarrow> (le_spvec a b) = (sparse_row_vector a <= sparse_row_vector b)"
  apply (induct a b rule: le_spvec.induct)
  apply (simp_all add: sorted_spvec_cons1 disj_matrices_add_le_zero disj_matrices_add_zero_le
    disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
  apply (rule conjI, intro strip)
  apply (simp add: sorted_spvec_cons1)
  apply (subst disj_matrices_add_x_le)
  apply (simp add: disj_sparse_row_singleton[OF less_imp_le] disj_matrices_x_add disj_matrices_commute)
  apply (simp add: disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
  apply (simp, blast)
  apply (intro strip, rule conjI, intro strip)
  apply (simp add: sorted_spvec_cons1)
  apply (subst disj_matrices_add_le_x)
  apply (simp_all add: disj_sparse_row_singleton[OF order_refl] disj_sparse_row_singleton[OF less_imp_le] disj_matrices_commute disj_matrices_x_add)
  apply (blast)
  apply (intro strip)
  apply (simp add: sorted_spvec_cons1)
  apply (case_tac "a=b", simp_all)
  apply (subst disj_matrices_add)
  apply (simp_all add: disj_sparse_row_singleton[OF order_refl] disj_matrices_commute)
  done

lemma le_spvec_empty2_sparse_row[rule_format]: "sorted_spvec b \<longrightarrow> le_spvec b [] = (sparse_row_vector b <= 0)"
  apply (induct b)
  apply (simp_all add: sorted_spvec_cons1)
  apply (intro strip)
  apply (subst disj_matrices_add_le_zero)
  apply (auto simp add: disj_matrices_commute disj_sparse_row_singleton[OF order_refl] sorted_spvec_cons1)
  done

lemma le_spvec_empty1_sparse_row[rule_format]: "(sorted_spvec b) \<longrightarrow> (le_spvec [] b = (0 <= sparse_row_vector b))"
  apply (induct b)
  apply (simp_all add: sorted_spvec_cons1)
  apply (intro strip)
  apply (subst disj_matrices_add_zero_le)
  apply (auto simp add: disj_matrices_commute disj_sparse_row_singleton[OF order_refl] sorted_spvec_cons1)
  done

lemma le_spmat_iff_sparse_row_le[rule_format]: "(sorted_spvec A) \<longrightarrow> (sorted_spmat A) \<longrightarrow> (sorted_spvec B) \<longrightarrow> (sorted_spmat B) \<longrightarrow>
  le_spmat A B = (sparse_row_matrix A <= sparse_row_matrix B)"
  apply (induct A B rule: le_spmat.induct)
  apply (simp add: sparse_row_matrix_cons disj_matrices_add_le_zero disj_matrices_add_zero_le disj_move_sparse_vec_mat[OF order_refl]
    disj_matrices_commute sorted_spvec_cons1 le_spvec_empty2_sparse_row le_spvec_empty1_sparse_row)+
  apply (rule conjI, intro strip)
  apply (simp add: sorted_spvec_cons1)
  apply (subst disj_matrices_add_x_le)
  apply (rule disj_matrices_add_x)
  apply (simp add: disj_move_sparse_row_vector_twice)
  apply (simp add: disj_move_sparse_vec_mat[OF less_imp_le] disj_matrices_commute)
  apply (simp add: disj_move_sparse_vec_mat[OF order_refl] disj_matrices_commute)
  apply (simp, blast)
  apply (intro strip, rule conjI, intro strip)
  apply (simp add: sorted_spvec_cons1)
  apply (subst disj_matrices_add_le_x)
  apply (simp add: disj_move_sparse_vec_mat[OF order_refl])
  apply (rule disj_matrices_x_add)
  apply (simp add: disj_move_sparse_row_vector_twice)
  apply (simp add: disj_move_sparse_vec_mat[OF less_imp_le] disj_matrices_commute)
  apply (simp, blast)
  apply (intro strip)
  apply (case_tac "i=j")
  apply (simp_all)
  apply (subst disj_matrices_add)
  apply (simp_all add: disj_matrices_commute disj_move_sparse_vec_mat[OF order_refl])
  apply (simp add: sorted_spvec_cons1 le_spvec_iff_sparse_row_le)
  done

declare [[simp_depth_limit = 999]]

primrec abs_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat"
where
  "abs_spmat [] = []"
| "abs_spmat (a#as) = (fst a, abs_spvec (snd a))#(abs_spmat as)"

primrec minus_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat"
where
  "minus_spmat [] = []"
| "minus_spmat (a#as) = (fst a, minus_spvec (snd a))#(minus_spmat as)"

lemma sparse_row_matrix_minus:
  "sparse_row_matrix (minus_spmat A) = - (sparse_row_matrix A)"
  apply (induct A)
  apply (simp_all add: sparse_row_vector_minus sparse_row_matrix_cons)
  apply (subst Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply simp
  done

lemma Rep_sparse_row_vector_zero: "x \<noteq> 0 \<Longrightarrow> Rep_matrix (sparse_row_vector v) x y = 0"
proof -
  assume x:"x \<noteq> 0"
  have r:"nrows (sparse_row_vector v) <= Suc 0" by (rule nrows_spvec)
  show ?thesis
    apply (rule nrows)
    apply (subgoal_tac "Suc 0 <= x")
    apply (insert r)
    apply (simp only:)
    apply (insert x)
    apply arith
    done
qed

lemma sparse_row_matrix_abs:
  "sorted_spvec A \<Longrightarrow> sorted_spmat A \<Longrightarrow> sparse_row_matrix (abs_spmat A) = \<bar>sparse_row_matrix A\<bar>"
  apply (induct A)
  apply (simp_all add: sparse_row_vector_abs sparse_row_matrix_cons)
  apply (frule_tac sorted_spvec_cons1, simp)
  apply (simplesubst Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply auto
  apply (case_tac "x=a")
  apply (simp)
  apply (simplesubst sorted_sparse_row_matrix_zero)
  apply auto
  apply (simplesubst Rep_sparse_row_vector_zero)
  apply simp_all
  done

lemma sorted_spvec_minus_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec (minus_spmat A)"
  apply (induct A)
  apply (simp)
  apply (frule sorted_spvec_cons1, simp)
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spvec_abs_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec (abs_spmat A)"
  apply (induct A)
  apply (simp)
  apply (frule sorted_spvec_cons1, simp)
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spmat_minus_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat (minus_spmat A)"
  apply (induct A)
  apply (simp_all add: sorted_spvec_minus_spvec)
  done

lemma sorted_spmat_abs_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat (abs_spmat A)"
  apply (induct A)
  apply (simp_all add: sorted_spvec_abs_spvec)
  done

definition diff_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
  where "diff_spmat A B = add_spmat A (minus_spmat B)"

lemma sorted_spmat_diff_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (diff_spmat A B)"
  by (simp add: diff_spmat_def sorted_spmat_minus_spmat sorted_spmat_add_spmat)

lemma sorted_spvec_diff_spmat: "sorted_spvec A \<Longrightarrow> sorted_spvec B \<Longrightarrow> sorted_spvec (diff_spmat A B)"
  by (simp add: diff_spmat_def sorted_spvec_minus_spmat sorted_spvec_add_spmat)

lemma sparse_row_diff_spmat: "sparse_row_matrix (diff_spmat A B ) = (sparse_row_matrix A) - (sparse_row_matrix B)"
  by (simp add: diff_spmat_def sparse_row_add_spmat sparse_row_matrix_minus)

definition sorted_sparse_matrix :: "'a spmat \<Rightarrow> bool"
  where "sorted_sparse_matrix A \<longleftrightarrow> sorted_spvec A & sorted_spmat A"

lemma sorted_sparse_matrix_imp_spvec: "sorted_sparse_matrix A \<Longrightarrow> sorted_spvec A"
  by (simp add: sorted_sparse_matrix_def)

lemma sorted_sparse_matrix_imp_spmat: "sorted_sparse_matrix A \<Longrightarrow> sorted_spmat A"
  by (simp add: sorted_sparse_matrix_def)

lemmas sorted_sp_simps =
  sorted_spvec.simps
  sorted_spmat.simps
  sorted_sparse_matrix_def

lemma bool1: "(\<not> True) = False"  by blast
lemma bool2: "(\<not> False) = True"  by blast
lemma bool3: "((P::bool) \<and> True) = P" by blast
lemma bool4: "(True \<and> (P::bool)) = P" by blast
lemma bool5: "((P::bool) \<and> False) = False" by blast
lemma bool6: "(False \<and> (P::bool)) = False" by blast
lemma bool7: "((P::bool) \<or> True) = True" by blast
lemma bool8: "(True \<or> (P::bool)) = True" by blast
lemma bool9: "((P::bool) \<or> False) = P" by blast
lemma bool10: "(False \<or> (P::bool)) = P" by blast
lemmas boolarith = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10

lemma if_case_eq: "(if b then x else y) = (case b of True => x | False => y)" by simp

primrec pprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
where
  "pprt_spvec [] = []"
| "pprt_spvec (a#as) = (fst a, pprt (snd a)) # (pprt_spvec as)"

primrec nprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
where
  "nprt_spvec [] = []"
| "nprt_spvec (a#as) = (fst a, nprt (snd a)) # (nprt_spvec as)"

primrec pprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
where
  "pprt_spmat [] = []"
| "pprt_spmat (a#as) = (fst a, pprt_spvec (snd a))#(pprt_spmat as)"

primrec nprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
where
  "nprt_spmat [] = []"
| "nprt_spmat (a#as) = (fst a, nprt_spvec (snd a))#(nprt_spmat as)"

lemma pprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> pprt (A+B) = pprt A + pprt B"
  apply (simp add: pprt_def sup_matrix_def)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply simp
  apply (case_tac "Rep_matrix A x xa \<noteq> 0")
  apply (simp_all add: disj_matrices_contr1)
  done

lemma nprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> nprt (A+B) = nprt A + nprt B"
  apply (simp add: nprt_def inf_matrix_def)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply simp
  apply (case_tac "Rep_matrix A x xa \<noteq> 0")
  apply (simp_all add: disj_matrices_contr1)
  done

lemma pprt_singleton[simp]: "pprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (pprt x)"
  apply (simp add: pprt_def sup_matrix_def)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply simp
  done

lemma nprt_singleton[simp]: "nprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (nprt x)"
  apply (simp add: nprt_def inf_matrix_def)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply simp
  done

lemma less_imp_le: "a < b \<Longrightarrow> a <= (b::_::order)" by (simp add: less_def)

lemma sparse_row_vector_pprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (pprt_spvec v) = pprt (sparse_row_vector v)"
  apply (induct v)
  apply (simp_all)
  apply (frule sorted_spvec_cons1, auto)
  apply (subst pprt_add)
  apply (subst disj_matrices_commute)
  apply (rule disj_sparse_row_singleton)
  apply auto
  done

lemma sparse_row_vector_nprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (nprt_spvec v) = nprt (sparse_row_vector v)"
  apply (induct v)
  apply (simp_all)
  apply (frule sorted_spvec_cons1, auto)
  apply (subst nprt_add)
  apply (subst disj_matrices_commute)
  apply (rule disj_sparse_row_singleton)
  apply auto
  done

lemma pprt_move_matrix: "pprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (pprt A) j i"
  apply (simp add: pprt_def)
  apply (simp add: sup_matrix_def)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply (simp)
  done

lemma nprt_move_matrix: "nprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (nprt A) j i"
  apply (simp add: nprt_def)
  apply (simp add: inf_matrix_def)
  apply (simp add: Rep_matrix_inject[symmetric])
  apply (rule ext)+
  apply (simp)
  done

lemma sparse_row_matrix_pprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (pprt_spmat m) = pprt (sparse_row_matrix m)"
  apply (induct m)
  apply simp
  apply simp
  apply (frule sorted_spvec_cons1)
  apply (simp add: sparse_row_matrix_cons sparse_row_vector_pprt)
  apply (subst pprt_add)
  apply (subst disj_matrices_commute)
  apply (rule disj_move_sparse_vec_mat)
  apply auto
  apply (simp add: sorted_spvec.simps)
  apply (simp split: list.split)
  apply auto
  apply (simp add: pprt_move_matrix)
  done

lemma sparse_row_matrix_nprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (nprt_spmat m) = nprt (sparse_row_matrix m)"
  apply (induct m)
  apply simp
  apply simp
  apply (frule sorted_spvec_cons1)
  apply (simp add: sparse_row_matrix_cons sparse_row_vector_nprt)
  apply (subst nprt_add)
  apply (subst disj_matrices_commute)
  apply (rule disj_move_sparse_vec_mat)
  apply auto
  apply (simp add: sorted_spvec.simps)
  apply (simp split: list.split)
  apply auto
  apply (simp add: nprt_move_matrix)
  done

lemma sorted_pprt_spvec: "sorted_spvec v \<Longrightarrow> sorted_spvec (pprt_spvec v)"
  apply (induct v)
  apply (simp)
  apply (frule sorted_spvec_cons1)
  apply simp
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_nprt_spvec: "sorted_spvec v \<Longrightarrow> sorted_spvec (nprt_spvec v)"
  apply (induct v)
  apply (simp)
  apply (frule sorted_spvec_cons1)
  apply simp
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spvec_pprt_spmat: "sorted_spvec m \<Longrightarrow> sorted_spvec (pprt_spmat m)"
  apply (induct m)
  apply (simp)
  apply (frule sorted_spvec_cons1)
  apply simp
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spvec_nprt_spmat: "sorted_spvec m \<Longrightarrow> sorted_spvec (nprt_spmat m)"
  apply (induct m)
  apply (simp)
  apply (frule sorted_spvec_cons1)
  apply simp
  apply (simp add: sorted_spvec.simps split:list.split_asm)
  done

lemma sorted_spmat_pprt_spmat: "sorted_spmat m \<Longrightarrow> sorted_spmat (pprt_spmat m)"
  apply (induct m)
  apply (simp_all add: sorted_pprt_spvec)
  done

lemma sorted_spmat_nprt_spmat: "sorted_spmat m \<Longrightarrow> sorted_spmat (nprt_spmat m)"
  apply (induct m)
  apply (simp_all add: sorted_nprt_spvec)
  done

definition mult_est_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat" where
  "mult_est_spmat r1 r2 s1 s2 =
  add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
  (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))"

lemmas sparse_row_matrix_op_simps =
  sorted_sparse_matrix_imp_spmat sorted_sparse_matrix_imp_spvec
  sparse_row_add_spmat sorted_spvec_add_spmat sorted_spmat_add_spmat
  sparse_row_diff_spmat sorted_spvec_diff_spmat sorted_spmat_diff_spmat
  sparse_row_matrix_minus sorted_spvec_minus_spmat sorted_spmat_minus_spmat
  sparse_row_mult_spmat sorted_spvec_mult_spmat sorted_spmat_mult_spmat
  sparse_row_matrix_abs sorted_spvec_abs_spmat sorted_spmat_abs_spmat
  le_spmat_iff_sparse_row_le
  sparse_row_matrix_pprt sorted_spvec_pprt_spmat sorted_spmat_pprt_spmat
  sparse_row_matrix_nprt sorted_spvec_nprt_spmat sorted_spmat_nprt_spmat

lemmas sparse_row_matrix_arith_simps =
  mult_spmat.simps mult_spvec_spmat.simps
  addmult_spvec.simps
  smult_spvec_empty smult_spvec_cons
  add_spmat.simps add_spvec.simps
  minus_spmat.simps minus_spvec.simps
  abs_spmat.simps abs_spvec.simps
  diff_spmat_def
  le_spmat.simps le_spvec.simps
  pprt_spmat.simps pprt_spvec.simps
  nprt_spmat.simps nprt_spvec.simps
  mult_est_spmat_def

(*lemma spm_linprog_dual_estimate_1:
  assumes
  "sorted_sparse_matrix A1"
  "sorted_sparse_matrix A2"
  "sorted_sparse_matrix c1"
  "sorted_sparse_matrix c2"
  "sorted_sparse_matrix y"
  "sorted_spvec b"
  "sorted_spvec r"
  "le_spmat ([], y)"
  "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
  "sparse_row_matrix A1 <= A"
  "A <= sparse_row_matrix A2"
  "sparse_row_matrix c1 <= c"
  "c <= sparse_row_matrix c2"
  "\<bar>x\<bar> \<le> sparse_row_matrix r"
  shows
  "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b, mult_spmat (add_spmat (add_spmat (mult_spmat y (diff_spmat A2 A1),
  abs_spmat (diff_spmat (mult_spmat y A1) c1)), diff_spmat c2 c1)) r))"
  by (insert prems, simp add: sparse_row_matrix_op_simps linprog_dual_estimate_1[where A=A])
*)

end


(*  Title:      HOL/SPARK/Examples/Liseq/Longest_Increasing_Subsequence.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG
*)

theory Longest_Increasing_Subsequence
imports "HOL-SPARK.SPARK"
begin

text \<open>
Set of all increasing subsequences in a prefix of an array
\<close>

definition iseq :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat set set" where
  "iseq xs l = {is. (\<forall>i\<in>is. i < l) \<and>
     (\<forall>i\<in>is. \<forall>j\<in>is. i \<le> j \<longrightarrow> xs i \<le> xs j)}"

text \<open>
Length of longest increasing subsequence in a prefix of an array
\<close>

definition liseq :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat" where
  "liseq xs i = Max (card ` iseq xs i)"

text \<open>
Length of longest increasing subsequence ending at a particular position
\<close>

definition liseq' :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat" where
  "liseq' xs i = Max (card ` (iseq xs (Suc i) \<inter> {is. Max is = i}))"

lemma iseq_finite: "finite (iseq xs i)"
  apply (simp add: iseq_def)
  apply (rule finite_subset [OF _
    finite_Collect_subsets [of "{j. j < i}"]])
  apply auto
  done

lemma iseq_finite': "is \<in> iseq xs i \<Longrightarrow> finite is"
  by (auto simp add: iseq_def bounded_nat_set_is_finite)

lemma iseq_singleton: "i < l \<Longrightarrow> {i} \<in> iseq xs l"
  by (simp add: iseq_def)

lemma iseq_trivial: "{} \<in> iseq xs i"
  by (simp add: iseq_def)

lemma iseq_nonempty: "iseq xs i \<noteq> {}"
  by (auto intro: iseq_trivial)

lemma liseq'_ge1: "1 \<le> liseq' xs x"
  apply (simp add: liseq'_def)
  apply (subgoal_tac "iseq xs (Suc x) \<inter> {is. Max is = x} \<noteq> {}")
  apply (simp add: Max_ge_iff iseq_finite)
  apply (rule_tac x="{x}" in bexI)
  apply (auto intro: iseq_singleton)
  done

lemma liseq_expand:
  assumes R: "\<And>is. liseq xs i = card is \<Longrightarrow> is \<in> iseq xs i \<Longrightarrow>
    (\<And>js. js \<in> iseq xs i \<Longrightarrow> card js \<le> card is) \<Longrightarrow> P"
  shows "P"
proof -
  have "Max (card ` iseq xs i) \<in> card ` iseq xs i"
    by (rule Max_in) (simp_all add: iseq_finite iseq_nonempty)
  then obtain js where js: "liseq xs i = card js" and "js \<in> iseq xs i"
    by (rule imageE) (simp add: liseq_def)
  moreover {
    fix js'
    assume "js' \<in> iseq xs i"
    then have "card js' \<le> card js"
      by (simp add: js [symmetric] liseq_def iseq_finite iseq_trivial)
  }
  ultimately show ?thesis by (rule R)
qed

lemma liseq'_expand:
  assumes R: "\<And>is. liseq' xs i = card is \<Longrightarrow> is \<in> iseq xs (Suc i) \<Longrightarrow>
    finite is \<Longrightarrow> Max is = i \<Longrightarrow>
    (\<And>js. js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow> card js \<le> card is) \<Longrightarrow>
    is \<noteq> {} \<Longrightarrow> P"
  shows "P"
proof -
  have "Max (card ` (iseq xs (Suc i) \<inter> {is. Max is = i})) \<in>
    card ` (iseq xs (Suc i) \<inter> {is. Max is = i})"
    by (auto simp add: iseq_finite intro!: iseq_singleton Max_in)
  then obtain js where js: "liseq' xs i = card js" and "js \<in> iseq xs (Suc i)"
    and "finite js" and "Max js = i"
    by (auto simp add: liseq'_def intro: iseq_finite')
  moreover {
    fix js'
    assume "js' \<in> iseq xs (Suc i)" "Max js' = i"
    then have "card js' \<le> card js"
      by (auto simp add: js [symmetric] liseq'_def iseq_finite intro!: iseq_singleton)
  }
  note max = this
  moreover have "card {i} \<le> card js"
    by (rule max) (simp_all add: iseq_singleton)
  then have "js \<noteq> {}" by auto
  ultimately show ?thesis by (rule R)
qed

lemma liseq'_ge:
  "j = card js \<Longrightarrow> js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
  js \<noteq> {} \<Longrightarrow> j \<le> liseq' xs i"
  by (simp add: liseq'_def iseq_finite)

lemma liseq'_eq:
  "j = card js \<Longrightarrow> js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
  js \<noteq> {} \<Longrightarrow> (\<And>js'. js' \<in> iseq xs (Suc i) \<Longrightarrow> Max js' = i \<Longrightarrow> finite js' \<Longrightarrow>
    js' \<noteq> {} \<Longrightarrow> card js' \<le> card js) \<Longrightarrow>
  j = liseq' xs i"
  by (fastforce simp add: liseq'_def iseq_finite
    intro: Max_eqI [symmetric])

lemma liseq_ge:
  "j = card js \<Longrightarrow> js \<in> iseq xs i \<Longrightarrow> j \<le> liseq xs i"
  by (auto simp add: liseq_def iseq_finite)

lemma liseq_eq:
  "j = card js \<Longrightarrow> js \<in> iseq xs i \<Longrightarrow>
  (\<And>js'. js' \<in> iseq xs i \<Longrightarrow> finite js' \<Longrightarrow>
    js' \<noteq> {} \<Longrightarrow> card js' \<le> card js) \<Longrightarrow>
  j = liseq xs i"
  by (fastforce simp add: liseq_def iseq_finite
    intro: Max_eqI [symmetric])

lemma max_notin: "finite xs \<Longrightarrow> Max xs < x \<Longrightarrow> x \<notin> xs"
  by (cases "xs = {}") auto

lemma iseq_insert:
  "xs (Max is) \<le> xs i \<Longrightarrow> is \<in> iseq xs i \<Longrightarrow>
  is \<union> {i} \<in> iseq xs (Suc i)"
  apply (frule iseq_finite')
  apply (cases "is = {}")
  apply (auto simp add: iseq_def)
  apply (rule order_trans [of _ "xs (Max is)"])
  apply auto
  apply (thin_tac "\<forall>a\<in>is. a < i")
  apply (drule_tac x=ia in bspec)
  apply assumption
  apply (drule_tac x="Max is" in bspec)
  apply (auto intro: Max_in)
  done

lemma iseq_diff: "is \<in> iseq xs (Suc (Max is)) \<Longrightarrow>
  is - {Max is} \<in> iseq xs (Suc (Max (is - {Max is})))"
  apply (frule iseq_finite')
  apply (simp add: iseq_def less_Suc_eq_le)
  done

lemma iseq_butlast:
  assumes "js \<in> iseq xs (Suc i)" and "js \<noteq> {}"
  and "Max js \<noteq> i"
  shows "js \<in> iseq xs i"
proof -
  from assms have fin: "finite js"
    by (simp add: iseq_finite')
  with assms have "Max js \<in> js"
    by auto
  with assms have "Max js < i"
    by (auto simp add: iseq_def)
  with fin assms have "\<forall>j\<in>js. j < i"
    by simp
  with assms show ?thesis
    by (simp add: iseq_def)
qed

lemma iseq_mono: "is \<in> iseq xs i \<Longrightarrow> i \<le> j \<Longrightarrow> is \<in> iseq xs j"
  by (auto simp add: iseq_def)

lemma diff_nonempty:
  assumes "1 < card is"
  shows "is - {i} \<noteq> {}"
proof -
  from assms have fin: "finite is" by (auto intro: card_ge_0_finite)
  with assms fin have "card is - 1 \<le> card (is - {i})"
    by (simp add: card_Diff_singleton_if)
  with assms have "0 < card (is - {i})" by simp
  then show ?thesis by (simp add: card_gt_0_iff)
qed

lemma Max_diff:
  assumes "1 < card is"
  shows "Max (is - {Max is}) < Max is"
proof -
  from assms have "finite is" by (auto intro: card_ge_0_finite)
  moreover from assms have "is - {Max is} \<noteq> {}"
    by (rule diff_nonempty)
  ultimately show ?thesis using assms
    apply (auto simp add: not_less)
    apply (subgoal_tac "a \<le> Max is")
    apply auto
    done
qed

lemma iseq_nth: "js \<in> iseq xs l \<Longrightarrow> 1 < card js \<Longrightarrow>
  xs (Max (js - {Max js})) \<le> xs (Max js)"
  apply (auto simp add: iseq_def)
  apply (subgoal_tac "Max (js - {Max js}) \<in> js")
  apply (thin_tac "\<forall>i\<in>js. i < l")
  apply (drule_tac x="Max (js - {Max js})" in bspec)
  apply assumption
  apply (drule_tac x="Max js" in bspec)
  using card_gt_0_iff [of js]
  apply simp
  using Max_diff [of js]
  apply simp
  using Max_in [of "js - {Max js}", OF _ diff_nonempty] card_gt_0_iff [of js]
  apply auto
  done

lemma card_leq1_singleton:
  assumes "finite xs" "xs \<noteq> {}" "card xs \<le> 1"
  obtains x where "xs = {x}"
  using assms
  by induct simp_all

lemma longest_iseq1:
  "liseq' xs i =
   Max ({0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}) + 1"
proof -
  have "Max ({0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}) = liseq' xs i - 1"
  proof (rule Max_eqI)
    fix y
    assume "y \<in> {0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}"
    then show "y \<le> liseq' xs i - 1"
    proof
      assume "y \<in> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}"
      then obtain j where j: "j < i" "xs j \<le> xs i" "y = liseq' xs j"
        by auto
      have "liseq' xs j + 1 \<le> liseq' xs i"
      proof (rule liseq'_expand)
        fix "is"
        assume H: "liseq' xs j = card is" "is \<in> iseq xs (Suc j)"
          "finite is" "Max is = j" "is \<noteq> {}"
        from H j have "card is + 1 = card (is \<union> {i})"
          by (simp add: card.insert_remove max_notin)
        moreover {
          from H j have "xs (Max is) \<le> xs i" by simp
          moreover from \<open>j < i\<close> have "Suc j \<le> i" by simp
          with \<open>is \<in> iseq xs (Suc j)\<close> have "is \<in> iseq xs i"
            by (rule iseq_mono)
          ultimately have "is \<union> {i} \<in> iseq xs (Suc i)"
          by (rule iseq_insert)
        } moreover from H j have "Max (is \<union> {i}) = i" by simp
        moreover have "is \<union> {i} \<noteq> {}" by simp
        ultimately have "card is + 1 \<le> liseq' xs i"
          by (rule liseq'_ge)
        with H show ?thesis by simp
      qed
      with j show "y \<le> liseq' xs i - 1"
        by simp
    qed simp
  next
    have "liseq' xs i \<le> 1 \<or>
      (\<exists>j. liseq' xs i - 1 = liseq' xs j \<and> j < i \<and> xs j \<le> xs i)"
    proof (rule liseq'_expand)
      fix "is"
      assume H: "liseq' xs i = card is" "is \<in> iseq xs (Suc i)"
        "finite is" "Max is = i" "is \<noteq> {}"
      assume R: "\<And>js. js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
        card js \<le> card is"
      show ?thesis
      proof (cases "card is \<le> 1")
        case True with H show ?thesis by simp
      next
        case False
        then have "1 < card is" by simp
        then have "Max (is - {Max is}) < Max is"
          by (rule Max_diff)
        from \<open>is \<in> iseq xs (Suc i)\<close> \<open>1 < card is\<close>
        have "xs (Max (is - {Max is})) \<le> xs (Max is)"
          by (rule iseq_nth)
        have "card is - 1 = liseq' xs (Max (is - {i}))"
        proof (rule liseq'_eq)
          from \<open>Max is = i\<close> [symmetric] \<open>finite is\<close> \<open>is \<noteq> {}\<close>
          show "card is - 1 = card (is - {i})" by simp
        next
          from \<open>is \<in> iseq xs (Suc i)\<close> \<open>Max is = i\<close> [symmetric]
          show "is - {i} \<in> iseq xs (Suc (Max (is - {i})))"
            by simp (rule iseq_diff)
        next
          from \<open>1 < card is\<close>
          show "is - {i} \<noteq> {}" by (rule diff_nonempty)
        next
          fix js
          assume "js \<in> iseq xs (Suc (Max (is - {i})))"
            "Max js = Max (is - {i})" "finite js" "js \<noteq> {}"
          from \<open>xs (Max (is - {Max is})) \<le> xs (Max is)\<close>
            \<open>Max js = Max (is - {i})\<close> \<open>Max is = i\<close>
          have "xs (Max js) \<le> xs i" by simp
          moreover from \<open>Max is = i\<close> \<open>Max (is - {Max is}) < Max is\<close>
          have "Suc (Max (is - {i})) \<le> i"
            by simp
          with \<open>js \<in> iseq xs (Suc (Max (is - {i})))\<close>
          have "js \<in> iseq xs i"
            by (rule iseq_mono)
          ultimately have "js \<union> {i} \<in> iseq xs (Suc i)"
            by (rule iseq_insert)
          moreover from \<open>js \<noteq> {}\<close> \<open>finite js\<close> \<open>Max js = Max (is - {i})\<close>
            \<open>Max is = i\<close> [symmetric] \<open>Max (is - {Max is}) < Max is\<close>
          have "Max (js \<union> {i}) = i"
            by simp
          ultimately have "card (js \<union> {i}) \<le> card is" by (rule R)
          moreover from \<open>Max is = i\<close> [symmetric] \<open>finite js\<close>
            \<open>Max (is - {Max is}) < Max is\<close> \<open>Max js = Max (is - {i})\<close>
          have "i \<notin> js" by (simp add: max_notin)
          with \<open>finite js\<close>
          have "card (js \<union> {i}) = card ((js \<union> {i}) - {i}) + 1"
            by simp
          ultimately show "card js \<le> card (is - {i})"
            using \<open>i \<notin> js\<close> \<open>Max is = i\<close> [symmetric] \<open>is \<noteq> {}\<close> \<open>finite is\<close>
            by simp
        qed simp
        with H \<open>Max (is - {Max is}) < Max is\<close>
          \<open>xs (Max (is - {Max is})) \<le> xs (Max is)\<close>
        show ?thesis by auto
      qed
    qed
    then show "liseq' xs i - 1 \<in> {0} \<union>
      {liseq' xs j |j. j < i \<and> xs j \<le> xs i}" by simp
  qed simp
  moreover have "1 \<le> liseq' xs i" by (rule liseq'_ge1)
  ultimately show ?thesis by simp
qed

lemma longest_iseq2': "liseq xs i < liseq' xs i \<Longrightarrow>
  liseq xs (Suc i) = liseq' xs i"
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule liseq_eq [symmetric])
  apply (rule refl)
  apply assumption
  apply (case_tac "Max js' = i")
  apply simp
  apply (drule_tac js=js' in iseq_butlast)
  apply assumption+
  apply (drule_tac js=js' in liseq_ge [OF refl])
  apply simp
  done

lemma longest_iseq2: "liseq xs i < liseq' xs i \<Longrightarrow>
  liseq xs i + 1 = liseq' xs i"
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq_expand)
  apply (drule_tac s="Max is" in sym)
  apply simp
  apply (case_tac "card is \<le> 1")
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac i="Suc (Max (is - {Max is}))" and j="Max is" in iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (drule_tac x="is - {Max is}" in meta_spec,
    drule meta_mp, assumption)
  apply simp
  done

lemma longest_iseq3:
  "liseq xs j = liseq' xs i \<Longrightarrow> xs i \<le> xs j \<Longrightarrow> i < j \<Longrightarrow>
  liseq xs (Suc j) = liseq xs j + 1"
  apply (rule_tac xs=xs and i=j in liseq_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac js="isa \<union> {j}" in liseq_eq [symmetric])
  apply (simp add: card.insert_remove card_Diff_singleton_if max_notin)
  apply (rule iseq_insert)
  apply simp
  apply (erule iseq_mono)
  apply simp
  apply (case_tac "j = Max js'")
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac x="js' - {j}" in meta_spec)
  apply (drule meta_mp)
  apply simp
  apply (case_tac "card js' \<le> 1")
  apply (erule_tac xs=js' in card_leq1_singleton)
  apply assumption+
  apply (simp add: iseq_trivial)
  apply (erule iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (rule le_diff_iff [THEN iffD1, of 1])
  apply (simp add: card_0_eq [symmetric] del: card_0_eq)
  apply (simp add: card.insert_remove)
  apply (subgoal_tac "card (js' - {j}) = card js' - 1")
  apply (simp add: card.insert_remove card_Diff_singleton_if max_notin)
  apply (frule_tac A=js' in Max_in)
  apply assumption
  apply (simp add: card_Diff_singleton_if)
  apply (drule_tac js=js' in iseq_butlast)
  apply assumption
  apply (erule not_sym)
  apply (drule_tac x=js' in meta_spec)
  apply (drule meta_mp)
  apply assumption
  apply (simp add: card_insert_disjoint max_notin)
  done

lemma longest_iseq4:
  "liseq xs j = liseq' xs i \<Longrightarrow> xs i \<le> xs j \<Longrightarrow> i < j \<Longrightarrow>
  liseq' xs j = liseq' xs i + 1"
  apply (rule_tac xs=xs and i=j in liseq_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac js="isa \<union> {j}" in liseq'_eq [symmetric])
  apply (simp add: card.insert_remove card_Diff_singleton_if max_notin)
  apply (rule iseq_insert)
  apply simp
  apply (erule iseq_mono)
  apply simp
  apply simp
  apply simp
  apply (drule_tac s="Max js'" in sym)
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac x="js' - {j}" in meta_spec)
  apply (drule meta_mp)
  apply simp
  apply (case_tac "card js' \<le> 1")
  apply (erule_tac xs=js' in card_leq1_singleton)
  apply assumption+
  apply (simp add: iseq_trivial)
  apply (erule iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (rule le_diff_iff [THEN iffD1, of 1])
  apply (simp add: card_0_eq [symmetric] del: card_0_eq)
  apply (simp add: card.insert_remove)
  apply (subgoal_tac "card (js' - {j}) = card js' - 1")
  apply (simp add: card.insert_remove card_Diff_singleton_if max_notin)
  apply (frule_tac A=js' in Max_in)
  apply assumption
  apply (simp add: card_Diff_singleton_if)
  done

lemma longest_iseq5: "liseq' xs i \<le> liseq xs i \<Longrightarrow>
  liseq xs (Suc i) = liseq xs i"
  apply (rule_tac i=i and xs=xs in liseq'_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq_expand)
  apply simp
  apply (rule liseq_eq [symmetric])
  apply (rule refl)
  apply (erule iseq_mono)
  apply simp
  apply (case_tac "Max js' = i")
  apply (drule_tac x=js' in meta_spec)
  apply simp
  apply (drule iseq_butlast, assumption, assumption)
  apply simp
  done

lemma liseq_empty: "liseq xs 0 = 0"
  apply (rule_tac js="{}" in liseq_eq [symmetric])
  apply simp
  apply (rule iseq_trivial)
  apply (simp add: iseq_def)
  done

lemma liseq'_singleton: "liseq' xs 0 = 1"
  by (simp add: longest_iseq1 [of _ 0])

lemma liseq_singleton: "liseq xs (Suc 0) = Suc 0"
  by (simp add: longest_iseq2' liseq_empty liseq'_singleton)

lemma liseq'_Suc_unfold:
  "A j \<le> x \<Longrightarrow>
   (insert 0 {liseq' A j' |j'. j' < Suc j \<and> A j' \<le> x}) =
   (insert 0 {liseq' A j' |j'. j' < j \<and> A j' \<le> x}) \<union>
   {liseq' A j}"
  by (auto simp add: less_Suc_eq)

lemma liseq'_Suc_unfold':
  "\<not> (A j \<le> x) \<Longrightarrow>
   {liseq' A j' |j'. j' < Suc j \<and> A j' \<le> x} =
   {liseq' A j' |j'. j' < j \<and> A j' \<le> x}"
  by (auto simp add: less_Suc_eq)

lemma iseq_card_limit:
  assumes "is \<in> iseq A i"
  shows "card is \<le> i"
proof -
  from assms have "is \<subseteq> {0..<i}"
    by (auto simp add: iseq_def)
  with finite_atLeastLessThan have "card is \<le> card {0..<i}"
    by (rule card_mono)
  with card_atLeastLessThan show ?thesis by simp
qed

lemma liseq_limit: "liseq A i \<le> i"
  by (rule_tac xs=A and i=i in liseq_expand)
    (simp add: iseq_card_limit)

lemma liseq'_limit: "liseq' A i \<le> i + 1"
  by (rule_tac xs=A and i=i in liseq'_expand)
    (simp add: iseq_card_limit)

definition max_ext :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "max_ext A i j = Max ({0} \<union> {liseq' A j' |j'. j' < j \<and> A j' \<le> A i})"

lemma max_ext_limit: "max_ext A i j \<le> j"
  apply (auto simp add: max_ext_def)
  apply (drule Suc_leI)
  apply (cut_tac i=j' and A=A in liseq'_limit)
  apply simp
  done

text \<open>Proof functions\<close>

abbreviation (input)
  "arr_conv a \<equiv> (\<lambda>n. a (int n))"

lemma idx_conv_suc:
  "0 \<le> i \<Longrightarrow> nat (i + 1) = nat i + 1"
  by simp

abbreviation liseq_ends_at' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int" where
  "liseq_ends_at' A i \<equiv> int (liseq' (\<lambda>l. A (int l)) (nat i))"

abbreviation liseq_prfx' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int" where
  "liseq_prfx' A i \<equiv> int (liseq (\<lambda>l. A (int l)) (nat i))"

abbreviation max_ext' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int" where
  "max_ext' A i j \<equiv> int (max_ext (\<lambda>l. A (int l)) (nat i) (nat j))"

spark_proof_functions
  liseq_ends_at = "liseq_ends_at' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int"
  liseq_prfx = "liseq_prfx' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int"
  max_ext = "max_ext' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int"

text \<open>The verification conditions\<close>

spark_open \<open>liseq/liseq_length\<close>

spark_vc procedure_liseq_length_5
  by (simp_all add: liseq_singleton liseq'_singleton)

spark_vc procedure_liseq_length_6
proof -
  from H1 H2 H3 H4
  have eq: "liseq (arr_conv a) (nat i) =
    liseq' (arr_conv a) (nat pmax)"
    by simp
  from H14 H3 H4
  have pmax1: "arr_conv a (nat pmax) \<le> arr_conv a (nat i)"
    by simp
  from H3 H4 have pmax2: "nat pmax < nat i"
    by simp
  {
    fix i2
    assume i2: "0 \<le> i2" "i2 \<le> i"
    have "(l(i := l pmax + 1)) i2 =
      int (liseq' (arr_conv a) (nat i2))"
    proof (cases "i2 = i")
      case True
      from eq pmax1 pmax2 have "liseq' (arr_conv a) (nat i) =
        liseq' (arr_conv a) (nat pmax) + 1"
        by (rule longest_iseq4)
      with True H1 H3 H4 show ?thesis
        by simp
    next
      case False
      with H1 i2 show ?thesis
        by simp
    qed
  }
  then show ?C1 by simp
  from eq pmax1 pmax2
  have "liseq (arr_conv a) (Suc (nat i)) =
    liseq (arr_conv a) (nat i) + 1"
    by (rule longest_iseq3)
 with H2 H3 H4 show ?C2
    by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_7
proof -
  from H1 show ?C1
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  from H6
  have m: "max_ext (arr_conv a) (nat i) (nat i) + 1 =
    liseq' (arr_conv a) (nat i)"
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  with H2 H18
  have gt: "liseq (arr_conv a) (nat i) < liseq' (arr_conv a) (nat i)"
    by simp
  then have "liseq' (arr_conv a) (nat i) = liseq (arr_conv a) (nat i) + 1"
    by (rule longest_iseq2 [symmetric])
  with H2 m show ?C2 by simp
  from gt have "liseq (arr_conv a) (Suc (nat i)) = liseq' (arr_conv a) (nat i)"
    by (rule longest_iseq2')
  with m H6 show ?C3 by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_8
proof -
  {
    fix i2
    assume i2: "0 \<le> i2" "i2 \<le> i"
    have "(l(i := max_ext' a i i + 1)) i2 =
      int (liseq' (arr_conv a) (nat i2))"
    proof (cases "i2 = i")
      case True
      with H1 show ?thesis
        by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
    next
      case False
      with H1 i2 show ?thesis by simp
    qed
  }
  then show ?C1 by simp
  from H2 H6 H18
  have "liseq' (arr_conv a) (nat i) \<le> liseq (arr_conv a) (nat i)"
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  then have "liseq (arr_conv a) (Suc (nat i)) = liseq (arr_conv a) (nat i)"
    by (rule longest_iseq5)
  with H2 H6 show ?C2 by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_12
  by (simp add: max_ext_def)

spark_vc procedure_liseq_length_13
  using H1 H6 H13 H21 H22
  by (simp add: max_ext_def
    idx_conv_suc liseq'_Suc_unfold max_def del: Max_less_iff)

spark_vc procedure_liseq_length_14
  using H1 H6 H13 H21
  by (cases "a j \<le> a i")
    (simp_all add: max_ext_def
      idx_conv_suc liseq'_Suc_unfold liseq'_Suc_unfold')

spark_vc procedure_liseq_length_19
  using H3 H4 H5 H8 H9
  apply (rule_tac y="int (nat i)" in order_trans)
  apply (cut_tac A="arr_conv a" and i="nat i" and j="nat i" in max_ext_limit)
  apply simp_all
  done

spark_vc procedure_liseq_length_23
  using H2 H3 H4 H7 H8 H11
  apply (rule_tac y="int (nat i)" in order_trans)
  apply (cut_tac A="arr_conv a" and i="nat i" in liseq_limit)
  apply simp_all
  done

spark_vc procedure_liseq_length_29
  using H2 H3 H8 H13
  by (simp add: add1_zle_eq [symmetric])

spark_end

end


theory point
imports Complex_Main (*"~~/src/HOL/Library/Old_Datatype.thy"*)
begin

(*References
[1] "Automation for Geometry in Isabelle/HOL", Laura Meikle
[2] Intuition in Formal Proof: A Novel Framework for Combining Mathematical Tools, Laura Meikle*)

(*defintion for Points*)
typedef point2d = "{p::(real*real). True}" by(auto)(*[1]*)
definition xCoord :: "point2d \<Rightarrow> real" where "xCoord P \<equiv> fst(Rep_point2d P)"(*[1]*)
definition yCoord :: "point2d \<Rightarrow> real" where "yCoord P \<equiv> snd(Rep_point2d P)"(*[1]*)
lemma xCoord[simp]: "xCoord (Abs_point2d (a, b)) = a" by (simp add: xCoord_def Abs_point2d_inverse)
lemma yCoord[simp]: "yCoord (Abs_point2d (a, b)) = b" by (simp add: yCoord_def Abs_point2d_inverse)
lemma pointSameCoord [simp]: "Abs_point2d(a, b) = Abs_point2d(a', c) = (a = a' \<and> b = c)"
  by (metis (full_types) Abs_point2d_inject fst_conv mem_Collect_eq snd_conv)

(*points equal*)
definition pointsEqual :: "point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "pointsEqual r p \<equiv> (xCoord r = xCoord p \<and> yCoord r = yCoord p)"
lemma pointsNotEqual : "\<not>pointsEqual r p = (xCoord r \<noteq> xCoord p \<or> yCoord r \<noteq> yCoord p)"
  by (simp add: pointsEqual_def)
lemma pointsNotEqual1: "(xCoord r \<noteq> xCoord p \<or> yCoord r \<noteq> yCoord p) \<longleftrightarrow> r \<noteq> p"
  by (metis Rep_point2d_inverse prod.collapse xCoord_def yCoord_def)
lemma pointsEqualSame : "pointsEqual p p" by (simp add: pointsEqual_def)
theorem pointsEqual1 [simp] : "pointsEqual p r = (p = r)"
  apply (auto simp add: pointsEqual_def)
by (metis Rep_point2d_inverse prod.collapse xCoord_def yCoord_def)

(*Point a left from point B*)
definition leftFrom :: "point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "leftFrom a b \<equiv> (xCoord a < xCoord b)"
lemma leftFromSimp: "xCoord a \<noteq> xCoord b \<Longrightarrow> \<not>leftFrom a b \<Longrightarrow> leftFrom b a"
  by(simp add: leftFrom_def)
lemma leftFromDest [dest]: "leftFrom a b \<Longrightarrow> leftFrom b a \<Longrightarrow> False"
  by (simp add: leftFrom_def)

(*signed area of a triangle; with the convention being that
- if the points are ordered anti-clockwise, the area is positive
- if the points are ordered clockwise, the area is negative.*)
definition signedArea :: "[point2d, point2d, point2d] \<Rightarrow> real" where(*[1]*)
  "signedArea a b c \<equiv> (xCoord b - xCoord a)*(yCoord c - yCoord a)
    - (yCoord b - yCoord a)*(xCoord c - xCoord a)"
(*sigendArea-Rotate*)
lemma signedAreaMin: "signedArea A B C = -signedArea A C B"
  by (simp add: signedArea_def)
lemma signedAreaRotate [simp]: "signedArea b c a = signedArea a b c"(*[1]*)
  by (simp add: signedArea_def, algebra)
lemma signedAreaRotate2 [simp]: "signedArea b a c = signedArea a c b"(*[1]*)
  by (simp add: signedArea_def,  algebra)
(*equal Points*)
lemma areaDoublePoint [simp]: "signedArea a a b = 0"(*[1]*) by (simp add: signedArea_def)
lemma areaDoublePoint2 [simp]: "signedArea a b b = 0"(*[1]*) by (simp add: signedArea_def)
(*hausner*)
lemma hausner: "signedArea P A B + signedArea P B C + signedArea P C A = signedArea A B C" (*[2]*)
  by (simp add: mult.commute right_diff_distrib' signedArea_def)

(*3 points are on a line*)
definition collinear :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where(*[1]*)
  "collinear a b c \<equiv>
    ((xCoord a - xCoord b)*(yCoord b - yCoord c) = (yCoord a- yCoord b)*(xCoord b - xCoord c))"
lemma colliniearRight : "collinear a b c = (signedArea a b c = 0)"
  by (simp add: collinear_def signedArea_def, rule iffI, algebra+)
lemma collRotate [simp]: "collinear c a b = collinear a b c"(*[1]*)
  by (simp add: collinear_def, algebra)
lemma collSwap [simp]: "collinear a c b = collinear a b c"(*[1]*) by(simp add:collinear_def,algebra)
lemma twoPointsColl [simp]: "collinear a b b"(*[1]*) by (simp add: collinear_def)
lemma twoPointsColl2 [simp]: "collinear a a b"(*[1]*) by (simp add: collinear_def)

(*three points a, b and c make a left turn if they make an anti-clockwise cycle:*)
definition leftTurn :: "[point2d, point2d, point2d] \<Rightarrow> bool" where(*[1]*)
"leftTurn a b c \<equiv> 0 < signedArea a b c"
lemma leftTurnRotate [simp]: "leftTurn b c a = leftTurn a b c"(*[1]*) by (simp add: leftTurn_def)
lemma leftTurnRotate2 [simp]: "leftTurn b a c = leftTurn a c b"(*[1]*) by (simp add: leftTurn_def)
lemma leftTurnDiffPoints [intro]: "leftTurn a b c \<Longrightarrow> a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c"(*[1]*)
  by (auto simp add: leftTurn_def)

(*three points a, b and c make a right turn if they make an clockwise cycle:*)
definition rightTurn :: "[point2d, point2d, point2d] \<Rightarrow> bool" where
  "rightTurn a b c \<equiv> 0 > signedArea a b c"
lemma rightTurnEq: "rightTurn a b c = (signedArea a b c \<noteq> 0 \<and> \<not>leftTurn a b c)"
  using leftTurn_def rightTurn_def by auto
lemma leftRightTurn [simp]: "leftTurn a b c = rightTurn c b a"
  by (simp add: signedArea_def leftTurn_def rightTurn_def less_real_def mult.commute)
lemma rightTurnRotate [simp]: "rightTurn b c a = rightTurn a b c" by (simp add: rightTurn_def)
lemma rightTurnRotate2 [simp]: "rightTurn b a c = rightTurn a c b" by (simp add: rightTurn_def)

(*lemmas for leftTurn and rightTurn*)
lemma notLeftTurn [simp]: "(\<not> leftTurn a c b) = (leftTurn a b c \<or> collinear a b c)"(*[1]*)
  apply (simp add:leftTurn_def del: leftRightTurn, subst colliniearRight)
by (auto simp add: signedArea_def mult.commute)
lemma notRightTurn [simp]: "(\<not> rightTurn a c b) = (rightTurn a b c \<or> collinear a b c)"
  by (simp add: rightTurn_def, subst colliniearRight,auto simp add: signedArea_def mult.commute)
lemma notRightTurn1 [simp]: "(\<not> rightTurn a b c) = (leftTurn a b c \<or> collinear a b c)"
  by (metis leftRightTurn leftTurnRotate2 notLeftTurn)
lemma conflictingLeftTurns [dest]: "leftTurn a b c \<Longrightarrow> leftTurn a c b \<Longrightarrow> False"(*[1]*)
  by (metis notLeftTurn)
lemma conflictingLeftTurns3 [dest]: "leftTurn a b c \<Longrightarrow> collinear a b c \<Longrightarrow> False"(*[1]*)
  by (metis collSwap notLeftTurn)
lemma conflictingRigthTurns [dest]: "rightTurn a b c \<Longrightarrow> rightTurn a c b \<Longrightarrow> False"
  by (metis notRightTurn)
lemma conflictingRigthTurns1 [dest]: "rightTurn a b c \<Longrightarrow> rightTurn b a c \<Longrightarrow> False"
  by (metis leftRightTurn notLeftTurn)
lemma conflictingRightTurns3 [dest]: "rightTurn a b c \<Longrightarrow> collinear a b c \<Longrightarrow> False"
  by (metis collSwap notRightTurn)

(*signedArea Mult and Div *)
lemma leftTurnMult:"leftTurn a b c \<Longrightarrow> leftTurn d b e \<Longrightarrow> (signedArea a b c)*(signedArea d b e) > 0"
  using leftTurn_def by auto
lemma leftTurnDiv: "leftTurn a b c \<Longrightarrow> leftTurn d b e \<Longrightarrow> (signedArea a b c)/(signedArea d b e) > 0"
  using leftTurn_def by auto
lemma rightTurnMult: "rightTurn a b c \<Longrightarrow> rightTurn d b e \<Longrightarrow>
  (signedArea a b c)*(signedArea d b e) > 0"
  by (simp add: rightTurn_def zero_less_mult_iff)
lemma rightTurnDiv: "rightTurn a b c \<Longrightarrow> rightTurn d b e \<Longrightarrow>
  (signedArea a b c)/(signedArea d b e) > 0"
  by (simp add: rightTurn_def zero_less_divide_iff)

lemma interiority: "leftTurn t q r \<Longrightarrow> leftTurn p t r \<Longrightarrow> leftTurn p q t \<Longrightarrow> leftTurn p q r" (*[2]*)
  by (smt hausner leftRightTurn rightTurn_def)

(*lemmas for collinear und signedArea*)
lemma notCollThenDiffPoints [intro]: "\<not>collinear a b c \<Longrightarrow> a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c"(*[1]*) by (auto)
lemma notCollThenLfOrRt1 [intro]: "\<not>collinear a b c \<Longrightarrow> leftTurn a b c \<or> rightTurn a b c" by (auto)
lemma areaContra [dest]: " signedArea a c b < 0 \<Longrightarrow> signedArea a b c < 0  \<Longrightarrow> False"(*[1]*)
  by (metis colliniearRight leftTurn_def less_trans notLeftTurn)
lemma areaContra2 [dest]: "0 < signedArea a c b\<Longrightarrow> 0 < signedArea a b c \<Longrightarrow> False"(*[1]*)
  by (metis leftTurn_def notLeftTurn)
lemma collinearTransitiv1 : "\<exists> a. collinear a b c \<and> collinear a b d \<longrightarrow> collinear a c d"
  by (simp add: colliniearRight, rule_tac x=d in exI, simp)

(*scalar multiplication*)
definition scalMult :: "[real, point2d] \<Rightarrow> point2d" (infixl "*s" 65) where (*[2]*)
  "a *s P \<equiv> (\<lambda>(p1,p2). Abs_point2d (a*p1,a*p2)) (Rep_point2d P)"
lemma scalMultNull[simp]: "0 *s P = Abs_point2d (0,0)"
  by (simp add: scalMult_def)
(*addition*)
definition pointPlus :: "[point2d, point2d] \<Rightarrow> point2d" (infixl "+p" 60) where
  "P +p Q \<equiv> Abs_point2d ((xCoord P) + (xCoord Q), (yCoord P) + (yCoord Q))"
lemma pointPlusSym: "(P +p Q) = (Q +p P)" by (auto simp add: pointPlus_def)
lemma pointPlusNull[simp]: "xCoord Q = 0 \<Longrightarrow> P +p Q = Abs_point2d (xCoord P, yCoord P + yCoord Q)"
  by (simp add: pointPlus_def)
lemma pointPlusNull1[simp]: "yCoord Q = 0 \<Longrightarrow> P +p Q = Abs_point2d (xCoord P + xCoord Q, yCoord P)"
  by (simp add: pointPlus_def)
lemma pointPlusNull2[simp]: "P = P +p Abs_point2d(0,0)"
  by (smt Rep_point2d_inverse pointPlusNull1 prod.collapse xCoord xCoord_def yCoord)
lemma pointPlusNull3[simp]: "P = Abs_point2d(0,0) +p P"
  by (simp only: pointPlusSym pointPlusNull2)
lemma cramersRule: "signedArea P Q R \<noteq> 0 \<Longrightarrow> T =
  ((signedArea T Q R / signedArea P Q R) *s P) +p
  ((signedArea P T R / signedArea P Q R) *s Q) +p
  ((signedArea P Q T / signedArea P Q R) *s R)" (*[2]*)
  apply (auto)
  apply (case_tac "signedArea Q R T = 0", auto)
sorry
(*nur mit cramersRule beweisbar?*)
lemma transitivity: "leftTurn t s p \<Longrightarrow> leftTurn t s q \<Longrightarrow> leftTurn t s r \<Longrightarrow> leftTurn t p q (*[2]*)
  \<Longrightarrow> leftTurn t q r \<Longrightarrow> leftTurn t p r"
sorry

(*b is between a c?*)
definition isBetween :: "[point2d, point2d, point2d] \<Rightarrow> bool"
  ("_ isBetween _ _ " [60, 60, 60] 60) where(*[1]*)
  "b isBetween  a c \<equiv> collinear a b c \<and> (\<exists> d. signedArea a c d \<noteq> 0) \<and>
  (\<forall> d. signedArea a c d \<noteq> 0 \<longrightarrow>
  (0 < (signedArea a b d / signedArea a c d) \<and> (signedArea a b d / signedArea a c d) < 1 ))"
(*Punkte sind verschieden, wenn*)
lemma pointsEqualArea: "a \<noteq> b = (\<exists> d. signedArea a b d \<noteq> 0)"
  apply (auto)
  apply (case_tac "xCoord a = xCoord b", rule_tac x="Abs_point2d(xCoord b + 1, yCoord b)" in exI)
    apply (metis Abs_point2d_inverse Collect_const Rep_point2d_inverse UNIV_I add_diff_cancel_left'
    eq_iff_diff_eq_0 mult.left_neutral mult_zero_left prod.collapse prod.sel(1) signedAreaRotate
    signedArea_def xCoord_def yCoord_def)
  apply (case_tac "yCoord a = yCoord b", rule_tac x="Abs_point2d(xCoord b, yCoord b + 1)" in exI)
    apply (simp add: signedArea_def)
  apply (case_tac "xCoord a < xCoord b", rule_tac x="Abs_point2d((xCoord b) + 1, yCoord b)" in exI)
    apply (simp add: signedArea_def)
  apply (rule_tac x="Abs_point2d((xCoord b) - 1, yCoord b)" in exI)
    apply (simp add: signedArea_def)
done
lemma swapBetween1: "a isBetween c b \<Longrightarrow> a isBetween b c" (*[1]*)
  apply (simp add: isBetween_def, safe)
  apply (rule_tac x=d in exI, metis collSwap colliniearRight)
  apply (erule_tac x=da in allE, safe) using collSwap colliniearRight apply blast
  apply (simp add: colliniearRight divide_neg_neg le_divide_eq_1 left_diff_distrib' mult.commute
    signedArea_def)
  apply (simp add: divide_less_eq_1 divide_neg_neg right_diff_distrib')
  apply (smt divide_neg_neg divide_pos_pos)
  apply (erule_tac x=da in allE, safe) using collSwap colliniearRight apply blast
  apply (simp add: areaContra areaContra2 colliniearRight divide_le_0_iff divide_less_cancel
    divide_less_eq_1 left_diff_distrib' right_diff_distrib' signedArea_def)
  apply (simp add: mult.commute zero_less_divide_iff)
by smt
lemma swapBetween [simp]: "a isBetween c b = a isBetween b c" (*[1]*)
  by (auto simp add: swapBetween1)

lemma notBetweenSamePoint [dest]: "a isBetween b b \<Longrightarrow> False"(*[1]*)
  by (simp add: isBetween_def)
lemma isBetweenImpliesCollinear [intro] : "a isBetween b c \<longrightarrow> collinear a b c"(*[1]*)
  by (simp add: isBetween_def)
lemma isBetweenImpliesCollinear2 [intro] : "b isBetween a c \<longrightarrow> collinear a b c"(*[1]*)
  by (simp add: isBetween_def)
lemma isBetweenImpliesCollinear3 [intro] : "c isBetween a b \<longrightarrow> collinear a b c"(*[1]*)
  by (simp add: isBetween_def)
lemma notBetweenSelf [simp]: "\<not> (a isBetween a b)"(*[1]*)
  by (rule notI, auto simp add: isBetween_def)
lemma notBetweenSelf2 [simp]: "\<not> (b isBetween a b)"(*[1]*)
  by (rule notI, auto simp add: isBetween_def)

lemma isBetweenPointsDistinct [intro]: "a isBetween b c \<Longrightarrow> a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c"(*[1]*)
  by (auto simp add: isBetween_def)
lemma conflictingLeftTurns2 [dest]: "leftTurn a b c \<Longrightarrow> a isBetween b c \<Longrightarrow> False" (*[1]*)
  using isBetween_def by auto
lemma conflictingRightTurns2 [dest]: "rightTurn a b c \<Longrightarrow> a isBetween b c \<Longrightarrow> False" (*[1]*)
  using isBetween_def by auto
lemma isBetweenTransitiv: "b isBetween a c \<Longrightarrow> d isBetween a b \<Longrightarrow> d isBetween a c"
  apply (auto simp add: isBetween_def)
  using colliniearRight apply auto[1]
  apply (smt zero_less_divide_iff)
by (smt divide_le_0_iff le_divide_eq_1)
lemma notBetween3 [dest]: "\<lbrakk>B isBetween A C ; C isBetween A B\<rbrakk> \<Longrightarrow> False"(*[1]*)
  apply (auto simp add: isBetween_def)
  apply (case_tac "signedArea d A B \<noteq> 0")
    apply (erule_tac x=d in allE, simp)
    apply (erule_tac x=d in allE, safe, simp)
by (smt divide_le_0_iff divide_less_eq_1)
lemma leftTurnsImplyBetween: "leftTurn A B C \<Longrightarrow> leftTurn A C D \<Longrightarrow> collinear B C D \<Longrightarrow>
  C isBetween B D" (*[2]*)
  apply (case_tac "B = D", blast, case_tac "C = B", blast, case_tac "C = D", blast)
  apply (case_tac "A = B", blast, case_tac "A = C") using leftTurnDiffPoints apply blast
  apply (case_tac "A = D") using leftTurnDiffPoints apply blast
  apply (simp add: isBetween_def)
  apply (safe)
  apply (simp add: pointsEqualArea)
  apply (subgoal_tac "signedArea d B C \<noteq> 0")
sorry

lemma notBetween [dest]: "\<lbrakk>A isBetween B C; B isBetween A C\<rbrakk> \<Longrightarrow> False" (*[1]*)
  apply (auto simp add: isBetween_def)
  apply (case_tac "signedArea d B A \<noteq> 0")
    apply (erule_tac x=d in allE, simp)
    apply (erule_tac x=d in allE, safe, simp)
    apply (simp add: colliniearRight divide_less_eq_1 left_diff_distrib' right_diff_distrib'
      signedArea_def)
    apply (smt mult.commute)
    apply (simp add: divide_less_cancel divide_strict_right_mono_neg isBetween_def leftTurn_def
      leftTurnsImplyBetween rightTurn_def zero_less_divide_iff)
    apply (simp add: colliniearRight mult.commute right_diff_distrib' signedArea_def)
    apply (smt divide_less_eq_1_neg)
by (smt collSwap colliniearRight zero_less_divide_iff)
lemma notBetween2 [dest]: "\<lbrakk>A isBetween B C ; C isBetween A B\<rbrakk> \<Longrightarrow> False"(*[1]*)
  apply (auto simp add: isBetween_def)
  apply (case_tac "signedArea d B A \<noteq> 0")
    apply (erule_tac x=d in allE, simp)
    apply (erule_tac x=d in allE, safe, simp)
    apply (simp add: colliniearRight divide_less_eq_1 left_diff_distrib' right_diff_distrib'
      signedArea_def)
    apply (smt mult.commute)
    apply (simp add: divide_less_cancel divide_strict_right_mono_neg isBetween_def leftTurn_def
      leftTurnsImplyBetween rightTurn_def zero_less_divide_iff)
    apply (simp add: colliniearRight mult.commute right_diff_distrib' signedArea_def)
    apply (smt divide_less_eq_1_neg less_divide_eq_1_pos)
by (smt collSwap colliniearRight zero_less_divide_iff)

lemma onePointIsBetween[intro]: "collinear a b c \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<noteq> c \<Longrightarrow> b \<noteq> c \<Longrightarrow> (*[2]*)
  a isBetween b c \<or> b isBetween a c \<or> c isBetween a b"
  apply (safe)
  apply (auto simp add: isBetween_def)
  apply (simp add: pointsEqualArea)+
sorry

lemma collinearTransitiv: "a \<noteq> b \<Longrightarrow> collinear a b c \<Longrightarrow> collinear a b d \<Longrightarrow> collinear a c d"
  apply (simp add: colliniearRight)
  apply (cases "a = c", simp, cases "a = d", simp, cases "a = b", simp)
  apply (cases "c = d", simp, cases "c = b", simp)
  apply (cases "b = d", metis collSwap colliniearRight)
  apply (cut_tac a=a and b=b and c=c in onePointIsBetween)
    apply (auto simp add: colliniearRight)+
  apply (cut_tac a=a and b=b and c=d in onePointIsBetween)
    apply (auto simp add: colliniearRight)+
  apply (rule ccontr, subgoal_tac "signedArea a c d > 0 \<or> signedArea a c d < 0", safe, simp)
  apply (simp add: signedArea_def)
sorry
lemma collinearTransitiv3: "a \<noteq> b \<Longrightarrow> collinear a b c \<Longrightarrow> collinear a b d \<Longrightarrow> collinear b c d"
  by (smt collRotate collinearTransitiv)

lemma collinearTransitiv2: "b \<noteq> c \<Longrightarrow> collinear a b c \<Longrightarrow> collinear b c d \<Longrightarrow> collinear a b d"
  using collRotate collinearTransitiv by blast

lemma newLeftTurn: "\<lbrakk>A isBetween C D; leftTurn A B C \<rbrakk> \<Longrightarrow> leftTurn B C D" (*[2]*)
  apply (subgoal_tac "signedArea B C D \<noteq> 0")
  apply (simp add: isBetween_def, safe)
  apply (erule_tac x=B in allE, simp)
  apply (smt divide_nonneg_nonpos leftTurn_def notLeftTurn notRightTurn1)
  apply (auto simp add: isBetween_def)
  apply (case_tac "signedArea d C D \<noteq> 0", erule_tac x=d in allE, simp)
  apply (metis areaDoublePoint collinearTransitiv2 colliniearRight notRightTurn1 signedAreaRotate)
by blast

lemma newLeftTurn1: "\<lbrakk>A isBetween C D; leftTurn A B C \<rbrakk> \<Longrightarrow> leftTurn D B A" (*[1]*)
  apply (subgoal_tac "rightTurn C B D")
  apply (smt collinearTransitiv2 isBetweenPointsDistinct leftTurnRotate2 newLeftTurn notLeftTurn swapBetween)
  apply (subgoal_tac "signedArea C B D \<noteq> 0")
  apply (simp only: isBetween_def, safe)
  apply (erule_tac x=B in allE, simp)
  apply (smt colliniearRight divide_nonneg_nonpos notRightTurn rightTurn_def)
  apply (auto simp add: isBetween_def)
  apply (case_tac "signedArea d C D \<noteq> 0", erule_tac x=d in allE, simp)
  apply (metis areaDoublePoint collinearTransitiv2 colliniearRight notRightTurn1 signedAreaRotate)
by blast

lemma leftOrRightTurn: "c \<noteq> d \<Longrightarrow> leftFrom c d \<Longrightarrow> leftFrom a b \<Longrightarrow> rightTurn a b c \<Longrightarrow>
  rightTurn a b d \<Longrightarrow> leftFrom a d \<Longrightarrow> leftFrom c b\<Longrightarrow> leftTurn c d a \<or> leftTurn c d b"
oops

(*evtl. noch nützlich*)

(*lemma "a \<noteq> b \<Longrightarrow> \<exists> d c. leftTurn a b c \<and> leftTurn a b d \<and> signedArea a b c < signedArea a b d"
  apply (case_tac "xCoord a = xCoord b")
    apply (rule_tac x="Abs_point2d(xCoord b - 2, yCoord b)" in exI,
      rule_tac x="Abs_point2d(xCoord b - 1, yCoord b)" in exI)
oops*)

(*(*A point between B and C*)
(*definition midpoint :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
"midpoint a b c = (2 * yCoord a = yCoord b + yCoord c \<and> 2 * xCoord a = xCoord b + xCoord c)"*)
definition midpoint :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool"
  ("_ midpoint _ _ " [60, 60, 60] 60) where
  "d midpoint b c \<equiv> (signedArea d b c = 0 \<and> (\<forall> a. signedArea a b c = 2 * signedArea a b d))"
lemma midPointCollinear[simp]: "a midpoint b c \<Longrightarrow> collinear a b c"
  by (simp add: colliniearRight midpoint_def)
lemma midPointSym : "a midpoint b c = a midpoint c b"
  apply (auto simp add: midpoint_def)
by (metis collSwap colliniearRight notCollThenDiffPoints, smt hausner)+
lemma midpointNotSame1[dest]: "a \<noteq> b \<Longrightarrow> a midpoint a b \<Longrightarrow> False"
  by (simp add: midpoint_def pointsEqualArea)
lemma midpointNotSame[dest]: "b\<noteq>c \<Longrightarrow> a midpoint b c \<Longrightarrow> b midpoint a c \<Longrightarrow> False"
  apply (auto simp add: midpoint_def)
by (smt midPointSym midpointNotSame1 midpoint_def signedAreaMin)

lemma "(a midpoint b c) = (2 * yCoord a = yCoord b + yCoord c \<and> 2 * xCoord a = xCoord b + xCoord c)"
  apply (auto simp add: midpoint_def)
oops

lemma midpointPointExist: "\<exists> X. X midpoint a b"
  apply (case_tac "a=b", smt colliniearRight midpoint_def mult_zero_right notCollThenDiffPoints)
  apply (auto simp add: midpoint_def)
  apply (subgoal_tac "\<exists> d. signedArea a b d = 0", simp, erule_tac exE)
  apply (rule_tac x="d" in exI, auto)
oops*)

lemma CollPointExist: "\<exists> X. collinear A B X" by (rule_tac x=A in exI, auto)

(*lemma isBeetweenPointExist: "a \<noteq> b \<Longrightarrow> \<exists> X. X isBetween a b"
  apply (cut_tac a=a and b=b in midpointPointExist)
  apply (auto simp add: isBetween_def)
  apply (rule_tac x=X in exI)
  apply (safe)
  apply (simp add: pointsEqualArea)
  apply (simp add: pointsEqualArea)
  (*apply (subgoal_tac "collinear X a b")
    apply (case_tac "X = d", simp) using colliniearRight midPointCollinear apply blast
    apply (case_tac "X = a", simp, blast)
    apply (case_tac "X = b", simp)
    apply (case_tac "d = a", simp)
    apply (case_tac "d = b", simp)
    apply (case_tac "xCoord a = xCoord b", subgoal_tac "xCoord X = xCoord b")
      apply (case_tac "yCoord a < yCoord b", subgoal_tac "yCoord a < yCoord X \<and> yCoord X < yCoord b")
      apply (case_tac "signedArea d a b > 0")
      (*selbst hier kein Beweis*)*)
oops*)

(*definition segLength :: "point2d \<Rightarrow> point2d \<Rightarrow> real" where
  "segLength A B \<equiv> sqrt ((xCoord A - xCoord B)*(xCoord A - xCoord B) +
  (yCoord A - yCoord B)*(yCoord A - yCoord B))"
lemma segLengthSym: "segLength A B = segLength B A"
by (simp add: segLength_def, algebra)

definition quadArea :: "[point2d, point2d, point2d, point2d] \<Rightarrow> real" where
  "quadArea A B C D \<equiv> signedArea A B C + signedArea A C D"
lemma quadAreaSym: "quadArea A B C D = quadArea B C D A"
  by (auto simp add: quadArea_def signedArea_def, algebra)
lemma quadAreaSym1: "quadArea A B C D = quadArea C D A B"
  by (metis quadAreaSym)
lemma quadAreaSym2: "quadArea A B C D = quadArea D A B C"
  by (auto simp add: quadArea_def signedArea_def, algebra)*)

end