section \<open>Cylindric Conway Lattices\<close>

text \<open>Using this file requires downloading the Archive of Formal Proofs.\<close>

theory Cylindric_Conway_Lattice
  imports Main  "~~/src/HOL/Library/Lattice_Syntax"
          Kleene_Algebra.Kleene_Algebra

begin

text \<open>Conway algebras are a common basis for Kleene algebras and demonic refinement algebras. We use weak variants
in which a left distributivity law is absent most of the time, and sometimes replaced by an isotonicity law. This makes
the approach applicable for instance for probabilistic variants and algebras of general or order-preserving predicate
transformers.\<close>

text \<open>In near-semirings, there is no left distributivity law.\<close>

context near_conway_base
begin

definition kplus :: "'a \<Rightarrow> 'a" ("_\<^sup>\<oplus>" [101] 100) where
  "x\<^sup>\<oplus> = x \<cdot> x\<^sup>\<dagger>"

lemma kplus_dagger: "x\<^sup>\<dagger> = 1 + x\<^sup>\<oplus>"
  by (simp add: kplus_def)

end

text \<open>In presemirings, composition preserves the order in its second argument.\<close>

context pre_conway
begin

lemma kplus_opp:  "x\<^sup>\<oplus> = x\<^sup>\<dagger> \<cdot> x"
  by (metis dagger_denest dagger_prod_unfold dagger_slide dagger_unfoldr_eq join.sup.idem kplus_dagger kplus_def)

lemma kplus_unfoldr [simp]: "x + x\<^sup>\<oplus> \<cdot> x = x\<^sup>\<oplus>"
  by (metis kplus_def dagger_slide dagger_unfoldl_distr mult_onel mult_oner)

lemma kplus_unfoldl [simp]: "x + x \<cdot> x\<^sup>\<oplus> = x\<^sup>\<oplus>"
  by (metis kplus_def kplus_unfoldr dagger_unfoldl_distr mult_assoc)

end

class near_l_monoid = near_dioid_one + semilattice_inf +
  assumes absorp1 [simp]: "x + (x \<sqinter> y) = x"
  and absorp2 [simp]: "x \<sqinter> (x + y) = x"

class near_l_monoid_zerol = near_l_monoid + near_dioid_one_zerol

begin

lemma meet_zeror [simp]: "x \<sqinter> 0 = 0"
  by (simp add: inf_absorb2)

end

text \<open>We consider a unary case of cylindrification where the axiom for different coordinates is absent. This is simpler
because we can use type classes instead of locales.\<close>

class cylindric_near_dioid_un_base = near_dioid_one +
  fixes cyl :: "'a \<Rightarrow> 'a"
  assumes cyl_ext: "x \<le> cyl x"
  and cyl_sup_add: "cyl (x + y) \<le> cyl x + cyl y"
  and cyl_multl: "cyl (cyl x \<cdot> y) = cyl x \<cdot> cyl y"
  and cyl_multr: "cyl (x \<cdot> cyl y) = cyl x \<cdot> cyl y"

text \<open>We deal with annihilators separately. Most properties do not depend on them.\<close>

class cylindric_near_dioid_zerol_un_base = cylindric_near_dioid_un_base + near_dioid_one_zerol +
  assumes cyl_zero [simp]: "cyl 0 = 0"

begin

lemma c1_iff: "(cyl x = 0) = (x = 0)"
  using cyl_ext cyl_zero join.le_bot by blast

end

text \<open>For dioids we need a slightly different set of cylindrification axioms than for l-monoids.\<close>

class cylindric_near_dioid_un = cylindric_near_dioid_un_base +
  assumes cyl_sub_add: "cyl x \<le> cyl (x + y)"
  and cyl_idem [simp]: "cyl (cyl x) = cyl x"

begin

lemma c3_iff:  "cyl (x + y) = cyl x + cyl y"
  by (smt add_commute add_iso cyl_sup_add cyl_sub_add join.sup.orderE)

lemma cyl_iso: "x \<le> y \<Longrightarrow> cyl x \<le> cyl y"
  by (metis c3_iff less_eq_def)

lemma cyl_clos: "(x \<le> cyl y) = (cyl x \<le> cyl y)"
  by (metis cyl_iso cyl_ext cyl_idem dual_order.trans)

lemma cyl1_prop1: "cyl 1 \<cdot> x \<cdot> cyl 1 \<le> cyl x"
  by (metis cyl_ext cyl_multl cyl_multr cyl_idem mult_1_left mult_oner)

lemma cyl1_prop2: "cyl 1 \<cdot> x \<le> cyl x"
  by (metis cyl_ext cyl_multl cyl_multr cyl_idem mult_onel)

lemma cyl1_prop3: "x \<cdot> cyl 1 \<le> cyl x"
  by (metis cyl_ext cyl_multl cyl_multr cyl_idem mult_1_right)

lemma cyl_oplax: "cyl (x \<cdot> y) \<le> cyl x \<cdot> cyl y"
  by (metis cyl_iso cyl_ext cyl_multl mult_isor)

lemma "cyl x = x \<Longrightarrow> cyl 1 \<cdot> x \<cdot> cyl 1 = x"
  by (metis cyl_multl cyl_multr mult_1_left mult_oner)

lemma cyl_fix_im: "(cyl x = x) = (\<exists>y. cyl y = x)"
  using cyl_idem by auto

lemma cyl_1_unl [simp]: "cyl 1 \<cdot> cyl x = cyl x"
  by (metis cyl_multr cyl_idem mult_1_left)

lemma cyl_1_unr [simp]: "cyl x \<cdot> cyl 1 = cyl x"
  by (metis cyl_multl cyl_idem mult_1_right)

lemma cyl_1_idem [simp]: "cyl 1 \<cdot> cyl 1 = cyl 1"
  by simp

end

text \<open>Here are the axioms for l-monoids.\<close>

class cylindric_near_l_monoid_un = near_l_monoid + cylindric_near_dioid_un_base +
  assumes cyl_inf: "cyl (x \<sqinter> cyl y) = cyl x \<sqinter> cyl y"

begin

text \<open>Every cylindric near-l-monoid is a cylindric near dioid --- with one coordinate.\<close>

subclass cylindric_near_dioid_un
  apply unfold_locales
  apply (metis cyl_ext cyl_inf inf.order_iff join.sup.bounded_iff)
  by (metis cyl_ext cyl_inf inf.orderE inf_absorb2)

end

class cylindric_near_l_monoid_zerol_un = cylindric_near_l_monoid_un + cylindric_near_dioid_zerol_un_base

begin

lemma cyl_conj: "(x \<sqinter> cyl y = 0) = (y \<sqinter> cyl x = 0)"
  by (metis cyl_ext cyl_zero cyl_inf inf.commute join.le_bot)

lemma "cyl 1 \<cdot> x \<cdot> cyl 1 = cyl x"
  (*nitpick*)
  oops

text \<open>The following property holds in the relational model, but not in general.\<close>

lemma "(cyl x = x) = (cyl 1 \<cdot> x \<cdot> cyl 1 = x)"
  (*nitpick*)
  oops

end

text \<open>Next we consider iteration ... in fact the plus, we could do without a monoidal unit. We start with
near-dioids without a zero.\<close>

class cylindric_near_conway_un = cylindric_near_dioid_un + near_conway_base +
  assumes cyl_kplus: "cyl (x\<^sup>\<oplus>) \<le> (cyl x)\<^sup>\<oplus>"

begin

lemma cyl_dagger: "cyl x\<^sup>\<dagger> \<le> cyl 1 \<cdot> (cyl x)\<^sup>\<dagger>"
  by (metis cyl_ext mult_isor mult_onel)

lemma cyl_cyl_kplus [simp]: "cyl ((cyl x)\<^sup>\<oplus>) = (cyl x)\<^sup>\<oplus>"
  by (metis antisym cyl_ext cyl_kplus cyl_idem)

lemma cyl_kplus_onel [simp]: "cyl 1 \<cdot> (cyl x)\<^sup>\<oplus> = (cyl x)\<^sup>\<oplus>"
  by (metis cyl_cyl_kplus cyl_1_unl)

lemma cyl_kplus_one_shift [simp]: "cyl 1 \<cdot> (cyl x)\<^sup>\<oplus> = (cyl x)\<^sup>\<oplus> \<cdot> 1"
  by simp

lemma "(cyl 1)\<^sup>\<oplus> \<le> (cyl 1)"
  (*nitpick*)
  oops

end

text \<open>Some properties require order-preservation in the second argument of multiplication.\<close>

class cylindric_pre_conway_un = cylindric_near_conway_un + pre_conway_base

begin

lemma cyl_dagger_one: "cyl ((cyl x)\<^sup>\<dagger>) = cyl 1 \<cdot> (cyl x)\<^sup>\<dagger>"
  by (metis c3_iff cyl1_prop2 cyl_cyl_kplus cyl_kplus_onel dual_order.antisym kplus_dagger mult_1_right subdistl_var)

lemma cyl_star_one_shift: "cyl 1 \<cdot> (cyl x)\<^sup>\<dagger> = (cyl x)\<^sup>\<dagger> \<cdot> cyl 1"
  by (metis cyl_dagger_one c3_iff cyl_1_unr cyl_cyl_kplus dagger_unfoldl_distr kplus_dagger kplus_def)

end

text \<open>For Conway algebras based on near-l-monoids we have no special properties.\<close>

class near_conway_lattice = near_l_monoid + near_conway_base

begin

lemma dagger_meet: "(x \<sqinter> y)\<^sup>\<dagger> \<le> x\<^sup>\<dagger> \<sqinter> y\<^sup>\<dagger>"
  by (simp add: local.dagger_iso)

end

class cylindric_near_conway_lattice_un = cylindric_near_conway_un + near_conway_lattice

class near_conway_lattice_zerol = near_conway_lattice + near_conway_base_zerol

text \<open>Next, for the relational case, we present an alternative formalisation based on cylindrified units.
First we show that the axioms, which follow below, can be derived in Conway algebras.\<close>

class cylindric_near_conway_lattice_zerol_un = cylindric_near_conway_lattice_un + cylindric_near_l_monoid_zerol_un

begin

lemma cyl_1_zero: "cyl 1 \<cdot> 0 = 0"
  by (metis cyl_zero cyl_1_unl)

lemma "1 \<le> cyl 1"
  by (simp add: cyl_ext)

lemma "cyl 1 \<cdot> cyl 1 = cyl 1"
  by simp

lemma "(cyl 1 \<cdot> x \<cdot> cyl 1) \<sqinter> (cyl 1 \<cdot> y \<cdot> cyl 1) = cyl 1 \<cdot> (x \<sqinter> (cyl 1 \<cdot> y \<cdot> cyl 1)) \<cdot> cyl 1"
  (*nitpick*)
  oops

lemma "(\<forall>x. cyl x = cyl 1 \<cdot> x \<cdot> cyl 1) \<Longrightarrow> (cyl 1 \<cdot> x \<cdot> cyl 1) \<sqinter> (cyl 1 \<cdot> y \<cdot> cyl 1) = cyl 1 \<cdot> (x \<sqinter>  (cyl 1 \<cdot> y \<cdot> cyl 1)) \<cdot> cyl 1"
  by (metis cyl_inf)

lemma  "(\<forall>x. cyl x = cyl 1 \<cdot> x \<cdot> cyl 1) \<Longrightarrow> (\<forall>x. x \<cdot> 0 = 0) \<Longrightarrow> (cyl 1 \<cdot> x) \<sqinter> (cyl 1 \<cdot> y) = cyl 1 \<cdot> (x \<sqinter> (cyl 1 \<cdot> y))"
  (*nitpick*)
  oops

lemma  "(\<forall>x. cyl x = cyl 1 \<cdot> x \<cdot> cyl 1) \<Longrightarrow> (\<forall>x. x \<cdot> 0 = 0) \<Longrightarrow> (x \<cdot> cyl 1) \<sqinter> (y \<cdot> cyl 1) = (x \<sqinter> (y \<cdot> cyl 1)) \<cdot> cyl 1"
  (*nitpick*)
  oops

lemma "cyl 1 \<cdot> x\<^sup>\<oplus> \<cdot> cyl 1 \<le> (cyl 1 \<cdot> x)\<^sup>\<oplus> \<cdot> cyl 1"
  (*nitpick*)
  oops

lemma "(\<forall>x. cyl x = cyl 1 \<cdot> x \<cdot> cyl 1) \<Longrightarrow> cyl 1 \<cdot> x\<^sup>\<oplus> \<cdot> cyl 1 \<le> (cyl 1 \<cdot> x \<cdot> cyl 1)\<^sup>\<oplus>"
  by (metis cyl_kplus)

end

class cylindric_kleene_lattice_zerol_un = cylindric_near_conway_lattice_zerol_un + kleene_algebra_zerol

begin

definition "klplus x = x \<cdot> x\<^sup>\<star>"

lemma cyl_1_ast:"(cyl 1)\<^sup>\<star> \<le> cyl 1"
  by (simp add: local.cyl_ext local.star_inductl_one)

lemma cyl1_ast_eq [simp]: "(cyl 1)\<^sup>\<star> = cyl 1"
  by (simp add: local.boffa local.cyl_ext local.join.sup.absorb2)

lemma klplus_1: "klplus (cyl 1) \<le> cyl 1"
  by (simp add: klplus_def local.star_inductr_var_eq2)

lemma klplus_1_eq [simp]: "klplus (cyl 1) = cyl 1"
  by (simp add: klplus_def local.star_inductr_var_eq2)

lemma "x \<le> 1 \<Longrightarrow> \<not>(\<exists>y. x = cyl y)"
  (*nitpick*)
  oops

lemma "x < 1 \<Longrightarrow> cyl x = x"
  (*nitpick*)
  oops

end

text \<open>Next we present the axiomatisation with cylindrified units that works for relations.\<close>

class cy_conway_zerol = conway_base_zerol + near_l_monoid +
  fixes cy :: "'a"
  assumes cy1 [simp]: "cy \<cdot> 0 = 0"
  assumes cy2: "1 \<le> cy"
  assumes cy3: "cy \<cdot> cy \<le> cy"
  assumes cy4: "(cy \<cdot> x \<cdot> cy) \<sqinter> (cy \<cdot> y \<cdot> cy) \<le> cy \<cdot> (x \<sqinter> (cy \<cdot> y \<cdot> cy)) \<cdot> cy"

begin

lemma kplus_prop: "cy \<cdot> x\<^sup>\<oplus> \<cdot> cy \<le> (cy \<cdot> x)\<^sup>\<oplus> \<cdot> cy"
  by (metis local.cy2 local.dagger_iso local.kplus_def local.mult_1_left local.mult_isol local.mult_isor mult_assoc)

lemma cy_annir [simp]: "cy \<cdot> 0 \<cdot> cy = 0"
  by simp

lemma cy_idem [simp]: "cy \<cdot> cy = cy"
  using cy2 cy3 eq_iff mult_isol_var by fastforce

lemma cy_kplus_prop1 [simp]: "(cy \<cdot> x \<cdot> cy)\<^sup>\<oplus> = (cy \<cdot> x)\<^sup>\<oplus> \<cdot> cy"
  by (metis cy_idem local.dagger_slide_eq local.kplus_def mult_assoc)

lemma cy_kplus_prop2: "(cy \<cdot> x)\<^sup>\<oplus> \<cdot> cy = cy \<cdot> (x \<cdot> cy)\<^sup>\<oplus>"
  by (simp add: dagger_slide_eq kplus_def mult_assoc)

lemma cy_add: "cy \<cdot> (x + y) \<cdot> cy = (cy \<cdot> x \<cdot> cy) + (cy \<cdot> y \<cdot> cy)"
  by (simp add: distrib_left)

lemma cy_seq1: "cy \<cdot> x \<cdot> cy \<cdot> y \<cdot> cy \<cdot> cy = cy \<cdot> x \<cdot> cy \<cdot> cy \<cdot> y \<cdot> cy"
  by (simp add: mult_assoc)

lemma cy_seq2: "cy \<cdot> cy \<cdot> x \<cdot> cy \<cdot> y \<cdot> cy = cy \<cdot> x \<cdot> cy \<cdot> cy \<cdot> y \<cdot> cy"
  by (simp add: mult_assoc)

lemma  cy_meet: "cy \<cdot> (x \<sqinter> (cy \<cdot> y \<cdot> cy)) \<cdot> cy \<le> (cy \<cdot> x \<cdot> cy) \<sqinter> (cy \<cdot> y \<cdot> cy)"
  by (metis cy_idem inf.boundedI inf.cobounded1 inf.cobounded2 mult_double_iso mult_assoc)

end

text \<open>A formalisation of liberation algebras with one cylindrified unit follows.\<close>

class cyy_conway_zerol = conway_base_zerol + near_l_monoid +
  assumes cyy1: "cyy \<cdot> 0 \<le> 0"
  assumes cyy2: "1 \<le> cyy"
  assumes cyy4l: "(cyy \<cdot> x) \<sqinter> (cyy \<cdot> y) = cyy \<cdot> (x \<sqinter> (cyy \<cdot> y))"
  assumes cyy4r: "(x \<cdot> cyy) \<sqinter> (y \<cdot> cyy) = (x \<sqinter> (y \<cdot> cyy)) \<cdot> cyy"

begin

lemma cyy_trans: "cyy \<cdot> cyy \<le> cyy"
  by (metis local.cyy2 local.cyy4l local.inf.absorb_iff1 local.mult_oner)

lemma cyy_kplus: "cyy \<cdot> x\<^sup>\<oplus> \<le> (cyy \<cdot> x)\<^sup>\<oplus>"
  by (metis local.cyy2 local.dagger_iso local.kplus_def local.mult_1_left local.mult_isol local.mult_isor mult_assoc)

lemma cyy_kplus_var: "x\<^sup>\<oplus> \<cdot> cyy \<le> (x \<cdot> cyy)\<^sup>\<oplus>"
proof -
have f1: "\<forall>a. (a::'a)\<^sup>\<dagger> \<cdot> a = a\<^sup>\<oplus>"
by (metis local.dagger_slide_eq local.kplus_def local.mult_1_left mult_assoc)
  have "\<forall>a aa. (aa::'a)\<^sup>\<oplus> \<le> aa \<cdot> a \<or> \<not> aa\<^sup>\<dagger> \<le> a"
    using local.kplus_def local.mult_isol by force
then show ?thesis
  using f1 by (metis local.cyy2 local.dagger_iso local.dagger_slide_eq local.mult_1_left local.mult_isor mult_assoc)
qed

lemma cyy_meet: "(cyy \<cdot> x \<cdot> cyy) \<sqinter> (cyy \<cdot> y \<cdot> cyy) = cyy \<cdot> (x \<sqinter> (cyy \<cdot> y \<cdot> cyy)) \<cdot> cyy"
  by (metis local.cyy4l local.cyy4r mult_assoc)

lemma cyy_double_kplus: "cyy \<cdot> x\<^sup>\<oplus> \<cdot> cyy \<le> (cyy \<cdot> x)\<^sup>\<oplus> \<cdot> cyy"
  by (simp add: cyy_kplus local.mult_isor)

lemma cyy_right_kplus: "cyy \<cdot> (cyy \<cdot> x)\<^sup>\<oplus> = (cyy \<cdot> x)\<^sup>\<oplus>"
  by (metis local.absorp2 local.cyy4l local.dagger_ext local.dagger_slide_var1_eq local.dagger_unfoldl_distr local.inf.commute local.inf.orderE local.kplus_def local.mult_1_right mult_assoc)

lemma "1\<^sup>\<dagger> \<le> 1 \<Longrightarrow> cyy\<^sup>\<dagger> \<le> cyy"
  (*nitpick*)
  oops

end

text \<open>Finally we outline the first steps towards dual cylindrification.\<close>

class l_monoid_zerol = near_l_monoid_zerol + near_dioid_one_zerol

class dual_cylindric_l_monoid = l_monoid_zerol +
  fixes zy :: "'a \<Rightarrow> 'a"
  and dzy :: "'a \<Rightarrow> 'a"
  assumes zy_adj: "(zy x \<le> y) = (x \<le> dzy y)"
  assumes zy_seq1: "zy (x \<cdot> zy y) = zy x \<cdot> zy y"
  and zy_seq2: "zy (zy x \<cdot> y) = zy x \<cdot> zy y"
  and dzy_le_zy: "dzy x \<le> zy x"
  and zy_meet: "zy (x \<sqinter> zy y) = zy x \<sqinter> zy y"
  and dzy_join: "dzy (x + dzy y) = dzy x + dzy y"

begin

lemma dzy_zy: "dzy (zy x) = zy x"
  by (metis local.dzy_le_zy local.eq_refl local.inf.absorb_iff1 local.inf_absorb2 local.zy_adj local.zy_meet)

lemma zy_dzy: "zy (dzy x) = dzy x"
  by (metis dzy_zy local.eq_iff local.zy_adj)

lemma zy_iso: "x \<le> y \<Longrightarrow> zy x \<le> zy y"
  using local.order.trans local.zy_adj by blast

lemma dzy_iso: "x \<le> y \<Longrightarrow> dzy x \<le> dzy y"
  using local.order_trans local.zy_adj by blast

lemma zy_sup_pres: "zy (x + y) = zy x + zy y"
  apply (rule antisym)
  using local.zy_adj apply fastforce
  by (simp add: zy_iso)

lemma ccyl_inf_pres: "dzy (x \<sqinter> y) = dzy x \<sqinter> dzy y"
  apply (rule antisym)
  apply (simp add: dzy_iso)
  by (meson local.inf.boundedI local.inf.cobounded1 local.inf.cobounded2 local.zy_adj)

lemma cyl_canc1: "zy (dzy x) \<le> x"
  using local.zy_adj by auto

lemma cyl_canc3: "x \<le> dzy (zy x)"
  using local.zy_adj by blast

lemma cyl_zero: "zy 0 = 0"
  by (simp add: local.antisym local.zy_adj)

lemma cyl_infl: "x \<le> zy x"
  using cyl_canc3 local.dzy_zy by auto

lemma dzy_defl: "dzy x \<le> x"
  using cyl_canc1 local.zy_dzy by auto

lemma zy_dzy1: "zy (x \<cdot> dzy y) = zy x \<cdot> dzy y"
  by (metis local.zy_seq1 zy_dzy)

lemma dy_dzy2: "zy (dzy x \<cdot> y) = dzy x \<cdot> zy y"
  by (metis local.zy_seq2 zy_dzy)

end

end


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

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Star p) s) =
      (recognise (Plus Eps (Seq p (Star p))) s))"
  oops

end


theory Cuadrado2
imports Main
begin

text {* (cuadrado2 x) es el cuadrado de x. Por ejemplo,
     cuadrado2 3 = 9
*}
abbreviation cuadrado2 :: "int \<Rightarrow> int" where
  "cuadrado2 n \<equiv> n*n"

value "cuadrado2 3"
lemma "cuadrado2 3 = 9" by simp

end


(*
    Title:      QR_Decomposition.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>QR Decomposition\<close>

theory QR_Decomposition
imports Gram_Schmidt
begin

subsection\<open>The QR Decomposition of a matrix\<close>

text\<open>
First of all, it's worth noting what an orthogonal matrix is. In linear algebra,
an orthogonal matrix is a square matrix with real entries whose columns and rows are orthogonal
unit vectors.

Although in some texts the QR decomposition is presented over square matrices, it can be applied to any matrix.
There are some variants of the algorithm, depending on the properties that the output matrices
satisfy (see for instance, @{url "http://inst.eecs.berkeley.edu/~ee127a/book/login/l_mats_qr.html"}).
We present two of them below.

Let A be a matrix with m rows and n columns (A is \<open>m \<times> n\<close>).

Case 1: Starting with a matrix whose column rank is maximum. We can define the QR decomposition
to obtain:

\begin{itemize}
  \item @{term "A = Q ** R"}.
  \item Q has m rows and n columns. Its columns are orthogonal unit vectors
        and @{term "(transpose Q) * Q = mat 1"}. In addition, if A is a square matrix, then Q
        will be an orthonormal matrix.
  \item R is \<open>n \<times> n\<close>, invertible and upper triangular.
\end{itemize}

Case 2: The called full QR decomposition. We can obtain:
\begin{itemize}
 \item @{term "A = Q ** R"}
 \item Q is an orthogonal matrix (Q is \<open>m \<times> m\<close>).
 \item R is \<open>m \<times> n\<close> and upper triangular, but it isn't invertible.
\end{itemize}

We have decided to formalise the first one, because it's the only useful for solving
the linear least squares problem (@{url "http://math.mit.edu/linearalgebra/ila0403.pdf"}).

If we have an unsolvable system \<open>A *v x = b\<close>, we can try to find an approximate solution.
A plausible choice (not the only one) is to seek an \<open>x\<close> with the property that
\<open>\<parallel>A ** x - y\<parallel>\<close> (the magnitude of the error) is as small as possible. That \<open>x\<close>
is the least squares approximation.

We will demostrate that the best approximation (the solution for the linear least squares problem)
is the \<open>x\<close> that satisfies:

\<open>(transpose A) ** A *v x = (transpose A) *v b\<close>

Now we want to compute that x.

If we are working with the first case, \<open>A\<close> can be substituted by \<open>Q**R\<close> and then
obtain the solution of the least squares approximation by means of the QR decomposition:

\<open>x = (inverse R)**(transpose Q) *v b\<close>

On the contrary, if we are working with the second case after
substituting \<open>A\<close> by \<open>Q**R\<close> we obtain:

\<open>(transpose R) ** R *v x = (transpose R) ** (transpose Q) *v b\<close>

But the \<open>R\<close> matrix is not invertible (so neither is \<open>transpose R\<close>). The left part
of the equation \<open>(transpose R) ** R\<close> is not going to be an upper triangular matrix,
so it can't either be solved using backward-substitution.
\<close>

subsubsection\<open>Divide a vector by its norm\<close>

text\<open>An orthogonal matrix is a matrix whose rows (and columns) are orthonormal vectors. So, in order to
obtain the QR decomposition, we have to normalise (divide by the norm)
the vectors obtained with the Gram-Schmidt algorithm.\<close>

definition "divide_by_norm A  = (\<chi> a b. normalize (column b A) $ a)"

text\<open>Properties\<close>

lemma norm_column_divide_by_norm:
  fixes A::"'a::{real_inner}^'cols^'rows"
  assumes a: "column a A \<noteq> 0"
  shows "norm (column a (divide_by_norm A)) = 1"
proof -
  have not_0: "norm (\<chi> i. A $ i $ a) \<noteq> 0" by (metis a column_def norm_eq_zero)
  have "column a (divide_by_norm A) = (\<chi> i. (1 / norm (\<chi> i. A $ i $ a)) *\<^sub>R A $ i $ a)"
    unfolding divide_by_norm_def column_def normalize_def by auto
  also have "... =  (1 / norm (\<chi> i. A $ i $ a)) *\<^sub>R (\<chi> i.  A $ i $ a)"
    unfolding vec_eq_iff by auto
  finally have "norm (column a (divide_by_norm A)) = norm ((1 / norm (\<chi> i. A $ i $ a)) *\<^sub>R (\<chi> i.  A $ i $ a))"
    by simp
  also have "... = \<bar>1 / norm (\<chi> i. A $ i $ a)\<bar> * norm (\<chi> i. A $ i $ a)"
    unfolding norm_scaleR ..
  also have "... = (1 / norm (\<chi> i. A $ i $ a)) * norm (\<chi> i. A $ i $ a)"
    by auto
  also have "... = 1" using not_0 by auto
  finally show ?thesis .
qed

lemma span_columns_divide_by_norm:
  shows "span (columns A) = span (columns (divide_by_norm A))"
  unfolding real_vector.span_eq
proof (auto)
  fix x assume x: "x \<in> columns (divide_by_norm A)"
  from this obtain i where x_col_i: "x=column i (divide_by_norm A)" unfolding columns_def by blast
  also have "... = (1/norm (column i  A)) *\<^sub>R (column i A)"
    unfolding divide_by_norm_def column_def normalize_def by vector
  finally have x_eq: "x=(1/norm (column i A)) *\<^sub>R (column i A)" .
  show "x \<in> span (columns A)"
    by (unfold x_eq, rule span_mul, rule span_base, auto simp add: columns_def)
next
  fix x
  assume x: "x \<in> columns A"
  show "x \<in> span (columns (divide_by_norm A))"
  proof (cases "x=0")
    case True show ?thesis by (metis True span_0)
  next
    case False
    from x obtain i where x_col_i: "x=column i A" unfolding columns_def by blast
    have "x=column i A" using x_col_i .
    also have "... = norm (column i A) *\<^sub>R column i (divide_by_norm A)"
      using False unfolding x_col_i columns_def divide_by_norm_def column_def normalize_def by vector
    finally have x_eq: "x = norm (column i A) *\<^sub>R column i (divide_by_norm A)" .
    show "x \<in> span (columns (divide_by_norm A))"
      by (unfold x_eq, rule span_mul, rule span_base,
        auto simp add: columns_def Let_def)
  qed
qed

text\<open>Code lemmas\<close>

definition "divide_by_norm_row A a = vec_lambda(% b. ((1 / norm (column b A)) *\<^sub>R column b A) $ a)"

lemma divide_by_norm_row_code[code abstract]:
  "vec_nth (divide_by_norm_row A a) = (% b. ((1 / norm (column b A)) *\<^sub>R column b A) $ a)"
  unfolding divide_by_norm_row_def by (metis (lifting) vec_lambda_beta)

lemma divide_by_norm_code [code abstract]:
  "vec_nth (divide_by_norm A) = divide_by_norm_row A"
  unfolding divide_by_norm_def unfolding divide_by_norm_row_def[abs_def]
  unfolding normalize_def
  by fastforce

subsubsection\<open>The QR Decomposition\<close>

text\<open>The QR decomposition. Given a real matrix @{term "A"}, the algorithm will return a pair @{term "(Q,R)"}
  where @{term "Q"} is an matrix whose columns are orthogonal unit vectors, @{term "R"}
  is upper triangular and @{term "A=Q**R"}.\<close>

definition "QR_decomposition A = (let Q = divide_by_norm (Gram_Schmidt_matrix A) in (Q, (transpose Q) ** A))"

lemma is_basis_columns_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes b: "is_basis (columns A)"
  and c: "card (columns A) = ncols A"
  shows "is_basis (columns (fst (QR_decomposition A)))
  \<and> card (columns (fst (QR_decomposition A))) = ncols A"
proof (rule conjI, unfold is_basis_def, rule conjI)
  have "vec.span (columns (fst (QR_decomposition A))) = vec.span (columns (Gram_Schmidt_matrix A))"
    unfolding vec.span_eq
  proof (auto)
    fix x show "x \<in> vec.span (columns (Gram_Schmidt_matrix A))"
      using assms(1) assms(2) is_basis_columns_Gram_Schmidt_matrix is_basis_def by auto
  next
    fix x
    assume x: "x \<in> columns (Gram_Schmidt_matrix A)"
    from this obtain i where x_col_i: "x=column i (Gram_Schmidt_matrix A)" unfolding columns_def by blast
    have zero_not_in: "x \<noteq> 0" using is_basis_columns_Gram_Schmidt_matrix[OF b c] unfolding is_basis_def
      using vec.dependent_zero[of "(columns (Gram_Schmidt_matrix A))"] x by auto
    have "x=column i (Gram_Schmidt_matrix A)" using x_col_i .
    also have "... = norm (column i (Gram_Schmidt_matrix A)) *\<^sub>R column i (divide_by_norm (Gram_Schmidt_matrix A))"
      using zero_not_in unfolding x_col_i columns_def divide_by_norm_def column_def normalize_def by vector
    finally have x_eq: "x = norm (column i (Gram_Schmidt_matrix A)) *\<^sub>R column i (divide_by_norm (Gram_Schmidt_matrix A))" .
    show "x \<in> vec.span (columns (fst (QR_decomposition A)))"
      unfolding x_eq span_vec_eq
      apply (rule subspace_mul)
      apply (auto simp add: columns_def QR_decomposition_def Let_def subspace_span intro: span_superset)
      using span_superset by force
  qed
  thus s: "vec.span (columns (fst (QR_decomposition A))) = (UNIV::(real^'m::{mod_type}) set)"
    using is_basis_columns_Gram_Schmidt_matrix[OF b c] unfolding is_basis_def by simp
  thus "card (columns (fst (QR_decomposition A))) = ncols A"
    by (metis (hide_lams, mono_tags) b c card_columns_le_ncols vec.card_le_dim_spanning
      finite_columns vec.indep_card_eq_dim_span is_basis_def ncols_def top_greatest)
  thus "vec.independent (columns (fst (QR_decomposition A)))"
    by (metis s b c vec.card_eq_dim_span_indep finite_columns vec.indep_card_eq_dim_span is_basis_def)
qed

lemma orthogonal_fst_QR_decomposition:
  shows "pairwise orthogonal (columns (fst (QR_decomposition A)))"
  unfolding pairwise_def columns_def
proof (auto)
  fix i ia
  assume col_not_eq: "column i (fst (QR_decomposition A)) \<noteq> column ia (fst (QR_decomposition A))"
  hence i_not_ia: "i \<noteq> ia" by auto
  from col_not_eq obtain a
    where "(fst (QR_decomposition A)) $ a $ i \<noteq> (fst (QR_decomposition A)) $ a $ ia"
    unfolding column_def by force
  hence col_not_eq2: " (column i (Gram_Schmidt_matrix A)) \<noteq> (column ia (Gram_Schmidt_matrix A))"
    using col_not_eq unfolding QR_decomposition_def Let_def fst_conv
    by (metis (lifting) divide_by_norm_def vec_lambda_beta)
  have d1: "column i (fst (QR_decomposition A))
    = (1 / norm (\<chi> ia. Gram_Schmidt_matrix A $ ia $ i)) *\<^sub>R (column i (Gram_Schmidt_matrix A))"
    unfolding QR_decomposition_def Let_def fst_conv
    unfolding divide_by_norm_def column_def normalize_def unfolding vec_eq_iff by auto
  have d2: "column ia (fst (QR_decomposition A))
    = (1 / norm (\<chi> i. Gram_Schmidt_matrix A $ i $ ia)) *\<^sub>R (column ia (Gram_Schmidt_matrix A))"
    unfolding QR_decomposition_def Let_def fst_conv
    unfolding divide_by_norm_def column_def normalize_def unfolding vec_eq_iff by auto
  show "orthogonal (column i (fst (QR_decomposition A))) (column ia (fst (QR_decomposition A)))"
    unfolding d1 d2 apply (rule orthogonal_mult) using orthogonal_Gram_Schmidt_matrix[of A]
    unfolding pairwise_def using col_not_eq2 by auto
qed

lemma qk_uk_norm:
  "(1/(norm (column k ((Gram_Schmidt_matrix A))))) *\<^sub>R (column k ((Gram_Schmidt_matrix A)))
  = column k (fst(QR_decomposition A))"
  unfolding QR_decomposition_def Let_def fst_conv divide_by_norm_def
  unfolding column_def normalize_def by vector

lemma norm_columns_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes "rank A = ncols A"
  shows "norm (column i (fst (QR_decomposition A))) = 1"
proof -
  have "vec.independent (columns (Gram_Schmidt_matrix A))"
    by (metis assms full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix)
  hence "column i (Gram_Schmidt_matrix A) \<noteq> 0"
    using vec.dependent_zero[of "columns (Gram_Schmidt_matrix A)"]
    unfolding columns_def by auto
  thus "norm (column i (fst (QR_decomposition A))) = 1"
    unfolding QR_decomposition_def Let_def fst_conv
    by (rule norm_column_divide_by_norm)
qed

corollary span_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  shows "vec.span (columns A) = vec.span (columns (fst (QR_decomposition A)))"
  unfolding span_Gram_Schmidt_matrix[of A]
  unfolding QR_decomposition_def Let_def fst_conv
  by (metis \<open>span (columns A) = span (columns (Gram_Schmidt_matrix A))\<close> span_columns_divide_by_norm span_vec_eq)

corollary col_space_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  shows "col_space A = col_space (fst (QR_decomposition A))"
  unfolding col_space_def using span_fst_QR_decomposition
  by auto

lemma independent_columns_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes b: "vec.independent (columns A)"
  and c: "card (columns A) = ncols A"
  shows "vec.independent (columns (fst (QR_decomposition A)))
  \<and> card (columns (fst (QR_decomposition A))) = ncols A"
proof -
  have r: "rank A = ncols A" thm is_basis_imp_full_rank
  proof -
    have "rank A = col_rank A" unfolding rank_col_rank ..
    also have "... = vec.dim (col_space A)" unfolding col_rank_def ..
    also have "... = card (columns A)"
      unfolding col_space_def using b
      by (rule vec.dim_span_eq_card_independent)
    also have "... = ncols A" using c .
    finally show ?thesis .
  qed
  have "vec.independent (columns (fst (QR_decomposition A)))"
    by (metis b c col_rank_def col_space_QR_decomposition col_space_def
      full_rank_imp_is_basis2 vec.indep_card_eq_dim_span ncols_def rank_col_rank)
  moreover have "card (columns (fst (QR_decomposition A))) = ncols A"
    by (metis col_space_QR_decomposition full_rank_imp_is_basis2 ncols_def r rank_eq_dim_col_space')
  ultimately show ?thesis by simp
qed

lemma orthogonal_matrix_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "transpose (fst (QR_decomposition A)) ** (fst (QR_decomposition A)) = mat 1"
proof (unfold vec_eq_iff, clarify, unfold mat_1_fun, auto)
  define Q where "Q = fst (QR_decomposition A)"
  have n: "\<forall>i. norm (column i Q) = 1" unfolding Q_def using norm_columns_fst_QR_decomposition[OF r] by auto
  have c: "card (columns Q) = ncols A" unfolding Q_def
    by (metis full_rank_imp_is_basis2 independent_columns_fst_QR_decomposition r)
  have p: "pairwise orthogonal (columns Q)" by (metis Q_def orthogonal_fst_QR_decomposition)
  fix ia
  have "(transpose Q ** Q) $ ia $ ia = column ia Q \<bullet> column ia Q"
    unfolding matrix_matrix_mult_inner_mult unfolding row_transpose ..
  also have "... = 1" using n norm_eq_1 by blast
  finally show "(transpose Q ** Q) $ ia $ ia = 1" .
  fix i
  assume i_not_ia: "i \<noteq> ia"
  have column_i_not_ia: "column i Q \<noteq> column ia Q"
  proof (rule ccontr, simp)
    assume col_i_ia: "column i Q = column ia Q"
    have rw: "(\<lambda>i. column i Q)` (UNIV-{ia}) = {column i Q|i. i\<noteq>ia}" unfolding columns_def by auto
    have "card (columns Q) = card ({column i Q|i. i\<noteq>ia})"
      by (rule bij_betw_same_card[of id], unfold bij_betw_def columns_def, auto, metis col_i_ia i_not_ia)
    also have "... = card ((\<lambda>i. column i Q)` (UNIV-{ia}))" unfolding rw ..
    also have "... \<le> card (UNIV - {ia})" by (metis card_image_le finite_code)
    also have "... < CARD ('n)" by simp
    finally show False using c unfolding ncols_def by simp
  qed
  hence oia: "orthogonal (column i Q) (column ia Q)"
    using p unfolding pairwise_def unfolding columns_def by auto
  have "(transpose Q ** Q) $ i $ ia = column i Q \<bullet> column ia Q"
    unfolding matrix_matrix_mult_inner_mult unfolding row_transpose ..
  also have "... = 0" using oia unfolding orthogonal_def .
  finally show "(transpose Q ** Q) $ i $ ia = 0" .
qed

corollary orthogonal_matrix_fst_QR_decomposition':
  fixes A::"real^'n::{mod_type}^'n::{mod_type}"
  assumes "rank A = ncols A"
  shows "orthogonal_matrix (fst (QR_decomposition A))"
  by (metis assms orthogonal_matrix orthogonal_matrix_fst_QR_decomposition)

lemma column_eq_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  and c: "column i (fst (QR_decomposition A)) = column ia (fst (QR_decomposition A))"
  shows "i = ia"
proof (rule ccontr)
  assume i_not_ia: "i \<noteq> ia"
  have "columns  (fst (QR_decomposition A)) = (\<lambda>x. column x  (fst (QR_decomposition A)))` (UNIV::('n::{mod_type}) set)"
    unfolding columns_def by auto
  also have "... = (\<lambda>x. column x  (fst (QR_decomposition A)))` ((UNIV::('n::{mod_type}) set)-{ia})"
  proof (unfold image_def, auto)
    fix xa
    show "\<exists>x\<in>UNIV - {ia}. column xa  (fst (QR_decomposition A)) = column x  (fst (QR_decomposition A))"
    proof (cases "xa = ia")
      case True thus ?thesis using c i_not_ia by (metis DiffI UNIV_I empty_iff insert_iff)
    next
      case False thus ?thesis by auto
    qed
  qed
  finally have columns_rw: "columns  (fst (QR_decomposition A))
    = (\<lambda>x. column x  (fst (QR_decomposition A))) ` (UNIV - {ia})" .
  have "ncols A = card (columns  (fst (QR_decomposition A)))"
    by (metis full_rank_imp_is_basis2 independent_columns_fst_QR_decomposition r)
  also have "... \<le> card (UNIV - {ia})" unfolding columns_rw by (rule card_image_le, simp)
  also have "... = card (UNIV::'n set) - 1" by (simp add: card_Diff_singleton)
  finally show False unfolding ncols_def
    by (metis Nat.add_0_right Nat.le_diff_conv2 One_nat_def Suc_n_not_le_n add_Suc_right one_le_card_finite)
qed

corollary column_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "column k ((Gram_Schmidt_matrix A))
  = (column k A) - (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> (column k A) / (x \<bullet> x)) *\<^sub>R x)"
proof -
  let ?uk="column k ((Gram_Schmidt_matrix A))"
  let ?qk="column k (fst(QR_decomposition A))"
  let ?ak="(column k A)"
  define f where "f x = (1/norm x) *\<^sub>R x" for x :: "real^'m::{mod_type}"
  let ?g="\<lambda>x::real^'m::{mod_type}. (x \<bullet> (column k A) / (x \<bullet> x)) *\<^sub>R x"
  have set_rw: "{column i (fst (QR_decomposition A))|i. i < k} = f`{column i (Gram_Schmidt_matrix A)|i. i < k}"
  proof (auto)
    fix i
    assume i: "i < k"
    have col_rw: "column i (fst (QR_decomposition A)) =
      (1/norm (column i (Gram_Schmidt_matrix A))) *\<^sub>R (column i (Gram_Schmidt_matrix A))"
      unfolding QR_decomposition_def Let_def fst_conv divide_by_norm_def column_def normalize_def by vector
    thus "column i (fst (QR_decomposition A)) \<in> f ` {column i (Gram_Schmidt_matrix A) |i. i < k}"
      unfolding f_def using i
      by auto
    show "\<exists>ia. f (column i (Gram_Schmidt_matrix A)) = column ia (fst (QR_decomposition A)) \<and> ia < k"
      by (rule exI[of _ i], simp add: f_def col_rw i)
  qed
  have "(\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)
    = (\<Sum>x\<in>(f`{column i (Gram_Schmidt_matrix A)|i. i < k}). (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)"
    unfolding set_rw ..
  also have "... = sum (?g  \<circ> f) {column i (Gram_Schmidt_matrix A)|i. i < k}"
  proof (rule sum.reindex, unfold inj_on_def, auto)
    fix i ia assume i: "i < k" and ia: "ia < k"
      and f_eq: "f (column i (Gram_Schmidt_matrix A)) = f (column ia (Gram_Schmidt_matrix A))"
    have fi: "f (column i (Gram_Schmidt_matrix A)) = column i (fst (QR_decomposition A))"
      unfolding f_def QR_decomposition_def Let_def fst_conv divide_by_norm_def column_def normalize_def
      by vector
    have fia: "f (column ia (Gram_Schmidt_matrix A)) = column ia (fst (QR_decomposition A))"
      unfolding f_def QR_decomposition_def Let_def fst_conv divide_by_norm_def column_def normalize_def
      by vector
    have "i = ia" using column_eq_fst_QR_decomposition[OF r] f_eq unfolding fi fia by simp
    thus "column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_matrix A)" by simp
  qed
  also have "... =  (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i.
    i < k}. ((1 / norm x) *\<^sub>R x \<bullet> ?ak / ((1 / norm x) *\<^sub>R x \<bullet> (1 / norm x) *\<^sub>R x)) *\<^sub>R (1 / norm x) *\<^sub>R x)" unfolding o_def f_def ..
  also have "... =  (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i.
    i < k}. ((1 / norm x) *\<^sub>R x \<bullet> ?ak)  *\<^sub>R (1 / norm x) *\<^sub>R x)"
  proof (rule sum.cong, simp)
    fix x assume x: "x \<in> {column i (Gram_Schmidt_matrix A) |i. i < k}"
    have "vec.independent {column i (Gram_Schmidt_matrix A) |i. i < k}"
    proof (rule vec.independent_mono[of "columns (Gram_Schmidt_matrix A)"])
      show "vec.independent (columns (Gram_Schmidt_matrix A))"
        using full_rank_imp_is_basis2[of "(Gram_Schmidt_matrix A)"]
        by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r)
      show "{column i (Gram_Schmidt_matrix A) |i. i < k} \<subseteq> columns (Gram_Schmidt_matrix A)"
        unfolding columns_def by auto
    qed
    hence "x \<noteq> 0" using vec.dependent_zero[of " {column i (Gram_Schmidt_matrix A) |i. i < k}"] x
      by blast
    hence "((1 / norm x) *\<^sub>R x \<bullet> (1 / norm x) *\<^sub>R x) = 1" by (metis inverse_eq_divide norm_eq_1 norm_sgn sgn_div_norm)
    thus "((1 / norm x) *\<^sub>R x \<bullet> ?ak / ((1 / norm x) *\<^sub>R x \<bullet> (1 / norm x) *\<^sub>R x)) *\<^sub>R (1 / norm x) *\<^sub>R x =
      ((1 / norm x) *\<^sub>R x \<bullet> column k A) *\<^sub>R (1 / norm x) *\<^sub>R x" by auto
  qed
  also have "... = (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (((x \<bullet> ?ak)) / (x \<bullet> x)) *\<^sub>R x)"
  proof (rule sum.cong, simp)
    fix x
    assume x: "x \<in> {column i (Gram_Schmidt_matrix A) |i. i < k}"
    show "((1 / norm x) *\<^sub>R x \<bullet> column k A) *\<^sub>R (1 / norm x) *\<^sub>R x = (x \<bullet> column k A / (x \<bullet> x)) *\<^sub>R x"
      by (metis (hide_lams, no_types) mult.right_neutral inner_commute inner_scaleR_right
        norm_cauchy_schwarz_eq scaleR_one scaleR_scaleR times_divide_eq_right times_divide_times_eq)
  qed
  finally have "?ak - (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)
    = ?ak - (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (((x \<bullet> ?ak)) / (x \<bullet> x)) *\<^sub>R x)" by auto
  also have "... = ?uk" using column_Gram_Schmidt_matrix[of k A] by auto
  finally show ?thesis ..
qed

lemma column_QR_decomposition':
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(column k A) = column k ((Gram_Schmidt_matrix A))
  + (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> (column k A) / (x \<bullet> x)) *\<^sub>R x)"
  using column_QR_decomposition[OF r] by simp

lemma norm_uk_eq:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "norm (column k ((Gram_Schmidt_matrix A))) = ((column k (fst(QR_decomposition A))) \<bullet> (column k A))"
proof -
  let ?uk="column k ((Gram_Schmidt_matrix A))"
  let ?qk="column k (fst(QR_decomposition A))"
  let ?ak="(column k A)"
  have sum_rw: "(?uk \<bullet> (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)) = 0"
  proof -
    have "(?uk \<bullet> (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x))
      = ((\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. ?uk \<bullet> ((x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)))"
      unfolding inner_sum_right ..
    also have "... = (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. ((x \<bullet> ?ak / (x \<bullet> x)) * (?uk \<bullet> x)))"
      unfolding inner_scaleR_right ..
    also have "... = 0"
    proof (rule sum.neutral, clarify)
      fix x i assume "i<k"
      hence "?uk \<bullet> column i (Gram_Schmidt_matrix A) = 0"
        by (metis less_irrefl r scaleR_columns_Gram_Schmidt_matrix)
      thus "column i (Gram_Schmidt_matrix A) \<bullet> ?ak / (column i (Gram_Schmidt_matrix A) \<bullet> column i (Gram_Schmidt_matrix A)) *
        (?uk \<bullet> column i (Gram_Schmidt_matrix A)) = 0" by auto
    qed
    finally show ?thesis .
  qed
  have "?qk \<bullet> ?ak = ((1/(norm ?uk)) *\<^sub>R ?uk) \<bullet> ?ak" unfolding qk_uk_norm ..
  also have "... = (1/(norm ?uk)) * (?uk \<bullet> ?ak)" unfolding inner_scaleR_left ..
  also have "... =
    (1/(norm ?uk)) * (?uk \<bullet> (?uk + (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)))"
    using column_Gram_Schmidt_matrix2[of k A] by auto
  also have "... = (1/(norm ?uk)) * ((?uk \<bullet> ?uk) + (?uk \<bullet> (\<Sum>x\<in>{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)))"
    unfolding inner_add_right ..
  also have "... = (1/(norm ?uk)) * (?uk \<bullet> ?uk)" unfolding sum_rw by auto
  also have "... = norm ?uk"
    by (metis abs_of_nonneg divide_eq_imp div_by_0 inner_commute inner_ge_zero inner_real_def
      norm_mult_vec real_inner_1_right real_norm_def times_divide_eq_right)
  finally show ?thesis ..
qed

corollary column_QR_decomposition2:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(column k A)
  = (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i \<le> k}. (x \<bullet> (column k A)) *\<^sub>R x)"
proof -
  let ?uk="column k ((Gram_Schmidt_matrix A))"
  let ?qk="column k (fst(QR_decomposition A))"
  let ?ak="(column k A)"
  have set_rw: "{column i (fst (QR_decomposition A))|i. i \<le> k}
    = insert (column k (fst (QR_decomposition A))) {column i (fst (QR_decomposition A))|i. i < k}"
    by (auto, metis less_linear not_less)
  have uk_norm_uk_qk: "?uk = norm ?uk *\<^sub>R ?qk"
  proof -
    have "vec.independent (columns (Gram_Schmidt_matrix A))"
      by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r)
    moreover have "?uk \<in> columns (Gram_Schmidt_matrix A)" unfolding columns_def by auto
    ultimately have "?uk \<noteq> 0"
      using vec.dependent_zero[of "columns (Gram_Schmidt_matrix A)"] unfolding columns_def by auto
    hence norm_not_0: "norm ?uk \<noteq> 0" unfolding norm_eq_zero .
    have "norm (?uk) *\<^sub>R ?qk = (norm ?uk) *\<^sub>R ((1 / norm ?uk) *\<^sub>R ?uk)" using qk_uk_norm[of k A] by simp
    also have "... = ((norm ?uk) * (1 / norm ?uk)) *\<^sub>R ?uk" unfolding scaleR_scaleR ..
    also have "... = ?uk" using norm_not_0 by auto
    finally show ?thesis ..
  qed
  have norm_qk_1: "?qk  \<bullet> ?qk = 1"
    using norm_eq_1 norm_columns_fst_QR_decomposition[OF r]
    by auto
  have "?ak = ?uk + (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)"
    using column_QR_decomposition'[OF r] by auto
  also have "... = (norm ?uk *\<^sub>R ?qk)  + (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)"
    using uk_norm_uk_qk by simp
  also have "... = ((?qk \<bullet> ?ak) *\<^sub>R ?qk)
    + (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)"
    unfolding norm_uk_eq[OF r] ..
  also have "... = ((?qk \<bullet> ?ak)/(?qk \<bullet> ?qk)) *\<^sub>R ?qk
    + (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)" using norm_qk_1 by fastforce
  also have "... = (\<Sum>x\<in>insert ?qk {column i (fst (QR_decomposition A))|i. i < k}. (x \<bullet> ?ak / (x \<bullet> x)) *\<^sub>R x)"
  proof (rule sum.insert[symmetric])
    show "finite {column i (fst (QR_decomposition A)) |i. i < k}" by simp
    show "column k (fst (QR_decomposition A)) \<notin> {column i (fst (QR_decomposition A)) |i. i < k}"
    proof (rule ccontr, simp)
      assume "\<exists>i. column k (fst (QR_decomposition A)) = column i (fst (QR_decomposition A)) \<and> i < k"
      from this obtain i where col_eq: "column k (fst (QR_decomposition A)) = column i (fst (QR_decomposition A))"
        and i_less_k: "i < k" by blast
      show False using column_eq_fst_QR_decomposition[OF r col_eq] i_less_k by simp
    qed
  qed
  also have "... = (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i \<le> k}. (x \<bullet> (column k A)) *\<^sub>R x)"
  proof (rule sum.cong, simp add: set_rw)
    fix x assume x: "x \<in> {column i (fst (QR_decomposition A)) |i. i \<le> k}"
    from this obtain i where i: "x=column i (fst (QR_decomposition A))" by blast
    hence "(x \<bullet> x) = 1" using norm_eq_1 norm_columns_fst_QR_decomposition[OF r]
      by auto
    thus "(x \<bullet> column k A / (x \<bullet> x)) *\<^sub>R x = (x \<bullet> column k A) *\<^sub>R x" by simp
  qed
  finally show ?thesis .
qed

lemma orthogonal_columns_fst_QR_decomposition:
  assumes i_not_ia: "(column i (fst (QR_decomposition A))) \<noteq> (column ia (fst (QR_decomposition A)))"
  shows "(column i (fst (QR_decomposition A)) \<bullet> column ia (fst (QR_decomposition A))) = 0"
proof -
  have i: "column i (fst (QR_decomposition A)) \<in> columns (fst (QR_decomposition A))" unfolding columns_def by auto
  have ia: "column ia (fst (QR_decomposition A)) \<in> columns (fst (QR_decomposition A))" unfolding columns_def by auto
  show ?thesis
    using orthogonal_fst_QR_decomposition[of A] i ia i_not_ia unfolding pairwise_def orthogonal_def
    by auto
qed

lemma scaler_column_fst_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes i: "i>j"
  and r: "rank A = ncols A"
  shows "column i (fst (QR_decomposition A)) \<bullet> column j A = 0"
proof -
  have "column i (fst(QR_decomposition A)) \<bullet> column j A
    = column i (fst (QR_decomposition A)) \<bullet> (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i \<le> j}. (x \<bullet> (column j A)) *\<^sub>R x)"
    using column_QR_decomposition2[OF r] by presburger
  also have "... = (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i \<le> j}.
    column i (fst (QR_decomposition A)) \<bullet> (x \<bullet> (column j A)) *\<^sub>R x)" unfolding real_inner_class.inner_sum_right ..
  also have "... = (\<Sum>x\<in>{column i (fst (QR_decomposition A))|i. i \<le> j}.
    (x \<bullet> (column j A)) *(column i (fst (QR_decomposition A)) \<bullet> x))" unfolding real_inner_class.inner_scaleR_right ..
  also have "... = 0"
  proof (rule sum.neutral, clarify)
    fix ia assume ia: "ia \<le> j"
    have i_not_ia: "i \<noteq> ia" using i ia by simp
    hence "(column i (fst (QR_decomposition A)) \<noteq> column ia (fst (QR_decomposition A)))"
      by (metis column_eq_fst_QR_decomposition r)
    hence "(column i (fst (QR_decomposition A)) \<bullet> column ia (fst (QR_decomposition A))) = 0"
      by (rule orthogonal_columns_fst_QR_decomposition)
    thus "column ia (fst (QR_decomposition A)) \<bullet> column j A * (column i (fst (QR_decomposition A)) \<bullet> column ia (fst (QR_decomposition A))) = 0"
      by auto
  qed
  finally show ?thesis .
qed

lemma R_Qi_Aj:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  shows "(snd (QR_decomposition A)) $ i $ j = column i (fst (QR_decomposition A)) \<bullet> column j A"
  unfolding QR_decomposition_def Let_def snd_conv matrix_matrix_mult_inner_mult
  unfolding row_transpose by auto

lemma sums_columns_Q_0:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "(\<Sum>x\<in>{column i (fst (QR_decomposition A)) |i. i>b}. x \<bullet> column b A * x $ a) = 0"
proof (rule sum.neutral, auto)
  fix i assume "b<i"
  thus "column i (fst (QR_decomposition A)) \<bullet> column b A = 0"
    by (rule scaler_column_fst_QR_decomposition, simp add: r)
qed

lemma QR_decomposition_mult:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "A = (fst (QR_decomposition A)) ** (snd (QR_decomposition A))"
proof -
  have "\<forall>b. column b A = column b ((fst (QR_decomposition A)) ** (snd (QR_decomposition A)))"
  proof (clarify)
    fix b
    have "(fst (QR_decomposition A) ** snd (QR_decomposition A))
      =  (\<chi> i j. \<Sum>k\<in>UNIV. fst (QR_decomposition A) $ i $ k * (column k (fst (QR_decomposition A)) \<bullet> column j A))"
      unfolding matrix_matrix_mult_def R_Qi_Aj by auto
    hence "column b ((fst (QR_decomposition A) ** snd (QR_decomposition A))) =
      column b ((\<chi> i j. \<Sum>k\<in>UNIV. fst (QR_decomposition A) $ i $ k * (column k (fst (QR_decomposition A)) \<bullet> column j A)))"
      by auto
    also have "... = (\<Sum>x\<in>{column i (fst (QR_decomposition A)) |i. i \<le> b}. (x \<bullet> column b A) *\<^sub>R x)"
    proof (subst column_def, subst vec_eq_iff, auto)
      fix a
      define f where "f i = column i (fst (QR_decomposition A))" for i
      define g where "g x = (THE i. x = column i (fst (QR_decomposition A)))" for x
      have f_eq: "f`UNIV = {column i (fst (QR_decomposition A)) |i. i\<in>UNIV}" unfolding f_def by auto
      have inj_f: "inj f"
        by (metis inj_on_def f_def column_eq_fst_QR_decomposition r)
      have "(\<Sum>x\<in>{column i (fst (QR_decomposition A)) |i. i \<le> b}. x \<bullet> column b A * x $ a)
        = (\<Sum>x\<in>{column i (fst (QR_decomposition A)) |i. i\<in>UNIV}. x \<bullet> column b A * x $ a)"
      proof -
        let ?c= "{column i (fst (QR_decomposition A)) |i. i\<in>UNIV}"
        let ?d= "{column i (fst (QR_decomposition A)) |i. i\<le>b}"
        let ?f = "{column i (fst (QR_decomposition A)) |i. i>b}"
        have set_rw: "?c = ?d \<union> ?f" by force
        have "(\<Sum>x\<in>?c. x \<bullet> column b A * x $ a)
          = (\<Sum>x\<in>(?d \<union> ?f). x \<bullet> column b A * x $ a)" using set_rw by simp
        also have "... = (\<Sum>x\<in>?d. x \<bullet> column b A * x $ a) + (\<Sum>x\<in>?f. x \<bullet> column b A * x $ a)"
          by (rule sum.union_disjoint, auto, metis f_def inj_eq inj_f not_le)
        also have "... = (\<Sum>x\<in>?d. x \<bullet> column b A * x $ a)" using sums_columns_Q_0[OF r] by auto
        finally show ?thesis ..
      qed
      also have "... = (\<Sum>x\<in>f`UNIV. x \<bullet> column b A * x $ a)" using f_eq by auto
      also have "... = (\<Sum>k\<in>UNIV. fst (QR_decomposition A) $ a $ k * (column k (fst (QR_decomposition A)) \<bullet> column b A))"
        unfolding sum.reindex[OF inj_f] unfolding f_def column_def by (rule sum.cong, simp_all)
      finally show " (\<Sum>k\<in>UNIV. fst (QR_decomposition A) $ a $ k * (column k (fst (QR_decomposition A)) \<bullet> column b A)) =
        (\<Sum>x\<in>{column i (fst (QR_decomposition A)) |i. i \<le> b}. x \<bullet> column b A * x $ a)" ..
    qed
    also have "... = column b A"
      using column_QR_decomposition2[OF r] by simp
    finally show "column b A = column b (fst (QR_decomposition A) ** snd (QR_decomposition A))" ..
  qed
  thus ?thesis unfolding column_def vec_eq_iff by auto
qed

lemma upper_triangular_snd_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "upper_triangular (snd (QR_decomposition A))"
proof (unfold upper_triangular_def, auto)
  fix i j::'n
  assume j_less_i: "j < i"
  have "snd (QR_decomposition A) $ i $ j = column i (fst (QR_decomposition A)) \<bullet> column j A"
    unfolding QR_decomposition_def Let_def fst_conv snd_conv
    unfolding matrix_matrix_mult_inner_mult row_transpose ..
  also have "... = 0" using scaler_column_fst_QR_decomposition[OF j_less_i r] .
  finally show "snd (QR_decomposition A) $ i $ j = 0" by auto
qed

lemma upper_triangular_invertible:
  fixes A :: "real^'n::{finite,wellorder}^'n::{finite,wellorder}"
  assumes u: "upper_triangular A"
  and d: "\<forall>i. A $ i $ i \<noteq> 0"
  shows "invertible A"
proof -
  have det_R: "det A = (prod (\<lambda>i. A$i$i) (UNIV::'n set))"
    using det_upperdiagonal u unfolding upper_triangular_def by blast
  also have "... \<noteq> 0" using d by auto
  finally show ?thesis by (metis invertible_det_nz)
qed

lemma invertible_snd_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "invertible (snd (QR_decomposition A))"
proof (rule upper_triangular_invertible)
  show "upper_triangular (snd (QR_decomposition A))"
    using upper_triangular_snd_QR_decomposition[OF r] .
  show "\<forall>i. snd (QR_decomposition A) $ i $ i \<noteq> 0"
  proof (rule allI)
    fix i
    have ind: "vec.independent (columns (Gram_Schmidt_matrix A))"
      by (metis full_rank_imp_is_basis2
        independent_columns_Gram_Schmidt_matrix r)
    hence zero_not_in: "0 \<notin> (columns (Gram_Schmidt_matrix A))" by (metis vec.dependent_zero)
    hence c:"column i (Gram_Schmidt_matrix A) \<noteq> 0" unfolding columns_def by simp
    have "snd (QR_decomposition A) $ i $ i = column i (fst (QR_decomposition A)) \<bullet> column i A"
      unfolding QR_decomposition_def Let_def snd_conv fst_conv
      unfolding matrix_matrix_mult_inner_mult
      unfolding row_transpose ..
    also have "... = norm (column i (Gram_Schmidt_matrix A))"
      unfolding norm_uk_eq[OF r, symmetric] ..
    also have "... \<noteq> 0" by (rule ccontr, simp add: c)
    finally show "snd (QR_decomposition A) $ i $ i \<noteq> 0" .
  qed
qed

lemma QR_decomposition:
  fixes A::"real^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "A = fst (QR_decomposition A) ** snd (QR_decomposition A) \<and>
  pairwise orthogonal (columns (fst (QR_decomposition A))) \<and>
  (\<forall>i. norm (column i (fst (QR_decomposition A))) = 1) \<and>
  (transpose (fst (QR_decomposition A))) ** (fst (QR_decomposition A)) = mat 1 \<and>
  vec.independent (columns (fst (QR_decomposition A))) \<and>
  col_space A = col_space (fst (QR_decomposition A)) \<and>
  card (columns A) = card (columns (fst (QR_decomposition A))) \<and>
  invertible (snd (QR_decomposition A)) \<and>
  upper_triangular (snd (QR_decomposition A))"
  by (metis QR_decomposition_mult col_space_def full_rank_imp_is_basis2
    independent_columns_fst_QR_decomposition invertible_snd_QR_decomposition
    norm_columns_fst_QR_decomposition orthogonal_fst_QR_decomposition
    orthogonal_matrix_fst_QR_decomposition r span_fst_QR_decomposition
    upper_triangular_snd_QR_decomposition)

lemma QR_decomposition_square:
  fixes A::"real^'n::{mod_type}^'n::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "A = fst (QR_decomposition A) ** snd (QR_decomposition A) \<and>
  orthogonal_matrix (fst (QR_decomposition A)) \<and>
  upper_triangular (snd (QR_decomposition A)) \<and>
  invertible (snd (QR_decomposition A)) \<and>
  pairwise orthogonal (columns (fst (QR_decomposition A))) \<and>
  (\<forall>i. norm (column i (fst (QR_decomposition A))) = 1) \<and>
  vec.independent (columns (fst (QR_decomposition A))) \<and>
  col_space A = col_space (fst (QR_decomposition A)) \<and>
  card (columns A) = card (columns (fst (QR_decomposition A)))"
  by (metis QR_decomposition orthogonal_matrix_fst_QR_decomposition' r)

text\<open>QR for computing determinants\<close>

lemma det_QR_decomposition:
  fixes A::"real^'n::{mod_type}^'n::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "\<bar>det A\<bar> = \<bar>(prod (\<lambda>i. snd(QR_decomposition A)$i$i) (UNIV::'n set))\<bar>"
proof -
  let ?Q="fst(QR_decomposition A)"
  let ?R="snd(QR_decomposition A)"
  have det_R: "det ?R = (prod (\<lambda>i. snd(QR_decomposition A)$i$i) (UNIV::'n set))"
    apply (rule det_upperdiagonal)
    using upper_triangular_snd_QR_decomposition[OF r]
    unfolding upper_triangular_def by simp
  have "\<bar>det A\<bar> = \<bar>det ?Q * det ?R\<bar>" by (metis QR_decomposition_mult det_mul r)
  also have "... = \<bar>det ?Q\<bar> * \<bar>det ?R\<bar>" unfolding abs_mult ..
  also have "... = 1 * \<bar>det ?R\<bar>" using det_orthogonal_matrix[OF orthogonal_matrix_fst_QR_decomposition'[OF r]]
    by auto
  also have "... = \<bar>det ?R\<bar>" by simp
  also have "... = \<bar>(prod (\<lambda>i. snd(QR_decomposition A)$i$i) (UNIV::'n set))\<bar>" unfolding det_R ..
  finally show ?thesis .
qed

end


theory Sep_Generic_Wp
imports
  "../lib/Sep_Algebra_Add"
  "../lib/Frame_Infer"
begin

section \<open>General VCG Setup for Separation Logic\<close>

(* TODO: Move to Library *)

locale generic_wp_defs =
  fixes wp :: "'e \<Rightarrow> 'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
begin
  definition "htripleF e \<alpha> I F P c Q \<equiv> (\<forall>s. I s \<and> (P**F) (\<alpha> s) \<longrightarrow>
      wp e c (\<lambda>r s'. I s' \<and> (Q r ** F) (\<alpha> s')) s)"

  definition "htriple e \<alpha> I P c Q \<equiv> (\<forall>F s. I s \<and> (P**F) (\<alpha> s) \<longrightarrow>
      wp e c (\<lambda>r s'. I s' \<and> (Q r ** F) (\<alpha> s')) s)"

  lemma htriple_as_F_eq: "htriple e \<alpha> I P c Q = (\<forall>F. htripleF e \<alpha> I F P c Q)"
    unfolding htriple_def htripleF_def by blast

end

locale generic_wp = generic_wp_defs wp
  for wp :: "'e \<Rightarrow> 'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" +
  assumes wp_comm_inf: "inf (wp e c Q) (wp e c Q') = wp e c (inf Q Q')"
begin

  lemma wp_comm_conj: "wp e c (\<lambda>r. Q r and Q' r) s \<longleftrightarrow> wp e c Q s \<and> wp e c Q' s"
    using wp_comm_inf[of e c Q Q']
    unfolding inf_fun_def inf_bool_def by metis

  lemma wp_comm_conjI: "\<lbrakk> wp e c Q s; wp e c Q' s \<rbrakk> \<Longrightarrow> wp e c (\<lambda>r s. Q r s \<and> Q' r s) s"
    using wp_comm_inf[of e c Q Q']
    unfolding inf_fun_def inf_bool_def by metis

  lemma wp_mono: "Q\<le>Q' \<Longrightarrow> wp e c Q \<le> wp e c Q'"
    by (metis (mono_tags) antisym_conv le_inf_iff order_refl wp_comm_inf)

  lemma wp_monoI:
    assumes "wp e c Q s"
    assumes "\<And>r x. Q r x \<Longrightarrow> Q' r x"
    shows "wp e c Q' s"
    using assms wp_mono[of Q Q' e c] by auto

  lemma htripleI:
    assumes "\<And>F s. I s \<Longrightarrow> (P**F) (\<alpha> s) \<Longrightarrow> wp e c (\<lambda>r s'. I s' \<and> (Q r ** F) (\<alpha> s')) s"
    shows "htriple e \<alpha> I P c Q"
    using assms by (auto simp: htriple_def)

  lemma htripleFI:
    assumes "\<And>s. I s \<Longrightarrow> (P**F) (\<alpha> s) \<Longrightarrow> wp e c (\<lambda>r s'. I s' \<and> (Q r ** F) (\<alpha> s')) s"
    shows "htripleF e \<alpha> I F P c Q"
    using assms by (auto simp: htripleF_def)

  lemma htripleD:
    assumes "htriple e \<alpha> I P c Q"
    assumes "I s"
    assumes "(P**F) (\<alpha> s)"
    shows "wp e c (\<lambda>r s'. I s' \<and> (Q r ** F) (\<alpha> s')) s"
    using assms by (auto simp: htriple_def)

  lemma htriple_triv[simp, intro!]: "htriple e \<alpha> I sep_false c Q"
    by (auto simp: htriple_def)

  lemma frame_rule: "htriple e \<alpha> I P c Q \<Longrightarrow> htriple e \<alpha> I (P ** F) c (\<lambda>r. Q r ** F)"
    unfolding htriple_def
    by (fastforce)

  lemma cons_rule:
    assumes "htriple e \<alpha> I P c Q"
    assumes "\<And>s. P' s \<Longrightarrow> P s"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple e \<alpha> I P' c Q'"
    unfolding htriple_def
  proof clarsimp
    fix F s
    assume I: "I s"
    assume "(P' \<and>* F) (\<alpha> s)"
    with assms(2) have "(P \<and>* F) (\<alpha> s)"
      using sep_conj_impl1 by blast
    with assms(1) have "wp e c (\<lambda>r s'. I s' \<and> (Q r \<and>* F) (\<alpha> s')) s"
      unfolding htriple_def using I by auto
    thus "wp e c (\<lambda>r s'. I s' \<and> (Q' r \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using assms(3)
      using sep_conj_impl1 by blast
  qed

  lemma cons_post_rule:
    assumes "htriple e \<alpha> I P c Q"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple e \<alpha> I P c Q'"
    using cons_rule assms by blast

  lemma htriple_alt:
    "htriple e \<alpha> I P c Q
      = (\<forall>p s f. I s \<and> p##f \<and> \<alpha> s = p + f \<and> P p \<longrightarrow> wp e c (\<lambda>r s'. I s' \<and> (\<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p')) s)"
  proof (rule iffI, goal_cases)
    case 1
    show ?case
      using htripleD[OF 1, where F="EXACT x" for x]
        by (auto simp: sep_conj_def)

  next
    case 2
    show ?case proof (rule htripleI)
      fix F s
      assume I: "I s"
      assume "(P \<and>* F) (\<alpha> s)"
      then obtain p f where "p##f" "P p" "F f" "\<alpha> s = p+f"
        by (blast elim: sep_conjE)
      with 2 I have "wp e c (\<lambda>r s'. I s' \<and> (\<exists>p'. p' ## f \<and> \<alpha> s' = p' + f \<and> Q r p')) s" by blast
      then show "wp e c (\<lambda>r s'. I s' \<and> (Q r \<and>* F) (\<alpha> s')) s"
        apply (rule wp_monoI)
        using \<open>F f\<close> by (auto intro: sep_conjI)
    qed
  qed

  lemma htripleI':
    assumes "\<And>p s f. \<lbrakk> p##f; I s; \<alpha> s = p + f; P p\<rbrakk> \<Longrightarrow> wp e c (\<lambda>r s'. I s' \<and> (\<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p')) s"
    shows "htriple e \<alpha> I P c Q"
    using assms by (auto simp: htriple_alt)

  lemma htripleD':
    assumes "htriple e \<alpha> I P c Q"
    assumes "p##f" "I s" "\<alpha> s = p + f" "P p"
    shows "wp e c (\<lambda>r s'. I s' \<and> (\<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p')) s"
    using assms by (auto simp: htriple_alt)

  lemma htriple_extract_pre_pure:
    "htriple e \<alpha> I (\<up>\<Phi>**P) c Q \<longleftrightarrow> \<Phi> \<longrightarrow> htriple e \<alpha> I P c Q"
    by (cases \<Phi>) (auto simp: sep_algebra_simps)

  (*
  lemma htriple_extract_pre_EXS:
    assumes "\<And>x s. \<Phi> x \<Longrightarrow> P s \<Longrightarrow> f x ## s"
    shows "htriple e \<alpha> (EXS x. \<up>\<Phi> x ** EXACT (f x) ** P) c Q \<longleftrightarrow> (\<exists>x. \<Phi> x \<and> htriple e \<alpha> (EXACT (f x) ** P) c Q)"
    apply rule
  *)

  thm htripleD

  thm option.simps

  lemma sv_htripleD:
    assumes "htriple e \<alpha> I P c Q"
    assumes "I s"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. I s \<Longrightarrow> (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp e c Q' s"
    using assms
    by (force simp: htriple_def intro: wp_monoI)

  lemma sv_htripleFD:
    assumes "htripleF e \<alpha> I F P c Q"
    assumes "I s"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. I s \<Longrightarrow> (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp e c Q' s"
    using assms
    by (force simp: htripleF_def intro: wp_monoI)

  lemma htriple_conj_pure:
    fixes \<alpha>
    assumes "htriple e \<alpha> I P c Q"
    assumes "htriple e \<alpha> I P c (\<lambda>r. \<up>\<Phi> r ** sep_true)"
    shows "htriple e \<alpha> I P c (\<lambda>r. \<up>\<Phi> r ** Q r)"
  proof (rule htripleI)
    fix F s
    assume I: "I s"
    assume "(P**F) (\<alpha> s)"
    from wp_comm_conjI[OF assms[THEN htripleD,OF I this]]
    show "wp e c (\<lambda>r s'. I s' \<and> ((\<up>\<Phi> r \<and>* Q r) \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using and_pure_true I unfolding entails_def by blast

  qed

end

(* experiment begin
  text \<open>Precondition defined by semantics relation:
    \<^item> \<open>T c s\<close> command terminates in state \<open>s\<close>
    \<^item> \<open>R c s r s'\<close> command yields result \<open>r\<close> and new state \<open>s'\<close>
  \<close>

  definition "my_wp T (R::_ \<Rightarrow> 's\<Rightarrow>_\<Rightarrow>'s\<Rightarrow>bool) c Q s \<equiv> T c s \<and> (\<forall>r s'. R c s r s' \<longrightarrow> Q r s')"

  interpretation generic_wp "my_wp T R"
    apply unfold_locales
    unfolding my_wp_def
    by auto

end *)

definition STATE :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where "STATE \<alpha> I P s \<equiv> I s \<and> P (\<alpha> s)"

lemma STATE_assn_cong[fri_extract_congs]: "P\<equiv>P' \<Longrightarrow> STATE \<alpha> I P s \<equiv> STATE \<alpha> I P' s" by simp

lemma STATE_extract[vcg_normalize_simps]:
  "STATE \<alpha> I (\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> I \<box> h"
  "STATE \<alpha> I (\<up>\<Phi> ** P) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> I P h"
  "STATE \<alpha> I (EXS x. Q x) h \<longleftrightarrow> (\<exists>x. STATE \<alpha> I (Q x) h)"
  "STATE \<alpha> I (\<lambda>_. False) h \<longleftrightarrow> False"
  "STATE \<alpha> I ((\<lambda>_. False) ** P) h \<longleftrightarrow> False"
  by (auto simp: STATE_def sep_algebra_simps pred_lift_extract_simps)

definition POSTCOND :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where [vcg_tag_defs]: "POSTCOND \<alpha> I \<equiv> STATE \<alpha> I"

lemma POSTCONDI:
  "STATE \<alpha> I A h \<Longrightarrow> POSTCOND \<alpha> I A h"
  by (auto simp add: POSTCOND_def)
lemma POSTCOND_cong[vcg_normalize_congs]: "POSTCOND \<alpha> I A = POSTCOND \<alpha> I A" ..

lemma POSTCOND_triv_simps[vcg_normalize_simps]:
  "I h \<Longrightarrow> POSTCOND \<alpha> I sep_true h"
  "\<not>POSTCOND \<alpha> I sep_false h"
  unfolding POSTCOND_def STATE_def by auto

(* lemma STATE_imp_inv[vcg_normalize_simps]: "STATE \<alpha> I P h \<Longrightarrow> I h"
  unfolding STATE_def by simp *)

lemma start_entailsE:
  assumes "STATE \<alpha> I P h"
  assumes "ENTAILS P P'"
  shows "STATE \<alpha> I P' h"
  using assms unfolding STATE_def ENTAILS_def entails_def
  by auto

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms POSTCONDI},@{binding postcond_xformer},
    fn ctxt => eresolve_tac ctxt @{thms start_entailsE}
  ))
\<close>

named_theorems htriple_vcg_intros
named_theorems htriple_vcg_intro_congs
definition [vcg_tag_defs]: "DECOMP_HTRIPLE \<phi> \<equiv> \<phi>"
lemma DECOMP_HTRIPLEI: "\<phi> \<Longrightarrow> DECOMP_HTRIPLE \<phi>" unfolding vcg_tag_defs by simp

context generic_wp begin
  thm frame_rule
  thm cons_rule

  lemma htriple_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> I P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htriple e \<alpha> I P c Q"
    assumes P: "\<And>r s. STATE \<alpha> I (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp e c Q' s"
  proof -
    from S have I: "I s"
      unfolding STATE_def by simp
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleD[OF HT I])

  qed

  lemma htripleF_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> I P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htripleF e \<alpha> I F P c Q"
    assumes P: "\<And>r s. STATE \<alpha> I (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp e c Q' s"
  proof -
    from S have I: "I s"
      unfolding STATE_def by simp
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleFD[OF HT I])

  qed

  lemma htriple_vcgI':
    assumes "\<And>F s. STATE \<alpha> I (P**F) s \<Longrightarrow> wp e c (\<lambda>r. POSTCOND \<alpha> I (Q r ** F)) s"
    shows "htriple e \<alpha> I P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def by simp

  lemma htriple_vcgI[htriple_vcg_intros]:
    assumes "\<And>F s. STATE \<alpha> I (P**F) s \<Longrightarrow> EXTRACT (wp e c (\<lambda>r. POSTCOND \<alpha> I (Q r ** F)) s)"
    shows "htriple e \<alpha> I P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def by simp

  lemma htripleF_vcgI[htriple_vcg_intros]:
    assumes "\<And>s. STATE \<alpha> I (P**F) s \<Longrightarrow> EXTRACT (wp e c (\<lambda>r. POSTCOND \<alpha> I (Q r ** F)) s)"
    shows "htripleF e \<alpha> I F P c Q"
    apply (rule htripleFI)
    using assms unfolding vcg_tag_defs STATE_def by simp

  lemma htriple_decompI[vcg_decomp_rules]:
    "DECOMP_HTRIPLE (htriple e \<alpha> I P c Q) \<Longrightarrow> htriple e \<alpha> I P c Q"
    "DECOMP_HTRIPLE (htripleF e \<alpha> I F P c Q) \<Longrightarrow> htripleF e \<alpha> I F P c Q"
    unfolding vcg_tag_defs by auto

  lemma htriple_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htriple e \<alpha> I P c Q \<equiv> htriple e \<alpha> I P' c Q'" by simp

  lemma htripleF_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htripleF e \<alpha> I F P c Q \<equiv> htripleF e \<alpha> I F P' c Q'" by simp

  lemma htriple_ent_pre:
    "P\<turnstile>P' \<Longrightarrow> htriple e \<alpha> I P' c Q \<Longrightarrow> htriple e \<alpha> I P c Q"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_ent_post:
    "\<lbrakk>\<And>r. Q r \<turnstile> Q' r\<rbrakk> \<Longrightarrow> htriple e \<alpha> I P c Q \<Longrightarrow> htriple e \<alpha> I P c Q'"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_pure_preI: "\<lbrakk>pure_part P \<Longrightarrow> htriple e \<alpha> I P c Q\<rbrakk> \<Longrightarrow> htriple e \<alpha> I P c Q"
    by (meson htriple_def pure_partI sep_conjE)

  lemma htripleF_pure_preI: "\<lbrakk>pure_part P \<Longrightarrow> htripleF e \<alpha> I F P c Q\<rbrakk> \<Longrightarrow> htripleF e \<alpha> I F P c Q"
    by (meson htripleF_def pure_partI sep_conjE)

  lemma htriple_strengthen_inv:
    assumes "htriple e \<alpha> I P c Q"
    assumes "\<And>s. I' s \<Longrightarrow> I s"
    assumes "\<And>F s. I' s \<Longrightarrow> I s \<Longrightarrow> wp e c (\<lambda>r s'. I s' \<and> (Q r \<and>* F) (\<alpha> s')) s \<Longrightarrow> wp e c (\<lambda>_. I') s"
    shows "htriple e \<alpha> I' P c Q"
    using assms
    unfolding htriple_def
    apply clarify
    apply (rule wp_comm_conjI)
    using wp_monoI apply fastforce
    using assms(1) sv_htripleD by fastforce

end

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms DECOMP_HTRIPLEI},@{binding decomp_htriple_xformer},
    fn ctxt =>
      (full_simp_tac (put_simpset HOL_basic_ss ctxt
        addsimps (Named_Theorems.get ctxt @{named_theorems vcg_tag_defs})
        |> fold Simplifier.add_cong (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intro_congs})
      ))
      THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intros})
  ))
\<close>

section \<open>WP from inductive\<close>

locale wp_from_inductive =
  fixes rel :: "'e \<Rightarrow> 'c \<Rightarrow> 's \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool"
begin

definition valid :: "'e \<Rightarrow> 'c \<Rightarrow> 's \<Rightarrow> bool" where
  "valid e c s \<equiv> \<exists>r s'. rel e c s r s'"

definition wlp :: "'e \<Rightarrow> 'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" where
  "wlp e c Q s \<equiv> \<forall>r s'. rel e c s r s' \<longrightarrow> Q r s'"

definition wp :: "'e \<Rightarrow> 'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" where
  "wp e c Q s \<equiv> valid e c s \<and> wlp e c Q s"

sublocale generic_wp wp
  apply standard
  unfolding wp_def valid_def wlp_def
  by fastforce

lemma validI: "rel e c s r s' \<Longrightarrow> valid e c s"
  unfolding valid_def by auto
lemma validE:
  assumes "valid e c s"
  obtains r s' where "rel e c s r s'"
  using assms unfolding valid_def by auto

lemma wlpI: "(\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s') \<Longrightarrow> wlp e c Q s"
  unfolding wlp_def by auto
lemma wlpD:
  assumes "wlp e c Q s"
  shows "\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s'"
  using assms unfolding wlp_def by auto

lemma wpI: "rel e c s r s' \<Longrightarrow> (\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s') \<Longrightarrow> wp e c Q s"
  unfolding wp_def by (auto intro: validI wlpI)
lemma wpD:
  assumes "wp e c Q s"
  shows "\<exists>r s'. rel e c s r s' \<and> Q r s'" "\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s'"
  using assms unfolding wp_def by (auto dest: wlpD elim!: validE)
lemma wpE:
  assumes "wp e c Q s"
  obtains r s' where "rel e c s r s'"  "Q r s'" "\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s'"
  using assms unfolding wp_def
  using valid_def wlpD by fastforce
lemma wpE_concrete:
  assumes "wp e c Q s"
  obtains r s' where "rel e c s r s'" "Q r s'"
  using assms by (rule wpE)

lemma wp_to_wp:
  assumes "wp e c Q s"
    "\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s' \<Longrightarrow> \<exists> r' s''. rel e c' s r' s''"
    "(\<And>r s'. rel e c s r s' \<Longrightarrow> Q r s') \<Longrightarrow> (\<And>r' s''. rel e c' s r' s'' \<Longrightarrow> Q' r' s'')"
  shows "wp e c' Q' s"
  using assms
  by (metis wpE wpI)
end

subsection \<open>Deterministic inductives\<close>
locale wp_from_inductive_determ = wp_from_inductive +
  assumes determ: "rel e c s r s' \<Longrightarrow> rel e c s r' s'' \<Longrightarrow> r=r' \<and> s'=s''"
begin

lemma wlp_determI: "rel e c s r s' \<Longrightarrow> Q r s' \<Longrightarrow> wlp e c Q s"
  using determ wlpI by blast

lemma wp_determI: "rel e c s r s' \<Longrightarrow>  Q r s' \<Longrightarrow> wp e c Q s"
  unfolding wp_def by (auto intro: validI wlp_determI)

lemma wp_determE:
  assumes "wp e c Q s"
  obtains r s' where "rel e c s r s'" "Q r s'" "\<And>r' s''. rel e c s r' s'' \<Longrightarrow> (r' = r \<and> s'' = s')"
  by (metis assms determ wpD(1))
end

end