(* Title:  Stuff.thy
   Author: Lars Noschinski, TU München
*)

theory Stuff
imports
  Main
  "HOL-Library.Extended_Real"

begin

section {* Additional theorems for base libraries *}

text {*
  This section contains lemmas unrelated to graph theory which might be
  interesting for the Isabelle distribution
*}

lemma ereal_Inf_finite_Min:
  fixes S :: "ereal set"
  assumes "finite S" and "S \<noteq> {}"
  shows "Inf S = Min S"
using assms
by (induct S rule: finite_ne_induct) (auto simp: min_absorb1)

lemma finite_INF_in:
  fixes f :: "'a \<Rightarrow> ereal"
  assumes "finite S"
  assumes "S \<noteq> {}"
  shows "(INF s: S. f s) \<in> f ` S"
proof -
  from assms
  have "finite (f ` S)" "f ` S \<noteq> {}" by auto
  then show "Inf (f ` S) \<in> f ` S"
    using ereal_Inf_finite_Min [of "f ` S"]  by simp
qed

lemma not_mem_less_INF:
  fixes f :: "'a \<Rightarrow> 'b :: complete_lattice"
  assumes "f x < (INF s: S. f s)"
  assumes "x \<in> S"
  shows "False"
using assms by (metis INF_lower less_le_not_le)

lemma sym_diff:
  assumes "sym A" "sym B" shows "sym (A - B)"
using assms by (auto simp: sym_def)

subsection {* List *}

lemmas list_exhaust2 = list.exhaust[case_product list.exhaust]

lemma list_exhaust_NSC:
  obtains (Nil) "xs = []" | (Single) x where "xs = [x]" | (Cons_Cons) x y ys where "xs = x # y # ys"
by (metis list.exhaust)

lemma tl_rev:
  "tl (rev p) = rev (butlast p)"
by (induct p) auto

lemma butlast_rev:
  "butlast (rev p) = rev (tl p)"
by (induct p) auto

lemma take_drop_take:
   "take n xs @ drop n (take m xs) = take (max n m) xs"
proof cases
  assume "m < n" then show ?thesis by (auto simp: max_def)
next
  assume "\<not>m < n"
  then have "take n xs = take n (take m xs)" by (auto simp: min_def)
  then show ?thesis by (simp del: take_take add: max_def)
qed

lemma drop_take_drop:
  "drop n (take m xs) @ drop m xs = drop (min n m) xs"
proof cases
  assume A: "\<not>m < n"
  then show ?thesis
    using drop_append[of n "take m xs" "drop m xs"]
  by (cases "length xs < n") (auto simp: not_less min_def)
qed (auto simp: min_def)

lemma not_distinct_decomp_min_prefix:
  assumes "\<not> distinct ws"
  shows "\<exists> xs ys zs y. ws = xs @ y # ys @ y # zs \<and> distinct xs \<and> y \<notin> set xs \<and> y \<notin> set ys "
proof -
  obtain xs y ys where "y \<in> set xs" "distinct xs" "ws = xs @ y # ys"
    using assms by (auto simp: not_distinct_conv_prefix)
  moreover then obtain xs' ys' where "xs = xs' @ y # ys'" by (auto simp: in_set_conv_decomp)
  ultimately show ?thesis by auto
qed

lemma not_distinct_decomp_min_not_distinct:
  assumes "\<not> distinct ws"
  shows "\<exists>xs y ys zs. ws = xs @ y # ys @ y # zs \<and> distinct (ys @ [y])"
using assms
proof (induct ws)
  case (Cons w ws)
  show ?case
  proof (cases "distinct ws")
    case True
    then obtain xs ys where "ws = xs @ w # ys" "w \<notin> set xs"
      using Cons.prems by (fastforce dest: split_list_first)
    then have "distinct (xs @ [w])" "w # ws = [] @ w # xs @ w # ys"
      using `distinct ws` by auto
    then show ?thesis by blast
  next
    case False
    then obtain xs y ys zs where "ws = xs @ y # ys @ y # zs \<and> distinct (ys @ [y])"
      using Cons by auto
    then have "w # ws = (w # xs) @ y # ys @ y # zs \<and> distinct (ys @ [y])"
      by simp
    then show ?thesis by blast
  qed
qed simp

lemma card_Ex_subset:
  "k \<le> card M \<Longrightarrow> \<exists>N. N \<subseteq> M \<and> card N = k"
by (induct rule: inc_induct) (auto simp: card_Suc_eq)

lemma list_set_tl: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
by (cases xs) auto

section {* NOMATCH simproc *}

text {*
 The simplification procedure can be used to avoid simplification of terms of a certain form
*}

definition NOMATCH :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "NOMATCH val pat \<equiv> True"
lemma NOMATCH_cong[cong]: "NOMATCH val pat = NOMATCH val pat" by (rule refl)

simproc_setup NOMATCH ("NOMATCH val pat") = {* fn _ => fn ctxt => fn ct =>
  let
    val thy = Proof_Context.theory_of ctxt
    val dest_binop = Term.dest_comb #> apfst (Term.dest_comb #> snd)
    val m = Pattern.matches thy (dest_binop (Thm.term_of ct))
  in if m then NONE else SOME @{thm NOMATCH_def} end
*}

text {*
  This setup ensures that a rewrite rule of the form @{term "NOMATCH val pat \<Longrightarrow> t"}
  is only applied, if the pattern @{term pat} does not match the value @{term val}.
*}

end


(* Title:      Atoms
   Author:     Insa Stucke (ist@informatik.uni-kiel.de)
*)

theory Relation_Algebra_Atoms imports "$AFP/Relation_Algebra/Relation_Algebra"
                                       "$AFP/Relation_Algebra/Relation_Algebra_Functions"
                                       "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Points"
begin

text{* Facts about atom are outsourced to this file. *}

context relation_algebra_fin_points

begin

definition is_atom:: "'a \<Rightarrow> bool"
  where "is_atom x \<equiv> x\<noteq>0 \<and> x\<^sup>\<smile>;1;x \<le> 1' \<and> x;1;x\<^sup>\<smile> \<le> 1'"

lemma topatoms: "\<Squnion> {p;q\<^sup>\<smile>|p q. is_point p \<and> is_point q} = 1"
proof -
  have "1 = \<Squnion> {p|p. is_point p};(\<Squnion> {q|q. is_point q})\<^sup>\<smile>"
    using pointaxiom by auto
  also have "\<dots> = \<Squnion> {p|p. is_point p};(\<Squnion> {q\<^sup>\<smile>|q. is_point q})"
    using setsum_fun_add' finiteness by auto
  also have "\<dots> = \<Squnion> {p;q\<^sup>\<smile>|p q. is_point p \<and> is_point q}"
    using finiteness sum_sum_add_comp by blast
  finally show ?thesis
    by simp
qed

lemma pointssetcomp: "{x. \<exists> p q. p;q\<^sup>\<smile>=x \<and> is_point p \<and> is_point q} = {p;q\<^sup>\<smile>|p q. is_point p \<and> is_point q}"
by blast

lemma atompoint:
  assumes "is_atom x"
  shows "is_point (x;1)"
proof -
have a: "is_inj (x;1)"
  by (metis assms is_atom_def conv_contrav conv_one is_inj_def mult_assoc one_idem_mult)
have b: "(x;1)\<noteq>0"
  using assms is_atom_def ss_p18 by auto
have c: "is_vector (x;1)"
   by (simp add: comp_assoc is_vector_def)
thus ?thesis
  by (simp add: a b is_point_def)
qed

lemma atompointcnv:
  assumes "is_atom x"
  shows "is_point (x\<^sup>\<smile>;1)"
by (metis assms atompoint is_atom_def conv_invol conv_zero)

lemma atompoints:
  assumes "is_atom x"
  shows "\<exists> p q. x=p;q\<^sup>\<smile> \<and> is_point p \<and> is_point q"
proof -
  have hp: "is_point (x;1)"
    using atompoint assms by blast
  have hq: "is_point (x\<^sup>\<smile>;1)"
    using atompointcnv assms by blast
  have "x = (x;1);(x\<^sup>\<smile>;1)\<^sup>\<smile>"
    proof (rule antisym)
      show "x \<le> (x;1);(x\<^sup>\<smile>;1)\<^sup>\<smile>"
        by (metis conv_contrav conv_invol conv_one dedekind inf_top_left one_idem_mult)
      show "(x;1);(x\<^sup>\<smile>;1)\<^sup>\<smile> \<le> x"
        by (metis hq conv_invol conv_one dedekind_var_1 inf.absorb2 inf_top_right one_idem_mult point_cnv_map ss423 top_greatest)
    qed
  thus ?thesis
    using hp hq by blast
qed

lemma pointsatom:
  assumes "is_point p"
  and "is_point q"
  shows "is_atom (p;q\<^sup>\<smile>)"
proof (unfold is_atom_def, intro conjI)
  show "(p;q\<^sup>\<smile>)\<noteq>0"
    by (simp add: assms comp_points)
  show "(p;q\<^sup>\<smile>)\<^sup>\<smile>;1;(p;q\<^sup>\<smile>) \<le> 1'"
    by (metis assms comp_assoc conv_contrav conv_invol is_inj_def is_point_def is_vector_def points_surj surj_tx)
  show "(p;q\<^sup>\<smile>);1;(p;q\<^sup>\<smile>)\<^sup>\<smile> \<le> 1'"
    by (metis assms conv_contrav conv_one is_inj_def is_point_def is_vector_def mult_assoc points_surj surj_tx)
qed

lemma atomeqpoints: "{x|x. is_atom x} = {x. \<exists> p q. p;q\<^sup>\<smile>=x \<and> is_point p \<and> is_point q}"
proof (rule subset_antisym[OF subsetI subsetI])
  show "\<And>x. x \<in> {x |x. is_atom x} \<Longrightarrow> x \<in> {x. \<exists>p q. p;q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q}"
  using atompoints by fastforce
next
  show "\<And>x. x \<in> {x. \<exists>p q. p;q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q} \<Longrightarrow> x \<in> {x |x. is_atom x}"
  proof
  fix y::'a
  assume ypoints: "y \<in> {x. \<exists>p q. p;q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q}"
  show "\<exists>x. y = x \<and> is_atom x"
    proof
      obtain p q where h1: "p;q\<^sup>\<smile> = y \<and> is_point p \<and> is_point q"
        using ypoints by blast
      have catom: "is_atom (p;q\<^sup>\<smile>)"
        using h1 pointsatom by blast
      show "y = y \<and> is_atom y"
        using catom h1 by blast
    qed
  qed
qed

lemma topatoms': "\<Squnion> {x|x. is_atom x} = 1"
using atomeqpoints pointssetcomp topatoms by auto

lemma atominj:
  assumes "is_atom x"
  shows "is_inj x"
by (meson assms is_atom_def conv_galois_2 dual_order.trans is_inj_def maddux_20)

lemma atompfun:
  assumes "is_atom x"
  shows "is_p_fun x"
by (metis assms is_atom_def comp_assoc dual_order.trans is_p_fun_def maddux_21 mult_isol)

lemma atomtrans:
  assumes "is_atom x"
  shows "is_trans x"
proof (unfold is_trans_def)
  show "x;x \<le> x"
    proof -
      have "x;x \<le> x;1 \<cdot> 1;x"
        by (simp add: mult_isol_var)
      also have "\<dots> \<le> x;x\<^sup>\<smile>;1;x"
        by (metis inf_top.left_neutral modular_1_var mult.semigroup_axioms semigroup.assoc)
      also have "\<dots> \<le> x"
        using assms is_atom_def comp_assoc mult_isol by fastforce
      finally show ?thesis
        using dual_order.trans is_trans_def by blast
    qed
qed

lemma atomid:
  assumes "is_atom x"
  shows "x;x \<le> 1'"
proof -
  have "x;x \<le> x;x \<cdot> x"
    using assms atomtrans inf_absorb1 is_trans_def by auto
  also have "\<dots>  \<le> (x \<cdot> x;x\<^sup>\<smile>);(x \<cdot> x\<^sup>\<smile>;x)"
    using dedekind by blast
  also have "\<dots> \<le> x;x\<^sup>\<smile>;x\<^sup>\<smile>;x"
    by (metis comp_assoc inf.cobounded2 mult_isol_var)
  also have "\<dots> \<le> 1';x\<^sup>\<smile>;x"
    using assms atominj is_inj_def mult_isor by blast
  finally show ?thesis
    by (metis assms atompfun dual_order.trans is_p_fun_def mult_1_left)
qed

lemma atomdisj:
  assumes "is_atom x"
  and "is_atom y"
  and "x\<noteq>y"
  shows "x\<cdot>y \<le> 0"
proof -
  obtain p q where h1: "p ; q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q"
    using assms(1) atompoints by blast
  obtain r s where h2: "r ; s\<^sup>\<smile> = y \<and> is_point r \<and> is_point s"
    using assms(2) atompoints by blast
  have noteq: "p\<noteq>r \<or> q\<noteq>s"
    using assms(3) h1 h2 by blast
  have noteq: "p\<^sup>\<smile>;r \<le> 0 \<or> s\<^sup>\<smile>;q \<le> 0"
    using h1 h2 noteq pointcompbot by blast
  have "x\<cdot>y = p;q\<^sup>\<smile> \<cdot> r;s\<^sup>\<smile>"
    by (simp add: h1 h2)
  also have "\<dots> \<le> (p \<cdot> r;s\<^sup>\<smile>;q);(q\<^sup>\<smile> \<cdot> p\<^sup>\<smile>;r;s\<^sup>\<smile>)"
    by (metis comp_assoc conv_invol dedekind)
  also have "(p \<cdot> r;s\<^sup>\<smile>;q);(q\<^sup>\<smile> \<cdot> p\<^sup>\<smile>;r;s\<^sup>\<smile>) \<le> 0"
    using bot_unique mult_assoc noteq by fastforce
  finally show ?thesis
    by simp
qed

lemma pwd_points: "pairwise_disjoint {x |x.\<exists> p q. p;q\<^sup>\<smile>=x \<and> is_point p \<and> is_point q}"
using atomdisj le_bot pointsatom pairwise_disjoint_def by auto

lemma pwd_points_eq: "pairwise_disjoint {x |x.\<exists> p. p;p\<^sup>\<smile>=x \<and> is_point p}"
proof -
  have a: "{x |x.\<exists> p. p;p\<^sup>\<smile>=x \<and> is_point p} \<subseteq> {x |x.\<exists> p q. p;q\<^sup>\<smile>=x \<and> is_point p \<and> is_point q}"
    by blast
  thus ?thesis
    using pwd_mon pwd_points by blast
qed

lemma atomsareatoms:
  assumes "is_point p"
  and "is_point q"
  and "is_point r"
  and "is_point s"
  and "p;q\<^sup>\<smile>=r;s\<^sup>\<smile>"
  shows "p=r \<and> q=s"
proof (rule conjI)
  show "q = s"
  proof -
    have a: "p \<le> r;s\<^sup>\<smile>;q"
      by (metis assms comp_assoc maddux_20 pointcomptop)
    have b: "r;s\<^sup>\<smile>;q \<noteq> 0"
      by (metis a assms comp_assoc comp_points le_bot points_surj ss_p18 surj_tx)
    have c: "s\<^sup>\<smile>;q \<noteq> 0"
      using b annir comp_assoc by force
    thus ?thesis using assms c pointcompbot by blast
  qed
next
  show "p=r"
  proof -
    have a: "p;q\<^sup>\<smile>=r;q\<^sup>\<smile>"
      by (metis assms is_point_def is_vector_def mult.semigroup_axioms points_surj surj_tx semigroup.assoc)
    thus ?thesis
      by (metis assms comp_assoc is_point_def is_vector_def pointcomptop)
  qed
qed

lemma fin_points: "finite {x |x. \<exists>p q. p;q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q}"
proof -
  have a: "{x |x. \<exists>p q. p;q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q} = {p;q\<^sup>\<smile>|p q. is_point p \<and> is_point q}"
    by blast
  have b: " finite {p;q\<^sup>\<smile>|p q. is_point p \<and> is_point q}"
    by (metis atomeqpoints bot_unique is_atom_def pointssetcomp sum.infinite top_greatest topatoms' not_finite_existsD)
  thus ?thesis
    using a by auto
qed

lemma fin_atoms: "finite {x |x. is_atom x}"
proof -
  have a: "{x |x. is_atom x} = {x |x. \<exists>p q. p;q\<^sup>\<smile> = x \<and> is_point p \<and> is_point q}"
    using atompoints pointsatom by blast
  thus ?thesis
    using a fin_points by auto
qed

lemma fin_atoms': "finite {x. is_atom x}"
using fin_atoms by auto

lemma fin_atoms_p: "finite {x |x. is_atom x \<and> P x}"
by (simp add: Collect_mono fin_atoms')

lemma atom_lattice_atom:
  assumes "is_atom x"
  and "y\<noteq>0"
  and "y \<le> x"
  shows "y = x"
proof (rule univalent_antisym)
  show "is_p_fun x"
    by (simp add: assms atompfun)
  show "x; 1 \<le> y;1"
    by (metis assms atompoint comp_assoc inf_absorb2 is_vector_def mult_subdistr one_idem_mult point_lattice_atom ss_p18)
  show "y \<le> x"
    by (simp add: assms)
qed

lemma leq_atom_rel:
  assumes "is_atom x"
  and "y \<le> x"
  shows "y=x \<or> y \<le> 0"
using assms atom_lattice_atom by fastforce

lemma leq_atom_rel':
  assumes "is_atom x"
  shows "x \<le> y \<or> x \<cdot> y \<le> 0"
by (metis assms leq_atom_rel inf.cobounded1 inf.orderI)

lemma atomrel:
  assumes "is_atom x"
  shows "y \<cdot> x \<le> \<Squnion> {x|x. is_atom x \<and> x \<le> y}"
proof -
   have a: "x \<le> y \<or> x \<cdot> y \<le> 0"
     by (simp add: assms leq_atom_rel')
   then have b: "y \<cdot> x \<le> \<Squnion>{x|x. is_atom x \<and> x \<le> y}"
     proof
       assume asm: "x \<cdot> y \<le> 0"
       show "y \<cdot> x \<le> \<Squnion>{x|x. is_atom x \<and> x \<le> y}"
         using asm antisym bot_least inf.commute by fastforce
     next
       assume asm: "x \<le> y"
       show "y \<cdot> x \<le> \<Squnion>{x|x. is_atom x \<and> x \<le> y}"
         proof (rule leq_sum_p)
           show "finite {x. is_atom x \<and> x \<le> y}"
             by (simp add: fin_atoms')
         next
           show "is_atom (y \<cdot> x) \<and> y \<cdot> x \<le> y"
             by (simp add: asm assms inf.absorb2)
         qed
      qed
  thus ?thesis
    by blast
qed

lemma atomaux: "\<Squnion> {y \<cdot> x|x. is_atom x} \<le> \<Squnion> {x|x. is_atom x \<and> x \<le> y}"
proof (rule lub_sum_p)
  show "finite {x. is_atom x}"
    by (simp add: fin_atoms')
next
  show "\<forall>x. is_atom x \<longrightarrow> y \<cdot> x \<le> \<Squnion> {x|x. is_atom x \<and> x \<le> y}"
    using atomrel by auto
qed

lemma relatoms: "\<Squnion> {x|x. is_atom x \<and> x \<le> y} = y"
proof (rule antisym)
  show "\<Squnion>{x|x. is_atom x \<and> x \<le> y} \<le> y"
    by (metis (no_types, lifting) bot_least lub_sum sum.infinite mem_Collect_eq)
next
  have "y = y \<cdot> \<Squnion> {x|x. is_atom x}"
    using topatoms' by auto
  also have "\<dots> = \<Squnion> {y \<cdot> x|x. is_atom x}"
    using fin_atoms sum_cap_distr_left by auto
  also have "\<dots> \<le> \<Squnion> {x|x. is_atom x \<and> x \<le> y}"
    using atomaux by blast
  finally show "y \<le> \<Squnion>{x|x. is_atom x \<and> x \<le> y}"
    using Collect_cong by auto
qed

definition is_partial_point:: "'a \<Rightarrow> bool"
  where "is_partial_point x \<equiv> is_atom x \<and> is_test x"

lemma sumid_partial_points: "1' = \<Squnion> {x|x. is_partial_point x}"
using relatoms is_partial_point_def is_test_def by auto

lemma test_partial_points:
  assumes "is_test y"
  shows "y = \<Squnion> {x|x. is_partial_point x \<and> x \<le> y}"
proof -
  have a: "{x|x. is_atom x \<and> x \<le> y} = {x|x. is_partial_point x \<and> x \<le> y}"
    using assms is_partial_point_def dual_order.trans is_test_def by blast
  thus ?thesis
    by (metis relatoms)
qed

lemma fin_partial_points_p: "finite {x |x. is_partial_point x \<and> P x}"
using fin_atoms is_partial_point_def by auto

lemma fin_partial_points_fun: "finite {f x |x. is_partial_point x \<and> P x}"
using finite_image_set fin_partial_points_p by auto

end
end


section \<open> Chains \<close>

theory Chains
imports
  "HOL-Library.Sublist"
  Blocks
begin

text \<open>
  As defined in Section 3.1 of @{cite "genesis-paper"}, a @{emph \<open>chain\<close>} is simply a sequence of
  blocks. We do not record the genesis block explicitly as part of the chain:
\<close>

type_synonym chain = "block list"

text \<open>
  For the purposes of this work, a chain is @{emph \<open>valid\<close>} if either:

  1. It is empty; or

  2. It starts after the genesis slot and has strictly increasing slots.
\<close>

abbreviation is_slot_increasing :: "chain \<Rightarrow> bool" where
  "is_slot_increasing \<C> \<equiv> sorted_wrt (\<lambda>B B'. bslot B < bslot B') \<C>"

abbreviation starts_after_genesis :: "chain \<Rightarrow> bool" where
  "starts_after_genesis \<C> \<equiv> \<C> \<noteq> [] \<longrightarrow> bslot (hd \<C>) > genesis_slot"

abbreviation is_valid_chain :: "chain \<Rightarrow> bool" where
  "is_valid_chain \<C> \<equiv> is_slot_increasing \<C> \<and> starts_after_genesis \<C>"

abbreviation (input) tip :: "chain \<Rightarrow> block" where
  "tip \<equiv> last"

text \<open>
  If a non-empty chain is valid then so is its tail:
\<close>

lemma chain_tail_validity:
  assumes "is_valid_chain (B # \<C>)"
  shows "is_valid_chain \<C>"
  using assms by (induction \<C>) auto

notation length (\<open>|_|\<close>)

text \<open>
  A valid chain is sorted w.r.t. the slot field:
\<close>

lemma valid_chain_is_sorted_wrt_slot:
  assumes "is_valid_chain \<C>"
    and "0 \<le> i" and "i \<le> j" and "j < |\<C>|"
  shows "bslot (\<C> ! i) \<le> bslot (\<C> ! j)"
proof (cases "i < j")
  case True
  with assms(1,4) have "bslot (\<C> ! i) < bslot (\<C> ! j)"
    by (fastforce simp add: sorted_wrt_iff_nth_less)
  then show ?thesis
    by (rule less_imp_le)
next
  case False
  with assms(3) show ?thesis
    by simp
qed

notation prefix (infix \<open>\<preceq>\<close> 50)

text \<open>
  A prefix of a valid chain is also a valid chain:
\<close>

lemma chain_prefix_validity:
  assumes "is_valid_chain \<C>'"
    and "\<C> \<preceq> \<C>'"
  shows "is_valid_chain \<C>"
proof -
  from assms have "is_slot_increasing \<C>"
    unfolding prefix_def using sorted_wrt_append by blast
  moreover from assms have "starts_after_genesis \<C>"
    unfolding prefix_def by auto
  ultimately show ?thesis
    by simp
qed

text \<open>
  According to Section 3.1 of @{cite "genesis-paper"}, we define the concept of subchain induced by
  a given interval of slots:
\<close>

datatype slot_interval = ClosedInterval slot slot | RightOpenInterval slot

fun induced_subchain :: "chain \<Rightarrow> slot_interval \<Rightarrow> chain" where
  "induced_subchain \<C> (ClosedInterval sl\<^sub>1 sl\<^sub>2) = filter (\<lambda>B. bslot B \<in> {sl\<^sub>1..sl\<^sub>2}) \<C>"
| "induced_subchain \<C> (RightOpenInterval sl) = filter (\<lambda>B. bslot B \<ge> sl) \<C>"

syntax
  "_INDUCED_SUBCHAIN_CLOSED_INTERVAL" :: "chain \<Rightarrow> slot \<Rightarrow> slot \<Rightarrow> chain" ("_[_;_]" [70, 0, 0] 70)
  "_INDUCED_SUBCHAIN_RIGHT_OPEN_INTERVAL" :: "chain \<Rightarrow> slot \<Rightarrow> slot \<Rightarrow> chain" ("_[_;] " [70, 0] 70)

translations
  "\<C>[sl\<^sub>1;sl\<^sub>2]" \<rightleftharpoons> "CONST induced_subchain \<C> (CONST ClosedInterval sl\<^sub>1 sl\<^sub>2)"
  "\<C>[sl;]" \<rightleftharpoons> "CONST induced_subchain \<C> (CONST RightOpenInterval sl)"

text \<open>
  A right-open subchain is implicitly bounded by the chain tip's slot:
\<close>

lemma right_open_subchain_tip_boundedness:
  assumes "is_valid_chain \<C>"
    and "\<C> \<noteq> []"
  shows "\<C>[sl ;] = \<C>[sl ; bslot (tip \<C>)]"
proof -
  have "bslot B \<ge> sl \<longleftrightarrow> bslot B \<in> {sl..bslot (tip \<C>)}" if "B \<in> set \<C>" for B
  proof
    assume "bslot B \<ge> sl"
    from that obtain i where "i < |\<C>|" and "B = \<C> ! i"
      by (auto simp add: in_set_conv_nth)
    with assms(1) and that have "bslot (\<C> ! i) \<le> bslot (\<C> ! ( |\<C>| - 1 ))"
      by (simp add: valid_chain_is_sorted_wrt_slot)
    also from assms(2) have "\<dots> = bslot (tip \<C>)"
      by (simp add: last_conv_nth)
    finally show "bslot B \<in> {sl..bslot (tip \<C>)}"
      using \<open>B = \<C> ! i\<close> and \<open>sl \<le> bslot B\<close> and atLeastAtMost_iff by blast
  next
    assume "bslot B \<in> {sl..bslot (tip \<C>)}"
    then show "bslot B \<ge> sl"
      by auto
  qed
  then have "filter (\<lambda>B. bslot B \<ge> sl) \<C> = filter (\<lambda>B. bslot B \<in> {sl..bslot (tip \<C>)}) \<C>"
    by (metis (no_types, lifting) filter_cong)
  then show ?thesis
    by auto
qed

text \<open>
  Given a chain, its subchain starting right after the genesis slot is the original chain:
\<close>

lemma genesis_succesor_subchain_equality:
  assumes "is_valid_chain \<C>"
  shows "\<C>[genesis_slot + 1 ;] = \<C>"
proof -
  have "bslot B \<ge> genesis_slot + 1" if "B \<in> set \<C>" for B
  proof -
    from that have "\<C> \<noteq> []"
      by fastforce
    from that obtain i where "i < |\<C>|" and "B = \<C> ! i"
      by (auto simp add: in_set_conv_nth)
    with assms and \<open>\<C> \<noteq> []\<close> have "bslot (hd \<C>) \<le> bslot (\<C> ! i)"
      using valid_chain_is_sorted_wrt_slot by (simp add: hd_conv_nth)
    with \<open>B = \<C> ! i\<close> and assms and \<open>\<C> \<noteq> []\<close> show ?thesis
      by simp
  qed
  then show ?thesis
    by (simp add: filter_id_conv)
qed

text \<open>
  Given a chain, its subchain starting at a given slot \<open>sl\<^sub>1\<close> can be partitioned into two subchains
  by a subsequent slot \<open>sl\<^sub>2\<close> as the partition point:
\<close>

lemma right_open_subchain_partitioning:
  assumes "is_valid_chain \<C>"
    and "sl\<^sub>1 \<le> sl\<^sub>2"
  shows "\<C>[sl\<^sub>1 ; sl\<^sub>2] @ \<C>[sl\<^sub>2 + 1 ;] = \<C>[sl\<^sub>1 ;]"
  using assms
proof (induction \<C>)
  case Nil
  then show ?case
    by simp
next
  case (Cons B \<C>)
  from Cons.prems(1) have "is_valid_chain \<C>"
    by (rule chain_tail_validity)
  then show ?case
  proof (cases "bslot B \<ge> sl\<^sub>1")
    case True
    then have "(B # \<C>)[sl\<^sub>1 ;] = B # \<C>[sl\<^sub>1 ;]"
      by simp
    also from Cons.IH and \<open>is_valid_chain \<C>\<close> and assms(2) have "\<dots> = B # \<C>[sl\<^sub>1 ; sl\<^sub>2] @ \<C>[sl\<^sub>2 + 1 ;]"
      by auto
    also have "\<dots> = (B # \<C>)[sl\<^sub>1 ; sl\<^sub>2] @ (B # \<C>)[sl\<^sub>2 + 1 ;]"
    proof (cases "bslot B \<le> sl\<^sub>2")
      case True
      with \<open>(B # \<C>)[sl\<^sub>1 ;] = B # \<C>[sl\<^sub>1 ;]\<close> show ?thesis
        using not_less_eq_eq by fastforce
    next
      case False
      with Cons.prems(1) have "bslot B \<notin> {sl\<^sub>1..sl\<^sub>2}" if "B \<in> set \<C>" for B
        using that by auto
      then have "\<C>[sl\<^sub>1 ; sl\<^sub>2] = []"
        by simp
      with False show ?thesis
        by (simp add: not_less_eq_eq)
    qed
    finally show ?thesis ..
  next
    case False
    with Cons.IH and \<open>is_valid_chain \<C>\<close> and assms(2) show ?thesis
      by auto
  qed
qed

text \<open>
  A closed subchain can be partitioned into two subchains by a intermediate slot as the partition
  point:
\<close>

lemma closed_subchain_partitioning:
  assumes "is_valid_chain \<C>"
    and "sl\<^sub>0 \<le> sl\<^sub>1" and "sl\<^sub>1 < sl\<^sub>2"
  shows "\<C>[sl\<^sub>0 ; sl\<^sub>1] @ \<C>[sl\<^sub>1 + 1 ; sl\<^sub>2] = \<C>[sl\<^sub>0 ; sl\<^sub>2]"
proof -
  from assms have "\<C>[sl\<^sub>0 ; sl\<^sub>2] @ \<C>[sl\<^sub>2 + 1 ;] = \<C>[sl\<^sub>0 ;]"
    using right_open_subchain_partitioning by auto
  moreover from assms(1,2) have "\<C>[sl\<^sub>0 ; sl\<^sub>1] @ \<C>[sl\<^sub>1 + 1 ;] = \<C>[sl\<^sub>0 ;]"
    by (rule right_open_subchain_partitioning)
  ultimately have "\<C>[sl\<^sub>0 ; sl\<^sub>2] @ \<C>[sl\<^sub>2 + 1 ;] = \<C>[sl\<^sub>0 ; sl\<^sub>1] @ \<C>[sl\<^sub>1 + 1 ;]"
    by simp
  moreover from assms(1,3) have "\<C>[sl\<^sub>1 + 1 ; sl\<^sub>2] @ \<C>[sl\<^sub>2 + 1 ;] = \<C>[sl\<^sub>1 + 1;]"
    using right_open_subchain_partitioning by simp
  ultimately have "\<C>[sl\<^sub>0 ; sl\<^sub>2] @ \<C>[sl\<^sub>2 + 1 ;] = (\<C>[sl\<^sub>0 ; sl\<^sub>1] @ \<C>[sl\<^sub>1 + 1 ; sl\<^sub>2]) @ \<C>[sl\<^sub>2 + 1 ;]"
    by simp
  then show ?thesis
    by simp (* NOTE: `append_eq_append_conv` does the trick here *)
qed

text \<open>
  Given a chain, its subchain starting at the genesis slot and ending at a slot greater or equal to
  the chain tip's slot is the original chain:
\<close>

lemma maximal_closed_subchain_equality:
  assumes "is_valid_chain \<C>"
    and "bslot (tip \<C>) \<le> sl"
  shows "\<C>[genesis_slot ; sl] = \<C>"
proof -
  have "bslot B \<le> sl" if "B \<in> set \<C>" for B
  proof -
    from that obtain i where "i < |\<C>|" and "B = \<C> ! i"
      by (auto simp add: in_set_conv_nth)
    with assms(1) and that have "bslot (\<C> ! i) \<le> bslot (\<C> ! ( |\<C>| - 1 ))"
      by (simp add: valid_chain_is_sorted_wrt_slot)
    moreover from that have "\<C> \<noteq> []"
      by fastforce
    ultimately show ?thesis
      using \<open>B = \<C> ! i\<close> and assms(2) by (fastforce simp add: last_conv_nth)
  qed
  then show ?thesis
    by (simp add: filter_id_conv)
qed

text \<open>
  A chain can be partitioned into two subchains by a slot \<open>sl\<close> as the partition point:
\<close>

lemma chain_partitioning:
  assumes "is_valid_chain \<C>"
  shows "\<C>[genesis_slot ; sl] @ \<C>[sl + 1 ;] = \<C>"
  using assms and right_open_subchain_partitioning by fastforce

text \<open>
  Given a chain, its subchain starting at slot \<open>sl + 1\<close> is a suffix of its subchain starting at slot
  \<open>sl\<close>:
\<close>

lemma adjacent_slots_subchain_suffix:
  assumes "is_valid_chain \<C>"
  shows "suffix (\<C>[sl + 1 ;]) (\<C>[sl ;])"
  by (intro suffixI, subst right_open_subchain_partitioning[OF assms order_refl], simp)

text \<open>
  The subchain starting and ending at the genesis slot is empty:
\<close>

lemma genesis_slot_not_in_chain:
  assumes "is_valid_chain \<C>"
  shows "\<C>[genesis_slot ; genesis_slot] = []"
proof -
  from assms have "\<C>[genesis_slot + 1 ;] = \<C>"
    by (rule genesis_succesor_subchain_equality)
  with assms have "\<C>[genesis_slot ; genesis_slot] @ \<C> = \<C>"
    using chain_partitioning by metis
  then show ?thesis
    by blast
qed

text \<open>
  Given a non-empty chain, its subchain starting at the genesis slot and ending at the slot of its
  head is empty:
\<close>

lemma chain_tail_prefix_emptiness:
  assumes "is_valid_chain (B # \<C>)"
  shows "\<C>[genesis_slot ; bslot B] = []"
proof -
  from assms have "bslot B < bslot B'" if "B' \<in> set \<C>" for B'
    using that by simp
  then have "filter (\<lambda>B'. bslot B' \<in> {genesis_slot..bslot B}) \<C> = []"
    by (fastforce intro: filter_False)
  then show ?thesis
    by simp
qed

text \<open>
  If there are no blocks in a chain with slots greater than \<open>sl\<close>, then the tip of the chain is
  slot-bounded by \<open>sl\<close>:
\<close>

lemma chain_tip_slot_boundedness:
  assumes "is_valid_chain \<C>"
    and "\<C> \<noteq> []"
    and "\<C>[sl + 1 ;] = []"
  shows "bslot (tip \<C>) \<le> sl"
  using assms
proof (induction \<C>)
  case Nil
  then show ?case
    by simp
next
  case (Cons B \<C>)
  from Cons.prems(3) have "filter (\<lambda>B. bslot B \<ge> sl + 1) (B # \<C>) = []"
    by auto
  then have "\<not> bslot B' \<ge> sl + 1" if "B' \<in> set (B # \<C>)" for B'
    using that by (metis filter_empty_conv)
  then have "\<C>[sl + 1 ;] = []"
    by simp
  then show ?case
  proof -
    { assume "\<C> \<noteq> []"
      with Cons.IH and Cons.prems(1) and \<open>\<C>[sl + 1 ;] = []\<close> have "bslot (tip \<C>) \<le> sl"
        using chain_tail_validity by blast
      with \<open>\<C> \<noteq> []\<close> have ?thesis
        by simp }
    with Cons.prems(3) show ?thesis
      by fastforce
  qed
qed

end


section \<open>Implementation of the FIFO Push/Relabel Algorithm\<close>
theory Fifo_Push_Relabel_Impl
imports
  Fifo_Push_Relabel
  Prpu_Common_Impl
begin

subsection \<open>Basic Operations\<close>
context Network_Impl
begin

subsubsection \<open>Queue\<close>
text \<open>Obtain the empty queue.\<close>
definition q_empty :: "node list nres" where
  "q_empty \<equiv> return []"

text \<open>Check whether a queue is empty.\<close>
definition q_is_empty :: "node list \<Rightarrow> bool nres" where
  "q_is_empty Q \<equiv> return ( Q = [] )"

text \<open>Enqueue a node.\<close>
definition q_enqueue :: "node \<Rightarrow> node list \<Rightarrow> node list nres" where
  "q_enqueue v Q \<equiv> do {
    assert (v\<in>V);
    return (Q@[v])
  }"

text \<open>Dequeue a node.\<close>
definition q_dequeue :: "node list \<Rightarrow> (node \<times> node list) nres" where
  "q_dequeue Q \<equiv> do {
    assert (Q\<noteq>[]);
    return (hd Q, tl Q)
  }"

end \<comment> \<open>Network Implementation Locale\<close>

subsection \<open>Refinements to Basic Operations\<close>

context Network_Impl
begin
text \<open>In this section, we refine the algorithm to actually use the
 basic operations.
\<close>

subsubsection \<open>Refinement of Push\<close>
definition "fifo_push2_aux x cf Q \<equiv> \<lambda>(u,v). do {
  assert ( (u,v) \<in> E \<union> E\<inverse> );
  assert ( u \<noteq> v );
  let \<Delta> = min (x u) (cf (u,v));
  let Q = (if v\<noteq>s \<and> v\<noteq>t \<and> x v = 0 then Q@[v] else Q);
  return ((x( u := x u - \<Delta>, v := x v + \<Delta> ),augment_edge_cf cf (u,v) \<Delta>),Q)
}"

lemma fifo_push2_aux_refine:
  "\<lbrakk>((x,cf),f)\<in>xf_rel; (ei,e)\<in>Id\<times>\<^sub>rId; (Qi,Q)\<in>Id\<rbrakk>
    \<Longrightarrow> fifo_push2_aux x cf Qi ei \<le> \<Down>(xf_rel \<times>\<^sub>r Id) (fifo_push f l Q e)"
  unfolding fifo_push_def fifo_push2_aux_def
  apply refine_vcg
  apply (vc_solve simp: xf_rel_def no_self_loop)
  subgoal for u v
    unfolding push_precond_def using cfE_of_ss_invE by auto
  subgoal for u v
  proof -
    assume [simp]: "Labeling c s t f l"
    then interpret Labeling c s t f l .
    assume "push_precond f l (u, v)"
    then interpret l': push_effect_locale c s t f l u v by unfold_locales
    show ?thesis
      apply (safe intro!: ext)
      using l'.excess'_if l'.\<Delta>_def l'.cf'_alt l'.uv_not_eq(1)
      by (auto)
  qed
  done

definition "fifo_push2 x cf Q \<equiv> \<lambda>(u,v). do {
  assert ( (u,v) \<in> E \<union> E\<inverse> );
  xu \<leftarrow> x_get x u;
  xv \<leftarrow> x_get x v;
  cfuv \<leftarrow> cf_get cf (u,v);
  cfvu \<leftarrow> cf_get cf (v,u);
  let \<Delta> = min xu cfuv;
  x \<leftarrow> x_add x u (-\<Delta>);
  x \<leftarrow> x_add x v \<Delta>;

  cf \<leftarrow> cf_set cf (u,v) (cfuv - \<Delta>);
  cf \<leftarrow> cf_set cf (v,u) (cfvu + \<Delta>);

  if v\<noteq>s \<and> v\<noteq>t \<and> xv = 0 then do {
    Q \<leftarrow> q_enqueue v Q;
    return ((x,cf),Q)
  } else
    return ((x,cf),Q)
}"

lemma fifo_push2_refine[refine]:
  assumes "((x,cf),f)\<in>xf_rel" "(ei,e)\<in>Id\<times>\<^sub>rId" "(Qi,Q)\<in>Id"
  shows "fifo_push2 x cf Qi ei \<le> \<Down>(xf_rel \<times>\<^sub>r Id) (fifo_push f l Q e)"
proof -
  have "fifo_push2 x cf Qi ei \<le> (fifo_push2_aux x cf Qi ei)"
    unfolding fifo_push2_def fifo_push2_aux_def
    unfolding x_get_def x_add_def cf_get_def cf_set_def q_enqueue_def
    unfolding augment_edge_cf_def
    apply (simp only: nres_monad_laws)
    apply refine_vcg
    using E_ss_VxV
    by auto
  also note fifo_push2_aux_refine[OF assms]
  finally show ?thesis .
qed

subsubsection \<open>Refinement of Gap-Relabel\<close>

definition "fifo_gap_relabel_aux C f l Q u \<equiv> do {
  Q \<leftarrow> q_enqueue u Q;
  lu \<leftarrow> l_get l u;
  l \<leftarrow> relabel f l u;
  if gap_precond l lu then do {
    l \<leftarrow> gap_aux C l lu;
    return (l,Q)
  } else return (l,Q)
}"

lemma fifo_gap_relabel_aux_refine:
  assumes [simp]: "C = card V" "l_invar l"
  shows "fifo_gap_relabel_aux C f l Q u \<le> fifo_gap_relabel f l Q u"
  unfolding fifo_gap_relabel_aux_def fifo_gap_relabel_def relabel_def
    gap_relabel_effect_def l_get_def q_enqueue_def
  apply (simp only: Let_def nres_monad_laws)
  apply refine_vcg
  by auto

definition "fifo_gap_relabel2 C am cf clc Q u \<equiv> do {
  Q \<leftarrow> q_enqueue u Q;
  lu \<leftarrow> clc_get clc u;
  clc \<leftarrow> clc_relabel2 am cf clc u;
  has_gap \<leftarrow> clc_has_gap clc lu;
  if has_gap then do {
    clc \<leftarrow> gap2 C clc lu;
    RETURN (clc,Q)
  } else
    RETURN (clc,Q)
}"

lemma fifo_gap_relabel2_refine_aux:
  assumes XCF: "((x, cf), f) \<in> xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes [simplified,simp]: "(Ci,C)\<in>Id" "(Qi,Q)\<in>Id" "(ui,u)\<in>Id"
  shows "fifo_gap_relabel2 Ci am cf clc Qi ui
          \<le> \<Down>(clc_rel \<times>\<^sub>r Id) (fifo_gap_relabel_aux C f l Q u)"
  unfolding fifo_gap_relabel2_def fifo_gap_relabel_aux_def
  apply (refine_vcg XCF AM CLC if_bind_cond_refine bind_refine')
  apply refine_dref_type
  apply (vc_solve solve: refl )
  subgoal for _ lu
    using CLC
    unfolding clc_get_def l_get_def clc_rel_def in_br_conv clc_invar_def
    by (auto simp: refine_pw_simps split: prod.splits)
  done

lemma fifo_gap_relabel2_refine[refine]:
  assumes XCF: "((x, cf), f) \<in> xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes [simplified,simp]: "(Qi,Q)\<in>Id" "(ui,u)\<in>Id"
  assumes CC: "C = card V"
  shows "fifo_gap_relabel2 C am cf clc Qi ui
          \<le>\<Down>(clc_rel \<times>\<^sub>r Id) (fifo_gap_relabel f l Q u)"
proof -
  from CLC have LINV: "l_invar l"
    unfolding clc_rel_def in_br_conv clc_invar_def by auto

  note fifo_gap_relabel2_refine_aux[OF XCF CLC AM IdI IdI IdI]
  also note fifo_gap_relabel_aux_refine[OF CC LINV]
  finally show ?thesis by simp
qed

subsubsection \<open>Refinement of Discharge\<close>
context begin
text \<open>
  Some lengthy, multi-step refinement of discharge,
  changing the iteration to iteration over adjacent nodes with filter,
  and showing that we can do the filter wrt.\ the current state, rather than
  the original state before the loop.
\<close>

lemma am_nodes_as_filter:
  assumes "is_adj_map am"
  shows "{v . (u,v)\<in>cfE_of f} = set (filter (\<lambda>v. cf_of f (u,v) \<noteq> 0) (am u))"
  using assms cfE_of_ss_invE
  unfolding is_adj_map_def Graph.E_def
  by fastforce

private lemma adjacent_nodes_iterate_refine1:
  fixes ff u f
  assumes AMR: "(am,adjacent_nodes)\<in>Id \<rightarrow> \<langle>Id\<rangle>list_set_rel"
  assumes CR: "\<And>s si. (si,s)\<in>Id \<Longrightarrow> cci si \<longleftrightarrow> cc s"
  assumes FR: "\<And>v vi s si. \<lbrakk>(vi,v)\<in>Id; v\<in>V; (u,v)\<in>E\<union>E\<inverse>; (si,s)\<in>Id\<rbrakk> \<Longrightarrow>
    ffi vi si \<le> \<Down>Id (do {
                      if (cf_of f (u,v) \<noteq> 0) then ff v s else RETURN s
                    })" (is "\<And>v vi s si. \<lbrakk>_;_;_;_\<rbrakk> \<Longrightarrow> _  \<le> \<Down>_ (?ff' v s)")
  assumes S0R: "(s0i,s0)\<in>Id"
  assumes UR: "(ui,u)\<in>Id"
  shows "nfoldli (am ui) cci ffi s0i
        \<le>\<Down>Id (FOREACHc {v . (u,v)\<in>cfE_of f} cc ff s0)"
proof -
  from fun_relD[OF AMR] have AM: "is_adj_map am"
    unfolding is_adj_map_def
    by (auto simp: list_set_rel_def in_br_conv adjacent_nodes_def)

  from AM have AM_SS_V: "set (am u) \<subseteq> V" "{u}\<times>set (am u) \<subseteq> E \<union> E\<inverse>"
    unfolding is_adj_map_def using E_ss_VxV by auto

  thm nfoldli_refine
  have "nfoldli (am ui) cci ffi s0 \<le> \<Down>Id (nfoldli (am ui) cc ?ff' s0)"
    apply (refine_vcg FR)
    apply (rule list_rel_congD)
    apply refine_dref_type
    using CR
    apply vc_solve
    using AM_SS_V UR by auto
  also have "nfoldli (am ui) cc ?ff' s0
            \<le>\<Down>Id (FOREACHc (adjacent_nodes u) cc ?ff' s0)"
    by (rule LFOc_refine[OF fun_relD[OF AMR UR]]; simp)
  also have "FOREACHc (adjacent_nodes u) cc ?ff' s0
            \<le> FOREACHc {v . (u,v)\<in>cfE_of f} cc ff s0"
    apply (subst am_nodes_as_filter[OF AM])
    apply (subst FOREACHc_filter_deforestation2)
    subgoal using AM unfolding is_adj_map_def by auto
    subgoal
      apply (rule eq_refl)
      apply ((fo_rule cong)+; (rule refl)?)
      subgoal
        using fun_relD[OF AMR IdI[of u]]
        by (auto simp: list_set_rel_def in_br_conv)
      done
    done
  finally show ?thesis using S0R by simp
qed

private definition "dis_loop_aux am f\<^sub>0 l Q u \<equiv> do {
  assert (u\<in>V - {s,t});
  assert (distinct (am u));
  nfoldli (am u) (\<lambda>(f,l,Q). excess f u \<noteq> 0) (\<lambda>v (f,l,Q). do {
    assert ((u,v)\<in>E\<union>E\<inverse> \<and> v\<in>V);
    if (cf_of f\<^sub>0 (u,v) \<noteq> 0) then do {
      if (l u = l v + 1) then do {
        (f',Q) \<leftarrow> fifo_push f l Q (u,v);
        assert (\<forall>v'. v'\<noteq>v \<longrightarrow> cf_of f' (u,v') = cf_of f (u,v'));
        return (f',l,Q)
      } else return (f,l,Q)
    } else return (f,l,Q)
  }) (f\<^sub>0,l,Q)
}"

private definition "fifo_discharge_aux am f\<^sub>0 l Q \<equiv> do {
  (u,Q) \<leftarrow> q_dequeue Q;
  assert (u\<in>V \<and> u\<noteq>s \<and> u\<noteq>t);

  (f,l,Q) \<leftarrow> dis_loop_aux am f\<^sub>0 l Q u;

  if excess f u \<noteq> 0 then do {
    (l,Q) \<leftarrow> fifo_gap_relabel f l Q u;
    return (f,l,Q)
  } else do {
    return (f,l,Q)
  }
}"

private lemma fifo_discharge_aux_refine:
  assumes AM: "(am,adjacent_nodes)\<in>Id \<rightarrow> \<langle>Id\<rangle>list_set_rel"
  assumes [simplified,simp]: "(fi,f)\<in>Id" "(li,l)\<in>Id" "(Qi,Q)\<in>Id"
  shows "fifo_discharge_aux am fi li Qi \<le> \<Down>Id (fifo_discharge f l Q)"
  unfolding fifo_discharge_aux_def fifo_discharge_def dis_loop_aux_def
  unfolding q_dequeue_def
  apply (simp only: nres_monad_laws)
  apply (refine_rcg adjacent_nodes_iterate_refine1[OF AM])
  apply refine_dref_type
  apply vc_solve
  subgoal
    using fun_relD[OF AM IdI[of "hd Q"]]
    unfolding list_set_rel_def by (auto simp: in_br_conv)
  done

private definition "dis_loop_aux2 am f\<^sub>0 l Q u \<equiv> do {
  assert (u\<in>V - {s,t});
  assert (distinct (am u));
  nfoldli (am u) (\<lambda>(f,l,Q). excess f u \<noteq> 0) (\<lambda>v (f,l,Q). do {
    assert ((u,v)\<in>E\<union>E\<inverse> \<and> v\<in>V);
    if (cf_of f (u,v) \<noteq> 0) then do {
      if (l u = l v + 1) then do {
        (f',Q) \<leftarrow> fifo_push f l Q (u,v);
        assert (\<forall>v'. v'\<noteq>v \<longrightarrow> cf_of f' (u,v') = cf_of f (u,v'));
        return (f',l,Q)
      } else return (f,l,Q)
    } else return (f,l,Q)
  }) (f\<^sub>0,l,Q)
}"

private lemma dis_loop_aux2_refine:
  shows "dis_loop_aux2 am f\<^sub>0 l Q u \<le>\<Down>Id (dis_loop_aux am f\<^sub>0 l Q u)"
  unfolding dis_loop_aux2_def dis_loop_aux_def
  apply (intro ASSERT_refine_right ASSERT_refine_left; assumption?)
  apply (rule nfoldli_invar_refine[where
            I="\<lambda>it1 it2 (f,_,_). \<forall>v\<in>set it2. cf_of f (u,v) = cf_of f\<^sub>0 (u,v)"])
  apply refine_dref_type
  apply vc_solve
  apply (auto simp: pw_leof_iff refine_pw_simps fifo_push_def; metis)
  done

private definition "dis_loop_aux3 am x cf l Q u \<equiv> do {
  assert (u\<in>V \<and> distinct (am u));
  monadic_nfoldli (am u)
    (\<lambda>((x,cf),l,Q). do { xu \<leftarrow> x_get x u; return (xu \<noteq> 0) })
    (\<lambda>v ((x,cf),l,Q). do {
      cfuv \<leftarrow> cf_get cf (u,v);
      if (cfuv \<noteq> 0) then do {
        lu \<leftarrow> l_get l u;
        lv \<leftarrow> l_get l v;
        if (lu = lv + 1) then do {
          ((x,cf),Q) \<leftarrow> fifo_push2 x cf Q (u,v);
          return ((x,cf),l,Q)
        } else return ((x,cf),l,Q)
      } else return ((x,cf),l,Q)
  }) ((x,cf),l,Q)
}"

private lemma dis_loop_aux3_refine:
  assumes [simplified,simp]: "(ami,am)\<in>Id" "(li,l)\<in>Id" "(Qi,Q)\<in>Id" "(ui,u)\<in>Id"
  assumes XF: "((x,cf),f)\<in>xf_rel"
  shows "dis_loop_aux3 ami x cf li Qi ui
        \<le>\<Down>(xf_rel \<times>\<^sub>r Id \<times>\<^sub>r Id) (dis_loop_aux2 am f l Q u)"
  unfolding dis_loop_aux3_def dis_loop_aux2_def
  unfolding x_get_def cf_get_def l_get_def
  apply (simp only: nres_monad_laws nfoldli_to_monadic)
  apply (refine_rcg)
  apply refine_dref_type
  using XF
  by (vc_solve simp: xf_rel_def in_br_conv)

definition "dis_loop2 am x cf clc Q u \<equiv> do {
  assert (distinct (am u));
  amu \<leftarrow> am_get am u;
  monadic_nfoldli amu
    (\<lambda>((x,cf),clc,Q). do { xu \<leftarrow> x_get x u; return (xu \<noteq> 0) })
    (\<lambda>v ((x,cf),clc,Q). do {
      cfuv \<leftarrow> cf_get cf (u,v);
      if (cfuv \<noteq> 0) then do {
        lu \<leftarrow> clc_get clc u;
        lv \<leftarrow> clc_get clc v;
        if (lu = lv + 1) then do {
          ((x,cf),Q) \<leftarrow> fifo_push2 x cf Q (u,v);
          return ((x,cf),clc,Q)
        } else return ((x,cf),clc,Q)
      } else return ((x,cf),clc,Q)
  }) ((x,cf),clc,Q)
}"

private lemma dis_loop2_refine_aux:
  assumes [simplified,simp]: "(xi,x)\<in>Id" "(cfi,cf)\<in>Id" "(ami,am)\<in>Id"
  assumes [simplified,simp]: "(li,l)\<in>Id" "(Qi,Q)\<in>Id" "(ui,u)\<in>Id"
  assumes CLC: "(clc,l)\<in>clc_rel"
  shows "dis_loop2 ami xi cfi clc Qi ui
        \<le>\<Down>(Id \<times>\<^sub>r clc_rel \<times>\<^sub>r Id) (dis_loop_aux3 am x cf l Q u)"
  unfolding dis_loop2_def dis_loop_aux3_def am_get_def
  apply (simp only: nres_monad_laws)
  apply refine_rcg
  apply refine_dref_type
  apply (vc_solve simp: CLC)
  done

lemma dis_loop2_refine[refine]:
  assumes XF: "((x,cf),f)\<in>xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes [simplified,simp]: "(ami,am)\<in>Id" "(Qi,Q)\<in>Id" "(ui,u)\<in>Id"
  shows "dis_loop2 ami x cf clc Qi ui
        \<le>\<Down>(xf_rel \<times>\<^sub>r clc_rel \<times>\<^sub>r Id) (dis_loop_aux am f l Q u)"
proof -
  have [simp]:
    "((Id \<times>\<^sub>r clc_rel \<times>\<^sub>r Id) O (xf_rel \<times>\<^sub>r Id)) = xf_rel \<times>\<^sub>r clc_rel \<times>\<^sub>r Id"
    by (auto simp: prod_rel_comp)

  note dis_loop2_refine_aux[OF IdI IdI IdI IdI IdI IdI CLC]
  also note dis_loop_aux3_refine[OF IdI IdI IdI IdI XF]
  also note dis_loop_aux2_refine
  finally show ?thesis
    by (auto simp: conc_fun_chain monoD[OF conc_fun_mono])
qed

definition "fifo_discharge2 C am x cf clc Q \<equiv> do {
  (u,Q) \<leftarrow> q_dequeue Q;
  assert (u\<in>V \<and> u\<noteq>s \<and> u\<noteq>t);

  ((x,cf),clc,Q) \<leftarrow> dis_loop2 am x cf clc Q u;

  xu \<leftarrow> x_get x u;
  if xu \<noteq> 0 then do {
    (clc,Q) \<leftarrow> fifo_gap_relabel2 C am cf clc Q u;
    return ((x,cf),clc,Q)
  } else do {
    return ((x,cf),clc,Q)
  }
}"

lemma fifo_discharge2_refine[refine]:
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes XCF: "((x, cf), f) \<in> xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes [simplified,simp]: "(Qi,Q)\<in>Id"
  assumes CC: "C = card V"
  shows "fifo_discharge2 C am x cf clc Qi
        \<le>\<Down>(xf_rel \<times>\<^sub>r clc_rel \<times>\<^sub>r Id) (fifo_discharge f l Q)"
proof -
  have "fifo_discharge2 C am x cf clc Q
        \<le>\<Down>(xf_rel \<times>\<^sub>r clc_rel \<times>\<^sub>r Id) (fifo_discharge_aux am f l Q)"
    unfolding fifo_discharge2_def fifo_discharge_aux_def
    unfolding x_get_def
    apply (simp only: nres_monad_laws)
    apply (refine_rcg XCF CLC AM IdI)
    apply (vc_solve simp: CC)
    subgoal unfolding xf_rel_def in_br_conv by auto
    applyS assumption
    done
  also note fifo_discharge_aux_refine[OF AM IdI IdI IdI]
  finally show ?thesis by simp
qed

end \<comment> \<open>Anonymous Context\<close>

subsubsection \<open>Computing the Initial Queue\<close>
definition "q_init am \<equiv> do {
  Q \<leftarrow> q_empty;
  ams \<leftarrow> am_get am s;
  nfoldli ams (\<lambda>_. True) (\<lambda>v Q. do {
    if v\<noteq>t then q_enqueue v Q else return Q
  }) Q
}"

lemma q_init_correct[THEN order_trans, refine_vcg]:
  assumes AM: "is_adj_map am"
  shows "q_init am
    \<le> (spec l. distinct l \<and> set l = {v \<in> V - {s, t}. excess pp_init_f v \<noteq> 0})"
proof -
  from am_to_adj_nodes_refine[OF AM] have "set (am s) \<subseteq> V"
    using adjacent_nodes_ss_V
    by (auto simp: list_set_rel_def in_br_conv)
  hence "q_init am \<le> RETURN (filter ((\<noteq>) t) (am s))"
    unfolding q_init_def q_empty_def q_enqueue_def am_get_def
    apply (refine_vcg nfoldli_rule[where I="\<lambda>l1 _ l. l = filter ((\<noteq>) t) l1"])
    by auto
  also have "\<dots>
    \<le> (spec l. distinct l \<and> set l = {v \<in> V - {s, t}. excess pp_init_f v \<noteq> 0})"
  proof -
    from am_to_adj_nodes_refine[OF AM]
    have [simp]: "distinct (am s)" "set (am s) = adjacent_nodes s"
      unfolding list_set_rel_def
      by (auto simp: in_br_conv)

    show ?thesis
      using E_ss_VxV
      apply (auto simp: pp_init_x_def adjacent_nodes_def)
      unfolding Graph.E_def by auto
  qed
  finally show ?thesis .
qed

subsubsection \<open>Refining the Main Algorithm\<close>
definition "fifo_push_relabel_aux am \<equiv> do {
  cardV \<leftarrow> init_C am;
  assert (cardV = card V);
  let f = pp_init_f;
  l \<leftarrow> l_init cardV;

  Q \<leftarrow> q_init am;

  (f,l,_) \<leftarrow> monadic_WHILEIT (\<lambda>_. True)
    (\<lambda>(f,l,Q). do {qe \<leftarrow> q_is_empty Q; return (\<not>qe)})
    (\<lambda>(f,l,Q). do {
      fifo_discharge f l Q
    })
    (f,l,Q);

  assert (Height_Bounded_Labeling c s t f l);
  return f
}"

lemma fifo_push_relabel_aux_refine:
  assumes AM: "is_adj_map am"
  shows "fifo_push_relabel_aux am \<le> \<Down>Id (fifo_push_relabel)"
  unfolding fifo_push_relabel_aux_def fifo_push_relabel_def
  unfolding l_init_def pp_init_l_def q_is_empty_def bind_to_let_conv
  apply (rule specify_left[OF init_C_correct[OF AM]])
  apply (refine_rcg q_init_correct[OF AM])
  apply refine_dref_type
  apply vc_solve
  done

definition "fifo_push_relabel2 am \<equiv> do {
  cardV \<leftarrow> init_C am;
  (x,cf) \<leftarrow> pp_init_xcf2 am;
  clc \<leftarrow> clc_init cardV;
  Q \<leftarrow> q_init am;

  ((x,cf),clc,Q) \<leftarrow> monadic_WHILEIT (\<lambda>_. True)
    (\<lambda>((x,cf),clc,Q). do {qe \<leftarrow> q_is_empty Q; return (\<not>qe)})
    (\<lambda>((x,cf),clc,Q). do {
      fifo_discharge2 cardV am x cf clc Q
    })
    ((x,cf),clc,Q);

  return cf
}"

lemma fifo_push_relabel2_refine:
  assumes AM: "is_adj_map am"
  shows "fifo_push_relabel2 am
        \<le> \<Down>(br (flow_of_cf) (RPreGraph c s t)) fifo_push_relabel"
proof -
  {
    fix f l n
    assume "Height_Bounded_Labeling c s t f l"
    then interpret Height_Bounded_Labeling c s t f l .
    have G1: "flow_of_cf cf = f" by (rule fo_rg_inv)
    have G2: "RPreGraph c s t cf" by (rule is_RPreGraph)
    note G1 G2
  } note AUX1=this

  have "fifo_push_relabel2 am
        \<le> \<Down>(br (flow_of_cf) (RPreGraph c s t)) (fifo_push_relabel_aux am)"
    unfolding fifo_push_relabel2_def fifo_push_relabel_aux_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (vc_solve simp: AM am_to_adj_nodes_refine[OF AM])
    subgoal using AUX1 by (auto simp: in_br_conv xf_rel_def AM)
    done
  also note fifo_push_relabel_aux_refine[OF AM]
  finally show ?thesis .
qed

end \<comment> \<open>Network Impl. Locale\<close>

subsection \<open>Separating out the Initialization of the Adjacency Matrix\<close>
context Network_Impl
begin

text \<open>We split the algorithm into an initialization of the adjacency
  matrix, and the actual algorithm. This way, the algorithm can handle
  pre-initialized adjacency matrices.
\<close>

definition "fifo_push_relabel_init2 \<equiv> cf_init"
definition "pp_init_xcf2' am cf \<equiv> do {
  x \<leftarrow> x_init;

  assert (s\<in>V);
  adj \<leftarrow> am_get am s;
  nfoldli adj (\<lambda>_. True) (\<lambda>v (x,cf). do {
    assert ((s,v)\<in>E);
    assert (s \<noteq> v);
    a \<leftarrow> cf_get cf (s,v);
    x \<leftarrow> x_add x s (-a);
    x \<leftarrow> x_add x v a;
    cf \<leftarrow> cf_set cf (s,v) 0;
    cf \<leftarrow> cf_set cf (v,s) a;
    return (x,cf)
  }) (x,cf)
}"

definition "fifo_push_relabel_run2 am cf \<equiv> do {
  cardV \<leftarrow> init_C am;
  (x,cf) \<leftarrow> pp_init_xcf2' am cf;
  clc \<leftarrow> clc_init cardV;
  Q \<leftarrow> q_init am;

  ((x,cf),clc,Q) \<leftarrow> monadic_WHILEIT (\<lambda>_. True)
    (\<lambda>((x,cf),clc,Q). do {qe \<leftarrow> q_is_empty Q; return (\<not>qe)})
    (\<lambda>((x,cf),clc,Q). do {
      fifo_discharge2 cardV am x cf clc Q
    })
    ((x,cf),clc,Q);

  return cf
}"

lemma fifo_push_relabel2_alt:
  "fifo_push_relabel2 am = do {
    cf \<leftarrow> fifo_push_relabel_init2;
    fifo_push_relabel_run2 am cf
  }"
  unfolding fifo_push_relabel_init2_def fifo_push_relabel_run2_def
    fifo_push_relabel2_def pp_init_xcf2_def pp_init_xcf2'_def
    cf_init_def (* Unfolding this b/c it's a return and thus can be inlined.*)
  by simp

end \<comment> \<open>Network Impl. Locale\<close>

subsection \<open>Refinement To Efficient Data Structures\<close>

context Network_Impl
begin

subsubsection \<open>Registration of Abstract Operations\<close>
text \<open>We register all abstract operations at once,
  auto-rewriting the capacity matrix type\<close>

context includes Network_Impl_Sepref_Register
begin

sepref_register q_empty q_is_empty q_enqueue q_dequeue

sepref_register fifo_push2

sepref_register fifo_gap_relabel2

sepref_register dis_loop2 fifo_discharge2

sepref_register q_init pp_init_xcf2'

sepref_register fifo_push_relabel_run2 fifo_push_relabel_init2
sepref_register fifo_push_relabel2

end \<comment> \<open>Anonymous Context\<close>

subsubsection \<open>Queue by Two Stacks\<close>
definition (in -) "q_\<alpha> \<equiv> \<lambda>(L,R). L@rev R"
definition (in -) "q_empty_impl \<equiv> ([],[])"
definition (in -) "q_is_empty_impl \<equiv> \<lambda>(L,R). is_Nil L \<and> is_Nil R"
definition (in -) "q_enqueue_impl \<equiv> \<lambda>x (L,R). (L,x#R)"
definition (in -) "q_dequeue_impl
  \<equiv> \<lambda>(x#L,R) \<Rightarrow> (x,(L,R)) | ([],R) \<Rightarrow> case rev R of (x#L) \<Rightarrow> (x,(L,[]))"

lemma q_empty_impl_correct[simp]: "q_\<alpha> q_empty_impl = []"
  by (auto simp: q_\<alpha>_def q_empty_impl_def)

lemma q_enqueue_impl_correct[simp]: "q_\<alpha> (q_enqueue_impl x Q) = q_\<alpha> Q @ [x]"
  by (auto simp: q_\<alpha>_def q_enqueue_impl_def split: prod.split)

lemma q_is_empty_impl_correct[simp]: "q_is_empty_impl Q \<longleftrightarrow> q_\<alpha> Q = []"
  unfolding q_\<alpha>_def q_is_empty_impl_def
  by (cases Q) (auto split: list.splits)

lemma q_dequeue_impl_correct_aux:
  "\<lbrakk>q_\<alpha> Q = x#xs\<rbrakk> \<Longrightarrow> apsnd q_\<alpha> (q_dequeue_impl Q) = (x,xs)"
  unfolding q_\<alpha>_def q_dequeue_impl_def
  by (cases Q) (auto split!: list.split)

lemma q_dequeue_impl_correct[simp]:
  assumes "q_dequeue_impl Q = (x,Q')"
  assumes "q_\<alpha> Q \<noteq> []"
  shows "x = hd (q_\<alpha> Q)" and "q_\<alpha> Q' = tl (q_\<alpha> Q)"
  using assms q_dequeue_impl_correct_aux[of Q]
  by - (cases "q_\<alpha> Q"; auto)+

definition "q_assn \<equiv> pure (br q_\<alpha> (\<lambda>_. True))"

lemma q_empty_impl_hnr[sepref_fr_rules]:
  "(uncurry0 (return q_empty_impl), uncurry0 q_empty) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a q_assn"
  apply (sepref_to_hoare)
  unfolding q_assn_def q_empty_def pure_def
  by (sep_auto simp: in_br_conv)

lemma q_is_empty_impl_hnr[sepref_fr_rules]:
  "(return o q_is_empty_impl, q_is_empty) \<in> q_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  apply (sepref_to_hoare)
  unfolding q_assn_def q_is_empty_def pure_def
  by (sep_auto simp: in_br_conv)

lemma q_enqueue_impl_hnr[sepref_fr_rules]:
  "(uncurry (return oo q_enqueue_impl), uncurry (PR_CONST q_enqueue))
    \<in> nat_assn\<^sup>k *\<^sub>a q_assn\<^sup>d \<rightarrow>\<^sub>a q_assn"
  apply (sepref_to_hoare)
  unfolding q_assn_def q_enqueue_def pure_def
  by (sep_auto simp: in_br_conv refine_pw_simps)

lemma q_dequeue_impl_hnr[sepref_fr_rules]:
  "(return o q_dequeue_impl, q_dequeue) \<in> q_assn\<^sup>d \<rightarrow>\<^sub>a nat_assn \<times>\<^sub>a q_assn"
  apply (sepref_to_hoare)
  unfolding q_assn_def q_dequeue_def pure_def prod_assn_def
  by (sep_auto simp: in_br_conv refine_pw_simps split: prod.split)

subsubsection \<open>Push\<close>

sepref_thm fifo_push_impl is "uncurry3 (PR_CONST fifo_push2)"
  :: "x_assn\<^sup>d *\<^sub>a cf_assn\<^sup>d *\<^sub>a q_assn\<^sup>d *\<^sub>a edge_assn\<^sup>k
      \<rightarrow>\<^sub>a ((x_assn\<times>\<^sub>acf_assn)\<times>\<^sub>aq_assn)"
  unfolding fifo_push2_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_push_impl
  uses Network_Impl.fifo_push_impl.refine_raw is "(uncurry3 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_push_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Gap-Relabel\<close>

sepref_thm fifo_gap_relabel_impl is "uncurry5 (PR_CONST fifo_gap_relabel2)"
    :: "nat_assn\<^sup>k *\<^sub>a am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k *\<^sub>a clc_assn\<^sup>d *\<^sub>a q_assn\<^sup>d *\<^sub>a node_assn\<^sup>k
      \<rightarrow>\<^sub>a clc_assn \<times>\<^sub>a q_assn"
  unfolding fifo_gap_relabel2_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_gap_relabel_impl
  uses Network_Impl.fifo_gap_relabel_impl.refine_raw is "(uncurry5 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_gap_relabel_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Discharge\<close>

sepref_thm fifo_dis_loop_impl is "uncurry5 (PR_CONST dis_loop2)"
    :: "am_assn\<^sup>k *\<^sub>a x_assn\<^sup>d *\<^sub>a cf_assn\<^sup>d *\<^sub>a clc_assn\<^sup>d *\<^sub>a q_assn\<^sup>d *\<^sub>a node_assn\<^sup>k
      \<rightarrow>\<^sub>a (x_assn\<times>\<^sub>acf_assn)\<times>\<^sub>aclc_assn \<times>\<^sub>a q_assn"
  unfolding dis_loop2_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_dis_loop_impl
  uses Network_Impl.fifo_dis_loop_impl.refine_raw is "(uncurry5 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_dis_loop_impl.refine[OF Network_Impl_axioms]

sepref_thm fifo_fifo_discharge_impl is "uncurry5 (PR_CONST fifo_discharge2)"
    :: "nat_assn\<^sup>k *\<^sub>a am_assn\<^sup>k *\<^sub>a x_assn\<^sup>d *\<^sub>a cf_assn\<^sup>d *\<^sub>a clc_assn\<^sup>d *\<^sub>a q_assn\<^sup>d
    \<rightarrow>\<^sub>a (x_assn\<times>\<^sub>acf_assn)\<times>\<^sub>aclc_assn \<times>\<^sub>a q_assn"
  unfolding fifo_discharge2_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_fifo_discharge_impl
  uses Network_Impl.fifo_fifo_discharge_impl.refine_raw is "(uncurry5 ?f,_)\<in>_"
lemmas [sepref_fr_rules] =
  fifo_fifo_discharge_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Computing the Initial State\<close>
sepref_thm fifo_init_C_impl is "(PR_CONST init_C)"
    :: "am_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding init_C_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_init_C_impl
  uses Network_Impl.fifo_init_C_impl.refine_raw is "(?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_init_C_impl.refine[OF Network_Impl_axioms]

sepref_thm fifo_q_init_impl is "(PR_CONST q_init)"
    :: "am_assn\<^sup>k \<rightarrow>\<^sub>a q_assn"
  unfolding q_init_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_q_init_impl
  uses Network_Impl.fifo_q_init_impl.refine_raw is "(?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_q_init_impl.refine[OF Network_Impl_axioms]

sepref_thm pp_init_xcf2'_impl is "uncurry (PR_CONST pp_init_xcf2')"
    :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>d \<rightarrow>\<^sub>a x_assn \<times>\<^sub>a cf_assn"
  unfolding pp_init_xcf2'_def PR_CONST_def
  by sepref
concrete_definition (in -) pp_init_xcf2'_impl
  uses Network_Impl.pp_init_xcf2'_impl.refine_raw is "(uncurry ?f,_)\<in>_"
lemmas [sepref_fr_rules] = pp_init_xcf2'_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Main Algorithm\<close>
sepref_thm fifo_push_relabel_run_impl
  is "uncurry (PR_CONST fifo_push_relabel_run2)"
    :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>d \<rightarrow>\<^sub>a cf_assn"
  unfolding fifo_push_relabel_run2_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_push_relabel_run_impl
  uses Network_Impl.fifo_push_relabel_run_impl.refine_raw is "(uncurry ?f,_)\<in>_"
lemmas [sepref_fr_rules] =
  fifo_push_relabel_run_impl.refine[OF Network_Impl_axioms]

sepref_thm fifo_push_relabel_init_impl
  is "uncurry0 (PR_CONST fifo_push_relabel_init2)"
    :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a cf_assn"
  unfolding fifo_push_relabel_init2_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_push_relabel_init_impl
  uses Network_Impl.fifo_push_relabel_init_impl.refine_raw
    is "(uncurry0 ?f,_)\<in>_"
lemmas [sepref_fr_rules] =
  fifo_push_relabel_init_impl.refine[OF Network_Impl_axioms]

sepref_thm fifo_push_relabel_impl is "(PR_CONST fifo_push_relabel2)"
    :: "am_assn\<^sup>k \<rightarrow>\<^sub>a cf_assn"
  unfolding fifo_push_relabel2_alt PR_CONST_def
  by sepref
concrete_definition (in -) fifo_push_relabel_impl
  uses Network_Impl.fifo_push_relabel_impl.refine_raw is "(?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_push_relabel_impl.refine[OF Network_Impl_axioms]

end \<comment> \<open>Network Impl. Locale\<close>

export_code fifo_push_relabel_impl checking SML_imp

subsection \<open>Combining the Refinement Steps\<close>

theorem (in Network_Impl) fifo_push_relabel_impl_correct[sep_heap_rules]:
  assumes AM: "is_adj_map am"
  shows "
    <am_assn am ami>
      fifo_push_relabel_impl c s t N ami
    <\<lambda>cfi. \<exists>\<^sub>Acf.
        am_assn am ami * cf_assn cf cfi
      * \<up>(isMaxFlow (flow_of_cf cf) \<and> RGraph_Impl c s t N cf)>\<^sub>t"
proof -
  note fifo_push_relabel2_refine[OF AM]
  also note fifo_push_relabel_correct
  finally have R1:
    "fifo_push_relabel2 am
    \<le> \<Down> (br flow_of_cf (RPreGraph c s t)) (SPEC isMaxFlow)" .

  have [simp]: "nofail (\<Down>R (RES X))" for R X by (auto simp: refine_pw_simps)

  note R2 = fifo_push_relabel_impl.refine[
              OF Network_Impl_axioms, to_hnr, unfolded autoref_tag_defs]
  note R3 = hn_refine_ref[OF R1 R2, of ami]
  note R4 = R3[unfolded hn_ctxt_def pure_def, THEN hn_refineD, simplified]

  note RGII = rgraph_and_network_impl_imp_rgraph_impl[OF
    RPreGraph.maxflow_imp_rgraph
    Network_Impl_axioms
      ]

  show ?thesis
    by (sep_auto
        heap: R4
        simp: RGII
        simp: pw_le_iff refine_pw_simps in_br_conv)
qed

subsection \<open>Combination with Network Checker and Main Correctness Theorem\<close>

definition "fifo_push_relabel_impl_tab_am c s t N am \<equiv> do {
  ami \<leftarrow> Array.make N am;  \<comment> \<open>TODO/DUP: Called \<open>init_ps\<close> in Edmonds-Karp impl\<close>
  cfi \<leftarrow> fifo_push_relabel_impl c s t N ami;
  return (ami,cfi)
}"

theorem fifo_push_relabel_impl_tab_am_correct[sep_heap_rules]:
  assumes NW: "Network c s t"
  assumes VN: "Graph.V c \<subseteq> {0..<N}"
  assumes ABS_PS: "Graph.is_adj_map c am"
  shows "
    <emp>
      fifo_push_relabel_impl_tab_am c s t N am
    <\<lambda>(ami,cfi). \<exists>\<^sub>Acf.
        am_assn N am ami * cf_assn N cf cfi
      * \<up>(Network.isMaxFlow c s t (Network.flow_of_cf c cf)
        \<and> RGraph_Impl c s t N cf
        )>\<^sub>t"
proof -
  interpret Network c s t by fact
  interpret Network_Impl c s t N using VN by unfold_locales

  from ABS_PS have [simp]: "am u = []" if "u\<ge>N" for u
    unfolding is_adj_map_def
    using E_ss_VxV VN that
    apply (subgoal_tac "u\<notin>V")
    by (auto simp del: inV_less_N)

  show ?thesis
    unfolding fifo_push_relabel_impl_tab_am_def
    apply vcg
    apply (rule Hoare_Triple.cons_rule[
            OF _ _ fifo_push_relabel_impl_correct[OF ABS_PS]])
    subgoal unfolding am_assn_def is_nf_def by sep_auto
    apply (rule ent_refl)
    subgoal by sep_auto
    done
qed

definition "fifo_push_relabel el s t \<equiv> do {
  case prepareNet el s t of
    None \<Rightarrow> return None
  | Some (c,am,N) \<Rightarrow> do {
      (ami,cf) \<leftarrow> fifo_push_relabel_impl_tab_am c s t N am;
      return (Some (c,ami,N,cf))
  }
}"
export_code fifo_push_relabel checking SML_imp

(* TODO: Also generate correctness theorem for fifo_push_relabel_run!
  For this, push the split up to abstract level!
*)

text \<open>
  Main correctness statement:
  \<^item> If \<open>fifo_push_relabel\<close> returns \<open>None\<close>, the edge list was invalid or
    described an invalid network.
  \<^item> If it returns \<open>Some (c,am,N,cfi)\<close>, then the edge list is valid and describes
    a valid network. Moreover, \<open>cfi\<close> is an integer square matrix of dimension
    \<open>N\<close>, which describes a valid residual graph in the network, whose
    corresponding flow is maximal. Finally, \<open>am\<close> is a valid adjacency map of the
    graph, and the nodes of the graph are integers less than \<open>N\<close>.
\<close>

theorem fifo_push_relabel_correct[sep_heap_rules]:
  "<emp>
  fifo_push_relabel el s t
  <\<lambda>
    None \<Rightarrow> \<up>(\<not>ln_invar el \<or> \<not>Network (ln_\<alpha> el) s t)
  | Some (c,ami,N,cfi) \<Rightarrow>
      \<up>(c = ln_\<alpha> el \<and> ln_invar el \<and> Network c s t)
    * (\<exists>\<^sub>Aam cf. am_assn N am ami * cf_assn N cf cfi
          * \<up>(RGraph_Impl c s t N cf \<and> Graph.is_adj_map c am
            \<and> Network.isMaxFlow c s t (Network.flow_of_cf c cf))
      )
  >\<^sub>t
  "
  unfolding fifo_push_relabel_def
  using prepareNet_correct[of el s t]
  by (sep_auto simp: ln_rel_def in_br_conv)

subsubsection \<open>Justification of Splitting into Prepare and Run Phase\<close>
(* TODO: Show correctness theorems for both phases separately!  *)

definition "fifo_push_relabel_prepare_impl el s t \<equiv> do {
  case prepareNet el s t of
    None \<Rightarrow> return None
  | Some (c,am,N) \<Rightarrow> do {
      ami \<leftarrow> Array.make N am;
      cfi \<leftarrow> fifo_push_relabel_init_impl c N;
      return (Some (N,ami,c,cfi))
    }
}"

theorem justify_fifo_push_relabel_prep_run_split:
  "fifo_push_relabel el s t =
  do {
    pr \<leftarrow> fifo_push_relabel_prepare_impl el s t;
    case pr of
      None \<Rightarrow> return None
    | Some (N,ami,c,cf) \<Rightarrow> do {
        cf \<leftarrow> fifo_push_relabel_run_impl s t N ami cf;
        return (Some (c,ami,N,cf))
      }
  }"
  unfolding fifo_push_relabel_def fifo_push_relabel_prepare_impl_def
    fifo_push_relabel_impl_tab_am_def fifo_push_relabel_impl_def
  by (auto split: option.split)

subsection \<open>Usage Example: Computing Maxflow Value \<close>
text \<open>We implement a function to compute the value of the maximum flow.\<close>

definition "fifo_push_relabel_compute_flow_val el s t \<equiv> do {
  r \<leftarrow> fifo_push_relabel el s t;
  case r of
    None \<Rightarrow> return None
  | Some (c,am,N,cf) \<Rightarrow> do {
      v \<leftarrow> compute_flow_val_impl s N am cf;
      return (Some v)
    }
}"

text \<open>The computed flow value is correct\<close>
theorem fifo_push_relabel_compute_flow_val_correct:
  "<emp>
    fifo_push_relabel_compute_flow_val el s t
  <\<lambda>
    None \<Rightarrow> \<up>(\<not>ln_invar el \<or> \<not>Network (ln_\<alpha> el) s t)
  | Some v \<Rightarrow> \<up>( ln_invar el
      \<and> (let c = ln_\<alpha> el in
          Network c s t \<and> Network.is_max_flow_val c s t v
        ))
  >\<^sub>t"
proof -
  {
    fix cf N
    assume "RGraph_Impl (ln_\<alpha> el) s t N cf"
    then interpret RGraph "(ln_\<alpha> el)" s t cf by (rule RGraph_Impl.axioms)
    have "f = flow_of_cf cf" unfolding f_def by simp
  } note aux=this

  show ?thesis
    unfolding fifo_push_relabel_compute_flow_val_def
    by (sep_auto simp: Network.is_max_flow_val_def aux)

qed

export_code fifo_push_relabel_compute_flow_val checking SML_imp

end


theory BoogieDeBruijn
imports Lang
begin

text \<open>We define the machinery required to define substitution functions to substitute
arbitrary, potentially open, types. This is inspired by inspired by Vouillon's and Berghofer's
POPLMark solutions\<close>
fun ext_env :: "(nat \<Rightarrow> 'a option) \<Rightarrow> 'a \<Rightarrow> (nat \<Rightarrow> 'a option)"
  where "ext_env f x = (\<lambda>m. f (m-1))(0 \<mapsto> x)"

primrec shiftT :: "nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ty"
where
  "shiftT n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
| "shiftT n k (TPrim tp) = (TPrim tp)"
| "shiftT n k (TCon tcon_id ty_args) = (TCon tcon_id (map (shiftT n k) ty_args))"

primrec shift :: "nat \<Rightarrow> nat \<Rightarrow> expr \<Rightarrow> expr" ("\<up>")
where
  "\<up> n k (Var i) = Var i"
| "\<up> n k (BVar i) = (if i < k then BVar i else BVar (i + n))"
| "\<up> n k (Lit l) = (Lit l)"
| "\<up> n k (UnOp uop e) = UnOp uop (\<up> n k e)"
| "\<up> n k (e1 \<guillemotleft>bop\<guillemotright> e2) = (\<up> n k e1) \<guillemotleft>bop\<guillemotright> (\<up> n k e2)"
| "\<up> n k (FunExp f ty_args args) = FunExp f ty_args (map (\<up> n k) args)"
| "\<up> n k (CondExp cond els thn) = CondExp (\<up> n k cond) (\<up> n k els) (\<up> n k thn)"
| "\<up> n k (Old e) = Old (\<up> n k e)"
| "\<up> n k (Forall ty e) = (Forall ty (\<up> n (k+1) e))"
| "\<up> n k (Exists ty e) = (Exists ty (\<up> n (k+1) e))"
| "\<up> n k (ForallT e) = (ForallT (\<up> n k e))"
| "\<up> n k (ExistsT e) = (ExistsT (\<up> n k e))"

fun shift_env :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<rightharpoonup> ty) \<Rightarrow> (nat \<rightharpoonup> ty)"
  where "shift_env n k \<Delta> m = map_option (shiftT n k) (\<Delta> m)"

primrec shift_ty_term :: "nat \<Rightarrow> nat \<Rightarrow> expr \<Rightarrow> expr" ("\<up>\<^sub>\<tau>")
  where
  "\<up>\<^sub>\<tau> n k (Var i) = Var i"
| "\<up>\<^sub>\<tau> n k (BVar i) = BVar i"
| "\<up>\<^sub>\<tau> n k (Lit l) = (Lit l)"
| "\<up>\<^sub>\<tau> n k (UnOp uop e) = UnOp uop (\<up>\<^sub>\<tau> n k e)"
| "\<up>\<^sub>\<tau> n k (e1 \<guillemotleft>bop\<guillemotright> e2) = (\<up>\<^sub>\<tau> n k e1) \<guillemotleft>bop\<guillemotright> (\<up>\<^sub>\<tau> n k e2)"
| "\<up>\<^sub>\<tau> n k (FunExp f ty_args args) = FunExp f (map (shiftT n k) ty_args) (map (\<up>\<^sub>\<tau> n k) args)"
| "\<up>\<^sub>\<tau> n k (CondExp cond thn els) = CondExp (\<up>\<^sub>\<tau> n k cond) (\<up>\<^sub>\<tau> n k thn) (\<up>\<^sub>\<tau> n k els)"
| "\<up>\<^sub>\<tau> n k (Old e) = Old (\<up>\<^sub>\<tau> n k e)"
| "\<up>\<^sub>\<tau> n k (Forall ty e) = (Forall (shiftT n k ty) (\<up>\<^sub>\<tau> n k e))"
| "\<up>\<^sub>\<tau> n k (Exists ty e) = (Exists (shiftT n k ty) (\<up>\<^sub>\<tau> n k e))"
| "\<up>\<^sub>\<tau> n k (ForallT e) = (ForallT (\<up>\<^sub>\<tau> n (k+1) e))"
| "\<up>\<^sub>\<tau> n k (ExistsT e) = (ExistsT (\<up>\<^sub>\<tau> n (k+1) e))"

primrec substT :: "ty \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ty"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>\<tau>" [300, 0, 0] 300)
  where
  "(TVar i)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = (if k < i then TVar (i - 1) else if i = k then shiftT k 0 S else TVar i)"
| "(TPrim p)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = TPrim p"
| "(TCon tcon_id ty_args)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = TCon tcon_id (map (\<lambda>t. t[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>) ty_args)"

text\<open>At the top-level, e[k \<mapsto>_\<tau> S] must only be used for k = 0, since the function assumes that
S must be shifted by j if variable j must be substituted.\<close>

primrec subst_ty_expr :: "expr \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> expr" ("_[_ \<mapsto>\<^sub>\<tau> _]" [300, 0, 0] 300)
  where
    "(Var i)[k \<mapsto>\<^sub>\<tau> S] = Var i"
  | "(BVar i)[k \<mapsto>\<^sub>\<tau> S] = BVar i"
  | "(Lit l)[k \<mapsto>\<^sub>\<tau> S] = (Lit l)"
  | "(UnOp uop e)[k \<mapsto>\<^sub>\<tau> S] = UnOp uop (e[k \<mapsto>\<^sub>\<tau> S])"
  | "(e1 \<guillemotleft>bop\<guillemotright> e2)[k \<mapsto>\<^sub>\<tau> S] = (e1[k \<mapsto>\<^sub>\<tau> S]) \<guillemotleft>bop\<guillemotright> (e2[k \<mapsto>\<^sub>\<tau> S])"
  | "(FunExp f ty_args args)[k \<mapsto>\<^sub>\<tau> S] = FunExp f (map (\<lambda>t. t[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>) ty_args) (map (\<lambda>e. e[k \<mapsto>\<^sub>\<tau> S]) args)"
  | "(CondExp cond thn els)[k \<mapsto>\<^sub>\<tau> S] = CondExp (cond[k \<mapsto>\<^sub>\<tau> S]) (thn[k \<mapsto>\<^sub>\<tau> S]) (els[k \<mapsto>\<^sub>\<tau> S])"
  | "(Old e)[k \<mapsto>\<^sub>\<tau> S] = Old (e[k \<mapsto>\<^sub>\<tau> S])"
  | "(Forall ty e)[k \<mapsto>\<^sub>\<tau> S] = (Forall (ty[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>) (e[k \<mapsto>\<^sub>\<tau> S]))"
  | "(Exists ty e)[k \<mapsto>\<^sub>\<tau> S] = (Exists (ty[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>) (e[k \<mapsto>\<^sub>\<tau> S]))"
  | "(ForallT e)[k \<mapsto>\<^sub>\<tau> S] = (ForallT (e[k+1 \<mapsto>\<^sub>\<tau> S]))"
  | "(ExistsT e)[k \<mapsto>\<^sub>\<tau> S] = (ExistsT (e[k+1 \<mapsto>\<^sub>\<tau> S]))"

text\<open>Most of the following were adapted from Berhofer's POPLMark solution\<close>

lemma shiftT_shiftT [simp]:
  "i \<le> j \<Longrightarrow> j \<le> i + m \<Longrightarrow> shiftT n j (shiftT m i T) = shiftT (m + n) i T"
  by (induct T arbitrary: i j m n) simp_all

lemma shiftT_shiftT' [simp]:
  "i + m \<le> j \<Longrightarrow> shiftT n j (shiftT m i T) = shiftT m i (shiftT n (j - m) T)"
  apply (induct T arbitrary: i j m n)
  apply simp_all
  apply arith
(* from Berghofer, not required here
  apply (subgoal_tac "Suc j - m = Suc (j - m)")
  apply simp
  apply arith
*)
  done

lemma shiftT_size [simp]: "size (shiftT n k T) = size T"
  apply (induct T arbitrary: k; simp)
  by (simp add: eq_iff size_list_pointwise)

lemma shiftT0 [simp]: "shiftT 0 i T = T"
  apply (induct T arbitrary: i) by (auto simp add: map_idI)

lemma shift0 [simp]: "\<up> 0 i t = t"
  by (induct t arbitrary: i) (auto simp add: map_idI)

theorem substT_shiftT [simp]:
  "k \<le> k' \<Longrightarrow> k' < k + n \<Longrightarrow> (shiftT n k T)[k' \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau> = shiftT (n - 1) k T"
  by (induct T arbitrary: k k'; simp)

theorem shiftT_substT [simp]:
  "k \<le> k' \<Longrightarrow> shiftT n k (T[k' \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>) = shiftT n k T[k' + n \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>"
  apply (induct T arbitrary: k k')
  apply simp_all
  done

theorem shiftT_substT' [simp]: "k' < k \<Longrightarrow>
  shiftT n k (T[k' \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>) = shiftT n (k + 1) T[k' \<mapsto>\<^sub>\<tau> shiftT n (k - k') U]\<^sub>\<tau>"
  apply (induct T arbitrary: k k')
  apply simp_all
  apply arith
  done

(* no equivalent
lemma shiftT_substT_Top [simp]:
  "k \<le> k' \<Longrightarrow> shiftT n k' (T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>) = shiftT n (Suc k') T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>"
*)

lemma liftT_substT_strange:
  "shiftT n k T[n + k \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau> = shiftT n (Suc k) T[k \<mapsto>\<^sub>\<tau> shiftT n 0 U]\<^sub>\<tau>"
  apply (induct T arbitrary: n k)
    apply simp_all
  done
(* required in Berhofer's proof, not here
  apply (thin_tac "\<And>x. PROP P x" for P :: "_ \<Rightarrow> prop")
  apply (drule_tac x=n in meta_spec)
  apply (drule_tac x="Suc k" in meta_spec)
  apply simp
  done
*)

lemma lift_lift [simp]:
  "k \<le> k' \<Longrightarrow> k' \<le> k + n \<Longrightarrow> \<up> n' k' (\<up> n k t) = \<up> (n + n') k t"
  by (induct t arbitrary: k k') simp_all

lemma substT_substT:
  "i \<le> j \<Longrightarrow> T[Suc j \<mapsto>\<^sub>\<tau> V]\<^sub>\<tau>[i \<mapsto>\<^sub>\<tau> U[j - i \<mapsto>\<^sub>\<tau> V]\<^sub>\<tau>]\<^sub>\<tau> = T[i \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>[j \<mapsto>\<^sub>\<tau> V]\<^sub>\<tau>"
  apply (induct T arbitrary: i j U V)
    apply (simp_all add: diff_Suc split: nat.split)
  done
(* required in Berghofer's proof, not here
  apply (thin_tac "\<And>x. PROP P x" for P :: "_ \<Rightarrow> prop")
  apply (drule_tac x="Suc i" in meta_spec)
  apply (drule_tac x="Suc j" in meta_spec)
  apply simp
  done
*)

(* slow implementation of multi-substitution  *)
primrec msubstT :: "ty list \<Rightarrow> ty \<Rightarrow> ty"
  where
   "msubstT [] e = e"
 | "msubstT (t#ts) e = msubstT ts (e[0 \<mapsto>\<^sub>\<tau> t]\<^sub>\<tau>)"

(* substitution where free variable indices are not decremented *)
primrec msubstT_opt_aux :: "(nat \<Rightarrow> ty option) \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> ty"
  where
  "msubstT_opt_aux \<sigma> (TVar i) n = (if \<sigma> i \<noteq> None then shiftT n 0 (the (\<sigma> i)) else TVar i)"
| "msubstT_opt_aux \<sigma> (TPrim p) n = TPrim p"
| "msubstT_opt_aux \<sigma> (TCon tcon_id ty_args) n = TCon tcon_id (map (\<lambda>t. msubstT_opt_aux \<sigma> t n) ty_args)"

definition msubstT_opt :: "ty list \<Rightarrow> ty \<Rightarrow> ty"
  where
  "msubstT_opt ts \<tau> = msubstT_opt_aux (\<lambda>i. if i < length ts then Some (ts ! i) else None) \<tau> 0"

lemma msubstT_opt_empty: "msubstT_opt_aux Map.empty \<tau> n = \<tau>"
  by (induction \<tau>; simp add: map_idI)

lemma msubstT_opt_nil: "msubstT_opt [] \<tau> = \<tau>"
  by (simp add: msubstT_opt_def msubstT_opt_empty)
(*
lemma msubstT_msubstT_opt : "msubstT (map (shiftT (length ts) 0) ts) \<tau> =
       msubstT_opt \<tau> (\<lambda>i. if (i < length ts) then Some (ts ! i) else None) 0"
  apply (induction ts)
   apply (simp add: msubstT_opt_nil)
  oops
*)

primrec msubst_ty_expr :: "ty list \<Rightarrow> expr \<Rightarrow> expr"
  where
   "msubst_ty_expr [] e = e"
 | "msubst_ty_expr (t#ts) e = msubst_ty_expr ts (e[0 \<mapsto>\<^sub>\<tau> t])"

(*
lemma msubstT_msubstT: "msubstT ts2 (msubstT ts1 t) = msubstT (ts1@ts2) t"
  oops
*)

lemma msubstT_map_empty [simp]: "map (msubstT []) ts = ts"
  by (induction ts; auto)

lemma msubstT_tprim [simp]: "msubstT ts (TPrim p) = (TPrim p)"
  by (induction ts; auto)

lemma msubst_ty_map_empty [simp]: "map (msubst_ty_expr []) es = es"
  by (induction es; auto)

lemma msubst_ty_var [simp]: "msubst_ty_expr ts (Var i) = (Var i)"
  by (induction ts; auto)

lemma msubst_ty_lit [simp]: "msubst_ty_expr ts (Lit l) = (Lit l)"
  by (induction ts; auto)

lemma msubst_ty_unop [simp]: "msubst_ty_expr ts (UnOp uop e) = UnOp uop (msubst_ty_expr ts e)"
  by (induction ts arbitrary: e; auto)

lemma msubst_ty_binop [simp]: "msubst_ty_expr ts (e1 \<guillemotleft>bop\<guillemotright> e2) = (msubst_ty_expr ts e1) \<guillemotleft>bop\<guillemotright> (msubst_ty_expr ts e2)"
  by (induction ts arbitrary: e1 e2; auto)

lemma msubst_ty_funexp [simp]:
"msubst_ty_expr ts (FunExp f ty_args args) = (FunExp f (map (msubstT ts) ty_args) (map (msubst_ty_expr ts) args))"
  by (induction ts arbitrary: ty_args args; auto)

lemma msubst_ty_forall [simp]:
"msubst_ty_expr ts (Forall ty e) = Forall (msubstT ts ty) (msubst_ty_expr ts e)"
  by (induction ts arbitrary:e ty; auto)

lemma msubst_ty_exists [simp]:
"msubst_ty_expr ts (Exists ty e) = Exists (msubstT ts ty) (msubst_ty_expr ts e)"
  by (induction ts arbitrary:e ty; auto)

lemma msubst_ty_forallT:
"msubst_ty_expr ts (ForallT e) = ForallT (fold (\<lambda> \<tau> e'. (e'[1 \<mapsto>\<^sub>\<tau> \<tau>])) ts e)"
  by (induction ts arbitrary: e; auto)

lemma msubst_ty_existsT:
"msubst_ty_expr ts (ExistsT e) = ExistsT (fold (\<lambda> \<tau> e'. (e'[1 \<mapsto>\<^sub>\<tau> \<tau>])) ts e)"
  by (induction ts arbitrary: e; auto)

end


theory StackLanguage
imports "../Utilities/BasicComputation" "../Utilities/Iterate"
begin

datatype address =
  Constant int
| Local nat
| Argument nat

datatype stack_instruction =
  Add | Sub | Neg | Eq | Gt | Lt | And | Or | Not
| Push address | Pop address
| IfJ "stack_instruction list" "stack_instruction list"
| Goto code_label
| Call function_name
| Return
| Print

type_synonym stack_code_block = "stack_instruction list \<times> code_label"

record stack_function_def =
  arity :: nat
  local_count :: nat
  main_code :: stack_code_block
  other_code :: "code_label \<rightharpoonup> stack_code_block"

type_synonym stack_program = "function_name \<rightharpoonup> stack_function_def"

datatype stack_value =
  IntV int
| Bool bool

record frame =
  name :: function_name
  arguments :: "stack_value list"
  locals :: "stack_value list"
  saved_stack :: "stack_value list"
  saved_code :: stack_code_block

type_synonym stack_state = "stack_value list \<times> frame list \<times> stack_code_block \<times> output"
  (* \<sigma>, \<phi>, \<pi>, \<omega> *)

inductive eval_stack :: "stack_program \<Rightarrow> stack_state \<Rightarrow> stack_state \<Rightarrow> bool" where
  evs_jump [simp]: "\<Pi> (frame.name f) = Some def \<Longrightarrow> stack_function_def.other_code def s = Some \<pi> \<Longrightarrow>
    eval_stack \<Pi> ([], f # \<phi>, ([], s), \<omega>) ([], f # \<phi>, \<pi>, \<omega>)"
| evs_add [simp]: "eval_stack \<Pi> (IntV i1 # IntV i2 # \<sigma>, \<phi>, (Add # \<pi>, s), \<omega>)
    (IntV (i1 + i2) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_sub [simp]: "eval_stack \<Pi> (IntV i1 # IntV i2 # \<sigma>, \<phi>, (Sub # \<pi>, s), \<omega>)
    (IntV (i2 - i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_neg [simp]: "eval_stack \<Pi> (IntV i1 # \<sigma>, \<phi>, (Neg # \<pi>, s), \<omega>) (IntV (-i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_eq [simp]: "eval_stack \<Pi> (IntV i1 # IntV i2 # \<sigma>, \<phi>, (Eq # \<pi>, s), \<omega>)
    (Bool (i2 = i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_gt [simp]: "eval_stack \<Pi> (IntV i1 # IntV i2 # \<sigma>, \<phi>, (Gt # \<pi>, s), \<omega>)
    (Bool (i2 > i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_lt [simp]: "eval_stack \<Pi> (IntV i1 # IntV i2 # \<sigma>, \<phi>, (Lt # \<pi>, s), \<omega>)
    (Bool (i2 < i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_and [simp]: "eval_stack \<Pi> (Bool i1 # Bool i2 # \<sigma>, \<phi>, (And # \<pi>, s), \<omega>)
    (Bool (i2 \<and> i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_or [simp]: "eval_stack \<Pi> (Bool i1 # Bool i2 # \<sigma>, \<phi>, (Or # \<pi>, s), \<omega>)
    (Bool (i2 \<or> i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_not [simp]: "eval_stack \<Pi> (Bool i1 # \<sigma>, \<phi>, (Not # \<pi>, s), \<omega>) (Bool (\<not> i1) # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_push_c [simp]: "eval_stack \<Pi> (\<sigma>, \<phi>, (Push (Constant i) # \<pi>, s), \<omega>) (IntV i # \<sigma>, \<phi>, (\<pi>, s), \<omega>)"
| evs_push_l [simp]: "n < length (frame.locals f) \<Longrightarrow>
    eval_stack \<Pi> (\<sigma>, f # \<phi>, (Push (Local n) # \<pi>, s), \<omega>) (frame.locals f ! n # \<sigma>, f # \<phi>, (\<pi>, s), \<omega>)"
| evs_push_a [simp]: "n < length (frame.arguments f) \<Longrightarrow>
    eval_stack \<Pi> (\<sigma>, f # \<phi>, (Push (Argument n) # \<pi>, s), \<omega>)
      (frame.arguments f ! n # \<sigma>, f # \<phi>, (\<pi>, s), \<omega>)"
| evs_pop_l [simp]: "n < length (frame.locals f) \<Longrightarrow>
    eval_stack \<Pi> (v # \<sigma>, f # \<phi>, (Pop (Local n) # \<pi>, s), \<omega>)
      (\<sigma>, f \<lparr> locals := frame.locals f [n := v] \<rparr> # \<phi>, (\<pi>, s), \<omega>)"
| evs_pop_a [simp]: "n < length (frame.arguments f) \<Longrightarrow>
    eval_stack \<Pi> (v # \<sigma>, f # \<phi>, (Pop (Argument n) # \<pi>, s), \<omega>)
      (\<sigma>, f \<lparr> arguments := frame.arguments f [n := v] \<rparr> # \<phi>, (\<pi>, s), \<omega>)"
| evs_if_t [simp]: "eval_stack \<Pi> (Bool True # \<sigma>, \<phi>, (IfJ \<pi>\<^sub>t \<pi>\<^sub>f # \<pi>, s), \<omega>) (\<sigma>, \<phi>, (\<pi>\<^sub>t @ \<pi>, s), \<omega>)"
| evs_if_f [simp]: "eval_stack \<Pi> (Bool False # \<sigma>, \<phi>, (IfJ \<pi>\<^sub>t \<pi>\<^sub>f # \<pi>, s), \<omega>) (\<sigma>, \<phi>, (\<pi>\<^sub>f @ \<pi>, s), \<omega>)"
| evs_goto [simp]: "\<Pi> (frame.name f) = Some def \<Longrightarrow> stack_function_def.other_code def s = Some \<pi>' \<Longrightarrow>
    eval_stack \<Pi> ([], f # \<phi>, (Goto s # \<pi>, _), \<omega>) ([], f # \<phi>, \<pi>', \<omega>)"
| evs_call [simp]: "\<Pi> f = Some def \<Longrightarrow> length \<sigma> \<ge> stack_function_def.arity def \<Longrightarrow>
    eval_stack \<Pi> (\<sigma>, \<phi>, (Call f # \<pi>', s), \<omega>) ([], \<lparr>
      name = f, arguments = take (stack_function_def.arity def) \<sigma>,
      locals = repeat (IntV 0) (stack_function_def.local_count def),
      saved_stack = (drop (stack_function_def.arity def) \<sigma>), saved_code = (\<pi>', s) \<rparr> # \<phi>, \<pi>, \<omega>)"
| evs_return [simp]: "eval_stack \<Pi> (v # [], f # \<phi>, (Return # \<pi>, s), \<omega>)
    (v # frame.saved_stack f, \<phi>, frame.saved_code f, \<omega>)"
| evs_print [simp]: "eval_stack \<Pi> (IntV i1 # \<sigma>, \<phi>, (Print # \<pi>, s), \<omega>) (\<sigma>, \<phi>, (\<pi>, s), i1 # \<omega>)"

fun stack_output :: "stack_state \<Rightarrow> output" where
  "stack_output (\<sigma>, \<phi>, \<pi>, \<omega>) = \<omega>"

(* state validity *)

fun valid_frame :: "stack_program \<Rightarrow> frame \<Rightarrow> bool" where
  "valid_frame \<Pi> \<lparr> name = f, arguments = as, locals = ls, saved_stack = \<sigma>, saved_code = \<pi> \<rparr> = (
    case \<Pi> f of
        Some def \<Rightarrow> length as = stack_function_def.arity def \<and>
          length ls = stack_function_def.local_count def
      | None \<Rightarrow> False)"

fun valid_state :: "stack_program \<Rightarrow> stack_state \<Rightarrow> bool" where
  "valid_state \<Pi> (\<sigma>, \<phi>, \<pi>, \<omega>) = (\<forall>f \<in> set \<phi>. valid_frame \<Pi> f)"

lemma [simp]: "valid_frame \<Pi> fr \<Longrightarrow> valid_frame \<Pi> (fr\<lparr>arguments := arguments fr[n := v]\<rparr>)"
  by (cases fr) (auto split: option.splits)

lemma [simp]: "valid_frame \<Pi> fr \<Longrightarrow> \<Pi> (frame.name fr) = Some def \<Longrightarrow>
    length (frame.locals fr) = stack_function_def.local_count def"
  by (cases fr) simp

lemma [simp]: "eval_stack \<Pi> \<Sigma> \<Sigma>' \<Longrightarrow> valid_state \<Pi> \<Sigma> \<Longrightarrow> valid_state \<Pi> \<Sigma>'"
  by (induction \<Pi> \<Sigma> \<Sigma>' rule: eval_stack.induct) simp_all

lemma [simp]: "iterate_ind (eval_stack \<Pi>) \<Sigma> \<Sigma>' \<Longrightarrow> valid_state \<Pi> \<Sigma> \<Longrightarrow> valid_state \<Pi> \<Sigma>'"
  by (induction "eval_stack \<Pi>" \<Sigma> \<Sigma>' rule: iterate_ind.induct) simp_all

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Tensor Matricization\<close>

theory Tensor_Matricization
imports Tensor_Plus
Jordan_Normal_Form.Matrix Jordan_Normal_Form.DL_Missing_Sublist
begin

fun digit_decode :: "nat list \<Rightarrow> nat list \<Rightarrow> nat" where
"digit_decode [] [] = 0" |
"digit_decode (d # ds) (i # is) = i + d * digit_decode ds is"

fun digit_encode :: "nat list \<Rightarrow> nat \<Rightarrow> nat list" where
"digit_encode [] a = []" |
"digit_encode (d # ds) a = a mod d # digit_encode ds (a div d)"

lemma digit_encode_decode[simp]:
assumes "is \<lhd> ds"
shows "digit_encode ds (digit_decode ds is) = is"
  using assms apply (induction rule:valid_index.induct)
  unfolding digit_decode.simps digit_encode.simps
  by simp_all

lemma digit_decode_encode[simp]:
shows "digit_decode ds (digit_encode ds a) = a mod (prod_list ds)"
by (induction ds arbitrary:a; simp add: Divides.mod_mult2_eq add.commute)

lemma digit_decode_encode_lt[simp]:
assumes "a < prod_list ds"
shows "digit_decode ds (digit_encode ds a) = a"
by (simp add: assms)

lemma digit_decode_lt:
assumes "is \<lhd> ds"
shows "digit_decode ds is < prod_list ds"
using assms proof (induction rule:valid_index.induct)
  case Nil
  then show ?case by simp
next
  case (Cons "is" ds i d)
  have "(i + d * digit_decode ds is) div (d * prod_list ds) = 0"
    using Cons.IH Cons.hyps(2) div_mult2_eq by force
  then show ?case unfolding digit_decode.simps prod_list.Cons
    by (metis (no_types) Cons.IH Cons.hyps(2) div_eq_0_iff mult_eq_0_iff not_less0)
qed

lemma digit_encode_valid_index:
assumes "a < prod_list ds"
shows "digit_encode ds a \<lhd> ds"
using assms proof (induction ds arbitrary:a)
  case Nil
  show ?case by (simp add: valid_index.Nil)
next
  case (Cons d ds a)
  then have "a < d * prod_list ds"
    by simp
  then have "a div d < prod_list ds"
    by (metis div_eq_0_iff div_mult2_eq mult_0_right not_less0)
  then have "digit_encode ds (a div d) \<lhd> ds"
    by (rule Cons)
  moreover have "d > 0"
    using \<open>a < d * prod_list ds\<close> by (cases "d = 0") simp_all
  then have "a mod d < d"
    by simp
  ultimately show ?case
    by (simp add: valid_index.Cons)
qed

lemma length_digit_encode:
shows "length (digit_encode ds a) = length ds"
  by (induction ds arbitrary:a; simp_all)

lemma digit_encode_0:
"prod_list ds dvd a \<Longrightarrow> digit_encode ds a = replicate (length ds) 0"
proof (induction ds arbitrary:a)
  case Nil
  then show ?case by simp
next
  case (Cons d ds a)
  then have "prod_list ds dvd (a div d)" unfolding prod_list.Cons
    by (metis dvd_0_right dvd_div_iff_mult dvd_mult_left mult.commute split_div)
  then show ?case unfolding digit_encode.simps length_Cons replicate_Suc prod_list.Cons using Cons
    using dvd_imp_mod_0 dvd_mult_left prod_list.Cons by force
qed

lemma valid_index_weave:
assumes "is1 \<lhd> (nths ds A)"
and     "is2 \<lhd> (nths ds (-A))"
shows "weave A is1 is2 \<lhd> ds"
and "nths (weave A is1 is2) A = is1"
and "nths (weave A is1 is2) (-A) = is2"
proof -
  have length_ds: "length is1 + length is2 = length ds"
    using valid_index_length[OF assms(1)] valid_index_length[OF assms(2)]
    length_weave  weave_complementary_nthss by metis
  have 1:"length is1 = card {i \<in> A. i < length is1 + length is2}" unfolding length_ds
    using length_nths' assms(1) valid_index_length by auto
  have 2:"length is2 = card {i \<in> -A. i < length is1 + length is2}" unfolding length_ds
    using length_nths'[of ds "-A"] assms(2) valid_index_length by auto
  show "nths (weave A is1 is2) A = is1" "nths (weave A is1 is2) (-A) = is2" using nths_weave[OF 1 2] by blast+
  then have "nths (weave A is1 is2) A \<lhd> (nths ds A)"
       "nths (weave A is1 is2) (-A) \<lhd> (nths ds (-A))" using assms by auto
  then show "weave A is1 is2 \<lhd> ds" using list_all2_nths valid_index_list_all2_iff by blast
qed

definition matricize :: "nat set \<Rightarrow> 'a tensor \<Rightarrow> 'a mat" where
"matricize rmodes T = mat
  (prod_list (nths (Tensor.dims T) rmodes))
  (prod_list (nths (Tensor.dims T) (-rmodes)))
  (\<lambda>(r, c). Tensor.lookup T (weave rmodes
    (digit_encode (nths (Tensor.dims T) rmodes) r)
    (digit_encode (nths (Tensor.dims T) (-rmodes)) c)
  ))
"

definition dematricize::"nat set \<Rightarrow> 'a mat \<Rightarrow> nat list \<Rightarrow> 'a tensor" where
"dematricize rmodes A ds  = tensor_from_lookup ds
  (\<lambda>is. A $$ (digit_decode (nths ds rmodes) (nths is rmodes),
              digit_decode (nths ds (-rmodes)) (nths is (-rmodes)))
 )
"

lemma dims_matricize:
"dim_row (matricize rmodes T) = prod_list (nths (Tensor.dims T) rmodes)"
"dim_col (matricize rmodes T) = prod_list (nths (Tensor.dims T) (-rmodes))"
  unfolding matricize_def using dim_row_mat by simp_all

lemma dims_dematricize: "Tensor.dims (dematricize rmodes A ds) = ds"
  by (simp add: dematricize_def dims_tensor_from_lookup)

lemma valid_index_nths:
assumes "is \<lhd> ds"
shows "nths is A \<lhd> nths ds A"
using assms proof (induction arbitrary:A rule:valid_index.induct)
  case Nil
  then show ?case using nths_nil valid_index.simps by blast
next
  case (Cons "is" ds i d)
  then have " nths is {j. Suc j \<in> A} \<lhd> nths ds {j. Suc j \<in> A}"
    by simp
  then show ?case unfolding nths_Cons
    by (cases "0\<in>A"; simp_all add: Cons.hyps(2) valid_index.Cons)
qed

lemma dematricize_matricize:
shows "dematricize rmodes (matricize rmodes T) (Tensor.dims T) = T"
proof (rule tensor_lookup_eqI)
  show 1:"Tensor.dims (dematricize rmodes (matricize rmodes T) (Tensor.dims T)) = Tensor.dims T"
    by (simp add: dematricize_def dims_tensor_from_lookup)
  fix "is" assume "is \<lhd> Tensor.dims (dematricize rmodes (matricize rmodes T) (Tensor.dims T))"
  then have "is \<lhd> Tensor.dims T" using 1 by auto
  let ?rds = "(nths (Tensor.dims T) rmodes)"
  let ?cds = "(nths (Tensor.dims T) (-rmodes))"
  have decode_r: "digit_decode ?rds (nths is rmodes) < prod_list ?rds"
    by (simp add: \<open>is \<lhd> Tensor.dims T\<close> valid_index_nths digit_decode_lt)
  have decode_c: "digit_decode ?cds (nths is (-rmodes)) < prod_list ?cds"
    by (simp add: \<open>is \<lhd> Tensor.dims T\<close> valid_index_nths digit_decode_lt)
  have "(matricize rmodes T) $$
     (digit_decode ?rds (nths is rmodes),
      digit_decode ?cds (nths is (- rmodes))) =
    Tensor.lookup T is"
    unfolding matricize_def
    by (simp add: decode_r decode_c \<open>is \<lhd> Tensor.dims T\<close> valid_index_nths)
  then show "Tensor.lookup (dematricize rmodes (matricize rmodes T) (Tensor.dims T)) is = Tensor.lookup T is"
    by (simp add: dematricize_def dims_tensor_from_lookup lookup_tensor_from_lookup[OF \<open>is \<lhd> Tensor.dims T\<close>])
qed

lemma matricize_dematricize:
assumes " dim_row A = prod_list (nths ds rmodes)"
and " dim_col A = prod_list (nths ds (-rmodes))"
shows "matricize rmodes (dematricize rmodes A ds) = A"
proof (rule eq_matI)
  show "dim_row (matricize rmodes (dematricize rmodes A ds)) = dim_row A"
    unfolding assms(1) dematricize_def dims_tensor_from_lookup matricize_def dim_row_mat by metis
  show "dim_col (matricize rmodes (dematricize rmodes A ds)) = dim_col A"
    unfolding assms(2) dematricize_def dims_tensor_from_lookup matricize_def dim_col_mat by metis
  fix r c assume "r < dim_row A" "c < dim_col A"
  have valid1:"digit_encode (nths ds rmodes) r \<lhd> nths ds rmodes" and
       valid2:"digit_encode (nths ds (- rmodes)) c \<lhd> nths ds (- rmodes)"
    using \<open>r < dim_row A\<close> assms(1) \<open>c < dim_col A\<close> assms(2) digit_encode_valid_index by auto
  have 0:"Tensor.lookup (dematricize rmodes A ds)
     (weave rmodes
       (digit_encode (nths (Tensor.dims (dematricize rmodes A ds)) rmodes) r)
       (digit_encode (nths (Tensor.dims (dematricize rmodes A ds)) (- rmodes)) c)
     ) =  A $$ (r, c)"
      unfolding dematricize_def unfolding dims_tensor_from_lookup
      unfolding lookup_tensor_from_lookup[OF valid_index_weave(1)[OF valid1 valid2]]
      using digit_decode_encode_lt[OF \<open>c < dim_col A\<close>[unfolded assms(2)]]
      digit_decode_encode_lt[OF \<open>r < dim_row A\<close>[unfolded assms(1)]]
      valid_index_weave(2)[OF valid1 valid2] valid_index_weave(3)[OF valid1 valid2]
      by presburger
  from \<open>r < dim_row A\<close> have r_le: "r < prod_list (nths (Tensor.dims (dematricize rmodes A ds)) rmodes)"
    by (metis \<open>dim_row (matricize rmodes (dematricize rmodes A ds)) = dim_row A\<close> matricize_def dim_row_mat(1))
  from \<open>c < dim_col A \<close>have c_le: "c < prod_list (nths (Tensor.dims (dematricize rmodes A ds)) (- rmodes))"
    by (metis \<open>dim_col (matricize rmodes (dematricize rmodes A ds)) = dim_col A\<close> matricize_def dim_col_mat(1))
  then show "(matricize rmodes (dematricize rmodes A ds)) $$ (r, c) = A $$ (r, c)"
    unfolding matricize_def using r_le c_le 0 by simp
qed

lemma matricize_add:
assumes "dims A = dims B"
shows "matricize I A + matricize I B = matricize I (A+B)"
proof (rule eq_matI)
  show "dim_row (matricize I A + matricize I B) = dim_row (matricize I (A + B))" by (simp add: assms dims_matricize(1))
  show "dim_col (matricize I A + matricize I B) = dim_col (matricize I (A + B))" by (simp add: assms dims_matricize(2))
  fix i j assume ij_le1:"i < dim_row (matricize I (A + B))" "j < dim_col (matricize I (A + B))"
  then have
    ij_le2:"i < prod_list (nths (Tensor.dims A) I)"  "j < prod_list (nths (Tensor.dims A) (-I))" and
    ij_le3:"i < prod_list (nths (Tensor.dims B) I)"  "j < prod_list (nths (Tensor.dims B) (-I))" and
    ij_le4:"i < prod_list (nths (Tensor.dims (A + B)) I)"  "j < prod_list (nths (Tensor.dims (A + B)) (-I))"
    by (simp_all add: assms dims_matricize)
  then have ij_le5:"i < dim_row (matricize I B)" "j < dim_col (matricize I B)"
    by (simp_all add: assms dims_matricize)
  show "(matricize I A + matricize I B) $$ (i, j) = matricize I (A + B) $$ (i, j)"
    unfolding index_add_mat(1)[OF ij_le5] unfolding matricize_def unfolding index_mat[OF ij_le2] index_mat[OF ij_le3] index_mat[OF ij_le4]
    using assms digit_encode_valid_index ij_le2(1) ij_le2(2) valid_index_weave(1) by auto
qed

lemma matricize_0:
shows "matricize I (tensor0 ds) = 0\<^sub>m (dim_row (matricize I (tensor0 ds))) (dim_col (matricize I (tensor0 ds)))"
proof (rule eq_matI)
  show "dim_row (matricize I (tensor0 ds)) = dim_row (0\<^sub>m (dim_row (matricize I (tensor0 ds))) (dim_col (matricize I (tensor0 ds))))"
    unfolding zero_mat_def dim_row_mat by (simp add: dims_matricize(1))
  show "dim_col (matricize I (tensor0 ds)) = dim_col (0\<^sub>m (dim_row (matricize I (tensor0 ds))) (dim_col (matricize I (tensor0 ds))))"
    unfolding zero_mat_def dim_row_mat by (simp add: dims_matricize(2))
  fix i j assume ij_le1: "i < dim_row (0\<^sub>m (dim_row (matricize I (tensor0 ds))) (dim_col (matricize I (tensor0 ds))))"
                 "j < dim_col (0\<^sub>m (dim_row (matricize I (tensor0 ds))) (dim_col (matricize I (tensor0 ds))))"
  then have ij_le2:"i < dim_row (matricize I (tensor0 ds))" "j < dim_col (matricize I (tensor0 ds))"
    unfolding zero_mat_def dim_row_mat by (simp_all add: dims_matricize)
  show "matricize I (tensor0 ds) $$ (i, j) = 0\<^sub>m (dim_row (matricize I (tensor0 ds))) (dim_col (matricize I (tensor0 ds))) $$ (i, j)"
    unfolding zero_mat_def  index_mat[OF ij_le2] unfolding matricize_def index_mat[OF ij_le2[unfolded dims_matricize]]
    by (simp, metis lookup_tensor0 digit_encode_valid_index dims_matricize(1) dims_matricize(2) dims_tensor0
    ij_le2(1) ij_le2(2) valid_index_weave(1))
qed

end