theory Syntax
  imports "Nominal2.Nominal2"
begin

atom_decl "var"
atom_decl "tyvar"

typedef data_name = "{ x. x \<in> (UNIV :: string set) }" by simp
typedef ctor_name = "{ x. x \<in> (UNIV :: string set) }" by simp

instantiation data_name :: pure
begin
  definition "p \<bullet> (x::data_name) = x"
  instance by (standard, auto simp: permute_data_name_def)
end
instantiation ctor_name :: pure
begin
  definition "p \<bullet> (x::ctor_name) = x"
  instance by (standard, auto simp: permute_ctor_name_def)
end

nominal_datatype "\<kappa>" =
  Star ("\<star>")
  | KArrow "\<kappa>" "\<kappa>" (infixr "\<rightarrow>" 50)

nominal_datatype "\<tau>" =
  TyVar "tyvar"
  | TyData "data_name"
  | TyArrow
  | TyApp "\<tau>" "\<tau>"
  | TyForall a::"tyvar" "\<kappa>" t::"\<tau>" binds a in t ("\<forall> _ : _ . _" 50)

abbreviation arrow_app :: "\<tau> \<Rightarrow> \<tau> \<Rightarrow> \<tau>" (infixr "\<rightarrow>" 50) where
  "arrow_app \<tau>1 \<tau>2 \<equiv> TyApp (TyApp TyArrow \<tau>1) \<tau>2"

nominal_datatype "term" =
   Var "var"
 | App "term" "term"
 | TApp "term" "\<tau>"
 | Ctor "ctor_name"
 | Lam x::"var" "\<tau>" e::"term" binds x in e  ("\<lambda> _ : _ . _" 50)
 | TyLam a::"tyvar" "\<kappa>" e::"term" binds a in e ("\<Lambda> _ : _ . _" 50)
 | Let x::"var" "\<tau>" "term" e2::"term" binds x in e2

nominal_datatype "binder" =
  BVar "var" "\<tau>"
  | BTyVar "tyvar" "\<kappa>"

nominal_datatype "axiom" =
  AxData "data_name" "\<kappa>"
  | AxCtor "ctor_name" "\<tau>"

type_synonym "\<Gamma>" = "binder list"
type_synonym "\<Delta>" = "axiom list"

declare pure_fresh[simp]

lemma no_vars_in_kinds[simp]: "atom (x :: var) \<sharp> (k :: \<kappa>)"
  by (induction k rule: \<kappa>.induct) auto
lemma no_vars_in_ty[simp]: "atom (x :: var) \<sharp> (ty :: \<tau>)"
  by (induction rule: \<tau>.induct) auto
lemma no_vars_in_axioms[simp]: "atom (x :: var) \<sharp> (\<Delta> :: \<Delta>)"
proof (induction \<Delta>)
  case (Cons a \<Delta>)
  then show ?case by (cases a rule: axiom.exhaust) (auto simp: fresh_Cons)
qed (rule fresh_Nil)

lemma perm_axioms_vars[simp]: "((a::var) \<leftrightarrow> b) \<bullet> (\<Delta>::\<Delta>) = \<Delta>"
  using flip_fresh_fresh by force
lemma perm_\<tau>_vars[simp]: "((a::var) \<leftrightarrow> b) \<bullet> (\<tau>::\<tau>) = \<tau>"
  using flip_fresh_fresh by force

lemma no_tyvars_in_kinds[simp]: "atom (a :: tyvar) \<sharp> (k :: \<kappa>)"
  by (induction k rule: \<kappa>.induct) auto

lemma supp_empty_kinds[simp]: "supp (k :: \<kappa>) = {}"
  by (induction k rule: \<kappa>.induct) (auto simp: \<kappa>.supp)

lemma perm_data_name_var[simp]: "((a::var) \<leftrightarrow> b) \<bullet> (T :: data_name) = T"
  using flip_fresh_fresh pure_fresh by blast
lemma perm_data_name_tyvar[simp]: "((a::tyvar) \<leftrightarrow> b) \<bullet> (T :: data_name) = T"
  using flip_fresh_fresh pure_fresh by blast
lemma perm_ctor_name_var[simp]: "((a::var) \<leftrightarrow> b) \<bullet> (D :: ctor_name) = D"
  using flip_fresh_fresh pure_fresh by blast
lemma perm_ctor_name_tyvar[simp]: "((a::tyvar) \<leftrightarrow> b) \<bullet> (D :: ctor_name) = D"
  using flip_fresh_fresh pure_fresh by blast

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section "Generic scanner"

theory MaxChop
imports MaxPrefix
begin

type_synonym 'a chopper = "'a list \<Rightarrow> 'a list list * 'a list"

definition
 is_maxchopper :: "('a list \<Rightarrow> bool) \<Rightarrow> 'a chopper \<Rightarrow> bool" where
"is_maxchopper P chopper =
 (\<forall>xs zs yss.
    (chopper(xs) = (yss,zs)) =
    (xs = concat yss @ zs \<and> (\<forall>ys \<in> set yss. ys \<noteq> []) \<and>
     (case yss of
        [] \<Rightarrow> is_maxpref P [] xs
      | us#uss \<Rightarrow> is_maxpref P us xs \<and> chopper(concat(uss)@zs) = (uss,zs))))"

definition
 reducing :: "'a splitter \<Rightarrow> bool" where
"reducing splitf =
 (\<forall>xs ys zs. splitf xs = (ys,zs) \<and> ys \<noteq> [] \<longrightarrow> length zs < length xs)"

function chop :: "'a splitter \<Rightarrow> 'a list \<Rightarrow> 'a list list \<times> 'a list" where
  [simp del]: "chop splitf xs = (if reducing splitf
                      then let pp = splitf xs
                           in if fst pp = [] then ([], xs)
                           else let qq = chop splitf (snd pp)
                                in (fst pp # fst qq, snd qq)
                      else undefined)"
by pat_completeness auto

termination apply (relation "measure (length \<circ> snd)")
apply (auto simp: reducing_def)
apply (case_tac "splitf xs")
apply auto
done

lemma chop_rule: "reducing splitf \<Longrightarrow>
  chop splitf xs = (let (pre, post) = splitf xs
                    in if pre = [] then ([], xs)
                       else let (xss, zs) = chop splitf post
                            in (pre # xss,zs))"
apply (simp add: chop.simps)
apply (simp add: Let_def split: prod.split)
done

lemma reducing_maxsplit: "reducing(\<lambda>qs. maxsplit P ([],qs) [] qs)"
by (simp add: reducing_def maxsplit_eq)

lemma is_maxsplitter_reducing:
 "is_maxsplitter P splitf \<Longrightarrow> reducing splitf"
by(simp add:is_maxsplitter_def reducing_def)

lemma chop_concat[rule_format]: "is_maxsplitter P splitf \<Longrightarrow>
  (\<forall>yss zs. chop splitf xs = (yss,zs) \<longrightarrow> xs = concat yss @ zs)"
apply (induct xs rule:length_induct)
apply (simp (no_asm_simp) split del: if_split
            add: chop_rule[OF is_maxsplitter_reducing])
apply (simp add: Let_def is_maxsplitter_def split: prod.split)
done

lemma chop_nonempty: "is_maxsplitter P splitf \<Longrightarrow>
  \<forall>yss zs. chop splitf xs = (yss,zs) \<longrightarrow> (\<forall>ys \<in> set yss. ys \<noteq> [])"
apply (induct xs rule:length_induct)
apply (simp (no_asm_simp) add: chop_rule is_maxsplitter_reducing)
apply (simp add: Let_def is_maxsplitter_def split: prod.split)
apply (intro allI impI)
apply (rule ballI)
apply (erule exE)
apply (erule allE)
apply auto
done

lemma is_maxchopper_chop:
 assumes prem: "is_maxsplitter P splitf" shows "is_maxchopper P (chop splitf)"
apply(unfold is_maxchopper_def)
apply clarify
apply (rule iffI)
 apply (rule conjI)
  apply (erule chop_concat[OF prem])
 apply (rule conjI)
  apply (erule prem[THEN chop_nonempty[THEN spec, THEN spec, THEN mp]])
 apply (erule rev_mp)
 apply (subst prem[THEN is_maxsplitter_reducing[THEN chop_rule]])
 apply (simp add: Let_def prem[simplified is_maxsplitter_def]
             split: prod.split)
 apply clarify
 apply (rule conjI)
  apply (clarify)
 apply (clarify)
 apply simp
 apply (frule chop_concat[OF prem])
 apply (clarify)
apply (subst prem[THEN is_maxsplitter_reducing, THEN chop_rule])
apply (simp add: Let_def prem[simplified is_maxsplitter_def]
             split: prod.split)
apply (clarify)
apply (rename_tac xs1 ys1 xss1 ys)
apply (simp split: list.split_asm)
 apply (simp add: is_maxpref_def)
 apply (blast intro: prefix_append[THEN iffD2])
apply (rule conjI)
 apply (clarify)
 apply (simp (no_asm_use) add: is_maxpref_def)
 apply (blast intro: prefix_append[THEN iffD2])
apply (clarify)
apply (rename_tac us uss)
apply (subgoal_tac "xs1=us")
 apply simp
apply simp
apply (simp (no_asm_use) add: is_maxpref_def)
apply (blast intro: prefix_append[THEN iffD2] prefix_order.antisym)
done

end


theory Lazy_lists
  imports Main
    Smap Siterate
begin
  codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "literate f x = LCons x (literate f (f x))"

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

primcorec llength :: "'a Llist \<Rightarrow> ENat" where
"llength xs = (if lnull xs then EZ else ESuc (llength (ltl xs)))"

primcorec ltake :: "ENat \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "is_zero n \<or> lnull xs \<Longrightarrow> lnull (ltake n xs)"
| "lhd (ltake n xs) = lhd xs"
| "ltl (ltake n xs) = ltake (epred n) (ltl xs)"

fun to_llist :: "'a list \<Rightarrow> 'a Llist" where
  "to_llist [] = LNil"
| "to_llist (Cons x xs) = LCons x (to_llist xs)"

primcorec llist_of_stream :: "'a Stream \<Rightarrow> 'a Llist"
  where "llist_of_stream s = LCons (shd s) (llist_of_stream (stl s))"

(*cohipster lappend *)
(*ca 25 seconds*)
(* lappend_LNil2 *)
lemma lemma_ac [thy_expl]: "lappend y LNil = y"
  by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    simp

lemma lemma_ad [thy_expl]: "lappend LNil y = y"
 by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    simp

lemma lemma_ae [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
 by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    (metis lappend.simps(4) lemma_ac lnull_def)

lemma lemma_af [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"

 by (simp add: lappend.code)
(* lappend_assoc *)
lemma lemma_ag [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    auto

lemma lemma_ah [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
 by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)
(*cohipster lmap *)
(* ca 5 seconds *)
lemma lemma_ai [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    simp

lemma lemma_aj [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    simp
(*cohipster lmap lappend *)
(*ca 80 seconds*)
lemma lemma_ak [thy_expl]: "ltl (lmap y z) = lmap y (ltl z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.case_eq_if Llist.collapse(2) Llist.inject lemma_aj lmap.disc_iff(2) lnull_def ltl_def)

lemma lemma_al [thy_expl]: "ltl (lappend z (lmap y z)) = lappend (ltl z) (lmap y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis lappend.simps(4) lemma_ac lmap.ctr(1))

lemma lemma_am [thy_expl]: "ltl (lappend (lmap y z) z) = lappend (lmap y (ltl z)) z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.sel(2) lappend.disc_iff(1) lappend.simps(4) lemma_ak lmap.disc_iff(2) lnull_def)

lemma lemma_an [thy_expl]: "ltl (lappend (lmap y z) (ltl z)) = lappend (lmap y (ltl z)) (ltl z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.sel(2) lappend.ctr(1) lappend.simps(4) lemma_ak lmap.ctr(1) lmap.disc_iff(2))

(*lmap_lappend_distrib*)
lemma lemma_ao [thy_expl]: "lappend (lmap y z) (lmap y x2) = lmap y (lappend z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.collapse(2) Llist.sel(1) lappend.disc_iff(1) lappend.simps(3) lappend.simps(4) lemma_aj lemma_ak lmap.disc_iff(2))
(*cohipster literate *)
(*Discovers nothing interesting - 3 seconds ish*)
(*cohipster llength *)
(* ca 4 seconds *)
(*llength_LCons*)
lemma lemma_ap [thy_expl]: "llength (LCons y z) = ESuc (llength z)"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    simp
(*cohipster lappend literate*)
(* 23 seconds *)
(* lappend_iterates *)
lemma lemma_aq [thy_expl]: "lappend (literate z x2) y = literate z x2"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    auto
(*cohipster llength lappend *)
(* 65 seconds *)
lemma lemma_ar [thy_expl]: "llength (lappend z (LCons y x2)) = ESuc (llength (lappend z x2))"
 by(coinduction arbitrary: x2 y z rule: ENat.coinduct_strong)
    (smt ENat.distinct(1) ENat.sel Llist.discI(2) Llist.sel(3) is_zero_def lappend.disc_iff(1) lappend.simps(4) llength.ctr(1) llength.ctr(2))

lemma lemma_as [thy_expl]: "llength (lappend z y) = llength (lappend y z)"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    (metis ENat.sel Lazy_lists.lemma_ar Llist.collapse(2) lappend.disc_iff(1) lappend.simps(4) llength.disc_iff(2) llength.sel)

lemma lemma_at [thy_expl]: "llength (ltl (lappend z y)) = llength (ltl (lappend y z))"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    (metis lemma_as llength.disc_iff(2) llength.sel lnull_def)
(*cohipster eplus *)
(* 85 seconds *)
lemma lemma_au [thy_expl]: "eplus x EZ = x"
 by(coinduction arbitrary: x rule: ENat.coinduct_strong)
    simp
(*178*)
lemma lemma_av [thy_expl]: "eplus EZ x = x"
 by(coinduction arbitrary: x rule: ENat.coinduct_strong)
    simp
(*iadd_Suc_right*)
lemma lemma_aw [thy_expl]: "ESuc (eplus x y) = eplus x (ESuc y)"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis ENat.distinct(1) ENat.sel eplus.code is_zero_def)
(*  eSuc_plus_1 *)
lemma lemma_ax [thy_expl]: "eplus x (ESuc EZ) = ESuc x"
 by(coinduction arbitrary: x rule: ENat.coinduct_strong)
    (metis lemma_au lemma_aw)

lemma lemma_ay [thy_expl]: "eplus y (ESuc x) = eplus x (ESuc y)"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis ENat.collapse(2) ENat.disc(2) eplus.sel lemma_au lemma_aw)
(*174*)
lemma lemma_az [thy_expl]: "eplus (eplus x y) z = eplus x (eplus y z)"
 by(coinduction arbitrary: x y z rule: ENat.coinduct_strong)
    auto

lemma lemma_ba [thy_expl]: "eplus y (ESuc (ESuc x)) = eplus x (ESuc (ESuc y))"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis lemma_aw lemma_ay)

lemma lemma_bb [thy_expl]: "epred (eplus x (ESuc y)) = eplus x y"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    auto
(*176*)
lemma lemma_bc [thy_expl]: "eplus y x = eplus x y"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis lemma_ay lemma_bb)

lemma lemma_bd [thy_expl]: "eplus y (eplus x z) = eplus x (eplus y z)"
proof(coinduction arbitrary: x y z rule: ENat.coinduct_strong)
  case Eq_ENat thus ?case
    using lemma_az lemma_bc
    by (force simp add: lemma_az lemma_bc)
qed

(*cohipster llength lappend eplus *)
(* 30 seconds *)
(*llength_lappend*)
lemma lemma_be [thy_expl]: "eplus (llength y) (llength z) = llength (lappend y z)"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    auto

lemma lemma_bf [thy_expl]: "eplus (ESuc (llength y)) (llength z) = ESuc (llength (lappend y z))"
proof(coinduction arbitrary: y z rule: ENat.coinduct_strong)
  case Eq_ENat thus ?case
    using lemma_be
    by (force simp add: lemma_be)
qed

(*cohipster llength lmap*)
(* 18 seconds *)
(* llength_lmap *)
lemma lemma_bg [thy_expl]: "llength (lmap y z) = llength z"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    (metis lemma_ak llength.disc_iff(2) llength.sel lmap.disc_iff(2))

(*cohipster ltake *)
(* ca 80 seconds *)
lemma lemma_bh [thy_expl]: "ltake y (ltake y z) = ltake y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    auto
(*ltake_ltl*)
lemma lemma_bi [thy_expl]: "ltl (ltake (ESuc y) z) = ltake y (ltl z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis ENat.disc(2) ENat.sel Llist.sel(2) lnull_def ltake.disc(1) ltake.simps(4))

lemma lemma_bj [thy_expl]: "ltake z (ltake y x2) = ltake y (ltake z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    auto

lemma lemma_bk [thy_expl]: "ltake y (ltake (ESuc y) z) = ltake y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt ENat.collapse(2) ENat.disc(2) lemma_bi ltake.disc_iff(2) ltake.simps(3))

lemma lemma_bl [thy_expl]: "ltake y (ltl (ltake y z)) = ltl (ltake y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.sel(2) ltake.ctr(1) ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))
(*ltake_eSuc_LCons*)
lemma lemma_bm [thy_expl]: "ltake (ESuc z) (LCons y x2) = LCons y (ltake z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    simp

lemma lemma_bn [thy_expl]: "ltake y (LCons z (ltake y x2)) = ltake y (LCons z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.disc(2) Llist.sel(1) Llist.sel(3) lemma_bj lemma_bl ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))

lemma lemma_bo [thy_expl]: "ltake (ESuc y) (ltl (ltake y z)) = ltl (ltake y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis lemma_bi lemma_bl)

lemma lemma_bp [thy_expl]: "ltake (ESuc (ESuc y)) (ltake y z) = ltake y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis ENat.disc(2) lemma_bi lemma_bo ltake.disc_iff(2) ltake.simps(3))

lemma lemma_bq [thy_expl]: "ltake (ESuc EZ) (ltake (ESuc y) z) = ltake (ESuc EZ) z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (simp add: ltake.ctr(1))
(*cohipster ltake lmap*)
(* 32 seconds *)
(* ltake_lmap *)
lemma lemma_br [thy_expl]: "ltake z (lmap y x2) = lmap y (ltake z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt ENat.collapse(2) Llist.case_eq_if Llist.sel(1) lemma_ak lemma_bi lmap.disc_iff(2) lmap.sel(1) ltake.ctr(2) ltake.disc_iff(2))

(*cohipster llist_of_stream *)
(* 5 seconds *)
lemma lemma_bw [thy_expl]: "llist_of_stream (SCons y z) = LCons y (llist_of_stream z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    simp
(*cohipster llist_of_stream smap lmap *)
(* 41 seconds *)
lemma lemma_bx [thy_expl]: "llist_of_stream (smap y z) = lmap y (llist_of_stream z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.case_eq_if lemma_ak llist_of_stream.disc_iff llist_of_stream.simps(2) llist_of_stream.simps(3) lmap.disc_iff(2) lmap.sel(1) smap.simps(1) smap.simps(2))
(*cohipster llist_of_stream literate siterate *)
(* 23 seconds *)
lemma lemma_by [thy_expl]: "llist_of_stream (siterate y z) = literate y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    auto
(*cohipster lmap literate *)
(* 45 seconds *)
lemma lemma_bz [thy_expl]: "lmap z (LCons y (literate z x2)) = LCons (z y) (literate z (z x2))"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.distinct(1) Llist.sel(1) Llist.sel(3) lemma_aj literate.code lnull_def)
(* lmap_iterates *)
lemma lemma_ca [thy_expl]: "lmap y (literate y z) = literate y (y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis lemma_bz literate.code)

(*cohipster to_llist lappend append *)
(* 80 seconds *)
(* lappend_llist_of_llist_of *)
lemma lemma_cb [thy_expl]: "lappend (to_llist y) (to_llist z) = to_llist (y @ z)"
apply (induct y arbitrary: z)
apply (simp add: lemma_ad)
apply (simp add: lappend.code)
  done
(*cohipster to_llist lmap map *)
(* 65 seconds *)
(*lmap_llist_of*)
lemma lemma_cc [thy_expl]: "to_llist (map y z) = lmap y (to_llist z)"
apply (induct z)
apply (simp add: lmap.ctr(1))
apply (simp add: lemma_aj)
  done
end


(*
    File:     General_Auxiliary.thy
    Author:   Joseph Thommes, TU München; Manuel Eberl, TU München
*)
section \<open>Auxiliary lemmas\<close>

theory General_Auxiliary
  imports Complex_Main
          "HOL-Algebra.IntRing"
          "HOL.Rings"
begin

lemma inter_imp_subset: "A \<inter> B = A \<Longrightarrow> A \<subseteq> B"
  by blast

lemma card_inter_eq:
  assumes "finite A" "card (A \<inter> B) = card A"
  shows "A \<subseteq> B"
proof -
  have "A \<inter> B \<subseteq> A" by blast
  with assms have "A \<inter> B = A" using card_subset_eq by blast
  thus ?thesis by blast
qed

lemma coprime_eq_empty_prime_inter:
  assumes "(n::nat) \<noteq> 0" "m \<noteq> 0"
  shows "coprime n m \<longleftrightarrow> (prime_factors n) \<inter> (prime_factors m) = {}"
proof
  show "coprime n m \<Longrightarrow> prime_factors n \<inter> prime_factors m = {}"
  proof (rule ccontr)
    assume cp: "coprime n m"
    assume pf: "prime_factors n \<inter> prime_factors m \<noteq> {}"
    then obtain p where p: "p \<in> prime_factors n" "p \<in> prime_factors m" by blast
    then have p_dvd: "p dvd n" "p dvd m" by blast+
    moreover have "\<not>is_unit p" using p using not_prime_unit by blast
    ultimately show "False" using cp unfolding coprime_def by simp
  qed
  assume assm: "prime_factors n \<inter> prime_factors m = {}"
  show "coprime n m" unfolding coprime_def
  proof
    fix c
    show "c dvd n \<longrightarrow> c dvd m \<longrightarrow> is_unit c"
    proof(rule; rule)
      assume c: "c dvd n" "c dvd m"
      then have "prime_factors c \<subseteq> prime_factors n" "prime_factors c \<subseteq> prime_factors m"
        using assms dvd_prime_factors by blast+
      then have "prime_factors c = {}" using assm by blast
      thus "is_unit c" using assms c
        by (metis dvd_0_left_iff prime_factorization_empty_iff set_mset_eq_empty_iff)
    qed
  qed
qed

lemma prime_factors_Prod:
  assumes "finite S" "\<And>a. a \<in> S \<Longrightarrow> f a \<noteq> 0"
  shows "prime_factors (prod f S) = \<Union>(prime_factors ` f ` S)"
  using assms
proof(induction S rule: finite_induct)
  case empty
  then show ?case by simp
next
  case i: (insert x F)
  from i have x: "f x \<noteq> 0" by blast
  from i have F: "prod f F \<noteq> 0" by simp
  from i have "prime_factors(prod f F) = \<Union> (prime_factors ` f ` F)" by blast
  moreover have "prod f (insert x F) = (prod f F) * f x" using i mult.commute by force
  ultimately
  have "prime_factors (prod f (insert x F)) = (\<Union>(prime_factors ` f ` F)) \<union> prime_factors (f x)"
    using prime_factors_product[OF F x] by argo
  thus ?case by force
qed

lemma lcm_is_Min_multiple_nat:
  assumes "c \<noteq> 0" "(a::nat) dvd c" "(b::nat) dvd c"
  shows "c \<ge> lcm a b"
  using lcm_least[of a c b] assms by fastforce

lemma diff_prime_power_imp_coprime:
  assumes "p \<noteq> q" "Factorial_Ring.prime (p::nat)" "Factorial_Ring.prime q"
  shows "coprime (p ^ (n::nat)) (q ^ m)"
  using assms
  by (metis power_0 power_one_right prime_dvd_power prime_imp_power_coprime_nat
            prime_nat_iff prime_power_inj'')

lemma "finite (prime_factors x)"
  using finite_set_mset by blast

lemma card_ge_1_two_diff:
  assumes "card A > 1"
  obtains x y where "x \<in> A" "y \<in> A" "x \<noteq> y"
proof -
  have fA: "finite A" using assms by (metis card.infinite not_one_less_zero)
  from assms obtain x where x: "x \<in> A" by fastforce
  with assms fA have "card (A - {x}) > 0" by simp
  then obtain y where y: "y \<in> (A - {x})" by (metis card_gt_0_iff ex_in_conv)
  thus ?thesis using that[of x y] x by blast
qed

lemma infinite_two_diff:
  assumes "infinite A"
  obtains x y where "x \<in> A" "y \<in> A" "x \<noteq> y"
proof -
  from assms obtain x where x: "x \<in> A" by fastforce
  from assms have "infinite (A - {x})" by simp
  then obtain y where y: "y \<in> (A - {x})"
    by (metis ex_in_conv finite.emptyI)
  show ?thesis using that[of x y] using x y by blast
qed

lemma Inf_le:
  "Inf A \<le> x" if "x \<in> (A::nat set)" for x
proof (cases "A = {}")
  case True
  then show ?thesis using that by simp
next
  case False
  hence "Inf A \<le> Inf {x}" using that by (simp add: cInf_lower)
  also have "\<dots> = x" by simp
  finally show "Inf A \<le> x" by blast
qed

lemma switch_elem_card_le:
  assumes "a \<in> A"
  shows "card (A - {a} \<union> {b}) \<le> card A"
  using assms
  by (metis Diff_insert_absorb Set.set_insert Un_commute card.infinite card_insert_disjoint
            card_mono finite_insert insert_is_Un insert_subset order_refl)

lemma pairwise_coprime_dvd:
  assumes "finite A" "pairwise coprime A" "(n::nat) = prod id A" "\<forall>a\<in>A. a dvd j"
  shows "n dvd j"
  using assms
proof (induction A arbitrary: n)
  case i: (insert x F)
  have "prod id F dvd j" "x dvd j" using i unfolding pairwise_def by auto
  moreover have "coprime (prod id F) x"
    by (metis i(2, 4) id_apply pairwise_insert prod_coprime_left)
  ultimately show ?case using i(1, 2, 5) by (simp add: coprime_commute divides_mult)
qed simp

lemma pairwise_coprime_dvd':
  assumes "finite A" "\<And>i j. \<lbrakk>i \<in> A; j \<in> A; i \<noteq> j\<rbrakk> \<Longrightarrow> coprime (f i) (f j)"
          "(n::nat) = prod f A" "\<forall>a\<in>A. f a dvd j"
  shows "n dvd j"
  using assms
proof (induction A arbitrary: n)
  case i: (insert x F)
  have "prod f F dvd j" "f x dvd j" using i unfolding pairwise_def by auto
  moreover have "coprime (prod f F) (f x)" by(intro prod_coprime_left, use i in blast)
  ultimately show ?case using i by (simp add: coprime_commute divides_mult)
qed simp

lemma transp_successively_remove1:
  assumes "transp f" "successively f l"
  shows "successively f (remove1 a l)" using assms(2)
proof(induction l rule: induct_list012)
  case (3 x y zs)
  from 3(3)[unfolded successively.simps] have fs: "f x y" "successively f (y # zs)" by auto
  moreover from this(2) successively.simps have s: "successively f zs" by(cases zs, auto)
  ultimately have s2: "successively f (remove1 a zs)" "successively f (remove1 a (y # zs))"
    using 3 by auto
  consider (x) "x = a" | (y) "y = a \<and> x \<noteq> a" | (zs) "a \<noteq> x \<and> a \<noteq> y" by blast
  thus ?case
  proof (cases)
    case x
    then show ?thesis using 3 by simp
  next
    case y
    then show ?thesis
    proof (cases zs)
      case Nil
      then show ?thesis using fs by simp
    next
      case (Cons a list)
      hence "f y a" using fs by simp
      hence "f x a" using fs(1) assms(1)[unfolded transp_def] by blast
      then show ?thesis using Cons y s by auto
    qed
  next
    case zs
    then show ?thesis using s2 fs by auto
  qed
qed auto

lemma exp_one_2pi_iff:
  fixes x::real shows "exp (2 * of_real pi * \<i> * x) = 1 \<longleftrightarrow> x \<in> \<int>"
proof -
  have c: "cis (2 * x * pi) = 1 \<longleftrightarrow> x \<in> \<int>"
    by (auto simp: complex_eq_iff sin_times_pi_eq_0 cos_one_2pi_int, meson Ints_cases)
  have "exp (2 * of_real pi * \<i> * x) = exp (\<i> * complex_of_real (2 * x * pi))"
  proof -
    have "2 * of_real pi * \<i> * x = \<i> * complex_of_real (2 * x * pi)" by simp
    thus ?thesis by argo
  qed
  also from cis_conv_exp have "\<dots> = cis (2 * x * pi)" by simp
  finally show ?thesis using c by simp
qed

(* Manuel Eberl *)
lemma of_int_divide_in_Ints_iff:
  assumes "b \<noteq> 0"
  shows   "(of_int a / of_int b :: 'a :: field_char_0) \<in> \<int> \<longleftrightarrow> b dvd a"
proof
  assume *: "(of_int a / of_int b :: 'a :: field_char_0) \<in> \<int>"
  from * obtain n where "of_int a / of_int b = (of_int n :: 'a)"
    by (elim Ints_cases)
  hence "of_int (b * n) = (of_int a :: 'a)"
    using assms by (subst of_int_mult) (auto simp: field_simps)
  hence "b * n = a"
    by (subst (asm) of_int_eq_iff)
  thus "b dvd a" by auto
qed auto

(* Manuel Eberl *)
lemma of_nat_divide_in_Ints_iff:
  assumes "b \<noteq> 0"
  shows   "(of_nat a / of_nat b :: 'a :: field_char_0) \<in> \<int> \<longleftrightarrow> b dvd a"
  using of_int_divide_in_Ints_iff[of "int b" "int a"] assms by simp

lemma true_nth_unity_root:
  fixes n::nat
  obtains x::complex where "x ^ n = 1" "\<And>m. \<lbrakk>0<m; m<n\<rbrakk> \<Longrightarrow> x ^ m \<noteq> 1"
proof(cases "n = 0")
  case False
  show ?thesis
  proof (rule that)
    show "cis (2 * pi / n) ^ n = 1"
      by (simp add: DeMoivre)
  next
    fix m assume m: "m > 0" "m < n"
    have "cis (2 * pi / n) ^ m = cis (2 * pi * m / n)"
      by (simp add: DeMoivre algebra_simps)
    also have "\<dots> = 1 \<longleftrightarrow> real m / real n \<in> \<int>"
      using exp_one_2pi_iff[of "m / n"] by (simp add: cis_conv_exp algebra_simps)
    also have "\<dots> \<longleftrightarrow> n dvd m"
      using m by (subst of_nat_divide_in_Ints_iff) auto
    also have "\<not>n dvd m"
      using m by auto
    finally show "cis (2 * pi / real n) ^ m \<noteq> 1" .
  qed
qed simp

lemma finite_bij_betwI:
  assumes "finite A" "finite B" "inj_on f A" "f \<in> A \<rightarrow> B" "card A = card B"
  shows "bij_betw f A B"
proof (intro bij_betw_imageI)
  show "inj_on f A" by fact
  show "f ` A = B"
  proof -
    have "card (f ` A) = card B" using assms by (simp add: card_image)
    moreover have "f ` A \<subseteq> B" using assms by blast
    ultimately show ?thesis using assms by (meson card_subset_eq)
  qed
qed

lemma powi_mod:
  "x powi m = x powi (m mod n)" if "x ^ n = 1" "n > 0" for x::complex and m::int
proof -
  have xnz: "x \<noteq> 0" using that by (metis zero_neq_one zero_power)
  obtain k::int where k: "m = k*n + (m mod n)" using div_mod_decomp_int by blast
  have "x powi m = x powi (k*n) * x powi (m mod n)" by (subst k, intro power_int_add, use xnz in auto)
  moreover have "x powi (k*n) = 1" using that
    by (metis mult.commute power_int_1_left power_int_mult power_int_of_nat)
  ultimately show ?thesis by force
qed

(* Manuel Eberl *)
lemma Sigma_insert: "Sigma (insert x A) B = (\<lambda>y. (x, y)) ` B x \<union> Sigma A B"
  by auto

end


chapter \<open>DBMs as Constraint Systems\<close>
theory DBM_Constraint_Systems
  imports
    DBM_Operations
    DBM_Normalization
begin

section \<open>Misc\<close>

lemma Max_le_MinI:
  assumes "finite S" "finite T" "S \<noteq> {}" "T \<noteq> {}" "\<And>x y. x \<in> S \<Longrightarrow> y \<in> T \<Longrightarrow> x \<le> y"
  shows "Max S \<le> Min T" by (simp add: assms)

lemma Min_insert_cases:
  assumes "x = Min (insert a S)" "finite S"
  obtains (default) "x = a" | (elem) "x \<in> S"
  by (metis Min_in assms finite.insertI insertE insert_not_empty)

lemma cval_add_simp[simp]:
  "(u \<oplus> d) x = u x + d"
  unfolding cval_add_def by simp

lemmas [simp] = any_le_inf

lemma Le_in_between:
  assumes "a < b"
  obtains d where "a \<le> Le d" "Le d \<le> b"
  using assms by atomize_elim (cases a; cases b; auto)

lemma DBMEntry_le_to_sum:
  fixes e e' :: "'t :: time DBMEntry"
  assumes "e' \<noteq> \<infinity>" "e \<le> e'"
  shows "- e' + e \<le> 0"
  using assms by (cases e; cases e') (auto simp: DBM.neutral DBM.add uminus)

lemma DBMEntry_le_add:
  fixes a b c :: "'t :: time DBMEntry"
  assumes "a \<le> b + c" "c \<noteq> \<infinity>"
  shows "-c + a \<le> b"
  using assms
  by (cases a; cases b; cases c) (auto simp: DBM.neutral DBM.add uminus algebra_simps)

lemma DBM_triv_emptyI:
  assumes "M 0 0 < 0"
  shows "[M]\<^bsub>v,n\<^esub> = {}"
  using assms
  unfolding DBM_zone_repr_def DBM_val_bounded_def DBM.less_eq[symmetric] DBM.neutral by auto

section \<open>Definition and Semantics of Constraint Systems\<close>
datatype ('x, 'v) constr =
  Lower 'x "'v DBMEntry" | Upper 'x "'v DBMEntry" | Diff 'x 'x "'v DBMEntry"

type_synonym ('x, 'v) cs = "('x, 'v) constr set"

inductive entry_sem ("_ \<Turnstile>\<^sub>e _" [62, 62] 62) where
  "v \<Turnstile>\<^sub>e Lt x" if "v < x" |
  "v \<Turnstile>\<^sub>e Le x" if "v \<le> x" |
  "v \<Turnstile>\<^sub>e \<infinity>"

inductive constr_sem ("_ \<Turnstile>\<^sub>c _" [62, 62] 62) where
  "u \<Turnstile>\<^sub>c Lower x e" if "- u x \<Turnstile>\<^sub>e e" |
  "u \<Turnstile>\<^sub>c Upper x e" if   "u x \<Turnstile>\<^sub>e e" |
  "u \<Turnstile>\<^sub>c Diff x y e" if "u x - u y \<Turnstile>\<^sub>e e"

definition cs_sem ("_ \<Turnstile>\<^sub>c\<^sub>s _" [62, 62] 62) where
  "u \<Turnstile>\<^sub>c\<^sub>s cs \<longleftrightarrow> (\<forall>c \<in> cs. u \<Turnstile>\<^sub>c c)"

definition cs_models ("_ \<Turnstile> _" [62, 62] 62) where
  "cs \<Turnstile> c \<equiv> \<forall>u. u \<Turnstile>\<^sub>c\<^sub>s cs \<longrightarrow> u \<Turnstile>\<^sub>c c"

definition cs_equiv ("_ \<equiv>\<^sub>c\<^sub>s _" [62, 62] 62) where
  "cs \<equiv>\<^sub>c\<^sub>s cs' \<equiv> \<forall>u. u \<Turnstile>\<^sub>c\<^sub>s cs \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s cs'"

definition
  "closure cs \<equiv> {c. cs \<Turnstile> c}"

definition
  "bot_cs = {Lower undefined (Lt 0), Upper undefined (Lt 0)}"

lemma constr_sem_less_eq_iff:
  "u \<Turnstile>\<^sub>c Lower x e \<longleftrightarrow> Le (-u x) \<le> e"
  "u \<Turnstile>\<^sub>c Upper x e \<longleftrightarrow> Le (u x) \<le> e"
  "u \<Turnstile>\<^sub>c Diff x y e \<longleftrightarrow> Le (u x - u y) \<le> e"
  by (cases e; auto simp: constr_sem.simps entry_sem.simps)+

lemma constr_sem_mono:
  assumes "e \<le> e'"
  shows
    "u \<Turnstile>\<^sub>c Lower x e  \<Longrightarrow> u \<Turnstile>\<^sub>c Lower x e'"
    "u \<Turnstile>\<^sub>c Upper x e  \<Longrightarrow> u \<Turnstile>\<^sub>c Upper x e'"
    "u \<Turnstile>\<^sub>c Diff x y e \<Longrightarrow> u \<Turnstile>\<^sub>c Diff x y e'"
  using assms unfolding constr_sem_less_eq_iff by simp+

lemma constr_sem_triv[simp,intro]:
  "u \<Turnstile>\<^sub>c Upper x \<infinity>" "u \<Turnstile>\<^sub>c Lower y \<infinity>" "u \<Turnstile>\<^sub>c Diff x y \<infinity>"
  unfolding constr_sem.simps entry_sem.simps by auto

lemma cs_sem_antimono:
  assumes "cs \<subseteq> cs'" "u \<Turnstile>\<^sub>c\<^sub>s cs'"
  shows "u \<Turnstile>\<^sub>c\<^sub>s cs"
  using assms unfolding cs_sem_def by auto

lemma cs_equivD[intro, dest]:
  assumes "u \<Turnstile>\<^sub>c\<^sub>s cs" "cs \<equiv>\<^sub>c\<^sub>s cs'"
  shows "u \<Turnstile>\<^sub>c\<^sub>s cs'"
  using assms unfolding cs_equiv_def by auto

lemma cs_equiv_sym:
  "cs \<equiv>\<^sub>c\<^sub>s cs'" if "cs' \<equiv>\<^sub>c\<^sub>s cs"
  using that unfolding cs_equiv_def by fast

lemma cs_equiv_union:
  "cs \<equiv>\<^sub>c\<^sub>s cs \<union> cs'" if "cs \<equiv>\<^sub>c\<^sub>s cs'"
  using that unfolding cs_equiv_def cs_sem_def by blast

lemma cs_equiv_alt_def:
  "cs \<equiv>\<^sub>c\<^sub>s cs' \<longleftrightarrow> (\<forall>c. cs \<Turnstile> c \<longleftrightarrow> cs' \<Turnstile> c)"
  unfolding cs_equiv_def cs_models_def cs_sem_def by auto

lemma closure_equiv:
  "closure cs \<equiv>\<^sub>c\<^sub>s cs"
  unfolding cs_equiv_alt_def closure_def cs_models_def cs_sem_def by auto

lemma closure_superset:
  "cs \<subseteq> closure cs"
  unfolding closure_def cs_models_def cs_sem_def by auto

lemma bot_cs_empty:
  "\<not> (u :: ('c \<Rightarrow> 't :: linordered_ab_group_add)) \<Turnstile>\<^sub>c\<^sub>s bot_cs"
  unfolding bot_cs_def cs_sem_def by (auto elim!: constr_sem.cases entry_sem.cases)

lemma finite_bot_cs:
  "finite bot_cs"
  unfolding bot_cs_def by auto

definition cs_vars where
  "cs_vars cs = \<Union> (set1_constr ` cs)"

definition map_cs_vars where
  "map_cs_vars v cs = map_constr v id ` cs"

lemma constr_sem_rename_vars:
  assumes "inj_on v S" "set1_constr c \<subseteq> S"
  shows "(u o inv_into S v) \<Turnstile>\<^sub>c map_constr v id c \<longleftrightarrow> u \<Turnstile>\<^sub>c c"
  using assms
  by (cases c) (auto intro!: constr_sem.intros elim!: constr_sem.cases simp: DBMEntry.map_id)

lemma cs_sem_rename_vars:
  assumes "inj_on v (cs_vars cs)"
  shows "(u o inv_into (cs_vars cs) v) \<Turnstile>\<^sub>c\<^sub>s map_cs_vars v cs \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s cs"
  using assms constr_sem_rename_vars unfolding map_cs_vars_def cs_sem_def cs_vars_def by blast

section \<open>Conversion of DBMs to Constraint Systems and Back\<close>

definition dbm_to_cs :: "nat \<Rightarrow> ('x \<Rightarrow> nat) \<Rightarrow> ('v :: {linorder,zero}) DBM \<Rightarrow> ('x, 'v) cs" where
  "dbm_to_cs n v M \<equiv> if M 0 0 < 0 then bot_cs else
    {Lower x (M 0 (v x)) | x. v x \<le> n} \<union>
    {Upper x (M (v x) 0) | x. v x \<le> n} \<union>
    {Diff x y (M (v x) (v y)) | x y. v x \<le> n \<and> v y \<le> n}"

lemma dbm_entry_val_Lower_iff:
  "dbm_entry_val u None (Some x) e \<longleftrightarrow> u \<Turnstile>\<^sub>c Lower x e"
  by (cases e) (auto simp: constr_sem_less_eq_iff)

lemma dbm_entry_val_Upper_iff:
  "dbm_entry_val u (Some x) None e \<longleftrightarrow> u \<Turnstile>\<^sub>c Upper x e"
  by (cases e) (auto simp: constr_sem_less_eq_iff)

lemma dbm_entry_val_Diff_iff:
  "dbm_entry_val u (Some x) (Some y) e \<longleftrightarrow> u \<Turnstile>\<^sub>c Diff x y e"
  by (cases e) (auto simp: constr_sem_less_eq_iff)

lemmas dbm_entry_val_constr_sem_iff =
  dbm_entry_val_Lower_iff
  dbm_entry_val_Upper_iff
  dbm_entry_val_Diff_iff

theorem dbm_to_cs_correct:
  "u \<turnstile>\<^bsub>v,n\<^esub> M \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s dbm_to_cs n v M"
  apply (rule iffI)
  unfolding DBM_val_bounded_def dbm_entry_val_constr_sem_iff dbm_to_cs_def
  subgoal
    by (auto simp: DBM.neutral DBM.less_eq[symmetric] cs_sem_def)
  using bot_cs_empty by (cases "M 0 0 < 0", auto simp: DBM.neutral DBM.less_eq[symmetric] cs_sem_def)

definition
  "cs_to_dbm v cs \<equiv> if (\<forall>u. \<not>u \<Turnstile>\<^sub>c\<^sub>s cs) then (\<lambda>_ _. Lt 0) else (
    \<lambda>i j.
      if i = 0 then
        if j = 0 then
          Le 0
        else
          Min (insert \<infinity> {e. \<exists>x. Lower x e \<in> cs \<and> v x = j})
      else
        if j = 0 then
          Min (insert \<infinity> {e. \<exists>x. Upper x e \<in> cs \<and> v x = i})
        else
          Min (insert \<infinity> {e. \<exists>x y. Diff x y e \<in> cs \<and> v x = i \<and> v y = j})
  )"

lemma finite_dbm_to_cs:
  assumes "finite {x. v x \<le> n}"
  shows "finite (dbm_to_cs n v M)"
  using [[simproc add: finite_Collect]] unfolding dbm_to_cs_def
  by (auto intro: assms simp: finite_bot_cs)

lemma empty_dbm_empty:
  "u \<turnstile>\<^bsub>v,n\<^esub> \<lambda>_ _. Lt 0 \<longleftrightarrow> False"
  unfolding DBM_val_bounded_def by (auto simp: DBM.less_eq[symmetric])

fun expr_of_constr where
  "expr_of_constr (Lower _ e) = e" |
  "expr_of_constr (Upper _ e) = e" |
  "expr_of_constr (Diff _ _ e) = e"

lemma cs_to_dbm1:
  assumes "\<forall>x \<in> cs_vars cs. v x > 0 \<and> v x \<le> n" "finite cs"
  assumes "u \<turnstile>\<^bsub>v,n\<^esub> cs_to_dbm v cs"
  shows "u \<Turnstile>\<^sub>c\<^sub>s cs"
proof (cases "\<forall>u. \<not>u \<Turnstile>\<^sub>c\<^sub>s cs")
  case True
  with assms(3) show ?thesis
    unfolding cs_to_dbm_def by (simp add: empty_dbm_empty)
next
  case False
  show "u \<Turnstile>\<^sub>c\<^sub>s cs"
    unfolding cs_sem_def
  proof (rule ballI)
    fix c
    assume "c \<in> cs"
    show "u \<Turnstile>\<^sub>c c"
    proof (cases c)
      case (Lower x e)
      with assms(1) \<open>c \<in> cs\<close> have *: "0 < v x" "v x \<le> n"
        by (auto simp: cs_vars_def)
      let ?S = "{e. \<exists>x'. Lower x' e \<in> cs \<and> v x' = v x}"
      let ?e = "Min (insert \<infinity> ?S)"
      have "?S \<subseteq> expr_of_constr ` cs"
        by force
      with \<open>finite cs\<close> \<open>c \<in> cs\<close> \<open>c = _\<close> have "?e \<le> e"
        using finite_subset finite_imageI by (blast intro: Min_le)
      moreover from * assms(3) False have "dbm_entry_val u None (Some x) ?e"
        unfolding DBM_val_bounded_def cs_to_dbm_def by (auto 4 4)
      ultimately have "dbm_entry_val u None (Some x) (e)"
        by - (rule dbm_entry_val_mono[folded DBM.less_eq])
      then show ?thesis
        unfolding dbm_entry_val_constr_sem_iff[symmetric] \<open>c = _\<close> .
    next
      case (Upper x e)
      with assms(1) \<open>c \<in> cs\<close> have *: "0 < v x" "v x \<le> n"
        by (auto simp: cs_vars_def)
      let ?S = "{e. \<exists>x'. Upper x' e \<in> cs \<and> v x' = v x}"
      let ?e = "Min (insert \<infinity> ?S)"
      have "?S \<subseteq> expr_of_constr ` cs"
        by force
      with \<open>finite cs\<close> \<open>c \<in> cs\<close> \<open>c = _\<close> have "?e \<le> e"
        using finite_subset finite_imageI by (blast intro: Min_le)
      moreover from * assms(3) False have "dbm_entry_val u (Some x) None ?e"
        unfolding DBM_val_bounded_def cs_to_dbm_def by (auto 4 4)
      ultimately have "dbm_entry_val u (Some x) None e"
        by - (rule dbm_entry_val_mono[folded DBM.less_eq])
      then show ?thesis
        unfolding dbm_entry_val_constr_sem_iff \<open>c = _\<close> .
    next
      case (Diff x y e)
      with assms(1) \<open>c \<in> cs\<close> have *: "0 < v x" "v x \<le> n" "0 < v y" "v y \<le> n"
        by (auto simp: cs_vars_def)
      let ?S = "{e. \<exists>x' y'. Diff x' y' e \<in> cs \<and> v x' = v x \<and> v y' = v y}"
      let ?e = "Min (insert \<infinity> ?S)"
      have "?S \<subseteq> expr_of_constr ` cs"
        by force
      with \<open>finite cs\<close> \<open>c \<in> cs\<close> \<open>c = _\<close> have "?e \<le> e"
        using finite_subset finite_imageI by (blast intro: Min_le)
      moreover from * assms(3) False have "dbm_entry_val u (Some x) (Some y) ?e"
        unfolding DBM_val_bounded_def cs_to_dbm_def by (auto 4 4)
      ultimately have "dbm_entry_val u (Some x) (Some y) e"
        by - (rule dbm_entry_val_mono[folded DBM.less_eq])
      then show ?thesis
        unfolding dbm_entry_val_constr_sem_iff \<open>c = _\<close> .
    qed
  qed
qed

lemma cs_to_dbm2:
  assumes "\<forall>x. v x \<le> n \<longrightarrow> v x > 0" "\<forall>x y. v x \<le> n \<and> v y \<le> n \<and> v x = v y \<longrightarrow> x = y"
  assumes "finite cs"
  assumes "u \<Turnstile>\<^sub>c\<^sub>s cs"
  shows "u \<turnstile>\<^bsub>v,n\<^esub> cs_to_dbm v cs"
proof (cases "\<forall>u. \<not>u \<Turnstile>\<^sub>c\<^sub>s cs")
  case True
  with assms show ?thesis
    unfolding cs_to_dbm_def by (simp add: empty_dbm_empty)
next
  case False
  let ?M = "cs_to_dbm v cs"
  show "u \<turnstile>\<^bsub>v,n\<^esub> cs_to_dbm v cs"
    unfolding DBM_val_bounded_def
  proof (clarsimp simp: DBM.less_eq [symmetric] ; safe)
    show "Le 0 \<le> cs_to_dbm v cs 0 0"
      using False unfolding cs_to_dbm_def by auto
  next
    fix x :: 'a
    assume "v x \<le> n"
    let ?S = "{e. \<exists>x'. Lower x' e \<in> cs \<and> v x' = v x}"
    from \<open>v x \<le> n\<close> assms have "v x > 0"
      by simp
    with False have "?M 0 (v x) = Min (insert \<infinity> ?S)"
      unfolding cs_to_dbm_def by auto
    moreover have "finite ?S"
    proof -
      have "?S \<subseteq> expr_of_constr ` cs"
        by force
      also have "finite \<dots>"
        using \<open>finite cs\<close> by (rule finite_imageI)
      finally show ?thesis .
    qed
    ultimately show "dbm_entry_val u None (Some x) (?M 0 (v x))"
      using assms(2-) \<open>v x \<le> n\<close>
      by (cases rule: Min_insert_cases, (auto; fail))
        (simp add: dbm_entry_val_constr_sem_iff cs_sem_def, metis)
  next
    fix x :: 'a
    assume "v x \<le> n"
    let ?S = "{e. \<exists>x'. Upper x' e \<in> cs \<and> v x' = v x}"
    from \<open>v x \<le> n\<close> assms have "v x > 0"
      by simp
    with False have "?M (v x) 0 = Min (insert \<infinity> ?S)"
      unfolding cs_to_dbm_def by auto
    moreover have "finite ?S"
    proof -
      have "?S \<subseteq> expr_of_constr ` cs"
        by force
      also have "finite \<dots>"
        using \<open>finite cs\<close> by (rule finite_imageI)
      finally show ?thesis .
    qed
    ultimately show "dbm_entry_val u (Some x) None (cs_to_dbm v cs (v x) 0)"
      using \<open>v x \<le> n\<close> assms(2-)
      by (cases rule: Min_insert_cases, (auto; fail))
        (simp add: dbm_entry_val_constr_sem_iff cs_sem_def, metis)
  next
    fix x y :: 'a
    assume "v x \<le> n" "v y \<le> n"
    let ?S = "{e. \<exists>x' y'. Diff x' y' e \<in> cs \<and> v x' = v x \<and> v y' = v y}"
    from \<open>v x \<le> n\<close> \<open>v y \<le> n\<close> assms have "v x > 0" "v y > 0"
      by auto
    with False have "?M (v x) (v y) = Min (insert \<infinity> ?S)"
      unfolding cs_to_dbm_def by auto
    moreover have "finite ?S"
    proof -
      have "?S \<subseteq> expr_of_constr ` cs"
        by force
      also have "finite \<dots>"
        using \<open>finite cs\<close> by (rule finite_imageI)
      finally show ?thesis .
    qed
    ultimately show "dbm_entry_val u (Some x) (Some y) (cs_to_dbm v cs (v x) (v y))"
      using \<open>v x \<le> n\<close> \<open>v y \<le> n\<close> assms(2-)
      by (cases rule: Min_insert_cases, (auto; fail))
        (simp add: dbm_entry_val_constr_sem_iff cs_sem_def, metis)
  qed
qed

theorem cs_to_dbm_correct:
  assumes "\<forall>x \<in> cs_vars cs. v x \<le> n" "\<forall>x. v x \<le> n \<longrightarrow> v x > 0"
    "\<forall>x y. v x \<le> n \<and> v y \<le> n \<and> v x = v y \<longrightarrow> x = y"
    "finite cs"
  shows "u \<turnstile>\<^bsub>v,n\<^esub> cs_to_dbm v cs \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s cs"
  using assms by (blast intro: cs_to_dbm1 cs_to_dbm2)

corollary cs_to_dbm_correct':
  assumes
    "bij_betw v (cs_vars cs) {1..n}" "\<forall>x. v x \<le> n \<longrightarrow> v x > 0" "\<forall>x. x \<notin> cs_vars cs \<longrightarrow> v x > n"
    "finite cs"
  shows "u \<turnstile>\<^bsub>v,n\<^esub> cs_to_dbm v cs \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s cs"
proof (rule cs_to_dbm_correct , safe)
  fix x assume "x \<in> cs_vars cs"
  then show "v x \<le> n"
    using assms(1) unfolding bij_betw_def by auto
next
  fix x assume "v x \<le> n"
  then show "0 < v x"
    using assms(2) by blast
next
  fix x y :: 'a
  assume A: "v x \<le> n" "v y \<le> n" "v x = v y"
  with A assms show "x = y"
    unfolding bij_betw_def by (auto dest!: inj_onD)
next
  show "finite cs"
    by (rule assms)
qed

section \<open>Application: Up On Constraint Systems\<close>
text \<open>The following is a sample application of viewing DBMs as constraint systems.
We show define an equivalent of the @{term up} operation on DBMs, prove it correct,
and then derive an alternative correctness proof for @{term up}.
\<close>
definition
  "up_cs cs = {c. c \<in> cs \<and> (case c of Upper _ _ \<Rightarrow> False | _ \<Rightarrow> True)}"

lemma Lower_shiftI:
  "u \<oplus> d \<Turnstile>\<^sub>c Lower x e" if "u \<Turnstile>\<^sub>c Lower x e" "(d :: 't :: linordered_ab_group_add) \<ge> 0"
  using that
  apply (cases e)
    apply (auto simp: constr_sem_less_eq_iff)
  using diff_mono apply fastforce
  using less_trans not_less_iff_gr_or_eq apply fastforce
  done

lemma Upper_shiftI:
  "u \<oplus> d \<Turnstile>\<^sub>c Upper x e" if "u \<Turnstile>\<^sub>c Upper x e" "(d :: 't :: linordered_ab_group_add) \<le> 0"
  using that
  apply (cases e)
    apply (auto simp: constr_sem_less_eq_iff)
   apply (simp add: add.commute add_decreasing; fail)
  using add_less_le_mono apply fastforce
  done

lemma Diff_shift:
  "u \<oplus> d \<Turnstile>\<^sub>c Diff x y e \<longleftrightarrow> u \<Turnstile>\<^sub>c Diff x y e" for d :: "'t :: linordered_ab_group_add"
  by (cases e) (auto simp: constr_sem_less_eq_iff)

lemma up_cs_complete:
  "u \<oplus> d \<Turnstile>\<^sub>c\<^sub>s up_cs cs" if "u \<Turnstile>\<^sub>c\<^sub>s cs" "d \<ge> 0" for d :: "'t :: linordered_ab_group_add"
  using that unfolding up_cs_def cs_sem_def
  apply clarsimp
  subgoal for x
    by (cases x) (auto simp: Diff_shift intro: Lower_shiftI)
  done

definition
  "lower_upper_closed cs \<equiv> \<forall>x y e e'.
    Lower x e \<in> cs \<and> Upper y e' \<in> cs \<longrightarrow> (\<exists> e''. Diff y x e'' \<in> cs \<and> e'' \<le> e + e')"

lemma up_cs_sound:
  assumes "u \<Turnstile>\<^sub>c\<^sub>s up_cs cs" "lower_upper_closed cs" "finite cs"
  obtains u' and d :: "'t :: time" where "d \<ge> 0" "u' \<Turnstile>\<^sub>c\<^sub>s cs" "u = u' \<oplus> d"
proof -
  define U and L and LT where
    "U \<equiv> {e  + Le (-u x) | x e. Upper x e \<in> cs \<and> e \<noteq> \<infinity>}"
    and "L \<equiv> {-e + Le (-u x) | x e. Lower x e \<in> cs \<and> e \<noteq> \<infinity>}"
    and "LT \<equiv> {Le (-d - u x) | x d. Lower x (Lt d) \<in> cs}"
  note defs = U_def L_def LT_def
  let ?l = "Max L" and ?u = "Min U"
  have "LT \<subseteq> L"
    by (force simp: DBM_arith_defs defs)
  have Diff_semD: "u \<Turnstile>\<^sub>c Diff y x (e + e')" if "Lower x e \<in> cs" "Upper y e' \<in> cs" for x y e e'
  proof -
    from assms that obtain e'' where "Diff y x e'' \<in> cs" "e'' \<le> e + e'"
      unfolding lower_upper_closed_def cs_equiv_def by blast
    with assms(1) show ?thesis
      unfolding cs_sem_def up_cs_def by (auto intro: constr_sem_mono)
  qed
  have Lower_semD: "u \<Turnstile>\<^sub>c Lower x e" if "Lower x e \<in> cs" for x e
    using that assms unfolding cs_sem_def up_cs_def by auto
  have Lower_boundI: "-e + Le (-u x) \<le> 0" if "Lower x e \<in> cs" "e \<noteq> \<infinity>" for x e
    using Lower_semD[OF that(1)] that(2) unfolding constr_sem_less_eq_iff
    by (intro DBMEntry_le_to_sum)
  from \<open>finite cs\<close> have "finite L"
    unfolding defs
    by (force intro: finite_subset[where B = "(\<lambda>c. case c of Lower x e \<Rightarrow> - e + Le (- u x)) ` cs"])
  from \<open>finite cs\<close> have "finite U"
    unfolding defs
    by (force intro: finite_subset[where B = "(\<lambda>c. case c of Upper x e \<Rightarrow> e + Le (- u x)) ` cs"])
  note L_ge = Max_ge[OF \<open>finite L\<close>] and U_le = Min_le[OF \<open>finite U\<close>]
  have L_0: "Max L \<le> 0" if "L \<noteq> {}"
    by (intro Max.boundedI \<open>finite L\<close> that) (auto intro: Lower_boundI simp: defs)
  have L_U: "Max L \<le> Min U" if "L \<noteq> {}" "U \<noteq> {}"
    apply (intro Max_le_MinI \<open>finite L\<close> \<open>finite U\<close> that)
    apply (clarsimp simp: defs)
    apply (drule (1) Diff_semD)
    subgoal for x y e e'
      unfolding constr_sem_less_eq_iff
      by (cases e; cases e'; simp add: DBM_arith_defs; simp add: algebra_simps)
    done
  consider
    (L_empty) "L = {}" | (Lt_empty) "LT = {}" | (L_gt_Lt) "Max L > Max LT" |
    (Lt_Max) x d where "Lower x (Lt d) \<in> cs" "Le (-d - u x) \<in> LT" "Max L = Le (-d - u x)"
    by (smt finite_subset Max_in Max_mono \<open>finite L\<close> \<open>LT \<subseteq> L\<close> less_le mem_Collect_eq defs)
  note L_Lt_cases = this
  have Lt_Max_rule: "- c - u x < 0"
    if "Lower x (Lt c) \<in> cs" "Max L = Le (- c - u x)" "L \<noteq> {}" for c x
    using that
    by (metis DBMEntry.distinct(1) L_0 Le_le_LeD Le_less_Lt Lower_semD
          add.inverse_inverse constr_sem_less_eq_iff(1) eq_iff_diff_eq_0 less_le neutral)
  have LT_0_boundI: "\<exists>d \<le> 0. (\<forall>l \<in> L. l \<le> Le d) \<and> (\<forall>l \<in> LT. l < Le d)" if \<open>L \<noteq> {}\<close>
  proof -
    obtain d where d: "?l \<le> Le d" "d \<le> 0"
      by (metis L_0 \<open>L \<noteq> {}\<close> neutral order_refl)
    show ?thesis
    proof (cases rule: L_Lt_cases)
      case L_empty
      with \<open>L \<noteq> {}\<close> show ?thesis
        by simp
    next
      case Lt_empty
      then show ?thesis
        by (smt L_ge d(1,2) empty_iff leD leI less_le_trans)
    next
      case L_gt_Lt
      then show ?thesis
        by (smt finite_subset Max_ge \<open>finite L\<close> \<open>LT \<subseteq> L\<close> d(1,2) leD leI less_le_trans)
    next
      case (Lt_Max x c)
      define d where "d \<equiv> - c - u x"
      from Lt_Max(1,3) \<open>L \<noteq> {}\<close> have "d < 0"
        unfolding d_def by (rule Lt_Max_rule)
      then obtain d' where d': "d < d'" "d' < 0"
        using dense by auto
      have "\<forall>l \<in> L. l < Le d'"
      proof safe
        fix l
        assume "l \<in> L"
        then have "l \<le> Le d"
          unfolding d_def \<open>Max L = _\<close>[symmetric] by (rule L_ge)
        also from d' have "\<dots> < Le d'"
          by auto
        finally show "l < Le d'" .
      qed
      with Lt_Max(1,3) d' \<open>finite L\<close> \<open>L \<noteq> {}\<close> \<open>LT \<subseteq> L\<close> show ?thesis
        by (intro exI[of _ d']) auto
    qed
  qed
  consider
      (none)   "L = {}" "U = {}"
    | (upper)  "L = {}" "U \<noteq> {}"
    | (lower)  "L \<noteq> {}" "U = {}"
    | (proper) "L \<noteq> {}" "U \<noteq> {}"
    by force
  text \<open>The main statement of of the proof. Note that most of the lengthiness of the proof is
  owed to the third conjunct. Our initial hope was that this conjunct would not be needed.\<close>
  then obtain d where d: "d \<le> 0" "\<forall>l \<in> L. l \<le> Le d" "\<forall>l \<in> LT. l < Le d" "\<forall>u \<in> U. Le d \<le> u"
  proof cases
    case none
    then show ?thesis
      by (intro that[of 0]) (auto simp: defs)
  next
    case upper
    obtain d where "Le d \<le> Min U" "d \<le> 0"
      by (smt DBMEntry.distinct(3) add_inf(2) any_le_inf neg_le_0_iff_le DBM.neutral
            order.not_eq_order_implies_strict sum_gt_neutral_dest')
    then show ?thesis
      using upper \<open>finite U\<close> by (intro that[of d]) (auto simp: defs)
  next
    case lower
    obtain d where d: "Max L \<le> Le d" "d \<le> 0"
      by (smt L_0 lower(1) neutral order_refl)
    show ?thesis
    proof (cases rule: L_Lt_cases)
      case L_empty
      with lower(1) show ?thesis
        by simp
    next
      case Lt_empty
      then show ?thesis
        by (metis (lifting) L_ge d(1,2) empty_iff leD leI less_le_trans lower(2) that)
    next
      case L_gt_Lt
      then show ?thesis
        by (smt finite_subset Max_ge \<open>finite L\<close> \<open>LT \<subseteq> L\<close> d(1,2) empty_iff
              leD leI less_le_trans lower(2) that)
    next
      case (Lt_Max x c)
      define d where "d \<equiv> - c - u x"
      from Lt_Max(1,3) lower(1) have "d < 0"
        unfolding d_def by (rule Lt_Max_rule)
      then obtain d' where d': "d < d'" "d' < 0"
        using dense by auto
      have "\<forall>l \<in> L. l < Le d'"
      proof safe
        fix l
        assume "l \<in> L"
        then have "l \<le> Le d"
          unfolding d_def \<open>Max L = _\<close>[symmetric] by (rule L_ge)
        also from d' have "\<dots> < Le d'"
          by auto
        finally show "l < Le d'" .
      qed
      with Lt_Max(1,3) d' \<open>finite L\<close> lower \<open>LT \<subseteq> L\<close> show ?thesis
        by (intro that[of d']) auto
    qed
  next
    case proper
    with L_U L_0 have "Max L \<le> Min U" "Max L \<le> 0"
      by auto
    from \<open>finite U\<close> \<open>U \<noteq> {}\<close> have "?u \<in> U"
      unfolding U_def by (rule Min_in)
    have main:
      "\<exists>d'. -d - u x < d' \<and> Le d' < ?u"
      if "Lower x (Lt d) \<in> cs" "Le (-d - u x) \<in> LT" "?l = Le (-d - u x)" for d x
    proof (cases ?u)
      case (Le d')
      with \<open>?u \<in> U\<close> obtain e y where *: "Le d' = e + Le (- u y)" "Upper y e \<in> cs"
        unfolding U_def by auto
      then obtain d1 where "e = Le d1"
        by (cases e) (auto simp: DBM_arith_defs)
      with * have "d' = d1 - u y"
        by (auto simp: DBM_arith_defs)
      from Diff_semD[OF \<open>Lower x (Lt d) \<in> cs\<close> \<open>Upper y e \<in> _\<close>] have "u y - u x < d + d1"
        unfolding constr_sem_less_eq_iff \<open>e = _\<close> by (simp add: DBM_arith_defs)
      then have "- d - u x < d'"
        unfolding \<open>d' = _\<close> by (simp add: algebra_simps)
      then obtain d1 where "-d - u x < d1" "d1 < d'"
        using dense by auto
      with \<open>?u = _\<close> show ?thesis
        by (intro exI[where x = d1]) auto
    next
      case (Lt d')
      with \<open>?u \<in> U\<close> obtain e y where *: "Lt d' = e + Le (- u y)" "Upper y e \<in> cs"
        unfolding U_def by auto
      then obtain d1 where "e = Lt d1"
        by (cases e) (auto simp: DBM_arith_defs)
      with * have "d' = d1 - u y"
        by (auto simp: DBM_arith_defs)
      from Diff_semD[OF \<open>Lower x (Lt d) \<in> cs\<close> \<open>Upper y e \<in> _\<close>] have "u y - u x < d + d1"
        unfolding constr_sem_less_eq_iff \<open>e = _\<close> by (simp add: DBM_arith_defs)
      then have "- d - u x < d'"
        unfolding \<open>d' = _\<close> by (simp add: algebra_simps)
      then obtain d1 where "-d - u x < d1" "d1 < d'"
        using dense by auto
      with \<open>?u = _\<close> show ?thesis
        by (intro exI[where x = d1]) auto
    next
      case INF
      with \<open>?u \<in> U\<close> show ?thesis
        using Lt_Max_rule proper(1) that(1,3) by fastforce
    qed
    consider (eq) "Max L = Min U" | (0) "Min U \<ge> 0" | (gt) "Max L < Min U" "Min U < 0"
      using \<open>Max L \<le> Min U\<close> by fastforce
    then show ?thesis
    proof cases
      case eq
      from proper \<open>finite L\<close> \<open>finite U\<close> have "?l \<in> L" "?u \<in> U"
        by - (rule Max_in Min_in; assumption)+
      then obtain x y e e' where *:
        "?l = - e + Le (- u x)" "Lower x e \<in> cs" "e \<noteq> \<infinity>"
        "?u = e' + Le (- u y)" "Upper y e' \<in> cs" "e' \<noteq> \<infinity>"
        unfolding defs by auto
      with \<open>?l = ?u\<close> obtain d where d: "?l = Le d"
        apply (cases e; cases e'; simp add: DBM_arith_defs)
        subgoal for a b
        proof -
          assume prems: "- a - u x = b - u y" "e = Le a" "e' = Lt b"
          from * have "u \<Turnstile>\<^sub>c Diff y x (e + e')"
            by (intro Diff_semD)
          with prems have False
            by (simp add: DBM_arith_defs constr_sem_less_eq_iff algebra_simps)
          then show ?thesis ..
        qed
        done
      from \<open>?l \<le> 0\<close> have **: "d \<le> 0" "\<forall>l \<in> L. l \<le> Le d" "\<forall>u \<in> U. Le d \<le> u"
          apply (simp add: DBM.neutral d; fail)
         apply (auto simp: d[symmetric] intro: L_ge; fail)
        apply (auto simp: d[symmetric] eq intro: U_le; fail)
        done
      show ?thesis
      proof (cases rule: L_Lt_cases)
        case L_empty
        with \<open>L \<noteq> {}\<close> show ?thesis
          by simp
      next
        case Lt_empty
        with ** show ?thesis
          by (intro that[of d]) auto
      next
        case L_gt_Lt
        with ** show ?thesis
          by (intro that[of d]; simp)
             (metis finite_subset Max_ge \<open>LT \<subseteq> L\<close> \<open>finite L\<close> d le_less_trans)
      next
        case (Lt_Max y d1)
        from main[OF this] obtain d' where "d' > - d1 - u y" "Le d' < Min U"
          by auto
        with ** Lt_Max(3)[symmetric] d eq show ?thesis
          by (intro that[of d']; simp)
      qed
    next
      case 0
      from LT_0_boundI[OF \<open>L \<noteq> {}\<close>] obtain d where "d \<le> 0" "\<forall>l\<in>L. l \<le> Le d" "\<forall>l\<in>LT. l < Le d"
        by safe
      with \<open>Max L \<le> 0\<close> \<open>finite L\<close> \<open>finite U\<close> proper 0 show ?thesis
        by (intro that[of d]) (auto simp: DBM.neutral intro: order_trans)
    next
      case gt
      then obtain d where d: "Max L \<le> Le d" "Le d \<le> Min U"
        by (elim Le_in_between)
      with \<open>_ < 0\<close> have "Le d < 0"
        by auto
      then have "d \<le> 0"
        by (simp add: neutral)
      show ?thesis
      proof (cases rule: L_Lt_cases)
        case L_empty
        with \<open>L \<noteq> {}\<close> show ?thesis
          by simp
      next
        case Lt_empty
        with d \<open>d \<le> 0\<close> show ?thesis
          using proper \<open>finite L\<close> \<open>finite U\<close> by (intro that[of d]) (auto intro: L_ge U_le)
      next
        case L_gt_Lt
        with d \<open>d \<le> 0\<close> proper \<open>finite L\<close> \<open>finite U\<close> show ?thesis
          by (intro that[of d]) (auto intro: L_ge U_le; fail
              | meson finite_subset Max_ge \<open>LT \<subseteq> L\<close> le_less_trans less_le_trans)+
      next
        case (Lt_Max y d1)
        from main[OF this] obtain d' where d': "d' > - d1 - u y" "Le d' < Min U"
          by auto
        with d have d_bounds: "?l < Le d'" "Le d' \<le> ?u"
          unfolding \<open>?l = _\<close> by auto
        from \<open>?l < Le d'\<close> have "\<forall>l \<in> L. l < Le d'"
          using Max_less_iff \<open>finite L\<close> by blast
        moreover from \<open>Le d' \<le> ?u\<close> \<open>?u < 0\<close> have "d' \<le> 0"
          by (metis Le_le_LeD le_less_trans neutral order.strict_iff_order)
        with d Lt_Max(3)[symmetric] d_bounds d' \<open>LT \<subseteq> L\<close> show ?thesis
          using proper \<open>finite L\<close> \<open>finite U\<close>
          by (intro that[of d']; auto)
      qed
    qed
  qed
  have "u \<oplus> d \<Turnstile>\<^sub>c\<^sub>s cs"
    unfolding cs_sem_def
  proof clarsimp
    fix c :: "('a, 't) constr"
    assume "c \<in> cs"
    show "u \<oplus> d \<Turnstile>\<^sub>c c"
    proof (cases c)
      case (Lower x e)
      show ?thesis
      proof (cases "e = \<infinity>")
        case True
        with \<open>c = _\<close> show ?thesis
          by (auto simp: constr_sem_less_eq_iff)
      next
        case False
        with \<open>c = _\<close> \<open>c \<in> _\<close> have "-e + Le (-u x) \<in> L"
          unfolding defs by auto
        with d have "-e + Le (-u x) \<le> Le d"
          by auto
        then show ?thesis
          using d(3) \<open>c \<in> _\<close> unfolding \<open>c = _\<close> constr_sem_less_eq_iff
          apply (cases e; simp add: defs DBM_arith_defs)
           apply (metis diff_le_eq minus_add_distrib minus_le_iff uminus_add_conv_diff)
          apply (metis ab_group_add_class.ab_diff_conv_add_uminus leD le_less less_diff_eq
                minus_diff_eq neg_less_iff_less)
          done
      qed
    next
      case (Upper x e)
      show ?thesis
      proof (cases "e = \<infinity>")
        case True
        with \<open>c = _\<close> show ?thesis
          by (auto simp: constr_sem_less_eq_iff)
      next
        case False
        with \<open>c = _\<close> \<open>c \<in> _\<close> have "e + Le (-u x) \<in> U"
          by (auto simp: defs)
        with d show ?thesis
          by (cases e) (auto simp: \<open>c = _\<close> constr_sem_less_eq_iff DBM_arith_defs algebra_simps)
      qed
    next
      case (Diff x y e)
      with assms \<open>c \<in> cs\<close> show ?thesis
        by (auto simp: Diff_shift cs_sem_def up_cs_def)
    qed
  qed
  with \<open>d \<le> 0\<close> show ?thesis
    by (intro that[of "-d" "u \<oplus> d"]; simp add: cval_add_def)
qed
text \<open>Note that if we compare this proof to @{thm DBM_up_sound'}, we can see that we have
not gained much. Settling on DBM entry arithmetic as done above was not the optimal choice for this
proof, while it can drastically simply some other proofs.
Also, note that the final theorem we obtain below (\<open>DBM_up_correct\<close>)
is slightly stronger than what we would get with @{thm DBM_up_sound'}.
Finally, note that a more elegant definition of @{term lower_upper_closed} would probably be:
\<comment> \<open>
definition
  "lower_upper_closed cs \<equiv> \<forall>x y e e'.
    cs \<Turnstile> Lower x e \<and> cs \<Turnstile> Upper y e' \<longrightarrow> (\<exists> e''. cs \<Turnstile> Diff y x e'' \<and> e'' \<le> e + e')"\<close>
This would mean that in the proof we would have to replace minimum and maximum by
supremum and infimum. The advantage would be that the finiteness assumption could be removed.
However, as our DBM entries do not come with \<open>-\<infinity>\<close>, they do not form a complete lattice.
Thus we would either have to make this extension or directly refer to the embedded values
directly, which would again have to form a complete lattice.
Both variants come with some technical inconvenience.
\<close>

lemma up_cs_sem:
  fixes cs :: "('x, 'v :: time) cs"
  assumes "lower_upper_closed cs" "finite cs"
  shows "{u. u \<Turnstile>\<^sub>c\<^sub>s up_cs cs} = {u \<oplus> d | u d. u \<Turnstile>\<^sub>c\<^sub>s cs \<and> d \<ge> 0}"
  by safe (metis up_cs_sound up_cs_complete assms)+

definition
  close_lu :: "('t::linordered_cancel_ab_semigroup_add) DBM \<Rightarrow> 't DBM"
where
  "close_lu M \<equiv> \<lambda>i j. if i > 0 then min (dbm_add (M i 0) (M 0 j)) (M i j) else M i j"

definition
  up' :: "('t::linordered_cancel_ab_semigroup_add) DBM \<Rightarrow> 't DBM"
where
  "up' M \<equiv> \<lambda>i j. if i > 0 \<and> j = 0 then \<infinity> else M i j"

lemma up_alt_def:
  "up M = up' (close_lu M)"
  by (intro ext) (simp add: up_def up'_def close_lu_def)

lemma close_lu_equiv:
  fixes M :: "'t ::time DBM"
  shows "dbm_to_cs n v M \<equiv>\<^sub>c\<^sub>s dbm_to_cs n v (close_lu M)"
  unfolding cs_equiv_def dbm_to_cs_correct[symmetric]
    DBM_val_bounded_def close_lu_def dbm_entry_val_constr_sem_iff
  apply (auto simp: min_def DBM.add[symmetric])
  unfolding constr_sem_less_eq_iff
  unfolding DBM.less_eq[symmetric] DBM.neutral[symmetric]
            apply (simp add: add_increasing2; fail)
           apply (metis le0)+
  subgoal premises prems for u c1 c2
  proof -
    have "Le (u c1 - u c2) = Le (u c1) + Le (- u c2)"
      by (simp add: DBM_arith_defs)
    also from prems have "\<dots> \<le> M (v c1) 0 + M 0 (v c2)"
      by (intro add_mono) auto
    finally show ?thesis .
  qed
  by (smt leI le_zero_eq order_trans | metis le0)+

lemma close_lu_closed:
  "lower_upper_closed (dbm_to_cs n v (close_lu M))" if "M 0 0 \<ge> 0"
  using that unfolding lower_upper_closed_def dbm_to_cs_def close_lu_def
  apply (clarsimp; safe)
  subgoal
    by auto
  subgoal for x y
    by (auto simp: DBM.add[symmetric])
       (metis add.commute add.right_neutral add_left_mono min.absorb2 min.cobounded1)
  by (simp add: add_increasing2)

lemma close_lu_closed': \<comment> \<open>Unused\<close>
  "lower_upper_closed (dbm_to_cs n v (close_lu M) \<union> dbm_to_cs n v M)" if "M 0 0 \<ge> 0"
  using that unfolding lower_upper_closed_def dbm_to_cs_def close_lu_def
  apply (clarsimp; safe)
  subgoal
    by auto
  subgoal for x y
    by (metis DBM.add add.commute add.right_neutral add_left_mono min.absorb2 min.cobounded1)
  subgoal for x y
    by (metis DBM.add add.commute min.cobounded1)
  by (simp add: add_increasing2)

lemma up_cs_up'_equiv:
  fixes M :: "'t ::time DBM"
  assumes "M 0 0 \<ge> 0" "clock_numbering v"
  shows "up_cs (dbm_to_cs n v M) \<equiv>\<^sub>c\<^sub>s dbm_to_cs n v (up' M)"
  using assms
  unfolding up'_def up_cs_def cs_equiv_def dbm_to_cs_correct[symmetric]
    DBM_val_bounded_def close_lu_def dbm_entry_val_constr_sem_iff
  by (auto split: if_split_asm
      simp: dbm_to_cs_def cs_sem_def DBM.add[symmetric] DBM.less_eq[symmetric] DBM.neutral)

lemma up_equiv_cong: \<comment> \<open>Unused\<close>
  fixes cs cs' :: "('x, 'v :: time) cs"
  assumes "cs \<equiv>\<^sub>c\<^sub>s cs'" "finite cs" "finite cs'" "lower_upper_closed cs" "lower_upper_closed cs'"
  shows "up_cs cs \<equiv>\<^sub>c\<^sub>s up_cs cs'"
  using assms unfolding cs_equiv_def by (metis up_cs_complete up_cs_sound)

lemma DBM_up_correct:
  fixes M :: "'t ::time DBM"
  assumes "clock_numbering v" "finite {x. v x \<le> n}"
  shows "u \<in> ([M]\<^bsub>v,n\<^esub>)\<^sup>\<up> \<longleftrightarrow> u \<in> [up M]\<^bsub>v,n\<^esub>"
proof (cases "M 0 0 \<ge> 0")
  case True
  have "u \<in> ([M]\<^bsub>v,n\<^esub>)\<^sup>\<up> \<longleftrightarrow> (\<exists>d u'. u' \<turnstile>\<^bsub>v,n\<^esub> M \<and> d \<ge> 0 \<and> u = u' \<oplus> d)"
    unfolding DBM_zone_repr_def zone_delay_def by auto
  also have "\<dots> \<longleftrightarrow> (\<exists>d u'. u' \<Turnstile>\<^sub>c\<^sub>s dbm_to_cs n v M \<and> d \<ge> 0 \<and> u = u' \<oplus> d)"
    unfolding dbm_to_cs_correct ..
  also have "\<dots> \<longleftrightarrow> (\<exists>d u'. u' \<Turnstile>\<^sub>c\<^sub>s dbm_to_cs n v (close_lu M) \<and> d \<ge> 0 \<and> u = u' \<oplus> d)"
    using cs_equivD close_lu_equiv cs_equiv_sym by metis
  also have "\<dots> \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s up_cs (dbm_to_cs n v (close_lu M))"
  proof -
    let ?cs = "dbm_to_cs n v (close_lu M)"
    have "lower_upper_closed ?cs"
      by (intro close_lu_closed True)
    moreover have "finite ?cs"
      by (intro finite_dbm_to_cs assms)
    ultimately have "{u. u \<Turnstile>\<^sub>c\<^sub>s up_cs ?cs} = {u \<oplus> d |u d. u \<Turnstile>\<^sub>c\<^sub>s ?cs \<and> 0 \<le> d}"
      by (rule up_cs_sem)
    then show ?thesis
      by (auto 4 3)
  qed
  also have "\<dots> \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s dbm_to_cs n v (up' (close_lu M))"
  proof -
    from \<open>M 0 0 \<ge> 0\<close> have "up_cs (dbm_to_cs n v (close_lu M)) \<equiv>\<^sub>c\<^sub>s dbm_to_cs n v (up' (close_lu M))"
      by (intro up_cs_up'_equiv[OF _ \<open>clock_numbering v\<close>], simp add: close_lu_def)
    then show ?thesis
      using cs_equivD cs_equiv_sym by metis
  qed
  also have "\<dots> \<longleftrightarrow> u \<Turnstile>\<^sub>c\<^sub>s dbm_to_cs n v (up M)"
    unfolding up_alt_def ..
  also have "\<dots> \<longleftrightarrow> u \<turnstile>\<^bsub>v,n\<^esub> up M"
    unfolding dbm_to_cs_correct ..
  also have "\<dots> \<longleftrightarrow> u \<in> [up M]\<^bsub>v,n\<^esub>"
    unfolding DBM_zone_repr_def by blast
  finally show ?thesis .
next
  case False
  then have "M 0 0 < 0"
    by auto
  then have "up M 0 0 < 0"
    unfolding up_def by auto
  with \<open>M 0 0 < 0\<close> have "[M]\<^bsub>v,n\<^esub> = {}" "[up M]\<^bsub>v,n\<^esub> = {}"
    by (auto intro!: DBM_triv_emptyI)
  then show ?thesis
    unfolding zone_delay_def by blast
qed

end


(*  Title:       Some extra results about linear algebra
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

(* After Isabelle 2012, some of these theorems
may be moved to the Isabelle repository *)

header "Linear algebra"

theory Linear_Algebra2
imports Miscellany
begin

lemma exhaust_4:
  fixes x :: 4
  shows "x = 1 \<or> x = 2 \<or> x = 3 \<or> x = 4"
proof (induct x)
  case (of_int z)
  hence "0 \<le> z" and "z < 4" by simp_all
  hence "z = 0 \<or> z = 1 \<or> z = 2 \<or> z = 3" by arith
  thus ?case by auto
qed

lemma forall_4: "(\<forall> i::4. P i) \<longleftrightarrow> P 1 \<and> P 2 \<and> P 3 \<and> P 4"
  by (metis exhaust_4)

lemma UNIV_4: "(UNIV::(4 set)) = {1, 2, 3, 4}"
  using exhaust_4
  by auto

lemma vector_4:
  fixes w :: "'a::zero"
  shows "(vector [w, x, y, z] :: 'a^4)$1 = w"
  and  "(vector [w, x, y, z] :: 'a^4)$2 = x"
  and  "(vector [w, x, y, z] :: 'a^4)$3 = y"
  and  "(vector [w, x, y, z] :: 'a^4)$4 = z"
  unfolding vector_def
  by simp_all

definition
  is_basis :: "(real^('n::finite)) set \<Rightarrow> bool" where
  "is_basis S \<equiv> independent S \<and> span S = UNIV"

lemma card_finite:
  assumes "card S = CARD('n::finite)"
  shows "finite S"
proof -
  from `card S = CARD('n)` have "card S \<noteq> 0" by simp
  with card_eq_0_iff [of S] show "finite S" by simp
qed

lemma independent_is_basis:
  fixes B :: "(real^('n::finite)) set"
  shows "independent B \<and> card B = CARD('n) \<longleftrightarrow> is_basis B"
proof
  assume "independent B \<and> card B = CARD('n)"
  hence "independent B" and "card B = CARD('n)" by simp+
  from card_finite [of B, where 'n = 'n] and `card B = CARD('n)`
  have "finite B" by simp
  from `card B = CARD('n)`
  have "card B = dim (UNIV :: ((real^'n) set))"
    by (simp add: dim_UNIV)
  with card_eq_dim [of B UNIV] and `finite B` and `independent B`
  have "span B = UNIV" by auto
  with `independent B` show "is_basis B" unfolding is_basis_def ..
next
  assume "is_basis B"
  hence "independent B" unfolding is_basis_def ..
  moreover have "card B = CARD('n)"
  proof -
    have "B \<subseteq> UNIV" by simp
    moreover
    { from `is_basis B` have "UNIV \<subseteq> span B" and "independent B"
        unfolding is_basis_def
        by simp+ }
    ultimately have "card B = dim (UNIV::((real^'n) set))"
      using basis_card_eq_dim [of B UNIV]
      by simp
    then show "card B = CARD('n)" by (simp add: dim_UNIV)
  qed
  ultimately show "independent B \<and> card B = CARD('n)" ..
qed

lemma basis_expand:
  assumes "is_basis B"
  shows "\<exists>c. v = (\<Sum>w\<in>B. (c w) *\<^sub>R w)"
proof -
  from `is_basis B` have "v \<in> span B" unfolding is_basis_def by simp
  from basis_finite [of B] and `is_basis B` have "finite B" by simp
  with span_finite [of B] and `v \<in> span B`
  show "\<exists>c. v = (\<Sum>w\<in>B. (c w) *\<^sub>R w)" by (simp add: scalar_equiv) auto
qed

lemma not_span_independent_insert:
  fixes v :: "('a::real_vector)^'n"
  assumes "independent S" and "v \<notin> span S"
  shows "independent (insert v S)"
proof -
  from span_superset and `v \<notin> span S` have "v \<notin> S" by auto
  with independent_insert [of v S] and `independent S` and `v \<notin> span S`
  show "independent (insert v S)" by simp
qed

lemma in_span_eq:
  fixes v :: "('a::real_vector)^'b"
  assumes "v \<in> span S"
  shows "span (insert v S) = span S"
proof
  { fix w
    assume "w \<in> span (insert v S)"
    with `v \<in> span S` have "w \<in> span S" by (rule span_trans) }
  thus "span (insert v S) \<subseteq> span S" ..

  have "S \<subseteq> insert v S" by (rule subset_insertI)
  thus "span S \<subseteq> span (insert v S)" by (rule span_mono)
qed

lemma dot_setsum_right_distrib:
  fixes v :: "real^'n"
  shows "v \<bullet> (\<Sum> j\<in>S. w j) = (\<Sum> j\<in>S. v \<bullet> (w j))"
proof -
  have "v \<bullet> (\<Sum> j\<in>S. w j) = (\<Sum> i\<in>UNIV. v$i * (\<Sum> j\<in>S. (w j)$i))"
    unfolding inner_vec_def
    by simp
  also from setsum_right_distrib [where ?A = S and ?'b = real]
  have "\<dots> = (\<Sum> i\<in>UNIV. \<Sum> j\<in>S. v$i * (w j)$i)" by simp
  also from setsum.commute [of "\<lambda> i j. v$i * (w j)$i" S UNIV]
  have "\<dots> = (\<Sum> j\<in>S. \<Sum> i\<in>UNIV. v$i * (w j)$i)" by simp
  finally show "v \<bullet> (\<Sum> j\<in>S. w j) = (\<Sum> j\<in>S. v \<bullet> (w j))"
    unfolding inner_vec_def
    by simp
qed

lemma orthogonal_setsum:
  fixes v :: "real^'n"
  assumes "\<forall> w\<in>S. orthogonal v w"
  shows "orthogonal v (\<Sum> w\<in>S. c w *s w)"
proof -
  from dot_setsum_right_distrib [of v]
  have "v \<bullet> (\<Sum> w\<in>S. c w *s w) = (\<Sum> w\<in>S. v \<bullet> (c w *s w))" by auto
  with inner_scaleR_right [of v]
  have "v \<bullet> (\<Sum> w\<in>S. c w *s w) = (\<Sum> w\<in>S. c w * (v \<bullet> w))"
    by (simp add: scalar_equiv)
  with `\<forall> w\<in>S. orthogonal v w` show "orthogonal v (\<Sum> w\<in>S. c w *s w)"
    unfolding orthogonal_def
    by simp
qed

lemma orthogonal_self_eq_0:
  fixes v :: "('a::real_inner)^('n::finite)"
  assumes "orthogonal v v"
  shows "v = 0"
  using inner_eq_zero_iff [of v] and assms
  unfolding orthogonal_def
  by simp

lemma orthogonal_in_span_eq_0:
  fixes v :: "real^('n::finite)"
  assumes "v \<in> span S" and "\<forall> w\<in>S. orthogonal v w"
  shows "v = 0"
proof -
  from span_explicit [of S] and `v \<in> span S`
  obtain T and u where "T \<subseteq> S" and "v = (\<Sum> w\<in>T. u w *\<^sub>R w)" by auto
  from `\<forall> w\<in>S. orthogonal v w` and `T \<subseteq> S` have "\<forall> w\<in>T. orthogonal v w" by auto
  with orthogonal_setsum [of T v u] and `v = (\<Sum> w\<in>T. u w *\<^sub>R w)`
  have "orthogonal v v" by (auto simp add: scalar_equiv)
  with orthogonal_self_eq_0 show "v = 0" by auto
qed

lemma orthogonal_independent:
  fixes v :: "real^('n::finite)"
  assumes "independent S" and "v \<noteq> 0" and "\<forall> w\<in>S. orthogonal v w"
  shows "independent (insert v S)"
proof -
  from orthogonal_in_span_eq_0 and `v \<noteq> 0` and `\<forall> w\<in>S. orthogonal v w`
  have "v \<notin> span S" by auto
  with not_span_independent_insert and `independent S`
  show "independent (insert v S)" by auto
qed

lemma card_ge_dim:
  fixes S :: "(real^('n::finite)) set"
  assumes "finite S"
  shows "card S \<ge> dim S"
proof -
  from span_inc have "S \<subseteq> span S" by auto
  with span_card_ge_dim [of S "span S"] and `finite S`
  have "card S \<ge> dim (span S)" by simp
  with dim_span [of S] show "card S \<ge> dim S" by simp
qed

lemma dot_scaleR_mult:
  shows "(k *\<^sub>R a) \<bullet> b = k * (a \<bullet> b)" and "a \<bullet> (k *\<^sub>R b) = k * (a \<bullet> b)"
  unfolding inner_vec_def
  by (simp_all add: algebra_simps setsum_right_distrib)

lemma dependent_explicit_finite:
  fixes S :: "(('a::{real_vector,field})^'n) set"
  assumes "finite S"
  shows "dependent S \<longleftrightarrow> (\<exists> u. (\<exists> v\<in>S. u v \<noteq> 0) \<and> (\<Sum> v\<in>S. u v *\<^sub>R v) = 0)"
proof
  assume "dependent S"
  with dependent_explicit [of S]
  obtain S' and u where
    "S' \<subseteq> S" and "\<exists> v\<in>S'. u v \<noteq> 0" and "(\<Sum> v\<in>S'. u v *\<^sub>R v) = 0"
    by auto
  let ?u' = "\<lambda> v. if v \<in> S' then u v else 0"
  from `S' \<subseteq> S` and `\<exists> v\<in>S'. u v \<noteq> 0` have "\<exists> v\<in>S. ?u' v \<noteq> 0" by auto
  moreover from setsum.mono_neutral_cong_right [of S S' "\<lambda> v. ?u' v *\<^sub>R v"]
    and `S' \<subseteq> S` and `(\<Sum> v\<in>S'. u v *\<^sub>R v) = 0` and `finite S`
  have "(\<Sum> v\<in>S. ?u' v *\<^sub>R v) = 0" by simp
  ultimately show "(\<exists> u. (\<exists> v\<in>S. u v \<noteq> 0) \<and> (\<Sum> v\<in>S. u v *\<^sub>R v) = 0)" by auto
next
  assume "(\<exists> u. (\<exists> v\<in>S. u v \<noteq> 0) \<and> (\<Sum> v\<in>S. u v *\<^sub>R v) = 0)"
  with dependent_explicit [of S] and `finite S`
  show "dependent S" by auto
qed

lemma dependent_explicit_2:
  fixes v w :: "('a::{field,real_vector})^'n"
  assumes "v \<noteq> w"
  shows "dependent {v, w} \<longleftrightarrow> (\<exists> i j. (i \<noteq> 0 \<or> j \<noteq> 0) \<and> i *\<^sub>R v + j *\<^sub>R w = 0)"
proof
  let ?S = "{v, w}"
  have "finite ?S" by simp

  { assume "dependent ?S"
    with dependent_explicit_finite [of ?S] and `finite ?S` and `v \<noteq> w`
    show "\<exists> i j. (i \<noteq> 0 \<or> j \<noteq> 0) \<and> i *\<^sub>R v + j *\<^sub>R w = 0" by auto }

  { assume "\<exists> i j. (i \<noteq> 0 \<or> j \<noteq> 0) \<and> i *\<^sub>R v + j *\<^sub>R w = 0"
    then obtain i and j where "i \<noteq> 0 \<or> j \<noteq> 0" and "i *\<^sub>R v + j *\<^sub>R w = 0" by auto
    let ?u = "\<lambda> x. if x = v then i else j"
    from `i \<noteq> 0 \<or> j \<noteq> 0` and `v \<noteq> w` have "\<exists> x\<in>?S. ?u x \<noteq> 0" by simp
    from `i *\<^sub>R v + j *\<^sub>R w = 0` and `v \<noteq> w`
    have "(\<Sum> x\<in>?S. ?u x *\<^sub>R x) = 0" by simp
    with dependent_explicit_finite [of ?S]
      and `finite ?S` and `\<exists> x\<in>?S. ?u x \<noteq> 0`
    show "dependent ?S" by best }
qed

subsection "Matrices"

lemma zero_times:
  "0 ** A = (0::real^('n::finite)^'n)"
  unfolding matrix_matrix_mult_def and zero_vec_def
  by simp

lemma zero_not_invertible:
  "\<not> (invertible (0::real^('n::finite)^'n))"
proof -
  let ?\<Lambda> = "0::real^'n^'n"
  let ?I = "mat 1::real^'n^'n"
  let ?k = "undefined :: 'n"
  have "?I $ ?k $ ?k \<noteq> ?\<Lambda> $ ?k $ ?k"
    unfolding mat_def
    by simp
  hence "?\<Lambda> \<noteq> ?I" by auto
  from zero_times have "\<forall> A. ?\<Lambda> ** A = ?\<Lambda>" by auto
  with `?\<Lambda> \<noteq> ?I` show "\<not> (invertible ?\<Lambda>)"
    unfolding invertible_def
    by simp
qed

text {* Based on matrix-vector-column in
  HOL/Multivariate\_Analysis/Euclidean\_Space.thy in Isabelle 2009-1: *}
lemma vector_matrix_row:
  fixes x :: "('a::comm_semiring_1)^'m" and A :: "('a^'n^'m)"
  shows "x v* A = (\<Sum> i\<in>UNIV. (x$i) *s (A$i))"
  unfolding vector_matrix_mult_def
  by (simp add: vec_eq_iff mult.commute)

lemma invertible_mult:
  fixes A B :: "real^('n::finite)^'n"
  assumes "invertible A" and "invertible B"
  shows "invertible (A ** B)"
proof -
  from `invertible A` and `invertible B`
  obtain A' and B' where "A ** A' = mat 1" and "A' ** A = mat 1"
    and "B ** B' = mat 1" and "B' ** B = mat 1"
    unfolding invertible_def
    by auto
  have "(A ** B) ** (B' ** A') = A ** (B ** B') ** A'"
    by (simp add: matrix_mul_assoc)
  with `A ** A' = mat 1` and `B ** B' = mat 1`
  have "(A ** B) ** (B' ** A') = mat 1" by (auto simp add: matrix_mul_rid)
  with matrix_left_right_inverse have "(B' ** A') ** (A ** B) = mat 1" by auto
  with `(A ** B) ** (B' ** A') = mat 1`
  show "invertible (A ** B)"
    unfolding invertible_def
    by auto
qed

lemma scalar_matrix_assoc:
  fixes A :: "real^'m^'n"
  shows "k *\<^sub>R (A ** B) = (k *\<^sub>R A) ** B"
proof -
  have "\<forall> i j. (k *\<^sub>R (A ** B))$i$j = ((k *\<^sub>R A) ** B)$i$j"
  proof default+
    fix i j
    have "(k *\<^sub>R (A ** B))$i$j = k * (\<Sum> l\<in>UNIV. A$i$l * B$l$j)"
      unfolding matrix_matrix_mult_def
      by simp
    also from scaleR_right.setsum [of k "\<lambda> l. A$i$l * B$l$j" UNIV]
    have "\<dots> = (\<Sum> l\<in>UNIV. k * A$i$l * B$l$j)" by (simp add: algebra_simps)
    finally show "(k *\<^sub>R (A ** B))$i$j = ((k *\<^sub>R A) ** B)$i$j"
      unfolding matrix_matrix_mult_def
      by simp
  qed
  thus "k *\<^sub>R (A ** B) = (k *\<^sub>R A) ** B" by (simp add: vec_eq_iff)
qed

lemma transpose_scalar: "transpose (k *\<^sub>R A) = k *\<^sub>R transpose A"
  unfolding transpose_def
  by (simp add: vec_eq_iff)

lemma transpose_iff [iff]: "transpose A = transpose B \<longleftrightarrow> A = B"
proof
  assume "transpose A = transpose B"
  with transpose_transpose [of A] have "A = transpose (transpose B)" by simp
  with transpose_transpose [of B] show "A = B" by simp
next
  assume "A = B"
  thus "transpose A = transpose B" by simp
qed

lemma matrix_scalar_ac:
  fixes A :: "real^'m^'n"
  shows "A ** (k *\<^sub>R B) = k *\<^sub>R A ** B"
proof -
  from matrix_transpose_mul [of A "k *\<^sub>R B"] and transpose_scalar [of k B]
  have "transpose (A ** (k *\<^sub>R B)) = k *\<^sub>R transpose B ** transpose A"
    by simp
  also from matrix_transpose_mul [of A B] and transpose_scalar [of k "A ** B"]
  have "\<dots> = transpose (k *\<^sub>R A ** B)" by (simp add: scalar_matrix_assoc)
  finally show "A ** (k *\<^sub>R B) = k *\<^sub>R A ** B" by simp
qed

lemma scalar_invertible:
  fixes A :: "real^'m^'n"
  assumes "k \<noteq> 0" and "invertible A"
  shows "invertible (k *\<^sub>R A)"
proof -
  from `invertible A`
  obtain A' where "A ** A' = mat 1" and "A' ** A = mat 1"
    unfolding invertible_def
    by auto
  with `k \<noteq> 0`
  have "(k *\<^sub>R A) ** ((1/k) *\<^sub>R A') = mat 1"
    and "((1/k) *\<^sub>R A') ** (k *\<^sub>R A) = mat 1"
    by (simp_all add: matrix_scalar_ac)
  thus "invertible (k *\<^sub>R A)"
    unfolding invertible_def
    by auto
qed

lemma matrix_inv:
  assumes "invertible M"
  shows "matrix_inv M ** M = mat 1"
  and "M ** matrix_inv M = mat 1"
  using `invertible M` and someI_ex [of "\<lambda> N. M ** N = mat 1 \<and> N ** M = mat 1"]
  unfolding invertible_def and matrix_inv_def
  by simp_all

lemma matrix_inv_invertible:
  assumes "invertible M"
  shows "invertible (matrix_inv M)"
  using `invertible M` and matrix_inv
  unfolding invertible_def [of "matrix_inv M"]
  by auto

lemma vector_matrix_mul_rid:
  fixes v :: "('a::semiring_1)^('n::finite)"
  shows "v v* mat 1 = v"
proof -
  have "v v* mat 1 = transpose (mat 1) *v v" by simp
  thus "v v* mat 1 = v" by (simp only: transpose_mat matrix_vector_mul_lid)
qed

lemma vector_matrix_mul_assoc:
  fixes v :: "('a::comm_semiring_1)^'n"
  shows "(v v* M) v* N = v v* (M ** N)"
proof -
  from matrix_vector_mul_assoc
  have "transpose N *v (transpose M *v v) = (transpose N ** transpose M) *v v" by fast
  thus "(v v* M) v* N = v v* (M ** N)"
    by (simp add: matrix_transpose_mul [symmetric])
qed

lemma matrix_scalar_vector_ac:
  fixes A :: "real^('m::finite)^('n::finite)"
  shows "A *v (k *\<^sub>R v) = k *\<^sub>R A *v v"
proof -
  have "A *v (k *\<^sub>R v) = k *\<^sub>R (v v* transpose A)"
    by (subst scalar_vector_matrix_assoc [symmetric]) simp
  also have "\<dots> = v v* k *\<^sub>R transpose A"
    by (subst vector_scalar_matrix_ac) simp
  also have "\<dots> = v v* transpose (k *\<^sub>R A)" by (subst transpose_scalar) simp
  also have "\<dots> = k *\<^sub>R A *v v" by simp
  finally show "A *v (k *\<^sub>R v) = k *\<^sub>R A *v v" .
qed

lemma scalar_matrix_vector_assoc:
  fixes A :: "real^('m::finite)^('n::finite)"
  shows "k *\<^sub>R (A *v v) = k *\<^sub>R A *v v"
proof -
  have "k *\<^sub>R (A *v v) = k *\<^sub>R (v v* transpose A)" by simp
  also have "\<dots> = v v* k *\<^sub>R transpose A"
    by (rule vector_scalar_matrix_ac [symmetric])
  also have "\<dots> = v v* transpose (k *\<^sub>R A)" apply (subst transpose_scalar) ..
  finally show "k *\<^sub>R (A *v v) = k *\<^sub>R A *v v" by simp
qed

lemma invertible_times_non_zero:
  fixes M :: "real^'n^('n::finite)"
  assumes "invertible M" and "v \<noteq> 0"
  shows "M *v v \<noteq> 0"
  using `invertible M` and `v \<noteq> 0` and invertible_times_eq_zero [of M v]
  by auto

lemma matrix_right_invertible_ker:
  fixes M :: "real^('m::finite)^('n::finite)"
  shows "(\<exists> M'. M ** M' = mat 1) \<longleftrightarrow> (\<forall> x. x v* M = 0 \<longrightarrow> x = 0)"
proof
  assume "\<exists> M'. M ** M' = mat 1"
  then obtain M' where "M ** M' = mat 1" ..
  have "transpose (M ** M') = transpose (mat 1)" apply (subst `M ** M' = mat 1`) ..
  hence "transpose M' ** transpose M = mat 1"
    by (simp add: matrix_transpose_mul transpose_mat)
  hence "\<exists> M''. M'' ** transpose M = mat 1" ..
  with matrix_left_invertible_ker [of "transpose M"]
  have "\<forall> x. transpose M *v x = 0 \<longrightarrow> x = 0" by simp
  thus "\<forall> x. x v* M = 0 \<longrightarrow> x = 0" by simp
next
  assume "\<forall> x. x v* M = 0 \<longrightarrow> x = 0"
  hence "\<forall> x. transpose M *v x = 0 \<longrightarrow> x = 0" by simp
  with matrix_left_invertible_ker [of "transpose M"]
  obtain M'' where "M'' ** transpose M = mat 1" by auto
  hence "transpose (M'' ** transpose M) = transpose (mat 1)" by simp
  hence "M ** transpose M'' = mat 1"
    by (simp add: matrix_transpose_mul transpose_transpose transpose_mat)
  thus "\<exists> M'. M ** M' = mat 1" ..
qed

lemma left_invertible_iff_invertible:
  fixes M :: "real^('n::finite)^'n"
  shows "(\<exists> N. N ** M = mat 1) \<longleftrightarrow> invertible M"
  using matrix_left_right_inverse
  unfolding invertible_def
  by auto

lemma right_invertible_iff_invertible:
  fixes M :: "real^('n::finite)^'n"
  shows "(\<exists> N. M ** N = mat 1) \<longleftrightarrow> invertible M"
  using left_invertible_iff_invertible
  by (subst matrix_left_right_inverse) auto

definition symmatrix :: "'a^'n^'n \<Rightarrow> bool" where
  "symmatrix M \<equiv> transpose M = M"

lemma symmatrix_preserve:
  fixes M N :: "('a::comm_semiring_1)^'n^'n"
  assumes "symmatrix M"
  shows "symmatrix (N ** M ** transpose N)"
proof -
  have "transpose (N ** M ** transpose N) = N ** transpose M ** transpose N"
    by (simp add: matrix_transpose_mul transpose_transpose matrix_mul_assoc)
  with `symmatrix M`
  show "symmatrix (N ** M ** transpose N)"
    unfolding symmatrix_def
    by simp
qed

lemma matrix_vector_right_distrib:
  fixes v w :: "real^('n::finite)" and M :: "real^'n^('m::finite)"
  shows "M *v (v + w) = M *v v + M *v w"
proof -
  have "M *v (v + w) = (v + w) v* transpose M" by simp
  also have "\<dots> = v v* transpose M + w v* transpose M"
    by (rule vector_matrix_left_distrib [of v w "transpose M"])
  finally show "M *v (v + w) = M *v v + M *v w" by simp
qed

end