(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo_inf
imports DLO
begin

subsection "Quantifier elimination with infinitesimals"

text{* This section presents a new quantifier elimination procedure
for dense linear orders based on (the simulation of) infinitesimals.
It is a fairly straightforward adaptation of the analogous algorithm
by Loos and Weispfenning for linear arithmetic described in
\S\ref{sec:lin-inf}. *}

fun asubst_peps :: "nat \<Rightarrow> atom \<Rightarrow> atom fm" ("asubst\<^sub>+") where
"asubst_peps k (Less 0 0) = FalseF" |
"asubst_peps k (Less 0 (Suc j)) = Atom(Less k j)" |
"asubst_peps k (Less (Suc i) 0) = (if i=k then TrueF
   else Or (Atom(Less i k)) (Atom(Eq i k)))" |
"asubst_peps k (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"asubst_peps k (Eq 0 0) = TrueF" |
"asubst_peps k (Eq 0 _) = FalseF" |
"asubst_peps k (Eq _ 0) = FalseF" |
"asubst_peps k (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation subst_peps :: "atom fm \<Rightarrow> nat \<Rightarrow> atom fm" ("subst\<^sub>+") where
"subst\<^sub>+ \<phi> k \<equiv> amap\<^bsub>fm\<^esub> (asubst\<^sub>+ k) \<phi>"

definition "nolb \<phi> xs l x = (\<forall>y\<in>{l<..<x}. y \<notin> LB \<phi> xs)"

lemma nolb_And[simp]:
  "nolb (And \<phi>\<^sub>1 \<phi>\<^sub>2) xs l x = (nolb \<phi>\<^sub>1 xs l x \<and> nolb \<phi>\<^sub>2 xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

lemma nolb_Or[simp]:
  "nolb (Or \<phi>\<^sub>1 \<phi>\<^sub>2) xs l x = (nolb \<phi>\<^sub>1 xs l x \<and> nolb \<phi>\<^sub>2 xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

declare[[simp_depth_limit=3]]

lemma I_subst_peps2:
 "nqfree \<phi> \<Longrightarrow> xs!l < x \<Longrightarrow> nolb \<phi> xs (xs!l) x \<Longrightarrow> x \<notin> EQ \<phi> xs
 \<Longrightarrow> \<forall>y \<in> {xs!l <.. x}. DLO.I \<phi> (y#xs)
 \<Longrightarrow> DLO.I (subst\<^sub>+ \<phi> l) xs"
proof(induct \<phi>)
  case FalseF thus ?case
    by simp (metis linorder_antisym_conv1 linorder_neq_iff)
next
  case (Atom a)
  show ?case
  proof(cases "(l,a)" rule:asubst_peps.cases)
    case 3 thus ?thesis using Atom
      by (auto simp: nolb_def EQ_def Ball_def)
         (metis One_nat_def linorder_antisym_conv1 not_less_iff_gr_or_eq)
  qed (insert Atom, auto simp: nolb_def EQ_def Ball_def)
next
  case Or thus ?case by(simp add: Ball_def)(metis order_refl innermost_intvl)
qed simp_all
declare[[simp_depth_limit=50]]

lemma I_subst_peps:
  "nqfree \<phi> \<Longrightarrow> DLO.I (subst\<^sub>+ \<phi> l) xs \<longrightarrow>
  (\<exists>leps>xs!l. \<forall>x. xs!l < x \<and> x \<le> leps \<longrightarrow> DLO.I \<phi> (x#xs))"
proof(induct \<phi>)
  case TrueF thus ?case by simp (metis no_ub)
next
  case (Atom a)
  show ?case
  proof (cases "(l,a)" rule: asubst_peps.cases)
    case 2 thus ?thesis using Atom
      apply(auto)
      apply(drule dense)
      apply(metis One_nat_def xt1(7))
      done
  next
    case 3 thus ?thesis using Atom
      apply(auto)
        apply (metis no_ub)
       apply (metis no_ub less_trans)
      apply (metis no_ub)
      done
  next
    case 4 thus ?thesis using Atom by(auto)(metis no_ub)
  next
    case 5 thus ?thesis using Atom by(auto)(metis no_ub)
  next
    case 8 thus ?thesis using Atom by(auto)(metis no_ub)
  qed (insert Atom, auto)
next
  case And thus ?case
    apply clarsimp
    apply(rule_tac x="min leps lepsa" in exI)
    apply simp
    done
next
  case Or thus ?case by force
qed simp_all

definition
"qe_eps\<^sub>1(\<phi>) =
(let as = DLO.atoms\<^sub>0 \<phi>; lbs = lbounds as; ebs = ebounds as
 in list_disj (inf\<^sub>- \<phi> # map (subst\<^sub>+ \<phi>) lbs @ map (subst \<phi>) ebs))"

theorem I_qe_eps1:
assumes "nqfree \<phi>" shows "DLO.I (qe_eps\<^sub>1 \<phi>) xs = (\<exists>x. DLO.I \<phi> (x#xs))"
  (is "?QE = ?EX")
proof
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?ebs = "ebounds ?as"
  assume ?QE
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using `?QE` min_inf[of \<phi> xs] `nqfree \<phi>`
      by(auto simp add:qe_eps\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<forall>i \<in> set ?ebs. \<not>DLO.I \<phi> (xs!i # xs)"
           "\<not> DLO.I (inf\<^sub>- \<phi>) xs"
    with `?QE` `nqfree \<phi>` obtain l where "DLO.I (subst\<^sub>+ \<phi> l) xs"
      by(fastforce simp: I_subst qe_eps\<^sub>1_def set_ebounds set_lbounds)
    then obtain leps where "DLO.I \<phi> (leps#xs)"
      using I_subst_peps[OF `nqfree \<phi>`] by fastforce
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?ebs = "ebounds ?as"
  assume ?EX
  then obtain x where x: "DLO.I \<phi> (x#xs)" ..
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?QE using `nqfree \<phi>` by(auto simp:qe_eps\<^sub>1_def)
  } moreover
  { assume "\<exists>k \<in> set ?ebs. DLO.I (subst \<phi> k) xs"
    hence ?QE by(auto simp:qe_eps\<^sub>1_def) } moreover
  { assume "\<not> DLO.I (inf\<^sub>- \<phi>) xs"
    and "\<forall>k \<in> set ?ebs. \<not> DLO.I (subst \<phi> k) xs"
    hence noE: "\<forall>e \<in> EQ \<phi> xs. \<not> DLO.I \<phi> (e#xs)" using `nqfree \<phi>`
      by (auto simp:set_ebounds EQ_def I_subst nth_Cons' split:split_if_asm)
    hence "x \<notin> EQ \<phi> xs" using x by fastforce
    obtain l where "l \<in> LB \<phi> xs" "l < x"
      using LBex[OF `nqfree \<phi>` x `\<not> DLO.I(inf\<^sub>- \<phi>) xs` `x \<notin> EQ \<phi> xs`] ..
    have "\<exists>l\<in>LB \<phi> xs. l<x \<and> nolb \<phi> xs l x \<and>
            (\<forall>y. l < y \<and> y \<le> x \<longrightarrow> DLO.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. DLO.I \<phi> (x#xs)", OF finite_LB `l\<in>LB \<phi> xs` `l<x` x] x innermost_intvl[OF `nqfree \<phi>` _ _ `x \<notin> EQ \<phi> xs`]
      by (simp add:nolb_def)
    then obtain m
      where *: "Less (Suc m) 0 \<in> set ?as \<and> xs!m < x \<and> nolb \<phi> xs (xs!m) x
            \<and> (\<forall>y. xs!m < y \<and> y \<le> x \<longrightarrow> DLO.I \<phi> (y#xs))"
      by blast
    then have "DLO.I (subst\<^sub>+ \<phi> m) xs"
      using noE by(auto intro!: I_subst_peps2[OF `nqfree \<phi>`])
    with * have ?QE
      by(simp add:qe_eps\<^sub>1_def bex_Un set_lbounds set_ebounds) metis
  } ultimately show ?QE by blast
qed

lemma qfree_asubst_peps: "qfree (asubst\<^sub>+ k a)"
by(cases "(k,a)" rule:asubst_peps.cases) simp_all

lemma qfree_subst_peps: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>+ \<phi> k)"
by(induct \<phi>) (simp_all add:qfree_asubst_peps)

lemma qfree_qe_eps\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree(qe_eps\<^sub>1 \<phi>)"
apply(simp add:qe_eps\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_subst_peps qfree_map_fm)
done

definition "qe_eps = DLO.lift_nnf_qe qe_eps\<^sub>1"

lemma qfree_qe_eps: "qfree(qe_eps \<phi>)"
by(simp add: qe_eps_def DLO.qfree_lift_nnf_qe qfree_qe_eps\<^sub>1)

lemma I_qe_eps: "DLO.I (qe_eps \<phi>) xs = DLO.I \<phi> xs"
by(simp add:qe_eps_def DLO.I_lift_nnf_qe qfree_qe_eps\<^sub>1 I_qe_eps1)

end


section {*Algebraic laws of programming*}

text{*In this section we introduce the semantic rules related to the different
      statements of IMP. In the literature this also known as the algebraic laws of programming.
      In our framework we will use these rules in order to optimize a given program written in our
      language, and this before any deductive proof verification activity or formal testing.*}

theory Algebraic_Laws
imports "../../../utp/utp_urel_laws"
begin

named_theorems symbolic_exec and symbolic_exec_assign_uop and symbolic_exec_assign_bop and
               symbolic_exec_assign_trop and symbolic_exec_assign_qtop and symbolic_exec_ex
(* Usage of symbolic_exec_ex for the simp lemmas avoids annoying warnings about duplicate theorems
when using `simp add: symbolic_exec` *)

subsection {*SKIP Laws*}
text{*In this section we introduce the algebraic laws of programming related to the SKIP
      statement.*}

lemma seqr_left_unit [simp, symbolic_exec_ex]:
  "II ;; P = P"
  by rel_auto

lemma seqr_right_unit [simp, symbolic_exec_ex]:
  "P ;; II = P"
  by rel_auto

lemma pre_skip_post: "(\<lceil>b\<rceil>\<^sub>< \<and> II) = (II \<and> \<lceil>b\<rceil>\<^sub>>)"
  by rel_auto

lemma skip_var:
  fixes x :: "(bool, '\<alpha>) uvar"
  shows "($x \<and> II) = (II \<and> $x\<acute>)"
  by rel_auto

lemma assign_r_alt_def [symbolic_exec]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "x :== v = II\<lbrakk>\<lceil>v\<rceil>\<^sub></$x\<rbrakk>"
  by rel_auto

lemma skip_r_alpha_eq:
  "II = ($\<Sigma>\<acute> =\<^sub>u $\<Sigma>)"
  by rel_auto

subsection {*Assignment Laws*}
text{*In this section we introduce the algebraic laws of programming related to the assignment
      statement.*}

lemma "&v\<lbrakk>expr/v\<rbrakk> = [v \<mapsto>\<^sub>s expr] \<dagger> &v" ..

lemma usubst_cancel[usubst,symbolic_exec]:
  assumes 1:"weak_lens v"
  shows "(&v)\<lbrakk>expr/v\<rbrakk> = expr"
  using 1
  by transfer' rel_auto

lemma usubst_cancel_r[usubst,symbolic_exec]:
  assumes 1:"weak_lens v"
  shows "($v)\<lbrakk>\<lceil>expr\<rceil>\<^sub></$v\<rbrakk>= \<lceil>expr\<rceil>\<^sub><"
  using 1
  by  rel_auto

lemma assign_test[symbolic_exec]:
  assumes 1:"mwb_lens x"
  shows     "(x :== \<guillemotleft>u\<guillemotright> ;; x :== \<guillemotleft>v\<guillemotright>) = (x :== \<guillemotleft>v\<guillemotright>)"
  using 1
  by (simp add: assigns_comp subst_upd_comp subst_lit usubst_upd_idem)

lemma assign_r_comp[symbolic_exec]:
  "(x :== u ;; P) = P\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>"
  by (simp add: assigns_r_comp usubst)

lemma assign_twice[symbolic_exec]:
  assumes "mwb_lens x" and  "x \<sharp> f"
  shows "(x :== e ;; x :== f) = (x :== f)"
  using assms
  by (simp add: assigns_comp usubst)

lemma assign_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x :== e ;; y :== f) = (y :== f ;; x :== e)"
  using assms
  by (rel_auto, simp_all add: lens_indep_comm)

lemma assign_cond:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "out\<alpha> \<sharp> b"
  shows "(x :== e ;; (P \<triangleleft> b \<triangleright> Q)) =
         ((x :== e ;; P) \<triangleleft>(b\<lbrakk>\<lceil>e\<rceil>\<^sub></$x\<rbrakk>)\<triangleright> (x :== e ;; Q))"
  by rel_auto

lemma assign_rcond[symbolic_exec]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "(x :== e ;; (P \<triangleleft> b \<triangleright>\<^sub>r Q)) = ((x :== e ;; P) \<triangleleft> (b\<lbrakk>e/x\<rbrakk>) \<triangleright>\<^sub>r (x :== e ;; Q))"
  by rel_auto

lemma assign_uop1[symbolic_exec_assign_uop]:
  assumes 1: "mwb_lens v"
  shows "(v:== e1 ;; v:== (uop F (&v))) = (v:== (uop F e1))"
  using 1
  by rel_auto

lemma assign_bop1[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v:== e1 ;; v:== (bop bp (&v) e2)) = (v:== (bop bp e1 e2))"
  using 1 2
  by rel_auto

lemma assign_bop2[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v:== e1 ;; v:== (bop bp e2 (&v))) = (v:== (bop bp e2 e1))"
  using 1 2
  by rel_auto

lemma assign_trop1[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v:== e1 ;; v:== (trop tp (&v) e2 e3)) =
         (v:== (trop tp e1 e2 e3))"
  using 1 2 3
  by rel_auto

lemma assign_trop2[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v:== e1 ;; v:== (trop tp e2 (&v) e3)) =
         (v:== (trop tp e2 e1 e3))"
  using 1 2 3
  by rel_auto

lemma assign_trop3[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v:== e1 ;; v:== (trop tp e2 e3 (&v))) =
         (v:== (trop tp e2 e3 e1))"
  using 1 2 3
  by rel_auto

lemma assign_qtop1[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v:== e1 ;; v:== (qtop tp (&v) e2 e3 e4)) =
         (v:== (qtop tp e1 e2 e3 e4))"
  using 1 2 3 4
  by rel_auto

lemma assign_qtop2[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v:== e1 ;; v:== (qtop tp e2 (&v) e3 e4)) =
         (v:== (qtop tp e2 e1 e3 e4))"
  using 1 2 3 4
  by rel_auto

lemma assign_qtop3[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v:== e1 ;; v:== (qtop tp e2 e3 (&v) e4)) =
         (v:== (qtop tp e2 e3 e1 e4))"
  using 1 2 3 4
  by rel_auto

lemma assign_qtop4[symbolic_exec_assign_qtop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v:== e1 ;; v:== (qtop tp e2 e3 e4 (&v))) =
         (v:== (qtop tp e2 e3 e4 e1))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_seqr_dist[symbolic_exec]:
  "((v:== e ;; P) \<triangleleft> (b\<lbrakk>\<lceil>e\<rceil>\<^sub></$v\<rbrakk>) \<triangleright> (v:== e ;; Q)) =
   (v:== e ;; P \<triangleleft> b \<triangleright> Q)"
  by rel_auto

text {*In the sequel we find assignment laws proposed by Hoare*}

lemma assign_vwb_skip:
  assumes 1: "vwb_lens v"
  shows "(v:== &v) = II"
  by (simp add: assms skip_r_def usubst_upd_var_id)

lemma assign_simultaneous:
  assumes  1: "vwb_lens var2"
  and      2: "var1 \<bowtie> var2"
  shows "(var1, var2 :== exp, &var2) = (var1 :== exp)"
  by (simp add: "1" "2" usubst_upd_comm usubst_upd_var_id)

lemma assign_seq:
  assumes  1: "vwb_lens var2"
  shows"(var1:== exp);; (var2 :== &var2) = (var1:== exp)"
  using 1 by rel_auto

lemma assign_cond_uop[symbolic_exec_assign_uop]:
  assumes 1: "weak_lens v"
  shows "(v:== exp ;; C1) \<triangleleft>uop F exp\<triangleright>\<^sub>r (v:== exp ;; C2) =
          v:== exp ;; C1 \<triangleleft>uop F (&v)\<triangleright>\<^sub>r  C2"
  using 1
  by rel_auto

lemma assign_cond_bop1[symbolic_exec_assign_bop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "(v:== exp ;; C1 \<triangleleft>(bop bp (&v) exp2)\<triangleright>\<^sub>r C2) =
         ((v:== exp ;; C1) \<triangleleft>(bop bp exp exp2)\<triangleright>\<^sub>r  (v:== exp ;; C2))"
  using 1 2
  by rel_auto

lemma assign_cond_bop2[symbolic_exec_assign_bop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "(v:== exp1 ;; C1 \<triangleleft>(bop bp exp2 (&v))\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(bop bp exp2 exp1)\<triangleright>\<^sub>r (v:== exp1 ;; C2))"
  using 1 2
  by rel_auto

lemma assign_cond_trop1[symbolic_exec_assign_trop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "(v:== exp ;; C1 \<triangleleft>(trop tp (&v) exp2 exp3)\<triangleright>\<^sub>r C2) =
         ((v:== exp ;; C1) \<triangleleft>(trop tp exp exp2 exp3)\<triangleright>\<^sub>r (v:== exp ;; C2))"
  using 1 2 3
  by rel_auto

lemma assign_cond_trop2[symbolic_exec_assign_trop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "(v:== exp1 ;; C1 \<triangleleft>(trop tp exp2 (&v) exp3)\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(trop tp exp2 exp1 exp3)\<triangleright>\<^sub>r (v:== exp1 ;; C2))"
  using 1 2 3
  by rel_auto

lemma assign_cond_trop3[symbolic_exec_assign_trop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "(v:== exp1 ;; C1 \<triangleleft>(trop bp exp2 exp3 (&v))\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(trop bp exp2 exp3 exp1)\<triangleright>\<^sub>r (v:== exp1 ;; C2))"
  using 1 2 3
  by rel_auto

lemma assign_cond_qtop1[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "(v:== exp1 ;;  C1 \<triangleleft>(qtop tp (&v) exp2 exp3 exp4)\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(qtop tp exp1 exp2 exp3  exp4)\<triangleright>\<^sub>r (v:== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_qtop2[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4:"v \<sharp> exp4"
  shows "(v:== exp1 ;; C1 \<triangleleft>(qtop tp exp2 (&v) exp3 exp4)\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(qtop tp exp2 exp1 exp3 exp4)\<triangleright>\<^sub>r  (v:== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_qtop3[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "(v:== exp1 ;; C1 \<triangleleft>(qtop bp exp2 exp3 (&v) exp4)\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(qtop bp exp2 exp3 exp1  exp4)\<triangleright>\<^sub>r (v:== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_qtop4[symbolic_exec_assign_qtop]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "(v:== exp1 ;; C1 \<triangleleft>(qtop bp exp2 exp3 exp4 (&v))\<triangleright>\<^sub>r C2) =
         ((v:== exp1 ;; C1) \<triangleleft>(qtop bp exp2 exp3  exp4 exp1)\<triangleright>\<^sub>r (v:== exp1 ;; C2))"
  using 1 2 3 4
  by rel_auto

lemma assign_cond_If [symbolic_exec]:
  "((v:== exp1) \<triangleleft> bexp\<triangleright>\<^sub>r (v:== exp2)) =
   (v :== (trop If bexp exp1 exp2))"
  by rel_auto

lemma assign_cond_If_uop[symbolic_exec_assign_uop]:
  assumes 1: "mwb_lens v"
  shows "(v:== E;;
         (v:== uop F (&v)) \<triangleleft>uop F (&v)\<triangleright>\<^sub>r (v:== uop G (&v))) =
         (v:== trop If (uop F E) (uop F E) (uop G E))"
  using 1
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp"
  shows "((v:== E);;
          (v:== (bop F exp (&v))) \<triangleleft>bop F exp (&v)\<triangleright>\<^sub>r (v:== (bop G exp (&v)))) =
         (v:== (trop If (bop F exp E) (bop F exp E) (bop G exp E)))"
  using 1 2
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop1[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp"
  shows "((v:== E);;
          (v:== (bop F (&v) exp)) \<triangleleft>bop F (&v) exp\<triangleright>\<^sub>r (v:== (bop G (&v) exp))) =
         (v:== (trop If (bop F E exp) (bop F E exp) (bop G E exp)))"
  using 1 2
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop2[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
          (v:== (bop F (&v) exp1)) \<triangleleft>bop F (&v) exp1\<triangleright>\<^sub>r (v:== (bop G (&v) exp2))) =
         (v:== (trop If (bop F E exp1) (bop F E exp1) (bop G E exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop4[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
          (v:== (bop F (&v) exp1)) \<triangleleft>bop F (&v) exp1\<triangleright>\<^sub>r (v:== (bop G exp2 (&v)))) =
         (v:== (trop If (bop F E exp1) (bop F E exp1) (bop G exp2 E)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop5[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
          (v:== (bop F exp1 (&v))) \<triangleleft>bop F exp1 (&v)\<triangleright>\<^sub>r (v:== (bop G (&v) exp2))) =
         (v:== (trop If (bop F exp1 E) (bop F exp1 E) (bop G E exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_bop6[symbolic_exec_assign_bop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
          (v:== (bop F exp1 (&v))) \<triangleleft>bop F exp1 (&v)\<triangleright>\<^sub>r (v:== (bop G exp2 (&v)))) =
         (v:== (trop If (bop F exp1 E) (bop F exp1 E) (bop G exp2 E)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
         (v:== (trop F exp1 exp2 (&v))) \<triangleleft>trop F exp1 exp2 (&v)\<triangleright>\<^sub>r (v:== (trop G exp1 exp2 (&v)))) =
         (v:== (trop If (trop F exp1 exp2 E) (trop F exp1 exp2 E) (trop G exp1 exp2 E)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop1[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
          (v:== (trop F exp1 (&v) exp2)) \<triangleleft>trop F exp1 (&v) exp2\<triangleright>\<^sub>r (v:== (trop G exp1 (&v) exp2))) =
         (v:== (trop If (trop F exp1 E exp2) (trop F exp1 E exp2) (trop G exp1 E exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop2[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2"
  shows "((v:== E);;
          (v:== (trop F (&v) exp1 exp2)) \<triangleleft>trop F (&v) exp1 exp2\<triangleright>\<^sub>r (v:== (trop G (&v) exp1 exp2))) =
         (v:== (trop If (trop F E exp1 exp2) (trop F E exp1 exp2) (trop G E exp1 exp2)))"
  using 1 2 3
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop3[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2" and 4:"v \<sharp> exp3" and 5:"v \<sharp> exp4"
  shows "((v:== E);;
          (v:== (trop F exp1 exp2 (&v))) \<triangleleft>trop F exp1 exp2 (&v)\<triangleright>\<^sub>r (v:== (trop G exp3 exp4 (&v)))) =
         (v:== (trop If (trop F exp1 exp2 E) (trop F exp1 exp2 E) (trop G exp3 exp4 E)))"
  using 1 2 3 4 5
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop4[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2" and 4:"v \<sharp> exp3" and 5:"v \<sharp> exp4"
  shows "((v:== E);;
         (v:== (trop F exp1 (&v) exp2)) \<triangleleft>trop F exp1 (&v) exp2\<triangleright>\<^sub>r (v:== (trop G exp3 (&v) exp4))) =
         (v:== (trop If (trop F exp1 E exp2) (trop F exp1 E exp2) (trop G exp3 E exp4)))"
  using 1 2 3 4 5
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

lemma assign_cond_If_trop5[symbolic_exec_assign_trop]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> exp1" and 3:"v \<sharp> exp2" and 4:"v \<sharp> exp3" and 5:"v \<sharp> exp4"
  shows "((v:== E);;
          (v:== (trop F (&v) exp1 exp2)) \<triangleleft>trop F (&v) exp1 exp2\<triangleright>\<^sub>r (v:== (trop G (&v) exp3 exp4))) =
         (v:== (trop If (trop F E exp1 exp2) (trop F E exp1 exp2) (trop G E exp3 exp4)))"
  using 1 2 3 4 5
proof (rel_simp, transfer)
  fix a :: 'a and b :: 'a and va :: "bool \<Longrightarrow> 'a" and Fa :: "bool \<Rightarrow> bool" and Ea :: "'a \<Rightarrow> bool" and Ga :: "bool \<Rightarrow> bool"
  have "Fa (Ea a) \<longrightarrow> (Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)) \<and> (\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a)))"
    by presburger
  then have "\<not> ((\<not> Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Fa (Ea a))) \<and> (Fa (Ea a) \<or> \<not> b = put\<^bsub>va\<^esub> a (Ga (Ea a)))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by fastforce
  then show "(Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Fa (Ea a)) \<or> \<not> Fa (Ea a) \<and> b = put\<^bsub>va\<^esub> a (Ga (Ea a))) = (b = put\<^bsub>va\<^esub> a (Fa (Ea a) \<or> \<not> Fa (Ea a) \<and> Ga (Ea a)))"
    by meson
qed

subsection {*Conditional Laws*}
text{*In this section we introduce the algebraic laws of programming related to the conditional
      statement.*}
named_theorems urel_cond and urel_comp
lemma cond_idem[urel_cond]:
  "(P \<triangleleft> b \<triangleright> P) = P"
  by rel_auto

lemma cond_symm:
  "(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft>\<not> b\<triangleright> P)"
  by rel_auto

lemma cond_assoc:
  "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = ((P \<triangleleft> b \<triangleright> Q) \<triangleleft> b \<triangleright>  R)"
  by rel_auto

lemma cond_distr[urel_cond]:
  "((P \<triangleleft> b'\<triangleright> R) \<triangleleft> b \<triangleright> (Q \<triangleleft> b'\<triangleright> R))= ((P \<triangleleft> b \<triangleright> Q) \<triangleleft> b'\<triangleright> R)"
  by rel_auto

lemma cond_unit_T:
  "(P \<triangleleft>true\<triangleright> Q) = P"
  by auto

lemma cond_unit_F:
  "(P \<triangleleft>false\<triangleright> Q) = Q"
  by auto

lemma cond_and_T_integrate[urel_cond]:
  "((P \<and> b) \<or> (Q \<triangleleft> b \<triangleright> R)) = ((P \<or> Q) \<triangleleft> b \<triangleright> R)"
  by rel_auto

lemma cond_L6[urel_cond]:
  "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)"
  by rel_auto

lemma cond_L7[urel_cond]:
  "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)"
  by rel_auto

lemma cond_and_distr[urel_cond]:
  "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_or_distr[urel_cond]:
  "((P \<or> Q) \<triangleleft> b \<triangleright> (R \<or> S)) = ((P \<triangleleft> b \<triangleright> R) \<or> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_imp_distr[urel_cond]:
  "((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (R \<Rightarrow> S)) =
   ((P \<triangleleft> b \<triangleright> R) \<Rightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_eq_distr[urel_cond]:
  "((P \<Leftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<Leftrightarrow> S)) =
   ((P \<triangleleft> b \<triangleright> R) \<Leftrightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_ueq_distr[urel_cond]:
  "((P =\<^sub>u Q) \<triangleleft> b \<triangleright> (R =\<^sub>u S)) =
   ((P \<triangleleft> b \<triangleright> R) =\<^sub>u (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_conj_distr[urel_cond]:
  "((P \<and> Q) \<triangleleft> b \<triangleright> (P \<and> S)) = (P \<and> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_disj_distr [urel_cond]:
  "((P \<or> Q) \<triangleleft> b \<triangleright> (P \<or> S)) = (P \<or> (Q \<triangleleft> b \<triangleright> S))"
  by rel_auto

lemma cond_neg[urel_cond]:
  "\<not> (P \<triangleleft> b \<triangleright> Q) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))"
  by rel_auto

lemma cond_conj[urel_cond]:
  "(P \<triangleleft>b \<and> c\<triangleright> Q) = (P \<triangleleft> c \<triangleright> Q) \<triangleleft> b \<triangleright> Q"
  by rel_auto

(*IF Theorem by Hoare: It optimize nested IF*)
theorem COND12[urel_cond]:
  "((C1 \<triangleleft>bexp2\<triangleright> C3) \<triangleleft>bexp1\<triangleright> (C2 \<triangleleft>bexp3\<triangleright> C3)) =
   ((C1 \<triangleleft>bexp1\<triangleright> C2) \<triangleleft>(bexp2 \<triangleleft>bexp1\<triangleright>bexp3)\<triangleright> C3)"
  by rel_auto

lemma comp_cond_left_distr:
  "((P \<triangleleft> b \<triangleright>\<^sub>r Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright>\<^sub>r (Q ;; R))"
  by rel_auto

lemma cond_var_subst_left[urel_cond]:
  assumes "vwb_lens x"
  shows "(P\<lbrakk>true/x\<rbrakk> \<triangleleft>&x \<triangleright> Q) = (P \<triangleleft>&x \<triangleright> Q)"
  using assms
  apply rel_auto apply transfer
  using vwb_lens.put_eq by fastforce

lemma cond_var_subst_right[urel_cond]:
  assumes "vwb_lens x"
  shows "(P \<triangleleft>&x \<triangleright> Q\<lbrakk>false/x\<rbrakk>) = (P \<triangleleft>&x \<triangleright> Q)"
  using assms
  apply rel_auto apply transfer
  by (metis (full_types) vwb_lens.put_eq)

lemma cond_var_split[urel_cond]:
  "vwb_lens x \<Longrightarrow> (P\<lbrakk>true/x\<rbrakk> \<triangleleft>&x \<triangleright> P\<lbrakk>false/x\<rbrakk>) = P"
  by (rel_auto, (metis (full_types) vwb_lens.put_eq)+)

lemma cond_seq_left_distr[urel_comp]:
  "out\<alpha> \<sharp> b \<Longrightarrow> ((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  by rel_auto

lemma cond_seq_right_distr[urel_comp]:
  "in\<alpha> \<sharp> b \<Longrightarrow> (P ;; (Q \<triangleleft> b \<triangleright> R)) = ((P ;; Q) \<triangleleft> b \<triangleright> (P ;; R))"
  by rel_auto

subsection {*Sequential Laws*}
text{*In this section we introduce the algebraic laws of programming related to the sequential
      composition of statements.*}

lemma seqr_exists_left[symbolic_exec]:
  "((\<exists> $x \<bullet> P) ;; Q) = (\<exists> $x \<bullet> (P ;; Q))"
  by rel_auto

lemma seqr_exists_right[symbolic_exec]:
  "(P ;; (\<exists> $x\<acute> \<bullet> Q)) = (\<exists> $x\<acute> \<bullet> (P ;; Q))"
  by rel_auto

lemma seqr_left_zero [simp, symbolic_exec_ex]:
  "false ;; P = false"
  by pred_auto

lemma seqr_right_zero [simp, symbolic_exec_ex]:
  "P ;; false = false"
  by pred_auto

lemma seqr_assoc: "P ;; (Q ;; R) = (P ;; Q) ;; R"
  by rel_auto

lemma seqr_or_distl[urel_comp]:
  "((P \<or> Q) ;; R) = ((P ;; R) \<or> (Q ;; R))"
  by rel_auto

lemma seqr_or_distr[urel_comp]:
  "(P ;; (Q \<or> R)) = ((P ;; Q) \<or> (P ;; R))"
  by rel_auto

lemma seqr_unfold:
  "(P ;; Q) = (\<^bold>\<exists> v \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright>/$\<Sigma>\<acute>\<rbrakk> \<and> Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$\<Sigma>\<rbrakk>)"
  by rel_auto

lemma seqr_middle:
  assumes "vwb_lens x"
  shows "(P ;; Q) = (\<^bold>\<exists> v \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
  using assms
  apply (rel_auto robust)
  apply (rename_tac xa P Q a b y)
  apply (rule_tac x="get\<^bsub>xa\<^esub> y" in exI)
  apply (rule_tac x="y" in exI)
  apply (simp)
done

lemma seqr_left_one_point[urel_comp]:
  assumes "vwb_lens x"
  shows "((P \<and> $x\<acute> =\<^sub>u \<guillemotleft>v\<guillemotright>) ;; Q) = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
  using assms
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put)

lemma seqr_right_one_point[urel_comp]:
  assumes "vwb_lens x"
  shows "(P ;; ($x =\<^sub>u \<guillemotleft>v\<guillemotright> \<and> Q)) = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
  using assms
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put)

lemma seqr_insert_ident_left[urel_comp]:
  assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
  shows "(($x\<acute> =\<^sub>u $x \<and> P) ;; Q) = (P ;; Q)"
  using assms
  by (rel_auto, meson vwb_lens_wb wb_lens_weak weak_lens.put_get)

lemma seqr_insert_ident_right[urel_comp]:
  assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
  shows "(P ;; ($x\<acute> =\<^sub>u $x \<and> Q)) = (P ;; Q)"
  using assms
  by (rel_auto, metis (no_types, hide_lams) vwb_lens_def wb_lens_def weak_lens.put_get)

lemma seq_var_ident_lift[urel_comp]:
  assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
  shows "(($x\<acute> =\<^sub>u $x \<and> P) ;; ($x\<acute> =\<^sub>u $x \<and> Q)) = ($x\<acute> =\<^sub>u $x \<and> (P ;; Q))"
  using assms
  by (rel_auto, metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)

lemma seqr_skip: "II ;; C = C ;; II"
  by (metis seqr_left_unit seqr_right_unit)

(*The rules SEQ6 SEQ7 related to SEQ and non-deterministic choice are missing for now*)

subsection {*While laws*}
text{*In this section we introduce the algebraic laws of programming related to the while
      statement.*}

theorem while_unfold:
  "while b do P od = ((P ;; while b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
proof -
  have m:"mono (\<lambda>X. (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (auto intro: monoI seqr_mono cond_mono)
  have "(while b do P od) = (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (simp add: while_def)
  also have "... = ((P ;; (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (subst lfp_unfold, simp_all add: m)
  also have "... = ((P ;; while b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (simp add: while_def)
  finally show ?thesis .
qed

lemma while_true:
  shows "(while true do P od) = false"
  apply (simp add: while_def alpha)
  apply (rule antisym)
  apply (simp_all)
  apply (rule lfp_lowerbound)
  apply (simp)
done

lemma while_false:
  shows "(while false do P od) = II"
proof -
  have "(while false do P od) = (P ;; while false do P od) \<triangleleft> false \<triangleright>\<^sub>r II"
    using while_unfold[of _ P] by simp
  also have "... = II" by (simp add: aext_false)
  finally show ?thesis .
qed

lemma while_inv_unfold:
  "while b invr p do P od = ((P ;; while b invr p do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
  unfolding while_inv_def using while_unfold
  by auto

theorem while_bot_unfold:
  "while\<^sub>\<bottom> b do P od = ((P ;; while\<^sub>\<bottom> b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
proof -
  have m:"mono (\<lambda>X. (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (auto intro: monoI seqr_mono cond_mono)
  have "(while\<^sub>\<bottom> b do P od) = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (simp add: while_bot_def)
  also have "... = ((P ;; (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (subst gfp_unfold, simp_all add: m)
  also have "... = ((P ;; while\<^sub>\<bottom> b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
    by (simp add: while_bot_def)
  finally show ?thesis .
qed

theorem while_bot_false: "while\<^sub>\<bottom> false do P od = II"
  by (simp add: while_bot_def mu_const alpha)

theorem while_bot_true: "while\<^sub>\<bottom> true do P od = (\<mu> X \<bullet> P ;; X)"
  by (simp add: while_bot_def alpha)

text {* An infinite loop with a feasible body corresponds to a program error (non-termination). *}

theorem while_infinite: "P ;; true\<^sub>h = true \<Longrightarrow> while\<^sub>\<bottom> true do P od = true"
  apply (simp add: while_bot_true)
  apply (rule antisym)
  apply (simp)
  apply (rule gfp_upperbound)
  apply (simp)
done

subsection {*assume and assert laws*}

lemma assume_twice[urel_comp]: "(b\<^sup>\<top> ;; c\<^sup>\<top>) = (b \<and> c)\<^sup>\<top>"
  by rel_auto

lemma assert_twice[urel_comp]: "(b\<^sub>\<bottom> ;; c\<^sub>\<bottom>) = (b \<and> c)\<^sub>\<bottom>"
  by rel_auto

subsection {* Relation algebra laws *}

theorem RA1: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)"
  using seqr_assoc by auto

theorem RA2: "(P ;; II) = P" "(II ;; P) = P"
  by simp_all

theorem RA3: "P\<^sup>-\<^sup>- = P"
  by simp

theorem RA4: "(P ;; Q)\<^sup>- = (Q\<^sup>- ;; P\<^sup>-)"
  by simp

theorem RA5: "(P \<or> Q)\<^sup>- = (P\<^sup>- \<or> Q\<^sup>-)"
  by (rel_auto)

theorem RA6[urel_comp]: "((P \<or> Q) ;; R) = ((P;;R) \<or> (Q;;R))"
  using seqr_or_distl by blast

subsection {* Relational alphabet extension *}

lift_definition rel_alpha_ext :: "'\<beta> hrel \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" (infix "\<oplus>\<^sub>R" 65)
is "\<lambda> P x (b1, b2). P (get\<^bsub>x\<^esub> b1, get\<^bsub>x\<^esub> b2) \<and> (\<forall> b. b1 \<oplus>\<^sub>L b on x = b2 \<oplus>\<^sub>L b on x)" .

lemma rel_alpha_ext_alt_def:
  assumes "vwb_lens y" "x +\<^sub>L y \<approx>\<^sub>L 1\<^sub>L" "x \<bowtie> y"
  shows "P \<oplus>\<^sub>R x = (P \<oplus>\<^sub>p (x \<times>\<^sub>L x) \<and> $y\<acute> =\<^sub>u $y)"
  using assms
  apply (rel_auto robust, simp_all add: lens_override_def)
  apply (metis lens_indep_get lens_indep_sym)
  apply (metis vwb_lens_def wb_lens.get_put wb_lens_def weak_lens.put_get)
done

subsection {*Tactic setup*}
text {*In this section we will design a tactic that can be used to automate
       the process of program optimization.*}
(*TODO*)

end


section \<open>General utility lemmas\<close>
theory Utils imports Main
begin

text \<open>
This is a potpourri of various lemmas not specific to our project. Some of them could very well be included in the default Isabelle library.
\<close>

text \<open>
Lemmas about the \<open>single_valued\<close> predicate.
\<close>

lemma single_valued_empty[simp]:"single_valued {}"
by (rule single_valuedI) auto

lemma single_valued_insert:
  assumes "single_valued rel"
      and "\<And> x y . \<lbrakk>(x,y) \<in> rel; x=a\<rbrakk> \<Longrightarrow> y = b"
  shows "single_valued (insert (a,b) rel)"
using assms
by (auto intro:single_valuedI dest:single_valuedD)

text \<open>
Lemmas about \<open>ran\<close>, the range of a finite map.
\<close>

lemma ran_upd: "ran (m (k \<mapsto> v)) \<subseteq> ran m \<union> {v}"
unfolding ran_def by auto

lemma ran_map_of: "ran (map_of xs) \<subseteq> snd ` set xs"
 by (induct xs)(auto simp del:fun_upd_apply dest: ran_upd[THEN subsetD])

lemma ran_concat: "ran (m1 ++ m2) \<subseteq> ran m1 \<union> ran m2"
unfolding ran_def
by auto

lemma ran_upds:
  assumes eq_length: "length ks = length vs"
  shows "ran (map_upds m ks vs) \<subseteq> ran m \<union> set vs"
proof-
  have "ran (map_upds m ks vs) \<subseteq> ran (m++map_of (rev (zip ks vs)))"
    unfolding map_upds_def by simp
  also have "\<dots> \<subseteq> ran m \<union> ran (map_of (rev (zip ks vs)))" by (rule ran_concat)
  also have "\<dots> \<subseteq> ran m \<union> snd ` set (rev (zip ks vs))"
    by (intro Un_mono[of "ran m" "ran m"] subset_refl ran_map_of)
  also have "\<dots>\<subseteq> ran m \<union> set vs"
    by (auto intro:Un_mono[of "ran m" "ran m"] subset_refl simp del:set_map simp add:set_map[THEN sym] map_snd_zip[OF eq_length])
  finally show ?thesis .
qed

lemma ran_upd_mem[simp]: "v \<in> ran (m (k \<mapsto> v))"
unfolding ran_def by auto

text \<open>
Lemmas about \<open>map\<close>, \<open>zip\<close> and \<open>fst\<close>/\<open>snd\<close>
\<close>

lemma map_fst_zip: "length xs = length ys \<Longrightarrow> map fst (zip xs ys) = xs"
apply (induct xs ys rule:list_induct2) by auto

lemma map_snd_zip: "length xs = length ys \<Longrightarrow> map snd (zip xs ys) = ys"
apply (induct xs ys rule:list_induct2) by auto

end


section \<open>Cones\<close>

text \<open>We define the notions like cone, polyhedral cone, etc. and prove some basic facts about them.\<close>

theory Cone
  imports
    Basis_Extension
    Missing_VS_Connect
    Integral_Bounded_Vectors
begin

context gram_schmidt
begin

definition "nonneg_lincomb c Vs b = (lincomb c Vs = b \<and> c ` Vs \<subseteq> {x. x \<ge> 0})"
definition "nonneg_lincomb_list c Vs b = (lincomb_list c Vs = b \<and> (\<forall> i < length Vs. c i \<ge> 0))"

definition finite_cone :: "'a vec set \<Rightarrow> 'a vec set" where
  "finite_cone Vs = ({ b. \<exists> c. nonneg_lincomb c (if finite Vs then Vs else {}) b})"

definition cone :: "'a vec set \<Rightarrow> 'a vec set" where
  "cone Vs = ({ x. \<exists> Ws. finite Ws \<and> Ws \<subseteq> Vs \<and> x \<in> finite_cone Ws})"

definition cone_list :: "'a vec list \<Rightarrow> 'a vec set" where
  "cone_list Vs = {b. \<exists>c. nonneg_lincomb_list c Vs b}"

lemma finite_cone_iff_cone_list: assumes Vs: "Vs \<subseteq> carrier_vec n"
  and id: "Vs = set Vsl"
shows "finite_cone Vs = cone_list Vsl"
proof -
  have fin: "finite Vs" unfolding id by auto
  from Vs id have Vsl: "set Vsl \<subseteq> carrier_vec n" by auto
  {
    fix c b
    assume b: "lincomb c Vs = b" and c: "c ` Vs \<subseteq> {x. x \<ge> 0}"
    from lincomb_as_lincomb_list[OF Vsl, of c]
    have b: "lincomb_list (\<lambda>i. if \<exists>j<i. Vsl ! i = Vsl ! j then 0 else c (Vsl ! i)) Vsl = b"
      unfolding b[symmetric] id by simp
    have "\<exists> c. nonneg_lincomb_list c Vsl b"
      unfolding nonneg_lincomb_list_def
      apply (intro exI conjI, rule b)
      by (insert c, auto simp: set_conv_nth id)
  }
  moreover
  {
    fix c b
    assume b: "lincomb_list c Vsl = b" and c: "(\<forall> i < length Vsl. c i \<ge> 0)"
    have "nonneg_lincomb (mk_coeff Vsl c) Vs b"
      unfolding b[symmetric] nonneg_lincomb_def
      apply (subst lincomb_list_as_lincomb[OF Vsl])
      by (insert c, auto simp: id mk_coeff_def intro!: sum_list_nonneg)
    hence "\<exists> c. nonneg_lincomb c Vs b" by blast
  }
  ultimately show ?thesis unfolding finite_cone_def cone_list_def
      nonneg_lincomb_def nonneg_lincomb_list_def using fin by auto
qed

lemma cone_alt_def: assumes Vs: "Vs \<subseteq> carrier_vec n"
  shows "cone Vs = ({ x. \<exists> Ws. set Ws \<subseteq> Vs \<and> x \<in> cone_list Ws})"
  unfolding cone_def
proof (intro Collect_cong iffI)
  fix x
  assume "\<exists>Ws. finite Ws \<and> Ws \<subseteq> Vs \<and> x \<in> finite_cone Ws"
  then obtain Ws where *: "finite Ws" "Ws \<subseteq> Vs" "x \<in> finite_cone Ws" by auto
  from finite_list[OF *(1)] obtain Wsl where id: "Ws = set Wsl" by auto
  from finite_cone_iff_cone_list[OF _ this] *(2-3) Vs
  have "x \<in> cone_list Wsl" by auto
  with *(2) id show "\<exists>Wsl. set Wsl \<subseteq> Vs \<and> x \<in> cone_list Wsl" by blast
next
  fix x
  assume "\<exists>Wsl. set Wsl \<subseteq> Vs \<and> x \<in> cone_list Wsl"
  then obtain Wsl where "set Wsl \<subseteq> Vs" "x \<in> cone_list Wsl" by auto
  thus "\<exists>Ws. finite Ws \<and> Ws \<subseteq> Vs \<and> x \<in> finite_cone Ws" using Vs
    by (intro exI[of _ "set Wsl"], subst finite_cone_iff_cone_list, auto)
qed

lemma cone_mono: "Vs \<subseteq> Ws \<Longrightarrow> cone Vs \<subseteq> cone Ws"
  unfolding cone_def by blast

lemma finite_cone_mono: assumes fin: "finite Ws"
  and Ws: "Ws \<subseteq> carrier_vec n"
  and sub: "Vs \<subseteq> Ws"
shows "finite_cone Vs \<subseteq> finite_cone Ws"
proof
  fix b
  assume "b \<in> finite_cone Vs"
  then obtain c where b: "b = lincomb c Vs" and c: "c ` Vs \<subseteq> {x. x \<ge> 0}"
    unfolding finite_cone_def nonneg_lincomb_def using finite_subset[OF sub fin] by auto
  define d where "d = (\<lambda> v. if v \<in> Vs then c v else 0)"
  from c have d: "d ` Ws \<subseteq> {x. x \<ge> 0}" unfolding d_def by auto
  have "lincomb d Ws = lincomb d (Ws - Vs) + lincomb d Vs"
    by (rule lincomb_vec_diff_add[OF Ws sub fin], auto)
  also have "lincomb d Vs = lincomb c Vs"
    by (rule lincomb_cong, insert Ws sub, auto simp: d_def)
  also have "lincomb d (Ws - Vs) = 0\<^sub>v n"
    by (rule lincomb_zero, insert Ws sub, auto simp: d_def)
  also have "0\<^sub>v n + lincomb c Vs = lincomb c Vs" using Ws sub by auto
  also have "\<dots> = b" unfolding b by simp
  finally
  have "b = lincomb d Ws" by auto
  then show "b \<in> finite_cone Ws" using d fin
    unfolding finite_cone_def nonneg_lincomb_def by auto
qed

lemma finite_cone_carrier: "A \<subseteq> carrier_vec n \<Longrightarrow> finite_cone A \<subseteq> carrier_vec n"
  unfolding finite_cone_def nonneg_lincomb_def by auto

lemma cone_carrier: "A \<subseteq> carrier_vec n \<Longrightarrow> cone A \<subseteq> carrier_vec n"
  using finite_cone_carrier unfolding cone_def by blast

lemma cone_iff_finite_cone: assumes A: "A \<subseteq> carrier_vec n"
  and fin: "finite A"
shows "cone A = finite_cone A"
proof
  show "finite_cone A \<subseteq> cone A" unfolding cone_def using fin by auto
  show "cone A \<subseteq> finite_cone A" unfolding cone_def using fin finite_cone_mono[OF fin A] by auto
qed

lemma set_in_finite_cone:
  assumes Vs: "Vs \<subseteq> carrier_vec n"
    and fin: "finite Vs"
  shows "Vs \<subseteq> finite_cone Vs"
proof
  fix x
  assume x: "x \<in> Vs"
  show "x \<in> finite_cone Vs" unfolding finite_cone_def
  proof
    let ?c = "\<lambda> y. if x = y then 1 else 0 :: 'a"
    have Vsx: "Vs - {x} \<subseteq> carrier_vec n" using Vs by auto
    have "lincomb ?c Vs = x + lincomb ?c (Vs - {x})"
      using lincomb_del2 x Vs fin by auto
    also have "lincomb ?c (Vs - {x}) = 0\<^sub>v n" using lincomb_zero Vsx by auto
    also have "x + 0\<^sub>v n = x " using M.r_zero Vs x by auto
    finally have "lincomb ?c Vs = x" by auto
    moreover have "?c ` Vs \<subseteq> {z. z \<ge> 0}" by auto
    ultimately show "\<exists>c. nonneg_lincomb c (if finite Vs then Vs else {}) x"
      unfolding nonneg_lincomb_def
      using fin by auto
  qed
qed

lemma set_in_cone:
  assumes Vs: "Vs \<subseteq> carrier_vec n"
  shows "Vs \<subseteq> cone Vs"
proof
  fix x
  assume x: "x \<in> Vs"
  show "x \<in> cone Vs" unfolding cone_def
  proof (intro CollectI exI)
    have "x \<in> carrier_vec n" using Vs x by auto
    then have "x \<in> finite_cone {x}" using set_in_finite_cone by auto
    then show "finite {x} \<and> {x} \<subseteq> Vs \<and> x \<in> finite_cone {x}" using x by auto
  qed
qed

lemma zero_in_finite_cone:
  assumes Vs: "Vs \<subseteq> carrier_vec n"
  shows "0\<^sub>v n \<in> finite_cone Vs"
proof -
  let ?Vs = "(if finite Vs then Vs else {})"
  have "lincomb (\<lambda> x. 0 :: 'a) ?Vs = 0\<^sub>v n" using lincomb_zero Vs by auto
  moreover have "(\<lambda> x. 0 :: 'a) ` ?Vs \<subseteq> {y. y \<ge> 0}" by auto
  ultimately show ?thesis unfolding finite_cone_def nonneg_lincomb_def by blast
qed

lemma lincomb_in_finite_cone:
  assumes "x = lincomb l W"
    and "finite W"
    and "\<forall>i \<in> W . l i \<ge> 0"
    and "W \<subseteq> carrier_vec n"
  shows "x \<in> finite_cone W"
  using cone_iff_finite_cone assms unfolding finite_cone_def nonneg_lincomb_def by auto

lemma lincomb_in_cone:
  assumes "x = lincomb l W"
    and "finite W"
    and "\<forall>i \<in> W . l i \<ge> 0"
    and "W \<subseteq> carrier_vec n"
  shows "x \<in> cone W"
  using cone_iff_finite_cone assms unfolding finite_cone_def nonneg_lincomb_def by auto

lemma zero_in_cone: "0\<^sub>v n \<in> cone Vs"
proof -
  have "finite {}" by auto
  moreover have "{} \<subseteq> cone Vs" by auto
  moreover have "0\<^sub>v n \<in> finite_cone {}" using zero_in_finite_cone by auto
  ultimately show ?thesis unfolding cone_def by blast
qed

lemma cone_smult:
  assumes a: "a \<ge> 0"
    and Vs: "Vs \<subseteq> carrier_vec n"
    and x: "x \<in> cone Vs"
  shows "a \<cdot>\<^sub>v x \<in> cone Vs"
proof -
  from x Vs obtain Ws c where Ws: "Ws \<subseteq> Vs" and fin: "finite Ws" and
    "nonneg_lincomb c Ws x"
    unfolding cone_def finite_cone_def by auto
  then have "nonneg_lincomb (\<lambda> w. a * c w) Ws (a \<cdot>\<^sub>v x)"
    unfolding nonneg_lincomb_def using a lincomb_distrib Vs by auto
  then show ?thesis using Ws fin unfolding cone_def finite_cone_def by auto
qed

lemma finite_cone_empty[simp]: "finite_cone {} = {0\<^sub>v n}"
  by (auto simp: finite_cone_def nonneg_lincomb_def)

lemma cone_empty[simp]: "cone {} = {0\<^sub>v n}"
  unfolding cone_def by simp

lemma cone_elem_sum:
  assumes Vs: "Vs \<subseteq> carrier_vec n"
    and x: "x \<in> cone Vs"
    and y: "y \<in> cone Vs"
  shows "x + y \<in> cone Vs"
proof -
  obtain Xs where Xs: "Xs \<subseteq> Vs" and fin_Xs: "finite Xs"
    and Xs_cone: "x \<in> finite_cone Xs"
    using Vs x unfolding cone_def by auto
  obtain Ys where Ys: "Ys \<subseteq> Vs" and fin_Ys: "finite Ys"
    and Ys_cone: "y \<in> finite_cone Ys"
    using Vs y unfolding cone_def
    by auto
  have "x \<in> finite_cone (Xs \<union> Ys)" and "y \<in> finite_cone (Xs \<union> Ys)"
    using finite_cone_mono fin_Xs fin_Ys Xs Ys Vs Xs_cone Ys_cone
    by (blast, blast)
  then obtain cx cy where "nonneg_lincomb cx (Xs \<union> Ys) x"
    and "nonneg_lincomb cy (Xs \<union> Ys) y"
    unfolding finite_cone_def using fin_Xs fin_Ys by auto
  hence "nonneg_lincomb (\<lambda> v. cx v + cy v) (Xs \<union> Ys) (x + y)"
    unfolding nonneg_lincomb_def
    using lincomb_sum[of "Xs \<union> Ys" cx cy] fin_Xs fin_Ys Xs Ys Vs
    by fastforce
  hence "x + y \<in> finite_cone (Xs \<union> Ys)"
    unfolding finite_cone_def using fin_Xs fin_Ys by auto
  thus ?thesis unfolding cone_def using fin_Xs fin_Ys Xs Ys by auto
qed

lemma cone_cone:
  assumes Vs: "Vs \<subseteq> carrier_vec n"
  shows "cone (cone Vs) = cone Vs"
proof
  show "cone Vs \<subseteq> cone (cone Vs)"
    by (rule set_in_cone[OF cone_carrier[OF Vs]])
next
  show "cone (cone Vs) \<subseteq> cone Vs"
  proof
    fix x
    assume x: "x \<in> cone (cone Vs)"
    then obtain Ws c where Ws: "set Ws \<subseteq> cone Vs"
      and c: "nonneg_lincomb_list c Ws x"
      using cone_alt_def Vs cone_carrier unfolding cone_list_def by auto

    have "set Ws \<subseteq> cone Vs \<Longrightarrow> nonneg_lincomb_list c Ws x \<Longrightarrow> x \<in> cone Vs"
    proof (induction Ws arbitrary: x c)
      case Nil
      hence "x = 0\<^sub>v n" unfolding nonneg_lincomb_list_def by auto
      thus "x \<in> cone Vs" using zero_in_cone by auto
    next
      case (Cons a Ws)
      have "a \<in> cone Vs" using Cons.prems(1) by auto
      moreover have "c 0 \<ge> 0"
        using Cons.prems(2) unfolding nonneg_lincomb_list_def by fastforce
      ultimately have "c 0 \<cdot>\<^sub>v a \<in> cone Vs" using cone_smult Vs by auto
      moreover have "lincomb_list (c \<circ> Suc) Ws \<in> cone Vs"
        using Cons unfolding nonneg_lincomb_list_def by fastforce
      moreover have "x = c 0 \<cdot>\<^sub>v a + lincomb_list (c \<circ> Suc) Ws"
        using Cons.prems(2) unfolding nonneg_lincomb_list_def
        by auto
      ultimately show "x \<in> cone Vs" using cone_elem_sum Vs by auto
    qed

    thus "x \<in> cone Vs" using Ws c by auto
  qed
qed

lemma cone_smult_basis:
  assumes Vs: "Vs \<subseteq> carrier_vec n"
    and l: "l ` Vs \<subseteq> {x. x > 0}"
  shows "cone {l v \<cdot>\<^sub>v v | v . v \<in> Vs} = cone Vs"
proof
  have "{l v \<cdot>\<^sub>v v |v. v \<in> Vs} \<subseteq> cone Vs"
  proof
    fix x
    assume "x \<in> {l v \<cdot>\<^sub>v v | v. v \<in> Vs}"
    then obtain v where "v \<in> Vs" and "x = l v \<cdot>\<^sub>v v" by auto
    thus "x \<in> cone Vs" using
        set_in_cone[OF Vs] cone_smult[OF _ Vs, of "l v" v] l by fastforce
  qed
  thus "cone {l v \<cdot>\<^sub>v v | v. v \<in> Vs} \<subseteq> cone Vs"
    using cone_mono cone_cone[OF Vs] by blast
next
  have lVs: "{l v \<cdot>\<^sub>v v | v. v \<in> Vs} \<subseteq> carrier_vec n" using Vs by auto
  have "Vs \<subseteq> cone {l v \<cdot>\<^sub>v v | v. v \<in> Vs}"
  proof
    fix v assume v: "v \<in> Vs"
    hence "l v \<cdot>\<^sub>v v \<in> cone {l v \<cdot>\<^sub>v v | v. v \<in> Vs}" using set_in_cone[OF lVs] by auto
    moreover have "1 / l v > 0" using l v by auto
    ultimately have "(1 / l v) \<cdot>\<^sub>v (l v \<cdot>\<^sub>v v) \<in> cone {l v \<cdot>\<^sub>v v | v. v \<in> Vs}"
      using cone_smult[OF _ lVs] by auto
    also have "(1 / l v) \<cdot>\<^sub>v (l v \<cdot>\<^sub>v v) = v" using l v
      by(auto simp add: smult_smult_assoc)
    finally show "v \<in> cone {l v \<cdot>\<^sub>v v | v. v \<in> Vs}" by auto
  qed
  thus "cone Vs \<subseteq> cone {l v \<cdot>\<^sub>v v | v. v \<in> Vs}"
    using cone_mono cone_cone[OF lVs] by blast
qed

lemma cone_add_cone:
  assumes C: "C \<subseteq> carrier_vec n"
  shows "cone C + cone C = cone C"
proof
  note CC = cone_carrier[OF C]
  have "cone C = cone C + {0\<^sub>v n}" by (subst add_0_right_vecset[OF CC], simp)
  also have "\<dots> \<subseteq> cone C + cone C"
    by (rule set_plus_mono2, insert zero_in_cone, auto)
  finally show "cone C \<subseteq> cone C + cone C" by auto
  from cone_elem_sum[OF C]
  show "cone C + cone C \<subseteq> cone C"
    by (auto elim!: set_plus_elim)
qed

lemma orthogonal_cone:
  assumes X: "X \<subseteq> carrier_vec n"
    and W: "W \<subseteq> carrier_vec n"
    and finX: "finite X"
    and spanLW: "span (set Ls \<union> W) = carrier_vec n"
    and ortho: "\<And> w x. w \<in> W \<Longrightarrow> x \<in> set Ls \<Longrightarrow> w \<bullet> x = 0"
    and WWs: "W = set Ws"
    and spanL: "span (set Ls) = span X"
    and LX: "set Ls \<subseteq> X"
    and lin_Ls_Bs: "lin_indpt_list (Ls @ Bs)"
    and len_Ls_Bs: "length (Ls @ Bs) = n"
  shows "cone (X \<union> set Bs) \<inter> {x \<in> carrier_vec n. \<forall>w\<in>W. w \<bullet> x = 0} = cone X"
    "\<And> x. \<forall>w\<in>W. w \<bullet> x = 0 \<Longrightarrow> Z \<subseteq> X \<Longrightarrow> B \<subseteq> set Bs \<Longrightarrow> x = lincomb c (Z \<union> B)
    \<Longrightarrow> x = lincomb c (Z - B)"
proof -
  from WWs have finW: "finite W" by auto
  define Y where "Y = X \<union> set Bs"
  from lin_Ls_Bs[unfolded lin_indpt_list_def] have
    Ls: "set Ls \<subseteq> carrier_vec n" and
    Bs: "set Bs \<subseteq> carrier_vec n" and
    distLsBs: "distinct (Ls @ Bs)" and
    lin: "lin_indpt (set (Ls @ Bs))"  by auto
  have LW: "set Ls \<inter> W = {}"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then obtain x where xX: "x \<in> set Ls" and xW: "x \<in> W" by auto
    from ortho[OF xW xX] have "x \<bullet> x = 0" by auto
    hence "sq_norm x = 0" by (auto simp: sq_norm_vec_as_cscalar_prod)
    with vs_zero_lin_dep[OF _ lin] xX Ls Bs show False by auto
  qed
  have Y: "Y \<subseteq> carrier_vec n" using X Bs unfolding Y_def by auto
  have CLB: "carrier_vec n = span (set (Ls @ Bs))"
    using lin_Ls_Bs len_Ls_Bs lin_indpt_list_length_eq_n by blast
  also have "\<dots> \<subseteq> span Y"
    by (rule span_is_monotone, insert LX, auto simp: Y_def)
  finally have span: "span Y = carrier_vec n" using Y by auto
  have finY: "finite Y" using finX finW unfolding Y_def by auto
  {
    fix x Z B d
    assume xX: "\<forall>w\<in>W. w \<bullet> x = 0" and ZX: "Z \<subseteq> X" and B: "B \<subseteq> set Bs" and
      xd: "x = lincomb d (Z \<union> B)"
    from ZX B X Bs have ZB: "Z \<union> B \<subseteq> carrier_vec n" by auto
    with xd have x: "x \<in> carrier_vec n" by auto
    from xX W have w0: "w \<in> W \<Longrightarrow> w \<bullet> x = 0" for w by auto
    from finite_in_span[OF _ _ x[folded spanLW]] Ls X W finW finX
    obtain c where xc: "x = lincomb c (set Ls \<union> W)" by auto
    have "x = lincomb c (set Ls \<union> W)" unfolding xc by auto
    also have "\<dots> = lincomb c (set Ls) + lincomb c W"
      by (rule lincomb_union, insert X LX W LW finW, auto)
    finally have xsum: "x = lincomb c (set Ls) + lincomb c W" .
    {
      fix w
      assume wW: "w \<in> W"
      with W have w: "w \<in> carrier_vec n" by auto
      from w0[OF wW, unfolded xsum]
      have "0 = w \<bullet> (lincomb c (set Ls) + lincomb c W)" by simp
      also have "\<dots> = w \<bullet> lincomb c (set Ls) + w \<bullet> lincomb c W"
        by (rule scalar_prod_add_distrib[OF w], insert Ls W, auto)
      also have "w \<bullet> lincomb c (set Ls) = 0" using ortho[OF wW]
        by (subst lincomb_scalar_prod_right[OF Ls w], auto)
      finally have "w \<bullet> lincomb c W = 0" by simp
    }
    hence "lincomb c W \<bullet> lincomb c W = 0" using W
      by (subst lincomb_scalar_prod_left, auto)
    hence "sq_norm (lincomb c W) = 0"
      by (auto simp: sq_norm_vec_as_cscalar_prod)
    hence 0: "lincomb c W = 0\<^sub>v n" using lincomb_closed[OF W, of c] by simp
    have xc: "x = lincomb c (set Ls)" unfolding xsum 0 using Ls by auto
    hence xL: "x \<in> span (set Ls)" by auto
    let ?X = "Z - B"
    have "lincomb d ?X \<in> span X" using finite_subset[OF _ finX, of ?X] X ZX by auto
    from finite_in_span[OF finite_set Ls this[folded spanL]]
    obtain e where ed: "lincomb e (set Ls) = lincomb d ?X" by auto
    from B finite_subset[OF B] have finB: "finite B" by auto
    from B Bs have BC: "B \<subseteq> carrier_vec n" by auto
    define f where "f =
      (\<lambda> x. if x \<in> set Bs then if x \<in> B then d x else 0 else if x \<in> set Ls then e x else undefined)"
    have "x = lincomb d (?X \<union> B)" unfolding xd by auto
    also have "\<dots> = lincomb d ?X + lincomb d B"
      by (rule lincomb_union[OF _ _ _ finite_subset[OF _ finX]], insert ZX X finB B Bs, auto)
    finally have xd: "x = lincomb d ?X + lincomb d B" .
    also have "\<dots> = lincomb e (set Ls) + lincomb d B" unfolding ed by auto
    also have "lincomb e (set Ls) = lincomb f (set Ls)"
      by (rule lincomb_cong[OF _ Ls], insert distLsBs, auto simp: f_def)
    also have "lincomb d B = lincomb f B"
      by (rule lincomb_cong[OF _ BC], insert B, auto simp: f_def)
    also have "lincomb f B = lincomb f (B \<union> (set Bs - B))"
      by (subst lincomb_clean, insert finB Bs B, auto simp: f_def)
    also have "B \<union> (set Bs - B) = set Bs" using B by auto
    finally have "x = lincomb f (set Ls) + lincomb f (set Bs)" by auto
    also have "lincomb f (set Ls) + lincomb f (set Bs) = lincomb f (set (Ls @ Bs))"
      by (subst lincomb_union[symmetric], insert Ls distLsBs Bs, auto)
    finally have "x = lincomb f (set (Ls @ Bs))" .
    hence f: "f \<in> set (Ls @ Bs) \<rightarrow>\<^sub>E UNIV \<and> lincomb f (set (Ls @ Bs)) = x"
      by (auto simp: f_def split: if_splits)
    from finite_in_span[OF finite_set Ls xL] obtain g where
      xg: "x = lincomb g (set Ls)" by auto
    define h where "h = (\<lambda> x. if x \<in> set Bs then 0 else if x \<in> set Ls then g x else undefined)"
    have "x = lincomb h (set Ls)" unfolding xg
      by (rule lincomb_cong[OF _ Ls], insert distLsBs, auto simp: h_def)
    also have "\<dots> = lincomb h (set Ls) + 0\<^sub>v n" using Ls by auto
    also have "0\<^sub>v n = lincomb h (set Bs)"
      by (rule lincomb_zero[symmetric, OF Bs], auto simp: h_def)
    also have "lincomb h (set Ls) + lincomb h (set Bs) = lincomb h (set (Ls @ Bs))"
      by (subst lincomb_union[symmetric], insert Ls Bs distLsBs, auto)
    finally have "x = lincomb h (set (Ls @ Bs))" .
    hence h: "h \<in> set (Ls @ Bs) \<rightarrow>\<^sub>E UNIV \<and> lincomb h (set (Ls @ Bs)) = x"
      by (auto simp: h_def split: if_splits)
    have basis: "basis (set (Ls @ Bs))" using lin_Ls_Bs[unfolded lin_indpt_list_def] len_Ls_Bs
      using CLB basis_def by blast
    from Ls Bs have "set (Ls @ Bs) \<subseteq> carrier_vec n" by auto
    from basis[unfolded basis_criterion[OF finite_set this], rule_format, OF x] f h
    have fh: "f = h" by auto
    hence "\<And> x. x \<in> set Bs \<Longrightarrow> f x = 0" unfolding h_def by auto
    hence "\<And> x. x \<in> B \<Longrightarrow> d x = 0" unfolding f_def using B by force
    thus "x = lincomb d ?X" unfolding xd
      by (subst (2) lincomb_zero, insert BC ZB X, auto intro!: M.r_zero)
  } note main = this
  have "cone Y \<inter> {x \<in> carrier_vec n. \<forall>w\<in>W. w \<bullet> x = 0} = cone X" (is "?I = _")
  proof
    {
      fix x
      assume xX: "x \<in> cone X"
      with cone_carrier[OF X] have x: "x \<in> carrier_vec n" by auto
      have "X \<subseteq> Y" unfolding Y_def by auto
      from cone_mono[OF this] xX have xY: "x \<in> cone Y" by auto
      from cone_iff_finite_cone[OF X finX] xX have "x \<in> finite_cone X" by auto
      from this[unfolded finite_cone_def nonneg_lincomb_def] finX obtain c
        where "x = lincomb c X" by auto
      with finX X have "x \<in> span X" by auto
      with spanL have "x \<in> span (set Ls)" by auto
      from finite_in_span[OF _ Ls this] obtain c where
        xc: "x = lincomb c (set Ls)" by auto
      {
        fix w
        assume wW: "w \<in> W"
        hence w: "w \<in> carrier_vec n" using W by auto
        have "w \<bullet> x = 0" unfolding xc using ortho[OF wW]
          by (subst lincomb_scalar_prod_right[OF Ls w], auto)
      }
      with xY x have "x \<in> ?I" by blast
    }
    thus "cone X \<subseteq> ?I" by blast
    {
      fix x
      let ?X = "X - set Bs"
      assume "x \<in> ?I"
      with cone_carrier[OF Y] cone_iff_finite_cone[OF Y finY]
      have xY: "x \<in> finite_cone Y" and x: "x \<in> carrier_vec n"
        and w0: "\<And> w. w \<in> W \<Longrightarrow> w \<bullet> x = 0" by auto
      from xY[unfolded finite_cone_def nonneg_lincomb_def] finY obtain d
        where xd: "x = lincomb d Y" and nonneg: "d ` Y \<subseteq> Collect ((\<le>) 0)" by auto
      from main[OF _ _ _ xd[unfolded Y_def]] w0
      have "x = lincomb d ?X" by auto
      hence "nonneg_lincomb d ?X x" unfolding nonneg_lincomb_def
        using nonneg[unfolded Y_def] by auto
      hence "x \<in> finite_cone ?X" using finX
        unfolding finite_cone_def by auto
      hence "x \<in> cone X" using finite_subset[OF _ finX, of ?X] unfolding cone_def by blast
    }
    then show "?I \<subseteq> cone X" by auto
  qed
  thus "cone (X \<union> set Bs) \<inter> {x \<in> carrier_vec n. \<forall>w\<in>W. w \<bullet> x = 0} = cone X" unfolding Y_def .
qed

definition "polyhedral_cone (A :: 'a mat) = { x . x \<in> carrier_vec n \<and> A *\<^sub>v x \<le> 0\<^sub>v (dim_row A)}"

lemma polyhedral_cone_carrier: assumes "A \<in> carrier_mat nr n"
  shows "polyhedral_cone A \<subseteq> carrier_vec n"
  using assms unfolding polyhedral_cone_def by auto

lemma cone_in_polyhedral_cone:
  assumes CA: "C \<subseteq> polyhedral_cone A"
    and A: "A \<in> carrier_mat nr n"
  shows "cone C \<subseteq> polyhedral_cone A"
proof
  interpret nr: gram_schmidt nr "TYPE ('a)".
  from polyhedral_cone_carrier[OF A] assms(1)
  have C: "C \<subseteq> carrier_vec n" by auto
  fix x
  assume x: "x \<in> cone C"
  then have xn: "x \<in> carrier_vec n"
    using cone_carrier[OF C] by auto
  from x[unfolded cone_alt_def[OF C] cone_list_def nonneg_lincomb_list_def]
  obtain ll Ds where l0: "lincomb_list ll Ds = x" and l1: "\<forall>i<length Ds. 0 \<le> ll i"
    and DsC: "set Ds \<subseteq> C"
    by auto
  from DsC C have Ds: "set Ds \<subseteq> carrier_vec n" by auto

  have "A *\<^sub>v x = A *\<^sub>v (lincomb_list ll Ds)" using l0 by auto
  also have "\<dots> = nr.lincomb_list ll (map (\<lambda> d. A *\<^sub>v d) Ds)"
  proof -
    have one: " \<forall>w\<in>set Ds. dim_vec w = n" using DsC C by auto
    have two: "\<forall>w\<in>set (map ((*\<^sub>v) A) Ds). dim_vec w = nr" using A DsC C by auto
    show "A *\<^sub>v lincomb_list ll Ds = nr.lincomb_list ll (map ((*\<^sub>v) A) Ds)"
      unfolding lincomb_list_as_mat_mult[OF one] nr.lincomb_list_as_mat_mult[OF two] length_map
    proof (subst assoc_mult_mat_vec[symmetric, OF A], force+, rule arg_cong[of _ _ "\<lambda> x. x *\<^sub>v _"])
      show "A * mat_of_cols n Ds = mat_of_cols nr (map ((*\<^sub>v) A) Ds)"
        unfolding mat_of_cols_def
        by (intro eq_matI, insert A Ds[unfolded set_conv_nth],
            (force intro!: arg_cong[of _ _ "\<lambda> x. row A _ \<bullet> x"])+)
    qed
  qed
  also have "\<dots> \<le> 0\<^sub>v nr"
  proof (intro lesseq_vecI[of _ nr])
    have *: "set (map ((*\<^sub>v) A) Ds) \<subseteq> carrier_vec nr" using A Ds by auto
    show Carr: "nr.lincomb_list ll (map ((*\<^sub>v) A) Ds) \<in> carrier_vec nr"
      by (intro nr.lincomb_list_carrier[OF *])
    fix i
    assume i: "i < nr"
    from CA[unfolded polyhedral_cone_def] A
    have l2: "x \<in> C \<Longrightarrow> A *\<^sub>v x \<le> 0\<^sub>v nr" for x by auto
    show "nr.lincomb_list ll (map ((*\<^sub>v) A) Ds) $ i \<le> 0\<^sub>v nr $ i"
      unfolding subst nr.lincomb_list_index[OF i *] length_map index_zero_vec(1)[OF i]
    proof (intro sum_nonpos mult_nonneg_nonpos)
      fix j
      assume "j \<in> {0..<length Ds}"
      hence j: "j < length Ds" by auto
      from j show "0 \<le> ll j" using l1 by auto
      from j have "Ds ! j \<in> C" using DsC by auto
      from l2[OF this] have l2: "A *\<^sub>v Ds ! j \<le> 0\<^sub>v nr" by auto
      from lesseq_vecD[OF _ this i] i have "(A *\<^sub>v Ds ! j) $ i \<le> 0" by auto
      thus "map ((*\<^sub>v) A) Ds ! j $ i \<le> 0" using j i by auto
    qed
  qed auto
  finally show "x \<in> polyhedral_cone A"
    unfolding polyhedral_cone_def using A xn by auto
qed

lemma bounded_cone_is_zero:
  assumes Ccarr: "C \<subseteq> carrier_vec n" and bnd: "cone C \<subseteq> Bounded_vec bnd"
  shows "cone C = {0\<^sub>v n}"
proof(rule ccontr)
  assume "\<not> ?thesis"
  then obtain v where vC: "v \<in> cone C" and vnz: "v \<noteq> 0\<^sub>v n"
    using zero_in_cone assms by auto
  have vcarr: "v \<in> carrier_vec n" using vC Ccarr cone_carrier by blast
  from vnz vcarr obtain i where i_le_n: "i < dim_vec v" and vinz: "v $ i \<noteq> 0" by force
  define M where "M = (1 / (v $ i) * (bnd + 1))"
  have abs_ge_bnd: "abs (M * (v $ i)) > bnd" unfolding M_def by (simp add: vinz)
  have aMvC: "(abs M) \<cdot>\<^sub>v v \<in> cone C" using cone_smult[OF _ Ccarr vC] abs_ge_bnd by simp
  have "\<not>(abs (abs M * (v $ i)) \<le> bnd)" using abs_ge_bnd by simp
  hence "(abs M) \<cdot>\<^sub>v v \<notin> Bounded_vec bnd" unfolding Bounded_vec_def using i_le_n aMvC by auto
  thus False using aMvC bnd by auto
qed

end
end


(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>The Replicated Growable Array (RGA)\<close>

text\<open>The RGA algorithm \cite{Roh:2011dw} is a replicated list (or
collaborative text-editing) algorithm. In this section we prove that
RGA satisfies our list specification. The Isabelle/HOL definition of
RGA in this section is based on our prior work on formally verifying
CRDTs \cite{Gomes:2017gy,Gomes:2017vo}.\<close>

theory RGA
  imports Insert_Spec
begin

fun insert_body :: "'oid::{linorder} list \<Rightarrow> 'oid \<Rightarrow> 'oid list" where
  "insert_body []       e = [e]" |
  "insert_body (x # xs) e =
     (if x < e then e # x # xs
               else x # insert_body xs e)"

fun insert_rga :: "'oid::{linorder} list \<Rightarrow> ('oid \<times> 'oid option) \<Rightarrow> 'oid list" where
  "insert_rga  xs      (e, None)   = insert_body xs e" |
  "insert_rga  []      (e, Some i) = []" |
  "insert_rga (x # xs) (e, Some i) =
     (if x = i then
        x # insert_body xs e
      else
        x # insert_rga xs (e, Some i))"

definition interp_rga :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> 'oid list" where
  "interp_rga ops \<equiv> foldl insert_rga [] ops"

subsection\<open>Commutativity of \isa{insert-rga}\<close>

lemma insert_body_set_ins [simp]:
  shows  "set (insert_body xs e) = insert e (set xs)"
  by (induction xs, auto)

lemma insert_rga_set_ins:
  assumes "i \<in> set xs"
  shows "set (insert_rga xs (oid, Some i)) = insert oid (set xs)"
  using assms by (induction xs, auto)

lemma insert_body_commutes:
  shows "insert_body (insert_body xs e1) e2 = insert_body (insert_body xs e2) e1"
  by (induction xs, auto)

lemma insert_rga_insert_body_commute:
  assumes "i2 \<noteq> Some e1"
  shows "insert_rga (insert_body xs e1) (e2, i2) = insert_body (insert_rga xs (e2, i2)) e1"
  using assms by (induction xs; cases i2) (auto simp add: insert_body_commutes)

lemma insert_rga_None_commutes:
  assumes "i2 \<noteq> Some e1"
  shows "insert_rga (insert_rga xs (e1, None)) (e2, i2  ) =
         insert_rga (insert_rga xs (e2, i2  )) (e1, None)"
  using assms by (induction xs; cases i2) (auto simp add: insert_body_commutes)

lemma insert_rga_nonexistent:
  assumes "i \<notin> set xs"
  shows "insert_rga xs (e, Some i) = xs"
  using assms by (induction xs, auto)

lemma insert_rga_Some_commutes:
  assumes "i1 \<in> set xs" and "i2 \<in> set xs"
    and "e1 \<noteq> i2" and "e2 \<noteq> i1"
  shows "insert_rga (insert_rga xs (e1, Some i1)) (e2, Some i2) =
         insert_rga (insert_rga xs (e2, Some i2)) (e1, Some i1)"
  using assms proof (induction xs, simp)
  case (Cons a xs)
  then show ?case
    by (cases "a = i1"; cases "a = i2";
        auto simp add: insert_body_commutes insert_rga_insert_body_commute)
qed

lemma insert_rga_commutes:
  assumes "i2 \<noteq> Some e1" and "i1 \<noteq> Some e2"
  shows "insert_rga (insert_rga xs (e1, i1)) (e2, i2) =
         insert_rga (insert_rga xs (e2, i2)) (e1, i1)"
proof(cases i1)
  case None
  then show ?thesis
    using assms(1) insert_rga_None_commutes by (cases i2, fastforce, blast)
next
  case some_r1: (Some r1)
  then show ?thesis
  proof(cases i2)
    case None
    then show ?thesis
      using assms(2) insert_rga_None_commutes by fastforce
  next
    case some_r2: (Some r2)
    then show ?thesis
    proof(cases "r1 \<in> set xs \<and> r2 \<in> set xs")
      case True
      then show ?thesis
        using assms some_r1 some_r2 by (simp add: insert_rga_Some_commutes)
    next
      case False
      then show ?thesis
        using assms some_r1 some_r2
        by (metis insert_iff insert_rga_nonexistent insert_rga_set_ins)
    qed
  qed
qed

lemma insert_body_split:
  shows "\<exists>p s. xs = p @ s \<and> insert_body xs e = p @ e # s"
proof(induction xs, force)
  case (Cons a xs)
  then obtain p s where IH: "xs = p @ s \<and> insert_body xs e = p @ e # s"
    by blast
  then show "\<exists>p s. a # xs = p @ s \<and> insert_body (a # xs) e = p @ e # s"
  proof(cases "a < e")
    case True
    then have "a # xs = [] @ (a # p @ s) \<and> insert_body (a # xs) e = [] @ e # (a # p @ s)"
      by (simp add: IH)
    then show ?thesis by blast
  next
    case False
    then have "a # xs = (a # p) @ s \<and> insert_body (a # xs) e = (a # p) @ e # s"
      using IH by auto
    then show ?thesis by blast
  qed
qed

lemma insert_between_elements:
  assumes "xs = pre @ ref # suf"
    and "distinct xs"
    and "\<And>i. i \<in> set xs \<Longrightarrow> i < e"
  shows "insert_rga xs (e, Some ref) = pre @ ref # e # suf"
  using assms proof(induction xs arbitrary: pre, force)
  case (Cons a xs)
  then show "insert_rga (a # xs) (e, Some ref) = pre @ ref # e # suf"
  proof(cases pre)
    case pre_nil: Nil
    then have "a = ref"
      using Cons.prems(1) by auto
    then show ?thesis
      using Cons.prems pre_nil by (cases suf, auto)
  next
    case (Cons b pre')
    then have "insert_rga xs (e, Some ref) = pre' @ ref # e # suf"
      using Cons.IH Cons.prems by auto
    then show ?thesis
      using Cons.prems(1) Cons.prems(2) local.Cons by auto
  qed
qed

lemma insert_rga_after_ref:
  assumes "\<forall>x\<in>set as. a \<noteq> x"
    and "insert_body (cs @ ds) e = cs @ e # ds"
  shows "insert_rga (as @ a # cs @ ds) (e, Some a) = as @ a # cs @ e # ds"
  using assms by (induction as; auto)

subsection\<open>Lemmas about the \isa{rga-ops} predicate\<close>

definition rga_ops :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> bool" where
  "rga_ops list \<equiv> crdt_ops list set_option"

lemma rga_ops_rem_last:
  assumes "rga_ops (xs @ [x])"
  shows "rga_ops xs"
  using assms crdt_ops_rem_last rga_ops_def by blast

lemma rga_ops_rem_penultimate:
  assumes "rga_ops (xs @ [(i1, r1), (i2, r2)])"
    and "\<And>r. r2 = Some r \<Longrightarrow> r \<noteq> i1"
  shows "rga_ops (xs @ [(i2, r2)])"
  using assms proof -
  have "crdt_ops (xs @ [(i2, r2)]) set_option"
    using assms crdt_ops_rem_penultimate rga_ops_def by fastforce
  thus "rga_ops (xs @ [(i2, r2)])"
    by (simp add: rga_ops_def)
qed

lemma rga_ops_ref_exists:
  assumes "rga_ops (pre @ (oid, Some ref) # suf)"
  shows "ref \<in> fst ` set pre"
proof -
  from assms have "crdt_ops (pre @ (oid, Some ref) # suf) set_option"
    by (simp add: rga_ops_def)
  moreover have "set_option (Some ref) = {ref}"
    by simp
  ultimately show "ref \<in> fst ` set pre"
    using crdt_ops_ref_exists by fastforce
qed

subsection\<open>Lemmas about the \isa{interp-rga} function\<close>

lemma interp_rga_tail_unfold:
  shows "interp_rga (xs@[x]) = insert_rga (interp_rga (xs)) x"
  by (clarsimp simp add: interp_rga_def)

lemma interp_rga_ids:
  assumes "rga_ops xs"
  shows "set (interp_rga xs) = set (map fst xs)"
  using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "set (interp_rga []) = set (map fst [])"
    by (simp add: interp_rga_def)
next
  case (snoc x xs)
  hence IH: "set (interp_rga xs) = set (map fst xs)"
    using rga_ops_rem_last by blast
  obtain xi xr where x_pair: "x = (xi, xr)" by force
  then show "set (interp_rga (xs @ [x])) = set (map fst (xs @ [x]))"
  proof(cases xr)
    case None
    then show ?thesis
      using IH x_pair by (clarsimp simp add: interp_rga_def)
  next
    case (Some r)
    moreover from this have "r \<in> set (interp_rga xs)"
      using IH rga_ops_ref_exists by (metis x_pair list.set_map snoc.prems)
    ultimately have "set (interp_rga (xs @ [(xi, xr)])) = insert xi (set (interp_rga xs))"
      by (simp add: insert_rga_set_ins interp_rga_tail_unfold)
    then show "set (interp_rga (xs @ [x])) = set (map fst (xs @ [x]))"
      using IH x_pair by auto
  qed
qed

lemma interp_rga_distinct:
  assumes "rga_ops xs"
  shows "distinct (interp_rga xs)"
  using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "distinct (interp_rga [])" by (simp add: interp_rga_def)
next
  case (snoc x xs)
  hence IH: "distinct (interp_rga xs)"
    using rga_ops_rem_last by blast
  moreover obtain xi xr where x_pair: "x = (xi, xr)"
    by force
  moreover from this have "xi \<notin> set (interp_rga xs)"
    using interp_rga_ids crdt_ops_unique_last rga_ops_rem_last
    by (metis rga_ops_def snoc.prems)
  moreover have "\<exists>pre suf. interp_rga xs = pre@suf \<and>
           insert_rga (interp_rga xs) (xi, xr) = pre @ xi # suf"
  proof -
    have "\<And>r. r \<in> set_option xr \<Longrightarrow> r \<in> set (map fst xs)"
      using crdt_ops_ref_exists rga_ops_def snoc.prems x_pair by fastforce
    hence "xr = None \<or> (\<exists>r. xr = Some r \<and> r \<in> set (map fst xs))"
      using option.set_sel by blast
    hence "xr = None \<or> (\<exists>r. xr = Some r \<and> r \<in> set (interp_rga xs))"
      using interp_rga_ids rga_ops_rem_last snoc.prems by blast
    thus ?thesis
      using IH insert_rga_preserves_order by blast
  qed
  ultimately show "distinct (interp_rga (xs @ [x]))"
    by (metis Un_iff disjoint_insert(1) distinct.simps(2) distinct_append
        interp_rga_tail_unfold list.simps(15) set_append)
qed

subsection\<open>Proof that RGA satisfies the list specification\<close>

lemma final_insert:
  assumes "set (xs @ [x]) = set (ys @ [x])"
    and "rga_ops (xs @ [x])"
    and "insert_ops (ys @ [x])"
    and "interp_rga xs = interp_ins ys"
  shows "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
proof -
  obtain oid ref where x_pair: "x = (oid, ref)" by force
  have "distinct (xs @ [x])" and "distinct (ys @ [x])"
    using assms crdt_ops_distinct spec_ops_distinct rga_ops_def insert_ops_def by blast+
  then have "set xs = set ys"
    using assms(1) by force
  have oid_greatest: "\<And>i. i \<in> set (interp_rga xs) \<Longrightarrow> i < oid"
  proof -
    have "\<And>i. i \<in> set (map fst ys) \<Longrightarrow> i < oid"
      using assms(3) by (simp add: spec_ops_id_inc x_pair insert_ops_def)
    hence "\<And>i. i \<in> set (map fst xs) \<Longrightarrow> i < oid"
      using \<open>set xs = set ys\<close> by auto
    thus "\<And>i. i \<in> set (interp_rga xs) \<Longrightarrow> i < oid"
      using assms(2) interp_rga_ids rga_ops_rem_last by blast
  qed
  thus "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
  proof(cases ref)
    case None
    moreover from this have "insert_rga (interp_rga xs) (oid, ref) = oid # interp_rga xs"
      using oid_greatest hd_in_set insert_body.elims insert_body.simps(1)
        insert_rga.simps(1) list.sel(1) by metis
    ultimately show "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
      using assms(4) by (simp add: interp_ins_tail_unfold interp_rga_tail_unfold x_pair)
  next
    case (Some r)
    have "\<exists>as bs. interp_rga xs = as @ r # bs"
    proof -
      have "r \<in> set (map fst xs)"
        using assms(2) Some by (simp add: rga_ops_ref_exists x_pair)
      hence "r \<in> set (interp_rga xs)"
        using assms(2) interp_rga_ids rga_ops_rem_last by blast
      thus ?thesis by (simp add: split_list)
    qed
    from this obtain as bs where as_bs: "interp_rga xs = as @ r # bs" by force
    hence "distinct (as @ r # bs)"
      by (metis assms(2) interp_rga_distinct rga_ops_rem_last)
    hence "insert_rga (as @ r # bs) (oid, Some r) = as @ r # oid # bs"
      by (metis as_bs insert_between_elements oid_greatest)
    moreover have "insert_spec (as @ r # bs) (oid, Some r) = as @ r # oid # bs"
      by (meson \<open>distinct (as @ r # bs)\<close> insert_after_ref)
    ultimately show "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
      by (metis assms(4) Some as_bs interp_ins_tail_unfold interp_rga_tail_unfold x_pair)
  qed
qed

lemma interp_rga_reorder:
  assumes "rga_ops (pre @ suf @ [(oid, ref)])"
    and "\<And>i r. (i, Some r) \<in> set suf \<Longrightarrow> r \<noteq> oid"
    and "\<And>r. ref = Some r \<Longrightarrow> r \<notin> fst ` set suf"
  shows "interp_rga (pre @ (oid, ref) # suf) = interp_rga (pre @ suf @ [(oid, ref)])"
  using assms proof(induction suf rule: List.rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  have ref_not_x: "\<And>r. ref = Some r \<Longrightarrow> r \<noteq> fst x" using snoc.prems(3) by auto
  have IH: "interp_rga (pre @ (oid, ref) # xs) = interp_rga (pre @ xs @ [(oid, ref)])"
  proof -
    have "rga_ops ((pre @ xs) @ [x] @ [(oid, ref)])"
      using snoc.prems(1) by auto
    moreover have "\<And>r. ref = Some r \<Longrightarrow> r \<noteq> fst x"
      by (simp add: ref_not_x)
    ultimately have "rga_ops ((pre @ xs) @ [(oid, ref)])"
      using rga_ops_rem_penultimate
      by (metis (no_types, lifting) Cons_eq_append_conv prod.collapse)
    thus ?thesis using snoc by force
  qed
  obtain xi xr where x_pair: "x = (xi, xr)" by force
  have "interp_rga (pre @ (oid, ref) # xs @ [(xi, xr)]) =
        insert_rga (interp_rga (pre @ xs @ [(oid, ref)])) (xi, xr)"
    using IH interp_rga_tail_unfold by (metis append.assoc append_Cons)
  moreover have "... = insert_rga (insert_rga (interp_rga (pre @ xs)) (oid, ref)) (xi, xr)"
    using interp_rga_tail_unfold by (metis append_assoc)
  moreover have "... = insert_rga (insert_rga (interp_rga (pre @ xs)) (xi, xr)) (oid, ref)"
  proof -
    have "\<And>xrr. xr = Some xrr \<Longrightarrow> xrr \<noteq> oid"
      using x_pair snoc.prems(2) by auto
    thus ?thesis
      using insert_rga_commutes ref_not_x by (metis fst_conv x_pair)
  qed
  moreover have "... = interp_rga (pre @ xs @ [x] @ [(oid, ref)])"
    by (metis append_assoc interp_rga_tail_unfold x_pair)
  ultimately show "interp_rga (pre @ (oid, ref) # xs @ [x]) =
                   interp_rga (pre @ (xs @ [x]) @ [(oid, ref)])"
    by (simp add: x_pair)
qed

lemma rga_spec_equal:
  assumes "set xs = set ys"
    and "insert_ops xs"
    and "rga_ops ys"
  shows "interp_ins xs = interp_rga ys"
  using assms proof(induction xs arbitrary: ys rule: rev_induct)
  case Nil
  then show ?case by (simp add: interp_rga_def interp_ins_def)
next
  case (snoc x xs)
  hence "x \<in> set ys"
    by (metis last_in_set snoc_eq_iff_butlast)
  from this obtain pre suf where ys_split: "ys = pre @ [x] @ suf"
    using split_list_first by fastforce
  have IH: "interp_ins xs = interp_rga (pre @ suf)"
  proof -
    have "crdt_ops (pre @ suf) set_option"
    proof -
      have "crdt_ops (pre @ [x] @ suf) set_option"
        using rga_ops_def snoc.prems(3) ys_split by blast
      thus "crdt_ops (pre @ suf) set_option"
        using crdt_ops_rem_spec snoc.prems ys_split insert_ops_def by blast
    qed
    hence "rga_ops (pre @ suf)"
      using rga_ops_def by blast
    moreover have "set xs = set (pre @ suf)"
      by (metis append_set_rem_last crdt_ops_distinct insert_ops_def rga_ops_def
          snoc.prems spec_ops_distinct ys_split)
    ultimately show ?thesis
      using insert_ops_rem_last ys_split snoc by metis
  qed
  have valid_rga: "rga_ops (pre @ suf @ [x])"
  proof -
    have "crdt_ops (pre @ suf @ [x]) set_option"
      using snoc.prems ys_split
      by (simp add: crdt_ops_reorder_spec insert_ops_def rga_ops_def)
    thus "rga_ops (pre @ suf @ [x])"
      by (simp add: rga_ops_def)
  qed
  have "interp_ins (xs @ [x]) = interp_rga (pre @ suf @ [x])"
  proof -
    have "set (xs @ [x]) = set (pre @ suf @ [x])"
      using snoc.prems(1) ys_split by auto
    thus ?thesis
      using IH snoc.prems(2) valid_rga final_insert append_assoc by metis
  qed
  moreover have "... = interp_rga (pre @ [x] @ suf)"
  proof -
    obtain oid ref where x_pair: "x = (oid, ref)"
      by force
    have "\<And>op2 r. op2 \<in> snd ` set suf \<Longrightarrow> r \<in> set_option op2 \<Longrightarrow> r \<noteq> oid"
      using snoc.prems
      by (simp add: crdt_ops_independent_suf insert_ops_def rga_ops_def x_pair ys_split)
    hence "\<And>i r. (i, Some r) \<in> set suf \<Longrightarrow> r \<noteq> oid"
      by fastforce
    moreover have "\<And>r. ref = Some r \<Longrightarrow> r \<notin> fst ` set suf"
      using crdt_ops_no_future_ref snoc.prems(3) x_pair ys_split
      by (metis option.set_intros rga_ops_def)
    ultimately show "interp_rga (pre @ suf @ [x]) = interp_rga (pre @ [x] @ suf)"
      using interp_rga_reorder valid_rga x_pair by force
  qed
  ultimately show "interp_ins (xs @ [x]) = interp_rga ys"
    by (simp add: ys_split)
qed

lemma insert_ops_exist:
  assumes "rga_ops xs"
  shows "\<exists>ys. set xs = set ys \<and> insert_ops ys"
  using assms by (simp add: crdt_ops_spec_ops_exist insert_ops_def rga_ops_def)

theorem rga_meets_spec:
  assumes "rga_ops xs"
  shows "\<exists>ys. set ys = set xs \<and> insert_ops ys \<and> interp_ins ys = interp_rga xs"
  using assms rga_spec_equal insert_ops_exist by metis

end