(*  Title:      Views.thy
    Author:     Sven Linker, University of Liverpool

Defines a type for views on traffic. Consists of closed real valued interval
denoting "extension" (length on the road visible", the visible interval of lanes,
and the owner of the view.

Contains chopping relations on extension and lanes and switching to
different owners.
*)

section\<open>Views on Traffic\<close>
text\<open>
In this section, we define a notion of locality for each car. These
local parts of a road are called \emph{views} and define the part of
the model currently under consideration by a car. In particular, a
view consists of
\begin{itemize}
\item the \emph{extension}, a real-valued interval denoting the distance perceived,
\item the \emph{lanes}, a discrete interval, denoting which lanes are perceived,
\item the \emph{owner}, the car associated with this view.
\end{itemize}
\<close>

theory Views
  imports NatInt RealInt Cars
begin

type_synonym lanes = nat_int
type_synonym extension = real_int

record basic_view =
  ext::extension
  lan ::lanes
  own ::cars

print_record basic_view
print_theorems

typedef view = "{v::basic_view. continuous (lan v) }"
proof -
  obtain e where "e = mk_empty 1" by simp
  obtain l where "l = \<emptyset>" by simp
  obtain c::cars where "c = Abs_cars 0" by simp
  obtain v where "v = \<lparr> ext = e, lan = l, own = c\<rparr>" by simp
  have "continuous l"
    by (simp add: \<open>l = bot\<close> empty_continuous)
  then show ?thesis
    by (metis (mono_tags, lifting) all_not_in_conv   mem_Collect_eq   select_convs(2)  )
qed

setup_lifting type_definition_view

locale view

lift_definition lan::"view \<Rightarrow> lanes" is basic_view.lan .
lift_definition ext::"view \<Rightarrow> extension" is basic_view.ext.
lift_definition own::"view \<Rightarrow> cars" is basic_view.own .

definition vshift::"view \<Rightarrow> real \<Rightarrow> view"
  where "(vshift v x) == Abs_view \<lparr> basic_view.ext = (real_int.shift (ext v) x), lan = lan v, own = own v\<rparr> "

text \<open>
The orders on discrete and continuous intervals induce an order on views.
For two views \(v\) and \(v^\prime\) with \(v \leq v^\prime\), we call \(v\)
a \emph{subview} of \(v^\prime\).\<close>

instantiation  view::  order
begin
definition "less_eq_view (V:: view)  (V'::  view)  \<equiv>
     (ext V \<le> ext V') \<and> (lan V \<sqsubseteq>  lan V') \<and> own V = own V'"
definition "less_view (V :: view) (V'::  view)  \<equiv>
     (ext V \<le> ext V') \<and> (lan V \<sqsubseteq>  lan V') \<and> own V' = own V
 \<and>
     \<not>((ext V' \<le> ext V) \<and> (lan V' \<sqsubseteq>  lan V) \<and> own V' = own V)"
instance
proof
  fix v v' v''::  "view"
  show "v \<le> v"
    by (simp add: less_eq_view_def)
  show " (v < v') = (v \<le> v' \<and> \<not> v' \<le> v)"
    using less_eq_view_def less_view_def by auto
  show "v \<le> v' \<Longrightarrow> v' \<le> v'' \<Longrightarrow> v \<le> v''"
    using less_eq_view_def less_eq_nat_int.rep_eq order_trans by auto
  show "v \<le> v' \<Longrightarrow> v' \<le> v \<Longrightarrow> v = v'"
  proof -
    assume "v \<le> v'" and "v' \<le> v"
    have "lan v = lan v'"
      using \<open>v \<le> v'\<close> \<open>v' \<le> v\<close> less_eq_view_def by auto
    have "ext v = ext v'"
      using \<open>v \<le> v'\<close> \<open>v' \<le> v\<close> less_eq_view_def by auto
    then show "v = v'"
      using Rep_view_inject \<open>Views.lan v = Views.lan v'\<close> \<open>v' \<le> v\<close> ext.rep_eq lan.rep_eq less_eq_view_def own.rep_eq by fastforce
  qed
qed

end

(*lemma 1:"u \<le> v \<Longrightarrow> ext u \<le> ext v"
  by (simp add: less_eq_view_def)
*)
instantiation view:: equal
begin
definition "equal_view (v::view) u \<equiv> ( v \<le> u \<and> u \<le> v)"
instance
proof
  fix v  u ::view
  show  "equal_class.equal v u = (v = u)"
  proof
    assume "equal_class.equal v u"
    then have "v \<le> u \<and> u \<le> v" using equal_view_def by blast
    then show "v = u"
      using antisym_conv by blast
  next
    assume "v = u"
    then have "v\<le> u \<and> u \<le>v "
      by simp
    then show "equal_class.equal v u" using equal_view_def by blast
  qed
qed
end

context view
begin

notation nat_int.maximum ("maximum")
notation nat_int.minimum ("minimum")
notation nat_int.consec ("consec")

text\<open>We lift the chopping relations from discrete and continuous intervals
to views, and introduce new notation for these relations.\<close>

definition       hchop :: "view \<Rightarrow> view \<Rightarrow>  view \<Rightarrow> bool" ("_=_\<parallel>_")
  where "(v=u\<parallel>w) == real_int.R_Chop(ext v)(ext u)(ext w) \<and>
                    lan v=lan u \<and>
                    lan v=lan w \<and>
                    own v = own u \<and>
                    own v = own w "
definition   vchop :: "view \<Rightarrow> view \<Rightarrow>  view \<Rightarrow> bool" ("_=_--_")
  where "(v=u--w) == nat_int.N_Chop(lan v)(lan u)( lan w) \<and>
                     ext v = ext u \<and>
                     ext v = ext w \<and>
                     own v = own u \<and>
                     own  v = own w"

text\<open>We can also switch the perspective of a view to the car \(c\). That is,
we substitute \(c\) for the original owner of the view.\<close>

definition switch :: "view \<Rightarrow> cars \<Rightarrow> view \<Rightarrow> bool" ("_ = _ > _")
  where   "  (v=c>w) == ext v = ext w \<and>
                        lan v = lan w \<and>
                        own w = c "

text\<open>Most of the lemmas in this theory are direct transfers of the corresponding
lemmas on discrete and continuous intervals, which implies rather simple proofs.
The only exception is
the connection between subviews and the chopping operations. This proof is rather lengthy,
since we need to distinguish several cases, and within each case, we need to
 explicitly construct six different views for the chopping relations.\<close>

lemma h_chop_middle1:"(v=u\<parallel>w) \<longrightarrow> left (ext v) \<le> right (ext u)"
  by (metis hchop_def real_int.rchop_def real_int.left_leq_right)

lemma h_chop_middle2:"(v=u\<parallel>w) \<longrightarrow> right (ext v) \<ge> left (ext w)"
  using real_int.left_leq_right real_int.rchop_def view.hchop_def by auto

lemma horizontal_chop1:
  obtains u and w where "v=u\<parallel>w"
proof -
    obtain x1 and x2 where x1_x2_def:" R_Chop(ext v, x1,x2)"
      using real_int_class.chop_always_possible by blast
      obtain V1 and V2
    where v1:"V1 = \<lparr> basic_view.ext = x1, lan = lan v, own = own v\<rparr>"
    and v2:"V2 = \<lparr> basic_view.ext = x2,lan= lan v, own = own v\<rparr> "  by blast
 from v1 and v2 have "v= (Abs_view V1)\<parallel> (Abs_view V2)"
    using hchop_def x1_x2_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq by auto
  then show ?thesis
    using that by auto
qed

lemma horizontal_chop_exists: " \<exists> u w. (v=u\<parallel>w)"

  using view.horizontal_chop1 by blast
(*proof -
  have real_chop:"\<exists>x1 x2.  R_Chop(ext v, x1,x2)"
    using real_int.chop_singleton_left by force
  obtain x1 and x2 where x1_x2_def:" R_Chop(ext v, x1,x2)"
    using real_chop by force
  obtain V1 and V2
    where v1:"V1 = \<lparr> basic_view.ext = x1, lan = lan v, own = own v\<rparr>"
    and v2:"V2 = \<lparr> basic_view.ext = x2,lan= lan v, own = own v\<rparr> "  by blast
  from v1 and v2 have "v= (Abs_view V1)\<parallel> (Abs_view V2)"
    using hchop_def x1_x2_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq by auto
  thus ?thesis by blast
qed
*)

lemma horizontal_chop_empty_right :" \<exists> u. (v=v\<parallel>u)"
proof -
  obtain u where 1:"u = Abs_view (\<lparr>basic_view.ext = (Abs_real_int (right( ext v),right (ext v))), lan = lan v, own = own v\<rparr>)" by simp
  then have "R_Chop(ext v, ext v, ext u)"
    using Abs_real_int_inverse Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq rchop_def by auto
  then have "v = v\<parallel>u"
    using "1" Abs_view_inverse Rep_view lan.rep_eq own.rep_eq view.hchop_def by auto
  then show ?thesis by blast
qed

lemma horizontal_chop_empty_left :"\<exists>u. (v=u\<parallel>v)"
proof -
  obtain u where 1:"u = Abs_view (\<lparr>basic_view.ext = (Abs_real_int (left( ext v),left (ext v))), lan = lan v, own = own v\<rparr>)" by simp
  then have "R_Chop(ext v, ext u, ext v)"
    using Abs_real_int_inverse Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq rchop_def by auto
  then have "v = u\<parallel>v"
    using "1" Abs_view_inverse Rep_view lan.rep_eq own.rep_eq view.hchop_def by auto
  then show ?thesis by blast
qed

lemma horizontal_chop_non_empty:
  "\<parallel>ext v\<parallel> > 0 \<longrightarrow> (\<exists>u w. (v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> > 0 \<and> \<parallel>ext w\<parallel>>0)"
proof
  assume "\<parallel>ext v\<parallel> > 0"
  then obtain l1 and l2
    where chop:" R_Chop(ext v, l1,l2) \<and> \<parallel>l1\<parallel> > 0 \<and> \<parallel>l2\<parallel> > 0"
    using chop_dense by blast

  obtain v1 where v1_def:"v1 = \<lparr> basic_view.ext = l1, lan = lan v, own = own v \<rparr>"
    by simp
  obtain v2 where v2_def:"v2 = \<lparr> basic_view.ext = l2, lan = lan v, own = own v \<rparr>"
    by simp
  then obtain V1 and V2 where "V1 = Abs_view v1" and "V2 = Abs_view v2" by simp
  then have  "(v=(V1)\<parallel>( V2)) \<and> \<parallel>ext V1\<parallel> > 0 \<and> \<parallel>ext V2\<parallel>>0"
   using  chop hchop_def v1_def
   using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq v2_def by auto
  then show " (\<exists>V1 V2. (v=V1\<parallel>V2) \<and> \<parallel>ext V1\<parallel> > 0 \<and> \<parallel>ext V2\<parallel>>0)"
    by blast
qed

lemma horizontal_chop_split_add:
  "x \<ge> 0 \<and> y \<ge> 0 \<longrightarrow> \<parallel>ext v\<parallel> = x+y \<longrightarrow> (\<exists>u w. (v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> = x \<and> \<parallel>ext w\<parallel> = y)"
proof (rule impI)+
  assume geq_0:"x \<ge> 0 \<and> y \<ge> 0" and len_v:"\<parallel>ext v\<parallel> = x+y"
  obtain v1
    where v1_def:
      "v1 = \<lparr> basic_view.ext = Abs_real_int (left (ext v), left (ext v) + x), lan = lan v, own = (own v) \<rparr>"
    by simp
  have v1_in_type:"(left (ext v), left (ext v) + x) \<in> {r::(real*real) . fst r \<le> snd r}"
    by (simp add: geq_0)
  obtain v2
    where v2_def:
      "v2 = \<lparr> basic_view.ext = Abs_real_int (left (ext v)+x, left (ext v) + (x+y)),
             lan = (lan v), own = (own v) \<rparr>" by simp
  have v2_in_type:
    "(left (ext v)+x, left (ext v) + (x+y)) \<in> {r::(real*real) . fst r \<le> snd r}"
    by (simp add: geq_0)
  obtain u and w where "u = Abs_view v1" and "w = Abs_view v2" by simp
  from v1_def and geq_0 have len_v1:"\<parallel>ext u\<parallel> = x" using v1_in_type
    using Abs_real_int_inverse Abs_view_inverse Rep_view \<open>u = Abs_view v1\<close> ext.rep_eq lan.rep_eq real_int.length_def by auto
  from v2_def and geq_0 have len_v2:"\<parallel>ext w\<parallel>= y" using v2_in_type
    using Abs_real_int_inverse Abs_view_inverse Rep_view \<open>w = Abs_view v2\<close> ext.rep_eq lan.rep_eq real_int.length_def by auto
  from v1_def and v2_def have "(v=u\<parallel>w)"
    using Abs_real_int_inverse Abs_view_inverse Rep_view \<open>u = Abs_view v1\<close> \<open>w = Abs_view v2\<close> ext.rep_eq lan.rep_eq len_v own.rep_eq rchop_def real_int.length_def v1_in_type v2_in_type view.hchop_def by auto
  with len_v1 and len_v2 have "(v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> = x \<and> \<parallel>ext w\<parallel> = y" by simp
  thus "(\<exists>u w. (v=u\<parallel>w) \<and> \<parallel>ext u\<parallel> = x \<and> \<parallel>ext w\<parallel> = y)" by blast
qed

lemma horizontal_chop_assoc1:
  "(v=v1\<parallel>v2) \<and> (v2=v3\<parallel>v4) \<longrightarrow> (\<exists>v'. (v=v'\<parallel>v4) \<and> (v'=v1\<parallel>v3))"
proof
  assume assm:"(v=v1\<parallel>v2) \<and> (v2=v3\<parallel>v4)"
(*  obtain u'
    where v'_def:
      "u' =\<lparr> basic_view.ext = Abs_real_int(left (ext v1), right (ext v3)),
             lan = (lan v), own = (own v) \<rparr>"
    by simp*)
  obtain u'
    where v'_def:
      "u' =\<lparr> basic_view.ext = combine (ext v1) (ext v3),
             lan = (lan v), own = (own v) \<rparr>"
    by simp
  then obtain "v'" where "v' = Abs_view u'" by simp
  hence 1:"v=v'\<parallel>v4"
    using assm real_int.chop_assoc1 hchop_def v'_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq by auto
  have 2:"v'=v1\<parallel>v3" using v'_def assm real_int.chop_assoc1 hchop_def
    using "1" rchop_def by auto
  from 1 and 2 have "(v=v'\<parallel>v4) \<and>  (v'=v1\<parallel>v3)" by best
  thus "(\<exists>v'. (v=v'\<parallel>v4)  \<and> (v'=v1\<parallel>v3))" ..
qed

lemma horizontal_chop_assoc2:
  "(v=v1\<parallel>v2) \<and> (v1=v3\<parallel>v4) \<longrightarrow> (\<exists>v'. (v=v3\<parallel>v') \<and> (v'=v4\<parallel>v2))"
proof
  assume assm:"(v=v1\<parallel>v2) \<and> (v1=v3\<parallel>v4)"
  obtain u
    where v'_def:
      "u=\<lparr> basic_view.ext = combine (ext v4) (ext v2),
            lan = (lan v), own = (own v) \<rparr>"
    by simp
  then obtain v' where "v' = Abs_view u" by simp
  hence 1:"v=v3\<parallel>v'"
    using assm fst_conv real_int.chop_assoc2 snd_conv hchop_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq v'_def by auto
  have 2: "v'=v4\<parallel>v2"
    using assm real_int.chop_assoc2 v'_def hchop_def
    using "1" rchop_def by auto
  from 1 and 2 have "(v=v3\<parallel>v') \<and> (v'=v4\<parallel>v2)" by best
  thus "(\<exists>v'. (v=v3\<parallel>v') \<and> (v'=v4\<parallel>v2))" ..
qed

lemma horizontal_chop_lanes_continuous:"(v=u\<parallel>w) \<longrightarrow> continuous (lan u) \<and> continuous (lan w)"
  using Rep_view lan.rep_eq by auto

lemma horizontal_chop_lanes_stable:"(v=u\<parallel>w) \<longrightarrow> lan v = lan u \<and> lan v = lan w"
  using view.hchop_def by blast

lemma horizontal_chop_width_stable:"(v=u\<parallel>w)\<longrightarrow>|lan v|=|lan u|\<and>|lan v|=|lan w|"
  using hchop_def by auto

lemma horizontal_chop_own_trans:"(v=u\<parallel>w) \<longrightarrow> own u = own w"
  using hchop_def by auto

lemma vertical_chop1:" \<exists> u w. (v=u--w)"
proof -
  have nat_chop:"\<exists>x1 x2.  N_Chop(lan v, x1,x2)"
    using Rep_view chop_empty_right lan.rep_eq by auto
  then obtain x1 and x2 where x1_x2_def:" N_Chop(lan v, x1,x2)"
    by force
  obtain V1 and V2
    where v1:"V1 = \<lparr> basic_view.ext = ext v, lan = x1, own = own v\<rparr>"
    and v2:"V2 = \<lparr> basic_view.ext = ext v,lan= x2, own = own v\<rparr> "  by blast
  from v1 and v2 have "v= (Abs_view V1)-- (Abs_view V2)"
    using vchop_def x1_x2_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq
    by (simp add: nat_int.nchop_def)
  thus ?thesis by blast
qed

lemma vertical_chop_empty_down:"\<exists> u.(v=v--u)"
proof -
  obtain u where "u = Abs_view \<lparr>basic_view.ext = ext v, lan = \<emptyset>, own = own v\<rparr>" by simp
  then have "v=v--u"
    using Abs_view_inverse Rep_view chop_empty_right empty_continuous ext.rep_eq lan.rep_eq own.rep_eq view.vchop_def by auto
  then show ?thesis by blast
qed

lemma vertical_chop_empty_up:"\<exists>u.(v=u--v)"
proof -
  obtain u where "u = Abs_view \<lparr>basic_view.ext = ext v, lan = \<emptyset>, own = own v\<rparr>" by simp
  then have "v=u--v"
    using Abs_view_inverse Rep_view chop_empty_left empty_continuous ext.rep_eq lan.rep_eq own.rep_eq view.vchop_def by auto
  then show ?thesis by blast
qed

lemma vertical_chop_assoc1:
  "(v=v1--v2) \<and> (v2=v3--v4) \<longrightarrow> (\<exists>v'. (v=v'--v4) \<and> (v'=v1--v3))"
proof
  assume assm:"(v=v1--v2) \<and> (v2=v3--v4)"
  obtain u'
    where v'_def:"u' = \<lparr> basic_view.ext = ext v, lan=(lan v1) \<squnion> (lan v3), own = (own v) \<rparr>"
    by simp
  then obtain v' where "v' = Abs_view u'" by simp
  have "continuous (lan v')"
    using nchop_def view.vchop_def view.vertical_chop_empty_down by auto
  then have "N_Chop(basic_view.lan u',lan v1,lan v3)"
        using v'_def assm nat_int.chop_assoc1 nchop_def Abs_view_inverse
        by (meson select_convs(2) view.vchop_def view.vertical_chop_empty_down)
  then have 2:"v'=v1--v3"
    using v'_def assm nat_int.chop_assoc1 vchop_def
    using Abs_view_inverse \<open>v' = Abs_view u'\<close> ext.rep_eq lan.rep_eq nchop_cont own.rep_eq by auto
  have "N_Chop(lan v, basic_view.lan u', lan v4)"
    using assm nat_int_class.chop_assoc1 v'_def view.vchop_def by auto
  then have 1:"v=v'--v4"
    using assm nat_int.chop_assoc1 vchop_def Abs_view_inverse
    by (metis (mono_tags, lifting) "2" Quotient_to_Domainp Quotient_view \<open>N_Chop(basic_view.lan u',Views.lan v1,Views.lan v3)\<close> \<open>v' = Abs_view u'\<close> lan.abs_eq nchop_cont  v'_def view.domain)
  from 1 and 2 have "(v=v'--v4) \<and>  (v'=v1--v3)" by best
  then show "(\<exists>v'. (v=v'--v4)  \<and> (v'=v1--v3))" ..
qed

lemma vertical_chop_assoc2:
  "(v=v1--v2) \<and> (v1=v3--v4) \<longrightarrow> (\<exists>v'. (v=v3--v') \<and> (v'=v4--v2))"
proof
  assume assm:"(v=v1--v2) \<and> (v1=v3--v4)"
  obtain u'
    where v'_def:"u'=\<lparr> basic_view.ext = ext v, lan =(lan v4) \<squnion> (lan v2), own = (own v) \<rparr>"
    by simp
  then obtain v' where "v' = Abs_view u'" by simp
  have "N_Chop(lan v, lan v3, basic_view.lan u')"
    using assm nat_int_class.chop_assoc2 v'_def view.vchop_def by auto
  then have 1:"v=v3--v'"
    using Abs_view_inverse \<open>v' = Abs_view u'\<close> assm ext.rep_eq lan.rep_eq nchop_def own.rep_eq v'_def view.vchop_def by auto
  have "continuous (basic_view.lan u')"
    using \<open>N_Chop(Views.lan v,Views.lan v3,basic_view.lan u')\<close> nchop_def by blast
  have "N_Chop(basic_view.lan u', lan v4, lan v2)"
    using assm nat_int_class.chop_assoc2 v'_def view.vchop_def by auto
  then have 2: "v'=v4--v2"
    using assm nat_int.chop_assoc2 v'_def vchop_def
    using "1" Abs_view_inverse \<open>continuous (basic_view.lan u')\<close> \<open>v' = Abs_view u'\<close> lan.rep_eq by auto
  from 1 and 2 have "(v=v3--v') \<and> (v'=v4--v2)" by best
  then show "(\<exists>v'. (v=v3--v') \<and> (v'=v4--v2))" ..
qed

lemma vertical_chop_singleton:
  "(v=u--w) \<and> |lan v| = 1 \<longrightarrow> ( |lan u| = 0 \<or> |lan w| = 0)"
  using nat_int.chop_single vchop_def Rep_nat_int_inverse
  by fastforce

lemma vertical_chop_add1:"(v=u--w) \<longrightarrow> |lan v| = |lan u| + |lan w|"
  using nat_int.chop_add1 vchop_def by fastforce

lemma vertical_chop_add2:
  "|lan v| = x+y \<longrightarrow> (\<exists> u w.  (v=u--w) \<and> |lan u| = x \<and> |lan w| = y)"
proof
  assume assm:"|lan v| = x+y"
  hence add:"\<exists>i j. N_Chop(lan v, i,j) \<and> |i| = x \<and> |j| = y"
    using chop_add2
    using nat_int.nchop_def view.vchop_def view.vertical_chop_empty_down by auto
  obtain i and j where l1_l2_def:"N_Chop(lan v, i,j) \<and> |i| = x \<and> |j| = y"
    using add by blast
  obtain u and w where "u=Abs_view \<lparr>basic_view.ext =  ext v, lan = i, own = (own v) \<rparr>"
    and "w = Abs_view \<lparr> basic_view.ext = ext v, lan = j, own = (own v) \<rparr> " by blast
  hence "(v=u--w) \<and> |lan u|=x \<and> |lan w|=y"
    using l1_l2_def view.vchop_def
    by (simp add: Abs_view_inverse ext.rep_eq lan.rep_eq nat_int.nchop_def own.rep_eq)
  thus "(\<exists> u w.  (v=u--w) \<and> |lan u| = x \<and> |lan w| = y)" by blast
qed

lemma vertical_chop_length_stable:
  "(v=u--w) \<longrightarrow> \<parallel>ext v\<parallel> = \<parallel>ext u\<parallel> \<and> \<parallel>ext v\<parallel> = \<parallel>ext w\<parallel>"
  using vchop_def by auto

lemma vertical_chop_own_trans:"(v=u--w) \<longrightarrow> own u = own w"
  using vchop_def by auto

lemma vertical_chop_width_mon:
  "(v=v1--v2) \<and> (v2=v3--v4) \<and> |lan v3| = x \<longrightarrow> |lan v| \<ge> x"
  by (metis le_add1 trans_le_add2 vertical_chop_add1)

lemma horizontal_chop_leq1:"(v=u\<parallel>w) \<longrightarrow> u \<le> v"
  using real_int.chop_leq1 hchop_def less_eq_view_def order_refl by fastforce

lemma horizontal_chop_leq2:"(v=u\<parallel>w) \<longrightarrow> w \<le> v"
  using real_int.chop_leq2 hchop_def less_eq_view_def order_refl by fastforce

lemma vertical_chop_leq1:"(v=u--w) \<longrightarrow> u \<le> v"
  using nat_int.chop_subset1 vchop_def less_eq_view_def order_refl by fastforce

lemma vertical_chop_leq2:"(v=u--w) \<longrightarrow> w \<le> v"
  using nat_int.chop_subset2 vchop_def less_eq_view_def order_refl by fastforce

lemma horizontal_intermed:"v \<le> v' \<longrightarrow> (\<exists>v''. (ext v'' \<le> ext v') \<and> (lan v'' = lan v') \<and> (own v'' = own v') \<and> (ext v = ext v'') \<and> (lan v \<sqsubseteq> lan v'') \<and> (own v = own v''))"
proof
  assume "v \<le> v'"
  obtain v'' where "v'' = Abs_view \<lparr> basic_view.ext = ext v, lan = lan v', own = own v'\<rparr>" by blast
  then have " (ext v'' \<le> ext v') \<and> (lan v'' = lan v') \<and> (own v'' = own v') \<and> (ext v = ext v'') \<and> (lan v \<sqsubseteq> lan v'') \<and> (own v = own v'')"
    using Abs_view_inverse Rep_view \<open>v \<le> v'\<close> ext.rep_eq lan.rep_eq less_eq_view_def own.rep_eq by auto
  then show "(\<exists>v''. (ext v'' \<le> ext v') \<and> (lan v'' = lan v') \<and> (own v'' = own v') \<and> (ext v = ext v'') \<and> (lan v \<sqsubseteq> lan v'') \<and> (own v = own v''))" by blast
qed

lemma vertical_intermed:"v \<le> v' \<longrightarrow> (\<exists>v''. (ext v'' = ext v') \<and> (lan v'' \<sqsubseteq> lan v') \<and> (own v'' = own v') \<and> (ext v \<le>  ext v'') \<and> (lan v = lan v'') \<and> (own v = own v''))"
proof
  assume "v \<le> v'"
  obtain v'' where "v'' = Abs_view \<lparr> basic_view.ext = ext v', lan = lan v, own = own v'\<rparr>" by blast
  then have " (ext v'' = ext v') \<and> (lan v'' \<sqsubseteq> lan v') \<and> (own v'' = own v') \<and> (ext v \<le> ext v'') \<and> (lan v = lan v'') \<and> (own v = own v'')"
    using Abs_view_inverse Rep_view \<open>v \<le> v'\<close> ext.rep_eq lan.rep_eq less_eq_view_def own.rep_eq by auto
  then show "(\<exists>v''. (ext v'' = ext v') \<and> (lan v'' \<sqsubseteq> lan v') \<and> (own v'' = own v') \<and> (ext v \<le> ext v'') \<and> (lan v = lan v'') \<and> (own v = own v''))" by blast
qed

lemma horizontal_leq:"ext v \<le> ext v' \<and> lan v = lan v' \<and> own v = own v' \<longrightarrow> (\<exists>v1 vl vr. (v'=vl\<parallel>v1) \<and> (v1=v\<parallel>vr))"
proof
  assume assm_exp:"(ext v \<le> ext v') \<and> (lan v = lan v') \<and> (own v = own v')"
  obtain vl v1  vr
    where
      vl:"vl=Abs_view \<lparr>basic_view.ext=Abs_real_int(left(ext v'),left(ext v)), lan=lan v', own=own v'\<rparr>"
    and
      v1:"v1=Abs_view \<lparr>basic_view.ext=Abs_real_int(left(ext v),right(ext v')), lan=lan v', own=own v'\<rparr>"
    and
      vr:"vr=Abs_view \<lparr>basic_view.ext=Abs_real_int(right(ext v),right(ext v')), lan=lan v', own=own v'\<rparr>"
    by blast
  have vl_in_type:"(left (ext v'), left (ext v)) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv
      fst_conv mem_Collect_eq by simp
  have v1_in_type:"(left (ext v), right (ext v')) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv fst_conv
      mem_Collect_eq order_trans by fastforce
  have vr_in_type:"(right (ext v), right (ext v')) \<in> {r::(real*real) . fst r \<le> snd r}"
    using less_eq_real_int_def assm_exp real_int.left_leq_right snd_conv fst_conv
      mem_Collect_eq order_trans by fastforce
  have "R_Chop(ext v', ext vl, ext v1)" using Abs_view_inverse vl v1
    by (metis (mono_tags, lifting) Quotient_real_int Quotient_to_Domainp Rep_view eq_onp_to_Domainp ext.rep_eq fst_conv lan.rep_eq left.abs_eq mem_Collect_eq rchop_def right.abs_eq select_convs(1) select_convs(2)  snd_conv v1_in_type vl_in_type)
  then have hchop1: "v'=vl\<parallel>v1"
    using Abs_view_inverse Rep_view lan.rep_eq own.rep_eq v1 view.hchop_def vl by auto
  have "R_Chop(ext v1, ext v, ext vr)" using Abs_view_inverse v1  vr
    by (metis (mono_tags, lifting) Quotient_real_int Quotient_to_Domainp Rep_view eq_onp_to_Domainp ext.rep_eq fst_conv lan.rep_eq left.abs_eq mem_Collect_eq rchop_def right.abs_eq select_convs(1) select_convs(2)  snd_conv  vr_in_type v1_in_type)
  then have hchop2: "v1=v\<parallel>vr"
    using Abs_view_inverse Rep_view lan.rep_eq own.rep_eq v1  vr view.hchop_def
    using assm_exp by auto
  from hchop1 and hchop2 have hchops:"(v'=vl\<parallel>v1)\<and> (v1=v\<parallel>vr)" by simp
  then show "(\<exists>v1 vl vr. (v'=vl\<parallel>v1) \<and> (v1=v\<parallel>vr))" by blast
qed

lemma vertical_leq:"ext v = ext v' \<and> (lan v \<sqsubseteq> lan v') \<and> own v = own v' \<longrightarrow> (\<exists>v1 vu vd. (v'=vd--v1) \<and> (v1=v--vu))"
proof
  assume assm:"ext v = ext v' \<and> (lan v \<sqsubseteq> lan v') \<and> own v = own v'"
  show " \<exists>v1 vu vd. (v'=vd--v1) \<and> (v1=v--vu)"
  proof (cases "lan v = \<emptyset>")
    case True
    then have "(v'=v'--v) \<and> (v=v--v)"
      using assm chop_empty chop_empty_right horizontal_chop_empty_right horizontal_chop_lanes_continuous view.vchop_def by fastforce
    then show ?thesis by blast
  next
    case False
    let ?lanv = "lan v"
    let ?lanv' = "lan v'"
    have v'_notE:"?lanv' \<noteq> \<emptyset>"
      using False assm bot.extremum_unique by fastforce
    have 1:"minimum ?lanv \<ge> minimum ?lanv'"
      by (simp add: False assm subset_min v'_notE)
    have 2:"maximum ?lanv \<le> maximum ?lanv'"
      by (simp add: False assm subset_max v'_notE)
    let ?diff_min = "minimum ?lanv - minimum ?lanv'"
    let ?diff_max = "maximum ?lanv' - maximum ?lanv"
    have max_rel:"maximum ?lanv' = maximum ?lanv + ?diff_max"
      by (simp add: "2")
    have min_rel:"minimum ?lanv'= minimum ?lanv - ?diff_min" by (simp add:1)
    obtain m and n where atLAM_v':"\<forall>l. l \<^bold>\<in> ?lanv' \<longleftrightarrow> l \<in> {m..n}"
      using continuos_atLeastAtMost view.horizontal_chop_empty_left view.horizontal_chop_lanes_continuous by blast
    from min_rel have min:"m = minimum ?lanv - ?diff_min"
      using atLAM_v' nat_int_atLeastAtMost_min v'_notE by blast
    from max_rel have max:"n = maximum ?lanv + ?diff_max"
      using atLAM_v' nat_int_atLeastAtMost_max v'_notE by blast
    have v'_rep:"\<forall>l. l \<^bold>\<in> ?lanv' \<longleftrightarrow> l \<in> { minimum ?lanv - ?diff_min .. maximum ?lanv + ?diff_max}" using min max atLAM_v' by blast
    obtain lan1 where lan1_rep:"\<forall>l. l\<in>{minimum ?lanv  .. maximum ?lanv + ?diff_max} \<longleftrightarrow> l \<^bold>\<in> lan1" using atLeastAtMost_rep
      by blast
    obtain lanu where lanu_rep:"\<forall>l. l\<in>{maximum ?lanv+1 .. maximum ?lanv + ?diff_max} \<longleftrightarrow> l \<^bold>\<in> lanu" using  atLeastAtMost_rep
      by blast
    obtain land where land_rep:"\<forall>l. l\<in>{minimum ?lanv' .. minimum ?lanv' + ?diff_min - 1} \<longleftrightarrow> l \<^bold>\<in> land" using atLeastAtMost_rep
      by blast
      have cont1: "continuous (lan1)" using   lan1_rep continuos_atLeastAtMost by blast
      have contu: "continuous lanu" using lanu_rep  continuos_atLeastAtMost by blast
      have contd: "continuous land" using land_rep  continuos_atLeastAtMost by blast
      have contv: "continuous ?lanv"
        using Rep_view lan.rep_eq by auto
    consider (a) "?diff_min = 0 \<and> ?diff_max = 0" | (b) "?diff_min \<noteq> 0 \<and> ?diff_max = 0" | (c) "?diff_min = 0 \<and> ?diff_max \<noteq> 0" | (d) "?diff_min \<noteq> 0 \<and> ?diff_max \<noteq> 0"
      by blast
    then show ?thesis
    proof (cases)
      case a
      then have "?lanv = ?lanv'"
        by (meson "1" False assm diff_is_0_eq leD less_max order.not_eq_order_implies_strict v'_notE view.horizontal_chop_empty_left view.horizontal_chop_lanes_continuous)
      then have "\<exists>vu vd. (v'=vd--v) \<and> (v=v--vu)"
        by (metis assm less_eq_view_def less_view_def order.order_iff_strict order_refl  view.vertical_chop_empty_down view.vertical_chop_empty_up)
      then show ?thesis by blast
    next
      case b
      then have ge:\<open>?diff_min > 0\<close> using 2 by blast
      have min_less:"minimum ?lanv' + ?diff_min > minimum ?lanv' "
        using ge by linarith
      have land_notE:"land \<noteq> \<emptyset>" using min_less land_rep
        by (metis "1"  Suc_diff_1  all_not_in_conv b  card_atLeastAtMost card_empty diff_is_0_eq' le_add_diff_inverse less_imp_diff_less min min_rel non_empty_elem_in  )
      then have 3:"minimum land = minimum ?lanv'" using land_rep nat_int_atLeastAtMost_min
        by (metis One_nat_def )
      have "maximum land = minimum ?lanv' + ?diff_min -1" using land_rep land_notE nat_int_atLeastAtMost_max
        by blast
      then have 4:"maximum land + 1= minimum ?lanv" using ge by linarith
      have consec:"consec land ?lanv" using 4
        by (simp add: False consec_def land_notE)
      have cont1: "continuous land" using land_notE land_rep
        by (simp add: "3" \<open>maximum land = minimum (Views.lan v') + (minimum (Views.lan v) - minimum (Views.lan v')) - 1\<close> continuous_nonE_atLeastAtMost)
      have "?lanv' = land \<squnion> ?lanv" using consec cont1 False land_notE
        by (metis (mono_tags, lifting) "3" Rep_view add.right_neutral b consec_un_max consec_un_min lan.rep_eq max_rel mem_Collect_eq nat_int.consec_un_equality v'_notE)
      then have "N_Chop(?lanv', land, ?lanv)"
        using consec cont1 nchop_def view.horizontal_chop_empty_left view.horizontal_chop_lanes_continuous by blast
      obtain vd where "vd =  \<lparr> basic_view.ext = ext v, lan = land, own =own v\<rparr>"
        by blast
      then have "v'=(Abs_view vd)--v"
        using Abs_view_inverse \<open>N_Chop(Views.lan v',land,Views.lan v)\<close> assm cont1 ext.rep_eq lan.rep_eq own.rep_eq view.vchop_def by auto
      show ?thesis
        using \<open>v'=Abs_view vd--v\<close> view.vertical_chop_empty_down by blast
    next
      case c
      then have ge:\<open>?diff_max > 0\<close> using 2 by blast
      have max_less:"maximum ?lanv < maximum ?lanv + ?diff_max"
        using ge by linarith
      have 3: "minimum ?lanv = minimum lan1" using lan1_rep nat_int_atLeastAtMost_min
        by (metis "1" c diff_is_0_eq in_eq le_antisym  max min v'_rep)
      have 4:"maximum ?lanv + 1 = minimum lanu" using lanu_rep  nat_int_atLeastAtMost_max nat_int_atLeastAtMost_min
        by (metis  Suc_eq_plus1 Suc_leI    atLeastAtMost_iff     le_eq_less_or_eq max_less max_rel  non_empty_elem_in  order_trans  )
      have "maximum lan1 = maximum ?lanv + ?diff_max" using lan1_rep nat_int_atLeastAtMost_max
        by (metis "3" c max  min min_rel minus_nat.diff_0 non_empty_elem_in v'_notE v'_rep)
      have "maximum lanu = maximum ?lanv + ?diff_max" using lanu_rep nat_int_atLeastAtMost_max
        by (metis "4" Max_in Suc_eq_plus1 add_diff_cancel_right card_atLeastAtMost card_empty finite_atLeastAtMost ge max max_rel non_empty_elem_in not_gr_zero)
      have 5:"maximum lan1 = maximum lanu"
        by (simp add: \<open>maximum lan1 = maximum (Views.lan v) + (maximum (Views.lan v') - maximum (Views.lan v))\<close> \<open>maximum lanu = maximum (Views.lan v) + (maximum (Views.lan v') - maximum (Views.lan v))\<close>)
      have "lanu \<noteq> \<emptyset>" using lanu_rep max_less
        using bot_nat_int.rep_eq  by auto
      have "consec ?lanv lanu"
        using "4" False \<open>lanu \<noteq> bot\<close> consec_def by blast
      have "lan1 = lan v \<squnion> lanu" using lan1_rep lanu_rep v'_rep 3 4 5
        by (metis \<open>consec (Views.lan v) lanu\<close> \<open>continuous (Views.lan v)\<close> \<open>continuous lan1\<close> \<open>continuous lanu\<close> bot_nat_int.rep_eq c consec_un_equality consec_un_max consec_un_min  el.rep_eq emptyE maximum_in minus_nat.diff_0 v'_notE)
      have "N_Chop(lan1, ?lanv, lanu)"
        by (simp add: \<open>consec (Views.lan v) lanu\<close> \<open>continuous (Views.lan v)\<close> \<open>continuous lanu\<close> \<open>lan1 = Views.lan v \<squnion> lanu\<close> nchop_def)
      obtain vu where vu:"vu= \<lparr> basic_view.ext = ext v, lan = lanu, own =own v\<rparr>"
        by blast
      obtain v1 where v1:"v1 = \<lparr> basic_view.ext = ext v, lan = lan1, own = own v\<rparr>"
        by blast
      have chop1:"(Abs_view v1)=v--(Abs_view vu)"
        using Abs_view_inverse \<open>N_Chop(lan1,Views.lan v,lanu)\<close> \<open>continuous lan1\<close> \<open>continuous lanu\<close> ext.rep_eq lan.rep_eq own.rep_eq v1 view.vchop_def vu by auto
      have "minimum lan1 = minimum ?lanv'" using lan1_rep
        using "1" "3" c by linarith
      have chop2:"N_Chop(?lanv', \<emptyset>, lan1)"
        by (metis \<open>\<And>thesis. (\<And>m n. \<forall>l. (l \<^bold>\<in> Views.lan v') = (l \<in> {m..n}) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>consec (Views.lan v) lanu\<close> \<open>continuous (Views.lan v)\<close> \<open>continuous lanu\<close> \<open>lan1 = Views.lan v \<squnion> lanu\<close> \<open>maximum lan1 = maximum (Views.lan v) + (maximum (Views.lan v') - maximum (Views.lan v))\<close> \<open>minimum lan1 = minimum (Views.lan v')\<close> consec_un_equality continuos_atLeastAtMost empty_continuous max_rel nchop_def sup_bot.left_neutral v'_notE)
      then show ?thesis using chop1 chop2
        by (metis (mono_tags, hide_lams) Rep_view_inverse assm equality ext.rep_eq lan.rep_eq nat_int.nchop_def old.unit.exhaust own.rep_eq select_convs(1) select_convs(2) select_convs(3) sup_bot.left_neutral v1 vertical_chop_empty_up)
    next
      case d
      then have ge:\<open>?diff_min > 0\<close> using 2 by blast
      have min_less:"minimum ?lanv' + ?diff_min > minimum ?lanv' "
        using ge by linarith
      have ge2:\<open>?diff_max > 0\<close> using 2 d by blast
      have max_less:"maximum ?lanv < maximum ?lanv + ?diff_max"
        using ge2 by linarith
      have land_notE:"land \<noteq> \<emptyset>" using min_less land_rep
        by (metis "1"  Suc_diff_1  all_not_in_conv d  card_atLeastAtMost card_empty diff_is_0_eq' le_add_diff_inverse less_imp_diff_less min min_rel non_empty_elem_in  )
      then have 3:"minimum land = minimum ?lanv'" using land_rep nat_int_atLeastAtMost_min
        by (metis One_nat_def )
      have lan1_notE: "lan1 \<noteq> \<emptyset>" using lan1_rep False
        using False assm bot_nat_int.rep_eq lan1_rep less_eq_nat_int.rep_eq nat_int.minimum_in v'_rep by fastforce
      have lanu_notE: "lanu \<noteq> \<emptyset>" using lanu_rep max_less
        using bot_nat_int.rep_eq  by auto
      have "maximum land = minimum ?lanv' + ?diff_min -1" using land_rep land_notE nat_int_atLeastAtMost_max
        by blast
      then have 4:"maximum land + 1= minimum ?lanv" using ge by linarith
      have consec:"consec land ?lanv" using 4
        by (simp add: False consec_def land_notE)
      have 3: "minimum ?lanv = minimum lan1" using lan1_rep nat_int_atLeastAtMost_min lan1_notE
        by simp
      have 4:"maximum ?lanv + 1 = minimum lanu" using lanu_rep  nat_int_atLeastAtMost_max nat_int_atLeastAtMost_min
        by (metis  Suc_eq_plus1 Suc_leI    atLeastAtMost_iff     le_eq_less_or_eq max_less max_rel  non_empty_elem_in  order_trans  )
      have "maximum lan1 = maximum ?lanv + ?diff_max" using lan1_rep nat_int_atLeastAtMost_max
        by (metis "3" "4" False atLeastAtMost_iff       consec_def consec_lesser     lanu_rep  less_imp_le_nat less_not_refl max  minimum_in non_empty_elem_in    order_refl order_trans  )
      have "maximum lanu = maximum ?lanv' " using lanu_rep nat_int_atLeastAtMost_max
        using lanu_notE max_rel by auto
      have 5:"maximum lan1 = maximum lanu"
        using \<open>maximum lan1 = maximum (Views.lan v) + (maximum (Views.lan v') - maximum (Views.lan v))\<close> \<open>maximum lanu = maximum (Views.lan v')\<close> max_rel by auto
      have 6:"maximum lan1 = maximum ?lanv'"
        using \<open>maximum lan1 = maximum (Views.lan v) + (maximum (Views.lan v') - maximum (Views.lan v))\<close> max_rel by auto

      have "consec ?lanv lanu"
        using "4" False \<open>lanu \<noteq> bot\<close> consec_def by blast
      have "lan1 = lan v \<squnion> lanu" using lan1_rep lanu_rep v'_rep 3 4 5
        by (metis \<open>consec (Views.lan v) lanu\<close>  cont1 contu contv consec_un_equality consec_un_max consec_un_min lan1_notE)
      have cont_un1:"continuous (lan v \<squnion> lanu)"
        using \<open>lan1 = Views.lan v \<squnion> lanu\<close> cont1 by auto
      have chop1:"N_Chop(lan1, ?lanv, lanu)"
        using \<open>consec (Views.lan v) lanu\<close> \<open>continuous (Views.lan v)\<close> \<open>continuous lanu\<close> \<open>lan1 = Views.lan v \<squnion> lanu\<close> nchop_def by blast
      have consec2:"consec land lan1"
        using "3" \<open>lan1 = Views.lan v \<squnion> lanu\<close> consec consec_def by auto
      then have "continuous (land \<squnion> lan1)"
        using  cont1 contd nchop_cont nchop_def by blast
      then have "?lanv' = land \<squnion> lan1" using consec2 cont1 v'_rep 3 5 6 v'_notE continuous_min_max
         by (metis (no_types, hide_lams) \<open>maximum lan1 = maximum (Views.lan v) + (maximum (Views.lan v') - maximum (Views.lan v))\<close> bot_eq_sup_iff consec_un_max consec_un_min continuous_nonE_atLeastAtMost land_notE land_rep nat_int_atLeastAtMost_min)
      then have chop2:"N_Chop(?lanv', land, lan1)"
        using  cont1 contd nchop_def view.horizontal_chop_empty_left view.horizontal_chop_lanes_continuous
        consec2 by blast
      obtain vu where vu:"vu= \<lparr> basic_view.ext = ext v, lan = lanu, own =own v\<rparr>"
        by blast
      obtain v1 where v1:"v1 = \<lparr> basic_view.ext = ext v, lan = lan1, own = own v\<rparr>"
        by blast
      obtain vd where vd:"vd =  \<lparr> basic_view.ext = ext v, lan = land, own =own v\<rparr>"
        by blast
      have 7:"(Abs_view v1)=v--(Abs_view vu)" using chop1 vu v1 Abs_view_inverse vchop_def ext.rep_eq own.rep_eq
        by (simp add: cont1 contu lan.rep_eq)
      have 8:"v'=(Abs_view vd)-- (Abs_view v1)" using chop2 v1 vd
        by (simp add: Abs_view_inverse assm eq_onp_same_args ext.abs_eq lan.rep_eq nchop_def own.abs_eq view.vchop_def)
      then have "(v'=(Abs_view vd)--(Abs_view v1)) \<and> ((Abs_view v1)=v--(Abs_view vu))"
        using "7" by blast
      then show ?thesis by blast
    qed
  qed
qed

lemma somewhere_leq:
  "v \<le> v' \<longleftrightarrow> (\<exists>v1 v2 v3 vl vr vu vd.
                (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu))"
proof
  assume "v \<le> v'"
  then obtain v'' where v'':" (ext v'' \<le> ext v') \<and> (lan v'' = lan v') \<and> (own v'' = own v') \<and> (ext v = ext v'') \<and> (lan v \<sqsubseteq> lan v'') \<and> (own v = own v'')" using
      horizontal_intermed by blast
  then have 1:"(\<exists>v1 vl vr. (v'=vl\<parallel>v1) \<and> (v1=v''\<parallel>vr))"  using horizontal_leq  by blast
  from v'' have 2:"\<exists>v2 vd vu. (v''=vd--v2) \<and> (v2=v--vu)"  using vertical_leq by blast
  from 1 and 2 show "(\<exists>v1 v2 v3 vl vr vu vd.
                (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu))" by blast
next
  assume
    "\<exists>v1 v2 v3 vl vr vu vd. (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu)"
  then obtain v1 v2 v3 vl vr vu vd
    where " (v'=vl\<parallel>v1) \<and> (v1=v2\<parallel>vr) \<and> (v2=vd--v3) \<and> (v3=v--vu)" by blast
  then show "v \<le> v'"
    by (meson horizontal_chop_leq1 horizontal_chop_leq2 order_trans vertical_chop_leq1
        vertical_chop_leq2)
qed

text\<open>The switch relation is compatible with the chopping relations, in the
following sense. If we can chop a view \(v\) into two subviews \(u\) and
\(w\), and we can reach \(v^\prime\) via the switch relation, then
there also exist two subviews \(u^\prime\), \(w^\prime\) of \(v^\prime\),
such that \(u^\prime\) is reachable from \(u\) (and respectively for \(w^\prime\), \(w\)).
\<close>
  (* switch lemmas *)
lemma switch_unique:"(v =c> u) \<and> (v =c> w) \<longrightarrow>u = w"
  using switch_def
  using Rep_view_inject ext.rep_eq lan.rep_eq own.rep_eq by fastforce

lemma switch_exists:"\<exists>c u.( v=c>u)"
  using switch_def by auto

lemma switch_always_exists:" \<exists>u. (v=c>u)"
proof -
  obtain u where "u =   Abs_view \<lparr> basic_view.ext = ext v, lan = lan v, own = c\<rparr>"  by simp
  then have "continuous (lan u) "
    using Rep_view lan.rep_eq by simp
  then have "lan v = lan u" using Rep_view lan.rep_eq Abs_view_inverse
    by (simp add: \<open>u = Abs_view \<lparr>basic_view.ext = Views.ext v, lan = Views.lan v, own = c\<rparr>\<close>)
  then have "v=c>u"
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq own.rep_eq view.switch_def
    by (simp add: \<open>u = Abs_view \<lparr>basic_view.ext = Views.ext v, lan = Views.lan v, own = c\<rparr>\<close>)
  then show ?thesis by blast
qed

lemma switch_origin:" \<exists>u. (u=(own v)>v)"
  using switch_def  by auto

lemma switch_refl:"(v=(own v)>v)"
  by (simp add:switch_def)

lemma switch_symm:"(v=c>u) \<longrightarrow> (u=(own v)>v)"
  by (simp add:switch_def)

lemma switch_trans:"(v=c>u) \<and> (u=d>w) \<longrightarrow> (v=d>w)"
  by (simp add: switch_def)

lemma switch_triangle:"(v=c>u) \<and> (v=d>w) \<longrightarrow> (u=d>w)"
  using switch_def by auto

lemma switch_hchop1:
  "(v=v1\<parallel>v2) \<and> (v=c>v') \<longrightarrow>
     (\<exists> v1' v2'. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v'=v1'\<parallel>v2'))"
proof
  assume assm:"(v=v1\<parallel>v2) \<and> (v=c>v')"
  obtain v1' and v2' where 1:"v1=c>v1'" and 2:"v2=c>v2'"
    by (meson view.switch_always_exists)
  from 1 and 2 and assm have "(v'=v1'\<parallel>v2')"
    using view.hchop_def view.switch_def by auto
  then show "\<exists> v1' v2'. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v'=v1'\<parallel>v2')" using 1 2 by blast
qed

lemma switch_hchop2:
  "(v'=v1'\<parallel>v2') \<and> (v=c>v') \<longrightarrow>
      (\<exists> v1 v2. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v=v1\<parallel>v2))"
proof
  assume assm:"(v'=v1'\<parallel>v2') \<and> (v=c>v')"
  obtain v1 and v2 where 1:"v1=c>v1'" and 2:"v2=c>v2'" and 3:"own v1 = own v" and 4:"own v2 = own v"  using switch_origin
    using assm view.hchop_def view.switch_def
    by (metis  view.switch_always_exists view.switch_symm)
  from 1 and 2 and 3 and 4 assm have "(v=v1\<parallel>v2)"
    using view.hchop_def view.switch_def by auto
  then show "\<exists> v1 v2. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v=v1\<parallel>v2)" using 1 2 by blast
qed

lemma switch_vchop1:
  "(v=v1--v2) \<and> (v=c>v') \<longrightarrow>
      (\<exists> v1' v2'. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v'=v1'--v2'))"
proof
  assume assm:"(v=v1--v2) \<and> (v=c>v')"
  obtain v1' and v2' where 1:"v1=c>v1'" and 2:"v2=c>v2'"
    by (meson view.switch_always_exists)
  from 1 and 2 and assm have "(v'=v1'--v2')"
    using view.vchop_def view.switch_def by auto
  then show "\<exists> v1' v2'. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v'=v1'--v2')" using 1 2 by blast
qed

lemma switch_vchop2:
  "(v'=v1'--v2') \<and> (v=c>v') \<longrightarrow>
       (\<exists> v1 v2. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v=v1--v2))"
proof
  assume assm:"(v'=v1'--v2') \<and> (v=c>v')"
  obtain v1 and v2 where 1:"v1=c>v1'" and 2:"v2=c>v2'" and 3:"own v1 = own v" and 4:"own v2 = own v"  using switch_origin
    using assm view.vchop_def view.switch_def
    by (metis  view.switch_always_exists view.switch_symm)
  from 1 and 2 and 3 and 4 assm have "(v=v1--v2)"
    using view.vchop_def view.switch_def by auto
  then show "\<exists> v1 v2. (v1 =c> v1') \<and> (v2 =c> v2') \<and> (v=v1--v2)" using 1 2 by blast
qed

lemma switch_leq:"u' \<le> u \<and> (v=c>u) \<longrightarrow> (\<exists>v'. (v'=c>u') \<and> v' \<le> v)"
proof
  assume assm: "u' \<le> u \<and> (v=c>u)"
(*  then have more_eq:"more v = more u"
    using view.switch_def by blast*)
  then obtain v' where v'_def:"v'= Abs_view \<lparr> basic_view.ext =ext u', lan = lan u', own = own v\<rparr>"
    by blast
  have ext:"ext v' \<le> ext v" using assm switch_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq less_eq_view_def v'_def by auto
  have lan:"lan v' \<le> lan v" using assm switch_def
    using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq less_eq_view_def v'_def by auto
  have less: "v' \<le> v" using less_eq_view_def ext lan  v'_def
    using Abs_view_inverse Rep_view lan.rep_eq own.rep_eq by auto
  have switch:"v' =c> u'" using v'_def switch_def assm
    using Abs_view_inverse Rep_view lan.rep_eq own.rep_eq
    by (simp add: ext.rep_eq less_eq_view_def)
    show  "(\<exists>v'. ( v' = c > u') \<and> v' \<le> v)" using switch less by blast
  qed

lemma vshift_ext_len_stab: "\<parallel>ext v\<parallel> = \<parallel>ext(vshift v x)\<parallel>"
  using Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq shift_keeps_length vshift_def by auto

lemma vshift_lan_stab: "lan v = lan (vshift v x)" using vshift_def Abs_view_inverse Rep_view  lan.rep_eq by auto

lemma vshift_own_stab: "own v = own (vshift v x)" using vshift_def Abs_view_inverse Rep_view  own.rep_eq lan.rep_eq by auto

lemma vshift_left:"left (ext (vshift v x)) = left (ext v) + x"
  using Abs_real_int_inverse Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq left_leq_right real_int_class.shift_def vshift_def by auto

lemma vshift_right:"right (ext (vshift v x)) = right (ext v) + x"
  using Abs_real_int_inverse Abs_view_inverse Rep_view ext.rep_eq lan.rep_eq left_leq_right real_int_class.shift_def vshift_def by auto

lemma vshift_zero: "vshift v 0 = v" using vshift_lan_stab vshift_own_stab vshift_left vshift_right Abs_view_inverse Rep_view vshift_def
  by (metis Rep_view_inverse cases ext.rep_eq lan.rep_eq own.rep_eq select_convs(1) select_convs(2) select_convs(3) shift_zero)

lemma vshift_additivity: "vshift (vshift v x) y = vshift v (x+y)"
  by (metis real_int_class.shift_def semiring_normalization_rules(25) view.vshift_lan_stab view.vshift_left view.vshift_own_stab view.vshift_right vshift_def)

end
end


(*<*)
(*
   Title:  Theory SteamBoiler_proof.thy (Steam Boiler System: Verification)
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
header {* Steam Boiler System: Verification *}

theory  SteamBoiler_proof
imports SteamBoiler
begin

subsection {* Properties of the Boiler Component *}

lemma L1_Boiler:
  assumes "SteamBoiler x s y"
         and "ts x"
  shows "ts s"
using assms  by (simp add: SteamBoiler_def)

lemma L2_Boiler:
  assumes "SteamBoiler x s y"
         and "ts x"
  shows "ts y"
using assms  by (simp add: SteamBoiler_def)

lemma L3_Boiler:
  assumes "SteamBoiler x s y"
         and "ts x"
  shows "200 \<le> hd (s 0)"
using assms by (simp add: SteamBoiler_def)

lemma L4_Boiler:
  assumes "SteamBoiler x s y"
         and "ts x"
  shows "hd (s 0) \<le> 800"
using assms by (simp add: SteamBoiler_def)

lemma L5_Boiler:
  assumes h1:"SteamBoiler x s y"
         and h2:"ts x"
         and h3:"hd (x j) = Zero"
  shows "(hd (s j)) \<le> hd (s (Suc j)) + (10::nat)"
proof -
   from h1 and h2 obtain r where
     a1:"r \<le> 10"  and
     a2:"hd (s (Suc j)) = (if hd (x j) = Zero then hd (s j) - r else hd (s j) + r)"
     by (simp add: SteamBoiler_def, auto)
   from a2 and h3 have "hd (s (Suc j)) = hd (s j) - r" by simp
   from this and a1 show ?thesis by auto
qed

lemma L6_Boiler:
  assumes h1:"SteamBoiler x s y"
         and h2:"ts x"
         and h3:"hd (x j) = Zero"
  shows "(hd (s j)) - (10::nat) \<le> hd (s (Suc j))"
proof -
   from h1 and h2 obtain r where
     a1:"r \<le> 10"  and
     a2:"hd (s (Suc j)) = (if hd (x j) = Zero then hd (s j) - r else hd (s j) + r)"
     by (simp add: SteamBoiler_def, auto)
   from a2 and h3 have "hd (s (Suc j)) = hd (s j) - r" by simp
   from this and a1 show ?thesis by auto
qed

lemma L7_Boiler:
  assumes h1:"SteamBoiler x s y"
      and h2:"ts x"
      and h3:"hd (x j) \<noteq> Zero"
  shows "(hd (s j)) \<ge> hd (s (Suc j)) - (10::nat)"
proof -
   from h1 and h2 obtain r where
     a1:"r \<le> 10"  and
     a2:"hd (s (Suc j)) = (if hd (x j) = Zero then hd (s j) - r else hd (s j) + r)"
     by (simp add: SteamBoiler_def, auto)
   from a2 and h3 have "hd (s (Suc j)) = hd (s j) + r" by simp
   from this and a1 show ?thesis by auto
qed

lemma L8_Boiler:
  assumes h1:"SteamBoiler x s y"
         and h2:"ts x"
         and h3:"hd (x j) \<noteq> Zero"
  shows "(hd (s j)) + (10::nat) \<ge> hd (s (Suc j))"
proof -
   from h1 and h2 obtain r where
     a1:"r \<le> 10"  and
     a2:"hd (s (Suc j)) = (if hd (x j) = Zero then hd (s j) - r else hd (s j) + r)"
     by (simp add: SteamBoiler_def, auto)
   from a2 and h3 have "hd (s (Suc j)) = hd (s j) + r" by simp
   from this and a1 show ?thesis by auto
qed

subsection {* Properties of the Controller Component *}

lemma L1_Controller:
  assumes "Controller_L s (fin_inf_append [Zero] l) l z"
  shows    "fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms
by (metis Controller_L_def fin_make_untimed_inf_truncate_Nonempty_all0a)

lemma L2_Controller_Zero:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "l t = Zero"
         and "300 < hd (y (Suc t))"
  shows    "z (Suc t) = []"
using assms
by (metis Controller_L_def correct_fin_inf_append1)

lemma L2_Controller_One:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
          and "l t = One"
          and "hd (y (Suc t)) < 700"
  shows "z (Suc t) = []"
using assms
by (metis Controller_L_def bit.distinct(1) correct_fin_inf_append2)

lemma L3_Controller_Zero:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "l t = Zero"
         and "\<not> 300 < hd (y (Suc t))"
  shows "z (Suc t) = [One]"
using assms
by (metis Controller_L_def correct_fin_inf_append1)

lemma L3_Controller_One:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
      and "l t = One"
      and "\<not> hd (y (Suc t)) < 700"
  shows      "z (Suc t) = [Zero]"
using assms
by (metis Controller_L_def bit.distinct(1) correct_fin_inf_append1)

lemma L4_Controller_Zero:
  assumes h1:"Controller_L y (fin_inf_append [Zero] l) l z"
         and h2:"l (Suc t) = Zero"
  shows      "(z (Suc t) = [] \<and> l t = Zero) \<or> (z (Suc t) = [Zero] \<and> l t = One)"
proof (cases "l t")
  assume a1:"l t = Zero"
  from this and h1 and h2 show ?thesis
  proof -
    from a1 have sg1:"fin_inf_append [Zero] l (Suc t) = Zero"
      by (simp add: correct_fin_inf_append1)
    from h1 and sg1 have sg2:
      "if 300 < hd (y (Suc t))
       then z (Suc t) = [] \<and> l (Suc t) = Zero
       else z (Suc t) = [One] \<and> l (Suc t) = One"
       by (simp add: Controller_L_def)
    show ?thesis
    proof (cases "300 < hd (y (Suc t))")
      assume a11:"300 < hd (y (Suc t))"
      from a11 and sg2 have sg3:"z (Suc t) = [] \<and> l (Suc t) = Zero" by simp
      from this and a1 show ?thesis by simp
    next
      assume a12:"\<not> 300 < hd (y (Suc t))"
      from a12 and sg2 have sg4:"z (Suc t) = [One] \<and> l (Suc t) = One" by simp
      from this and h2 show ?thesis by simp
    qed
  qed
next
  assume a2:"l t = One"
  from this and h1 and h2 show ?thesis
  proof -
    from a2 have sg5:"fin_inf_append [Zero] l (Suc t) \<noteq> Zero"
      by (simp add: correct_fin_inf_append1)
    from h1 and sg5 have sg6:
      "if hd (y (Suc t)) < 700
       then z (Suc t) = [] \<and> l (Suc t) = One
       else z (Suc t) = [Zero] \<and> l (Suc t) = Zero"
       by (simp add: Controller_L_def)
    show ?thesis
    proof (cases "hd (y (Suc t)) < 700")
      assume a21:"hd (y (Suc t)) < 700"
      from a21 and sg6 have sg7:"z (Suc t) = [] \<and> l (Suc t) = One" by simp
      from this and h2 show ?thesis by simp
    next
      assume a22:"\<not> hd (y (Suc t)) < 700"
      from a22 and sg6 have sg8:"z (Suc t) = [Zero] \<and> l (Suc t) = Zero" by simp
      from this and a2 show ?thesis by simp
    qed
  qed
qed

lemma L5_Controller_One:
  assumes h1:"Controller_L y lIn lOut z"
      and h2:"lOut t = One"
      and h3:"z t = []"
  shows "lIn t = One"
proof (cases "lIn t")
  assume a1:"lIn t = Zero"
  from a1 and h1 have sg1:
    "if 300 < hd (y t)
     then z t = [] \<and> lOut t = Zero
     else z t = [One] \<and> lOut t = One"
     by (simp add: Controller_L_def)
  show ?thesis
  proof (cases "300 < hd (y t)")
    assume a3:"300 < hd (y t)"
    from a3 and sg1 have sg2:"z t = [] \<and> lOut t = Zero" by simp
    from this and h2 show ?thesis by simp
  next
    assume a4:"\<not> 300 < hd (y t)"
    from a4 and sg1 have sg3:"z t = [One] \<and> lOut t = One" by simp
    from this and h3 show ?thesis by simp
  qed
next
  assume "lIn t = One"
  then show ?thesis by simp
qed

lemma L5_Controller:
  assumes "Controller_L y lIn lOut z"
         and "lOut t = a"
         and "z t = []"
  shows "lIn t = a"
using assms
by (metis L5_Controller_One L5_Controller_Zero bit.exhaust)

lemma L6_Controller_Zero:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "l (Suc t) = Zero"
         and "z (Suc t) = []"
  shows "l t = Zero"
using assms
by (metis L4_Controller_Zero not_Cons_self2)

lemma L6_Controller_One:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "l (Suc t) = One"
         and "z (Suc t) = []"
  shows "l t = One"
using assms
by (metis L4_Controller_One list.distinct(1))

lemma L6_Controller:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "l (Suc t) = a"
         and "z (Suc t) = []"
  shows "l t = a"
using assms
by (metis L5_Controller correct_fin_inf_append2)

lemma L7_Controller_Zero:
  assumes h1:"Controller_L y (fin_inf_append [Zero] l) l z"
         and h2:"l t = Zero"
  shows      "last (fin_make_untimed (inf_truncate z t)) = Zero"
using assms
proof (induct t)
  case 0
  from h1 have "z 0 = [Zero]" by (simp add: Controller_L_def)
  from this show ?case by (simp add: fin_make_untimed_def)
next
   fix t
   case (Suc t)
   from this show ?case
   proof (cases "l t")
     assume a1:"l t = Zero"
     from Suc have
       "(z (Suc t) = [] \<and> l t = Zero) \<or> (z (Suc t) = [Zero] \<and> l t = One)"
       by (simp add: L4_Controller_Zero)
     from this and a1 have "z (Suc t) = []"
       by simp
     from Suc and this and a1 show ?case
       by (simp add: fin_make_untimed_append_empty)
   next
     assume a1:"l t = One"
     from Suc have
       "(z (Suc t) = [] \<and> l t = Zero) \<or> (z (Suc t) = [Zero] \<and> l t = One)"
       by (simp add: L4_Controller_Zero)
     from this and a1 have "z (Suc t) = [Zero]"
       by simp
     from a1 and Suc and this show ?case
       by (simp add: fin_make_untimed_def)
   qed
qed

lemma L7_Controller_One_l0:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "y 0 = [500::nat]"
  shows    "l 0 = Zero"
proof (rule ccontr)
  assume a1:" \<not> l 0 = Zero"
  from assms have sg1:"z 0 = [Zero]" by (simp add: Controller_L_def)
  have sg2:"fin_inf_append [Zero] l (0::nat) = Zero" by  (simp add: fin_inf_append_def)
  from assms and a1 and sg1 and sg2 show "False"
   by (simp add: Controller_L_def)
qed

lemma L7_Controller_One:
  assumes h1:"Controller_L y (fin_inf_append [Zero] l) l z"
      and h2:"l t = One"
      and h3:"y 0 = [500::nat]"
  shows "last (fin_make_untimed (inf_truncate z t)) = One"
using assms
proof (induct t)
  case 0
  from h1 and h3 have "l 0 = Zero"
    by (simp add: L7_Controller_One_l0)
  from this and 0 show ?case by simp
next
   fix t
   case (Suc t)
   from this show ?case
   proof (cases "l t")
     assume a1:"l t = Zero"
     from Suc have
       "(z (Suc t) = [] \<and> l t = One) \<or> (z (Suc t) = [One] \<and> l t = Zero)"
       by (simp add: L4_Controller_One)
     from this and a1 have "z (Suc t) = [One]"
       by simp
     from Suc and this and a1 show ?case
       by (simp add: fin_make_untimed_def)
   next
     assume a1:"l t = One"
     from Suc have
       "(z (Suc t) = [] \<and> l t = One) \<or> (z (Suc t) = [One] \<and> l t = Zero)"
       by (simp add: L4_Controller_One)
     from this and a1 have "z (Suc t) = []"
       by simp
     from a1 and Suc and this show ?case
       by (simp add: fin_make_untimed_def)
   qed
qed

lemma L7_Controller:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
         and "y 0 = [500::nat]"
  shows      "last (fin_make_untimed (inf_truncate z t)) =  l t"
using assms
by (metis (full_types) L7_Controller_One L7_Controller_Zero bit.exhaust)

lemma L8_Controller:
  assumes "Controller_L y (fin_inf_append [Zero] l) l z"
  shows    "z t = [] \<or> z t = [Zero] \<or> z t = [One]"
proof (cases "fin_inf_append [Zero] l t = Zero")
  assume a1:"fin_inf_append [Zero] l t = Zero"
  from a1 and assms have sg1:
   "if 300 < hd (y t)
    then z t = [] \<and> l t = Zero
    else z t = [One] \<and> l t = One"
    by (simp add: Controller_L_def)
  show ?thesis
  proof (cases "300 < hd (y t)")
    assume a11:"300 < hd (y t)"
    from a11 and sg1 show ?thesis by simp
  next
    assume a12:"\<not> 300 < hd (y t)"
    from a12 and sg1 show ?thesis by simp
  qed
next
  assume a2:"fin_inf_append [Zero] l t \<noteq> Zero"
  from a2 and assms have sg2:
   "if hd (y t) < 700
    then z t = [] \<and> l t = One
    else z t = [Zero] \<and> l t = Zero"
    by (simp add: Controller_L_def)
  show ?thesis
  proof (cases "hd (y t) < 700")
    assume a21:"hd (y t) < 700"
    from a21 and sg2 show ?thesis by simp
  next
    assume a22:"\<not> hd (y t) < 700"
    from a22 and sg2 show ?thesis by simp
  qed
qed

lemma L9_Controller:
  assumes h1:"Controller_L s (fin_inf_append [Zero] l) l z"
         and h2:"fin_make_untimed (inf_truncate z i) !
              (length (fin_make_untimed (inf_truncate z i)) - Suc 0) =  Zero"
         and h3:"last (fin_make_untimed (inf_truncate z i)) = l i"
         and h5:"hd (s (Suc i)) = hd (s i) - r"
         and h6:"fin_make_untimed (inf_truncate z i) \<noteq> []"
         and h8:"r \<le> 10"
  shows "200 \<le> hd (s (Suc i))"
proof -
  from h6 and h2 and h3 have sg0:"l i = Zero"
    by (simp add: last_nth_length)
  show ?thesis
  proof (cases "fin_inf_append [Zero] l i = Zero")
    assume a1:"fin_inf_append [Zero] l i = Zero"
    from a1 and h1 have sg1:
      "if 300 < hd (s i)
       then z i = [] \<and> l i = Zero
       else z i = [One] \<and> l i = One"
       by (simp add: Controller_L_def)
    show ?thesis
    proof (cases "300 < hd (s i)")
      assume a11:"300 < hd (s i)"
      from a11 and h5 and h8 show ?thesis by simp
    next
      assume a12:"\<not> 300 < hd (s i)"
      from a12 and sg1 and sg0 show ?thesis by simp
    qed
  next
    assume a2:"fin_inf_append [Zero] l i \<noteq> Zero"
    from a2 and h1 have sg2:
      "if hd (s i) < 700
       then z i = [] \<and> l i = One
       else z i = [Zero] \<and> l i = Zero"
       by (simp add: Controller_L_def)
    show ?thesis
    proof (cases "hd (s i) < 700")
      assume a21:"hd (s i) < 700"
      from this and sg2 and sg0 show ?thesis by simp
    next
      assume a22:"\<not> hd (s i) < 700"
      from this and h5 and h8  show ?thesis by simp
    qed
  qed
qed

lemma L10_Controller:
  assumes h1:"Controller_L s (fin_inf_append [Zero] l) l z"
      and h2:"fin_make_untimed (inf_truncate z i) !
              (length (fin_make_untimed (inf_truncate z i)) - Suc 0) \<noteq>  Zero"
      and h3:"last (fin_make_untimed (inf_truncate z i)) = l i"
      and h5:"hd (s (Suc i)) = hd (s i) + r"
      and h6:"fin_make_untimed (inf_truncate z i) \<noteq> []"
      and h8:"r \<le> 10"
  shows "hd (s (Suc i)) \<le> 800"
proof -
  from h6 and h2 and h3 have sg0:"l i \<noteq>  Zero"
    by (simp add: last_nth_length)
  show ?thesis
  proof (cases "fin_inf_append [Zero] l i = Zero")
    assume a1:"fin_inf_append [Zero] l i = Zero"
    from a1 and h1 have sg1:
      "if 300 < hd (s i)
       then z i = [] \<and> l i = Zero
       else z i = [One] \<and> l i = One"
       by (simp add: Controller_L_def)
    show ?thesis
    proof (cases "300 < hd (s i)")
      assume a11:"300 < hd (s i)"
      from a11 and sg1 and sg0 show ?thesis by simp
    next
      assume a12:"\<not> 300 < hd (s i)"
      from h5 and a12 and h8 show ?thesis by simp
    qed
  next
    assume a2:"fin_inf_append [Zero] l i \<noteq> Zero"
    from a2 and h1 have sg2:
      "if hd (s i) < 700
       then z i = [] \<and> l i = One
       else z i = [Zero] \<and> l i = Zero"
       by (simp add: Controller_L_def)
    show ?thesis
    proof (cases "hd (s i) < 700")
      assume a21:"hd (s i) < 700"
      from this and h5 and h8 show ?thesis by simp
    next
      assume a22:"\<not> hd (s i) < 700"
      from this and sg2 and sg0 show ?thesis by simp
    qed
  qed
qed

subsection {* Properties of the Converter Component *}

lemma L1_Converter:
  assumes "Converter z x"
         and "fin_make_untimed (inf_truncate z t) \<noteq> []"
  shows      "hd (x t) = (fin_make_untimed (inf_truncate z t)) !
                 ((length (fin_make_untimed (inf_truncate z t))) - (1::nat))"
using assms
by (simp add: Converter_def)

lemma L1a_Converter:
  assumes "Converter z x"
         and "fin_make_untimed (inf_truncate z t) \<noteq> []"
         and "hd (x t) = Zero"
  shows      "(fin_make_untimed (inf_truncate z t)) !
                 ((length (fin_make_untimed (inf_truncate z t))) - (1::nat))
              = Zero"
using assms
by (simp add: L1_Converter)

subsection {* Properties of the System *}

lemma L1_ControlSystem:
  assumes "ControlSystemArch s"
  shows "ts s"
proof -
  from assms obtain x z y
    where a1:"Converter z x" and a2: "SteamBoiler x s y"
    by (simp only: ControlSystemArch_def, auto)
  from this have "ts x"
    by (simp add: Converter_def)
  from a2 and this show ?thesis by (rule L1_Boiler)
qed

lemma L2_ControlSystem:
  assumes "ControlSystemArch s"
  shows "(200::nat) \<le> hd (s i)"
proof -
  from assms obtain x z y
    where a1:"Converter z x" and a2: "SteamBoiler x s y" and a3:"Controller y z"
    by (simp only: ControlSystemArch_def, auto)
  from this have sg1:"ts x"  by (simp add: Converter_def)
  from sg1 and a2 have sg2:"ts y"  by (simp add: L2_Boiler)
  from sg1 and a2 have sg3:"y = s" by (simp add: SteamBoiler_def)
  from a1 and a2 and a3 and sg1 and sg2 and sg3 show "200 \<le> hd (s i)"
  proof (induction i)
    case 0
    from this show ?case  by (simp add: L3_Boiler)
  next
    fix i
    case (Suc i)
    from this obtain l
      where a4: "Controller_L s (fin_inf_append [Zero] l) l z"
      by (simp add: Controller_def, atomize, auto)
    from Suc and a4 have sg4:"fin_make_untimed (inf_truncate z i) \<noteq> []"
      by (simp add:  L1_Controller)
    from a2 and sg1 have y0asm:"y 0 = [500::nat]"  by (simp add: SteamBoiler_def)
    from Suc and a4 and sg4 and y0asm have sg5: "last (fin_make_untimed (inf_truncate z i)) =  l i"
      by (simp add: L7_Controller)
    from a2 and sg1 obtain r where
         aa0:"0 < r" and
         aa1:"r \<le> 10" and
         aa2:"hd (s (Suc i)) = (if hd (x i) = Zero then hd (s i) - r else hd (s i) + r)"
         by (simp add: SteamBoiler_def, auto)
    from Suc and a4 and sg4 and sg5 show ?case
    proof (cases "hd (x i) = Zero")
       assume aaZero:"hd (x i) = Zero"
       from a1 and sg4 and this have
         sg7:"(fin_make_untimed (inf_truncate z i)) !
             ((length (fin_make_untimed (inf_truncate z i))) - Suc 0)  = Zero"
         by (simp add: L1_Converter)
       from aa2 and aaZero have sg8:"hd (s (Suc i)) = hd (s i) - r" by simp
       from a4 and sg7 and sg5  and sg8 and sg4 and aa1 show ?thesis
          by (rule L9_Controller)
     next
       assume aaOne:"hd (x i) \<noteq> Zero"
       from a1 and sg4 and this have
         sg7:"(fin_make_untimed (inf_truncate z i)) !
             ((length (fin_make_untimed (inf_truncate z i))) - Suc 0) \<noteq> Zero"
         by (simp add: L1_Converter)
       from aa2 and aaOne have sg9:"hd (s (Suc i)) = hd (s i) + r" by simp
       from Suc and this show ?thesis by simp
     qed
  qed
qed

lemma L3_ControlSystem:
  assumes "ControlSystemArch s"
  shows "hd (s i) \<le> (800:: nat)"
proof -
  from assms obtain x z y
    where a1:"Converter z x" and a2: "SteamBoiler x s y" and a3:"Controller y z"
    by (simp only: ControlSystemArch_def, auto)
  from this have sg1:"ts x"  by (simp add: Converter_def)
  from sg1 and a2 have sg2:"ts y"  by (simp add: L2_Boiler)
  from sg1 and a2 have sg3:"y = s" by (simp add: SteamBoiler_def)
  from a1 and a2 and a3 and sg1 and sg2 and sg3 show "hd (s i) \<le> (800:: nat)"
  proof (induction i)
    case 0
    from this show ?case  by (simp add: L4_Boiler)
  next
    fix i
    case (Suc i)
    from this obtain l
      where a4: "Controller_L s (fin_inf_append [Zero] l) l z"
      by (simp add: Controller_def, atomize, auto)
    from a4 have sg4:"fin_make_untimed (inf_truncate z i) \<noteq> []"
      by (simp add:  L1_Controller)
    from a2 and sg1 have y0asm:"y 0 = [500::nat]"  by (simp add: SteamBoiler_def)
    from Suc and a4 and sg4 and y0asm have sg5: "last (fin_make_untimed (inf_truncate z i)) =  l i"
      by (simp add: L7_Controller)
    from a2 and sg1 obtain r where
         aa0:"0 < r" and
         aa1:"r \<le> 10" and
         aa2:"hd (s (Suc i)) = (if hd (x i) = Zero then hd (s i) - r else hd (s i) + r)"
         by (simp add: SteamBoiler_def, auto)
    from this and Suc and a4 and sg4 and sg5 show ?case
    proof (cases "hd (x i) = Zero")
       assume aaZero:"hd (x i) = Zero"
       from a1 and sg4 and this have
         sg7:"(fin_make_untimed (inf_truncate z i)) !
             ((length (fin_make_untimed (inf_truncate z i))) - Suc 0)  = Zero"
         by (simp add: L1_Converter)
       from aa2 and aaZero have sg8:"hd (s (Suc i)) = hd (s i) - r" by simp
       from this and Suc show ?thesis by simp
     next
       assume aaOne:"hd (x i) \<noteq> Zero"
       from a1 and sg4 and this have
         sg7:"(fin_make_untimed (inf_truncate z i)) !
             ((length (fin_make_untimed (inf_truncate z i))) - Suc 0) \<noteq> Zero"
         by (simp add: L1_Converter)
       from aa2 and aaOne have sg9:"hd (s (Suc i)) = hd (s i) + r" by simp
       from a4 and sg7 and sg5 and sg9 and sg4  and aa1 show ?thesis
          by (rule L10_Controller)
     qed
  qed
qed

subsection {* Proof of the Refinement Relation *}

lemma L0_ControlSystem:
  assumes h1:"ControlSystemArch s"
  shows   "ControlSystem s"
using assms
by (metis ControlSystem_def L1_ControlSystem L2_ControlSystem L3_ControlSystem)

end


theory Chapter12_5
imports "HOL-IMP.Hoare_Total"
begin

text\<open>
\exercise
Prove total correctness of the commands in exercises~\ref{exe:Hoare:sumeq} to
\ref{exe:Hoare:sqrt}.
\<close>

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = (And (Not (Less a1 a2)) (Not (Less a2 a1)))"

lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  unfolding Eq_def by auto

lemma
  "\<turnstile>\<^sub>t {\<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''y'' ::= N 0;;
     WHILE Not(Eq (V ''x'') (N 0))
     DO (''y'' ::= Plus (V ''y'') (V ''x'');;
           ''x'' ::= Plus (V ''x'') (N (-1)))
     {\<lambda>s. s ''y'' = sum i}"
  (is "\<turnstile>\<^sub>t {?HI} ''y'' ::= ?yi;; WHILE ?bx DO (''y'' ::= ?ay;; ''x'' ::= ?ax) {?HE}")
proof (intro Seq While_fun' allI impI; (elim conjE)?)
  let ?ax = "Plus (V ''x'') (N (- 1))"
  let ?ay = "Plus (V ''y'') (V ''x'')"
  let ?P = "\<lambda>s. s ''y'' = sum i - sum (s ''x'') \<and> 0 \<le> s ''x''"
  let ?f = "\<lambda>s::state. nat (s ''x'')"
  let ?Pw' = "\<lambda>n s. ?P s \<and> ?f s < n"
  let ?Q = "\<lambda>n s. ?Pw' n (s[?ax/''x''])"
  let ?Pw = "\<lambda>n s. ?P s \<and> bval ?bx s \<and> n = ?f s"
  let ?yi = "N 0"
  {
    have "\<forall>s. ?HI s \<longrightarrow> ?P (s[?yi/''y''])"
    proof (intro allI impI, elim conjE)
      fix s
      assume Hxi: "s ''x'' = i"
      then have "(s[?yi/''y'']) ''y'' = sum i - sum ((s[?yi/''y'']) ''x'')" (is ?H1) by simp
      moreover assume Hi: "0 \<le> i"
      with Hxi have "0 \<le> (s[?yi/''y'']) ''x''" (is ?H2) by simp
      ultimately show "?H1 \<and> ?H2" by blast
    qed
    from Assign' [OF this] show "\<turnstile>\<^sub>t {?HI} ''y'' ::= ?yi {?P}" .
  next
    fix s
    assume HP: "?P s"
    assume "\<not>bval ?bx s"
    then have "s ''x'' = 0" by simp
    with HP show "s ''y'' = sum i" by simp
  next
    fix n
    show "\<turnstile>\<^sub>t {?Q n} ''x'' ::= ?ax {?Pw' n}" by (rule Assign)
  next
    fix n
    have "\<forall>s. ?Pw n s \<longrightarrow> ?Q n (s[?ay/''y''])"
    proof (intro allI impI conjI; elim conjE)
      fix s
      assume assm: "s ''y'' = sum i - sum (s ''x'')" "0 \<le> s ''x''" "bval (bexp.Not (Eq (V ''x'') (N 0))) s" "n = nat (s ''x'')"
      from assm(2, 3) have Hx0: "0 < s ''x''" by simp
      from assm(1) have "((s[?ay/''y''])[?ax/''x'']) ''y'' = sum i - sum (s ''x'') + s ''x''" by simp
      also from Hx0 have "\<dots> = sum i - sum (s ''x'' - 1)" by auto
      also have "\<dots> = sum i - sum (((s[?ay/''y''])[?ax/''x'']) ''x'')" by simp
      finally show "((s[?ay/''y''])[?ax/''x'']) ''y'' = sum i - sum (((s[?ay/''y''])[?ax/''x'']) ''x'')" .
      from Hx0 show "0 \<le> ((s[?ay/''y''])[?ax/''x'']) ''x''" by simp
      from Hx0 assm(4) show "?f ((s[?ay/''y''])[?ax/''x'']) < n" by auto
    qed
    from Assign' [OF this] show "\<turnstile>\<^sub>t {?Pw n} ''y'' ::= ?ay {?Q n}" .
  }
qed

lemma
  "\<turnstile>\<^sub>t {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
     WHILE Less (N 0) (V ''x'')
     DO (''x'' ::= Plus (V ''x'') (N (-1));; ''y'' ::= Plus (V ''y'') (N (-1)))
     {\<lambda>t. t ''y'' = y - x}"
proof (rule strengthen_pre; intro While_fun' Seq allI impI; (elim conjE)?)
  let ?b = "Less (N 0) (V ''x'')"
  let ?P = "\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x''"
  let ?f = "\<lambda>s::state. nat(s ''x'')"
  let ?Pw' = "\<lambda>n s. ?P s \<and> ?f s < n"
  let ?Pw = "\<lambda>n s. ?P s \<and> bval ?b s \<and> n = ?f s"
  let ?Qold = "\<lambda>s. s ''y'' - 1 - s ''x'' = y - x \<and> 0 \<le> s ''x''"
  let ?ay = "Plus (V ''y'') (N (- 1))"
  let ?ax = "Plus (V ''x'') (N (- 1))"
  let ?Q = "\<lambda>n s. ?Pw' n (s[?ay/''y''])"
  {
    fix s
    assume "s ''x'' = x" "s ''y'' = y" "0 \<le> x"
    then show "?P s" by simp
  next
    fix s
    assume "\<not> bval (Less (N 0) (V ''x'')) s"
    then have "s ''x'' \<le> 0" by simp
    moreover assume "?P s"
    ultimately show "s ''y'' = y - x" by simp
  next
    fix n
    show "\<turnstile>\<^sub>t {?Q n} ''y'' ::= ?ay {?Pw' n}" by (rule Assign)
  next
    fix n
    have "\<forall>s. ?Pw n s \<longrightarrow> ?Q n (s[?ax/''x''])"
    proof (intro allI impI conjI; elim conjE)
      fix s
      assume assm: "s ''y'' - s ''x'' = y - x" "bval (Less (N 0) (V ''x'')) s" "n = nat (s ''x'')"
      from assm(2) have Hx0: "0 < s ''x''" by simp
      from assm(1) show "((s[?ax/''x''])[?ay/''y'']) ''y'' - ((s[?ax/''x''])[?ay/''y'']) ''x'' = y - x" by simp
      from Hx0 show "0 \<le> ((s[?ax/''x''])[?ay/''y'']) ''x''" by simp
      from assm(3) Hx0 show "?f ((s[Plus (V ''x'') (N (- 1))/''x''])[Plus (V ''y'') (N (- 1))/''y'']) < n" by simp
    qed
    then show "\<turnstile>\<^sub>t {?Pw n} ''x'' ::= ?ax {?Q n}" by (rule Assign')
  }
qed

lemma
  "\<turnstile>\<^sub>t { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''r'' ::= N 0;; ''r2'' ::= N 1;;
     WHILE (Not (Less (V ''x'') (V ''r2'')))
     DO (''r'' ::= Plus (V ''r'') (N 1);;
            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
proof (intro Seq While_fun' allI impI conjI; (elim conjE)?)
  let ?b = "Not (Less (V ''x'') (V ''r2''))"
  let ?ar = "Plus (V ''r'') (N 1)"
  let ?ar2 = "Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1))"
  let ?I = "\<lambda>s. s ''x'' = i \<and> 0 \<le> i"
  let ?II = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> 1 = (s ''r'' + 1)\<^sup>2 \<and> 0 \<le> s ''r''"
  let ?P = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'' + 1)\<^sup>2 \<and> 0 \<le> s ''r''"
  let ?f = "\<lambda>s::state. nat (s ''x'' + 1 - s ''r2'')"
  let ?Qold = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'')\<^sup>2"
  let ?Pw' = "\<lambda>n s. ?P s \<and> ?f s < n"
  let ?Q = "\<lambda>n s. ?Pw' n (s[?ar2/''r2''])"
  let ?Pw = "\<lambda>n s. ?P s \<and> bval ?b s \<and> n = ?f s"
  {
    have "\<forall>s. ?I s \<longrightarrow> ?II (s[N 0/''r''])" by auto
    then show "\<turnstile>\<^sub>t {?I} ''r'' ::= N 0 {?II}" by (rule Assign')
  next
    have "\<turnstile>\<^sub>t {\<lambda>s. ?P (s[N 1/''r2''])} ''r2'' ::= N 1 {?P}" by (rule Assign)
    then show "\<turnstile>\<^sub>t {?II} ''r2'' ::= N 1 {?P}" by simp
  next
    fix s
    assume "?P s"
    then have H: "s ''x'' = i" "(s ''r'')\<^sup>2 \<le> s ''x''" "s ''r2'' = (s ''r'' + 1)\<^sup>2" by blast+
    moreover assume "\<not> bval ?b s"
    then have "s ''x'' < s ''r2''" by auto
    ultimately show "(s ''r'')\<^sup>2 \<le> i" "i < (s ''r'' + 1)\<^sup>2" by auto
  next
    fix n
    have Heqv: "\<And>x::int. (x + 1)\<^sup>2 = x\<^sup>2 + x + x + 1" by (simp add: power2_sum)
    show "\<turnstile>\<^sub>t {?Q n} ''r2'' ::= ?ar2 {?Pw' n}" by (rule Assign)
  next
    fix n
    have "\<forall>s. ?Pw n s \<longrightarrow> ?Q n (s[?ar/''r''])"
    proof auto
      fix s :: state
      let ?r = "s ''r''"
      have "(?r + 1)\<^sup>2 + (3 + 2 * ?r) = ?r\<^sup>2 + 4 * ?r + 4" by (simp add: power2_sum)
      also have "\<dots> = (2 + ?r)\<^sup>2" by (simp add: power2_sum)
      finally show "(?r + 1)\<^sup>2 + (3 + 2 * ?r) = (2 + ?r)\<^sup>2" .
    qed
    then show "\<turnstile>\<^sub>t {?Pw n} ''r'' ::= ?ar {?Q n}" by (rule Assign')
  }
qed

text\<open>
\endexercise

\exercise
Modify the VCG to take termination into account. First modify type @{text acom}
by annotating  @{text WHILE} with a measure function in addition to an
invariant:
\<close>
datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn "state \<Rightarrow> nat" bexp acom
    ("({_, _}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_,_} WHILE b DO C) = (WHILE b DO strip C)"

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I,f} WHILE b DO C) Q = I"

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I, f} WHILE b DO C) Q =
  (\<forall>n. (\<forall>s. (I s \<and> bval b s \<and> n = f s \<longrightarrow> pre C (\<lambda>s. I s \<and> f s < n) s) \<and>
        (I s \<and> \<not> bval b s \<longrightarrow> Q s)) \<and>
    vc C (\<lambda>s. I s \<and> f s < n))"

text\<open>
Functions @{const strip} and @{const pre} remain almost unchanged.
The only significant change is in the @{text WHILE} case for @{const vc}.
Modify the old soundness proof to obtain
\<close>

lemmas [simp] = hoaret.Skip hoaret.Assign hoaret.Seq If

lemmas [intro!] = hoaret.Skip hoaret.Assign hoaret.Seq hoaret.If

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
proof(induct C arbitrary: Q)
  case (Awhile I f b C)
  show ?case
  proof (simp, rule While_fun')
    from Awhile(2) show "\<forall>s. I s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
    fix n
    from Awhile(2) have "\<forall>s. I s \<and> bval b s \<and> n = f s \<longrightarrow> pre C (\<lambda>s. I s \<and> f s < n) s" by auto
    moreover from Awhile(2) have "vc C (\<lambda>s. I s \<and> f s < n)" by auto
    with Awhile(1) have "\<turnstile>\<^sub>t {pre C (\<lambda>s. I s \<and> f s < n)} strip C {\<lambda>s. I s \<and> f s < n}" by auto
    ultimately show "\<turnstile>\<^sub>t {\<lambda>s. I s \<and> bval b s \<and> n = f s} strip C {\<lambda>s. I s \<and> f s < n}" by (rule strengthen_pre)
  qed
qed (auto intro: hoaret.conseq)

text\<open>
You may need the combined soundness and completeness of @{text"\<turnstile>\<^sub>t"}:
@{thm hoaret_sc}
\endexercise
\<close>

end


section\<open>A triangle inequality for sumsets\<close>

(*
  Session: Balog_Szemeredi_Gowers
  Title:   Sumset_Triangle_Inequality.thy
  Authors: Angeliki Koutsoukou-Argyraki, Mantas Bakšys, and Chelsea Edmonds
  Affiliation: University of Cambridge
  Date: August 2022.
*)

theory Sumset_Triangle_Inequality
  imports
    Pluennecke_Ruzsa_Inequality.Pluennecke_Ruzsa_Inequality
begin

context additive_abelian_group

begin

text\<open>We show a useful triangle inequality for sumsets that does *not* follow from the Ruzsa triangle
inequality. The proof follows the exposition in Zhao's book \cite{Zhaobook}. \<close>

text\<open>The following auxiliary lemma corresponds to Lemma 7.3.4 in Zhao's book \cite{Zhaobook}.\<close>

lemma triangle_ineq_sumsets_aux:
  fixes X B Y :: "'a set"
  assumes hX: "finite X" and hB: "finite B" and hXG: "X \<subseteq> G" and hBG: "B \<subseteq> G" and
    hXne: "X \<noteq> {}" and hYX: "\<And> Y. Y \<subseteq> X \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> card (sumset Y B) / card Y \<ge>
    card (sumset X B) / card X" and hC: "finite C" and hCne: "C \<noteq> {}" and hCG: "C \<subseteq> G"
  shows "card (sumset X (sumset C B)) / card (sumset X C) \<le> card (sumset X B) / card X"
  using hC hCne hCG proof (induct)
  case empty
  then show ?case by blast
next
  case hcase: (insert c C)
  have hc : "c \<in> G" using hcase by auto
  show "card (sumset X B) / card X \<ge>
    card (sumset X (sumset (insert c C) B)) / card (sumset X (insert c C))"
  proof(cases "C = {}")
    case True
    then have "card (sumset X (insert c C)) = card X" using hc hXG hX
      by (simp add: card_sumset_singleton_eq le_iff_inf)
    moreover have "card (sumset X (sumset (insert c C) B)) \<le> card (sumset X B)" using hX hB hBG hXG
      hc by (metis True card_sumset_le finite_sumset sumset_assoc sumset_commute)
    ultimately show ?thesis by (simp add: divide_right_mono)
  next
    case hCne: False
    have hCG : "C \<subseteq> G" using hcase by auto
    have hstep: "card (sumset X (sumset {c} B) - sumset X (sumset C B)) \<le>
      card (sumset X B) * card (sumset X {c} - sumset X C) / card X"
    proof-
      let ?Y = "{x \<in> X. sumset {x} (sumset {c} B) \<subseteq> sumset X (sumset C B)}"
      have hYX : "?Y \<subseteq> X" and hY: "finite ?Y" using finite_subset hX by auto
      have hsub1: "sumset X (sumset {c} B) - sumset X (sumset C B) \<subseteq>
        sumset (sumset X {c} - sumset X C) B"
        by (metis Diff_subset_conv Un_Diff_cancel sumset_assoc sumset_subset_Un1 sup.cobounded2)
      have hcard1 : "card (sumset X B) = card (sumset X (sumset {c} B))"
        by (metis card_sumset_singleton_eq finite_sumset hB hX hc sumset_Int_carrier sumset_assoc
            sumset_commute)
      have hcard2 : "card (sumset ?Y B) = card (sumset (sumset ?Y {c}) B)"
        using card_sumset_singleton_eq finite_sumset hB hY hc sumset_Int_carrier sumset_assoc
        sumset_commute by (smt (verit, ccfv_threshold))
      have "sumset (sumset ?Y {c}) B \<subseteq> sumset X (sumset C B)"
      proof
        fix d assume "d \<in> sumset (sumset ?Y {c}) B"
        then obtain a b where ha: "a \<in> ?Y" and "b \<in> B" and hd: "d = a \<oplus> c \<oplus> b"
          by (smt (verit) empty_iff insert_iff sumset.cases)
        then have "a \<oplus> c \<oplus> b \<in> sumset {a} (sumset {c} B)"
          by (smt (verit) associative composition_closed hBG hXG hc insertCI mem_Collect_eq subsetD
            sumset.sumsetI)
        then show "d \<in> sumset X (sumset C B)" using ha hd by blast
      qed
      then have hdisj : "disjnt ((sumset X (sumset {c} B)) - (sumset X (sumset C B)))
        (sumset (sumset ?Y {c}) B)"
        by (auto simp add : disjnt_iff)
      have hsub2 : "sumset (sumset X {c} - sumset X C) B \<union> sumset (sumset ?Y {c}) B \<subseteq>
        sumset (sumset X {c}) B" by (simp add: sumset_mono)
      then have ineq1: "card (sumset X (sumset {c} B) - sumset X (sumset C B)) + card (sumset ?Y B) \<le>
        card (sumset X B)"
      proof-
      have "card (sumset X (sumset {c} B) - sumset X (sumset C B)) + card (sumset ?Y B) =
        card ((sumset X (sumset {c} B) - sumset X (sumset C B)) \<union> sumset (sumset ?Y {c}) B)"
          using hdisj hcard2 card_Un_disjnt finite_sumset hX hYX finite_subset hB
          by (metis (no_types, lifting) finite.emptyI finite.insertI finite_Diff)
      also have "... \<le> card (sumset X (sumset {c} B))" using card_mono finite_sumset hX hB
        by (metis (no_types, lifting) Diff_subset Un_subset_iff finite.emptyI finite.insertI
            hsub2 sumset_assoc)
      finally show "card (sumset X (sumset {c} B) - sumset X (sumset C B)) + card (sumset ?Y B) \<le>
        card (sumset X B)" using hcard1 by auto
    qed
    have ineq2: "card (sumset X {c} - sumset X C)  \<ge> card X - card ?Y"
    proof-
      let ?Z = "{x \<in> X. sumset {x} {c} \<subseteq> sumset X C}"
      have hZY: "?Z \<subseteq> ?Y"
        by (smt (verit, del_insts) Collect_mono_iff subset_refl sumset_assoc sumset_mono)
      have hinj: "inj_on (\<lambda> x. x \<oplus> c) (X - ?Z)"
      proof (intro inj_onI)
        fix x y assume "x \<in> X - ?Z" and "y \<in> X - ?Z" and h: "x \<oplus> c = y \<oplus> c"
        then have "x \<in> G" and "y \<in> G" using hXG by auto
        then show "x = y" using h hc by simp
      qed
      have himage: "(\<lambda> x. x \<oplus> c) ` (X - ?Z) = sumset X {c} - sumset X C"
      proof
        show "(\<lambda>x. x \<oplus> c) ` (X - ?Z) \<subseteq> sumset X {c} - sumset X C"
        proof(intro image_subsetI)
          fix x assume hx: "x \<in> X - ?Z"
          then have hxG : "x \<in> G" using hXG by auto
          then have hxc1: "x \<oplus> c \<in> sumset X {c}" using hXG hc hx by auto
          have "x \<oplus> c \<in> sumset {x} {c}" using hxG hc by auto
          then have hxc2: "x \<oplus> c \<notin> sumset X C" using hx hXG hc hCG
            using DiffD2 sumset.simps sumset.sumsetI by auto
          then show "x \<oplus> c \<in> sumset X {c} - sumset X C" using hxc1 hxc2 by simp
        qed
        show "sumset X {c} - sumset X C \<subseteq> (\<lambda>x. x \<oplus> c) ` (X - ?Z)"
        proof
          fix d assume "d \<in> sumset X {c} - sumset X C"
          then obtain x where hd: "d = x \<oplus> c" and hxc: "x \<oplus> c \<notin> sumset X C" and hx: "x \<in> X"
            using sumset.cases by force
          then show "d \<in> (\<lambda>x. x \<oplus> c) ` (X - ?Z)" using hd hxc hx hXG hc by auto
        qed
      qed
      have hcard3: "card (X - ?Z) = card (sumset X {c} - sumset X C)"
        using card_image hinj himage by fastforce
      have "card X = card ?Z + card (X - ?Z)"
        by (simp add: card_Diff_subset card_mono hX)
      also have "... \<le> card ?Y + card (sumset X {c} - sumset X C)"
        using hcard3 card_mono hZY hY by auto
      finally show ?thesis by simp
    qed
    have ineq3: "card (sumset X B) - card (sumset ?Y B) \<le>
      card (sumset X B) * (card X - card ?Y) / card X"
    proof(cases "?Y = {}")
      case True
      then show ?thesis using card_eq_0_iff
        by (smt (verit) hX hXne minus_nat.diff_0 nonzero_mult_div_cancel_right of_nat_eq_0_iff
        of_nat_mult sumset_empty(2))
    next
      case hYne: False
      have "card (sumset ?Y B) \<ge> card (sumset X B) / card X * card ?Y" using assms(6)[OF hYX hYne]
        hX hYne hX hYX finite_subset divide_le_eq
        by (smt (z3) card_gt_0_iff hY mult_imp_div_pos_less of_nat_0_less_iff)
      moreover have "card (sumset X B) / card X * card ?Y = (card (sumset X B) * card ?Y) / card X"
        by auto
      moreover have "card (sumset X B) * card ?Y / card X  * card X = card (sumset X B) * card ?Y"
        using hX by (simp add: field_simps)
      ultimately have "card (sumset ?Y B) * card X \<ge> card (sumset X B) * card ?Y"
        using hX hXne of_nat_0_less_iff le_divide_eq
        by (smt (z3) card_sumset_0_iff hBG hXG mult_cancel1 mult_cancel2 of_nat_le_0_iff
        of_nat_le_iff of_nat_mult)
      then have "real ((card (sumset X B) - card (sumset ?Y B)) * card X) \<le>
        card (sumset X B) * (card X - card ?Y)"
        by (simp add: diff_mult_distrib diff_mult_distrib2)
      thus ?thesis using le_divide_eq card_eq_0_iff hX hXne
        by (smt (z3) of_nat_le_0_iff of_nat_mult)
    qed
    show ?thesis
    proof-
      have "real (card ((sumset X (sumset {c} B)) - (sumset X (sumset C B)))) \<le>
        card (sumset X B) - card (sumset ?Y B)" using ineq1 by auto
      also have "... \<le> card (sumset X B) * (card X - card ?Y) / card X" using ineq3 by auto
      also have "... \<le> card (sumset X B) * card (sumset X {c} - sumset X C) / card X" using ineq2
        divide_le_cancel of_nat_less_0_iff of_nat_mono by (smt (verit, del_insts) mult_le_mono2)
      finally show ?thesis by simp
    qed
  qed
  have hinsert: "real (card (sumset X (sumset (insert c C) B))) / real (card (sumset X (insert c C))) =
  (card (sumset X (sumset {c} B) - sumset X (sumset C B)) + card (sumset X (sumset C B))) /
  (card (sumset X {c} - sumset X C) + card (sumset X C))"
    using sumset_insert2 card_Un_disjoint finite_sumset hX hB hC Diff_disjoint Int_commute
    Un_commute finite.emptyI finite.insertI finite_Diff hcase.hyps(1)
    by (smt (verit) Un_Diff_cancel2 insert_is_Un sumset_commute sumset_subset_Un2)
  have hsplit: "real (card (sumset X B)) * (card (sumset X {c} - sumset X C) + card (sumset X C)) / card X =
  real (card (sumset X B)) * card (sumset X {c} - sumset X C) / card X +
  card (sumset X B) * card (sumset X C) / card X"
    by (smt (verit, ccfv_threshold) add_divide_distrib add_mult_distrib2 of_nat_add of_nat_mult)
  have hind: "card (sumset X B) * card (sumset X C) / card X \<ge> card (sumset X (sumset C B))"
    using hcase(3)[OF hCne hCG] hXne hCne hcase(1) hX finite_sumset card_gt_0_iff
    add_mult_distrib2 of_nat_mult card_eq_0_iff card_sumset_0_iff hCG
    hXG of_nat_0_less_iff by (metis (no_types, opaque_lifting) divide_le_eq times_divide_eq_left)
  have "real (card (sumset X B)) * (card (sumset X {c} - sumset X C) + card (sumset X C)) / card X \<ge>
  (card (sumset X (sumset {c} B) - sumset X (sumset C B)) + card (sumset X (sumset C B)))"
    using hsplit hind hstep by simp
  then have "card (sumset X B) / card X \<ge>
    (card (sumset X (sumset {c} B) - sumset X (sumset C B)) + card (sumset X (sumset C B))) /
    (card (sumset X {c} - sumset X C) + card (sumset X C))" using card_sumset_0_iff hCG hXG
    card_eq_0_iff hC hX hXne hCne divide_self le_divide_eq
    by (smt (z3) add_is_0 hcase.hyps(1) of_nat_le_0_iff times_divide_eq_left)
  thus "real (card (sumset X (sumset (insert c C) B))) / real (card (sumset X (insert c C))) \<le>
    real (card (sumset X B)) / real (card X)" using hinsert by auto
  qed
qed

text\<open>The following inequality is the result corresponding to Corollary 7.3.6 in Zhao's book \cite{Zhaobook}.\<close>

lemma triangle_ineq_sumsets:
  assumes hA: "finite A" and hB: "finite B" and hC: "finite C" and
  hAG : "A \<subseteq> G" and hBG: "B \<subseteq> G" and hCG: "C \<subseteq> G"
  shows "card A * card (sumset B C) \<le> card (sumset A B) * card (sumset A C)"

proof(cases "A = {}")
  case True
  then show ?thesis by simp
next
  case hAne: False
  show "card A * card (sumset B C) \<le> card (sumset A B) * card (sumset A C)"
  proof(cases "B = {}")
    case True
    then show ?thesis by simp
  next
    case hBne: False
    define KS where "KS \<equiv> (\<lambda>X. card (sumset X C) / real (card X)) ` (Pow A - {{}})"
    define K where "K \<equiv> Min KS"
    define X where "X \<equiv> @X. X \<in> Pow A - {{}} \<and> K = card (sumset X C) / real (card X)"
    obtain KS: "finite KS" "KS \<noteq> {}"
      using KS_def hA hAne by blast
    then have "K \<in> KS"
      using K_def Min_in by blast
    then have "\<exists>X. X \<in> Pow A - {{}} \<and> K = card (sumset X C) / real (card X)"
      using KS_def by blast
    then obtain "X \<in> Pow A - {{}}" and Keq: "K = card (sumset X C) / real (card X)"
      by (metis (mono_tags, lifting) X_def someI_ex)
    then have hX: "X \<subseteq> A" "X \<noteq> {}"
      by auto
    have hXmin : "\<And> Y. Y \<subseteq> A \<Longrightarrow> Y \<noteq> {} \<Longrightarrow>
      card (sumset X C) / card X \<le> card (sumset Y C) / card Y"
      using K_def KS_def Keq Min_le KS(1) by auto
    then have hXAineq: "card (sumset X C) / card X \<le> card (sumset A C) / card A"
      by (metis hAne subset_refl)
    have haux: "real (card (sumset X (sumset B C))) / real (card (sumset X B))
      \<le> real (card (sumset X C)) / real (card X)" using triangle_ineq_sumsets_aux[of "X" "C" "B"]
      hXmin hX hA hAG finite_subset hB hC hBne hBG hC hCG subset_trans by metis
    have hXAsumset : "real (card (sumset X B)) \<le> card (sumset A B)"
      using hX(1) card_mono hA finite_sumset hB order_refl sumset_mono
      by (metis of_nat_le_iff)
    have "card (sumset B C) \<le> card (sumset X (sumset B C))" using assms hX
      finite_sumset hAG card_le_sumset
      by (metis bot.extremum_uniqueI dual_order.trans infinite_super subsetD subsetI
        sumset_subset_carrier)
    also have "... \<le> (card (sumset X C) / card X) * card (sumset X B)" using haux divide_le_eq
      card_sumset_0_iff hBne hX hB hA finite_subset card_0_eq by (smt (verit) hCG mult_eq_0_iff
      of_nat_0_eq_iff of_nat_0_le_iff sumset_assoc sumset_subset_carrier)
    also have "... \<le> (card (sumset A C) / card A) * card (sumset A B)"
      using hXAineq hXAsumset by (meson divide_nonneg_nonneg mult_mono' of_nat_0_le_iff)
    finally have "card (sumset B C) \<le> (card (sumset A C) * card (sumset A B)) / card A" by simp
    then have "card (sumset B C) * card A \<le> card (sumset A C) * card (sumset A B)"
      using le_divide_eq hAne hA card_gt_0_iff by (smt (verit, ccfv_threshold)
      card_0_eq of_nat_le_0_iff of_nat_le_iff of_nat_mult)
    thus "card A * card (sumset B C) \<le> card (sumset A B) * card (sumset A C)"
      by (simp add: mult.commute)
  qed
qed

end
end


section {* WebAssembly Core AST *}

theory Wasm_Ast imports Main "HOL-Word.Word" begin

type_synonym \<comment> \<open>immediate\<close>
  i = nat
type_synonym \<comment> \<open>static offset\<close>
  off = nat
type_synonym \<comment> \<open>alignment exponent\<close>
  a = nat

\<comment> \<open>primitive types\<close>
typedef i32 = "UNIV :: (32 word) set" ..
typedecl i64
typedecl f32
typedecl f64

setup_lifting type_definition_i32
declare Quotient_i32[transfer_rule]

\<comment> \<open>memory\<close>
type_synonym byte = "8 word"

type_synonym bytes = "byte list"

definition bytes_takefill :: "byte \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" where
  "bytes_takefill = (\<lambda>(a::8 word) n as. takefill a n as)"

definition bytes_replicate :: "nat \<Rightarrow> byte \<Rightarrow> bytes" where
  "bytes_replicate = (\<lambda>n (b::8 word). replicate n b)"

definition msbyte :: "bytes \<Rightarrow> byte" where
  "msbyte bs = last (bs)"

record limit_t =
  l_min :: nat
  l_max :: "nat option"

free_constructors case_limit_t_ext for limit_t_ext
  using limit_t.cases_scheme
  by blast+

type_synonym tab_t = \<comment> \<open>table type\<close>
  "limit_t"

type_synonym mem_t = \<comment> \<open>memory type\<close>
  "limit_t"

definition Ki64 :: "nat" where
  "Ki64 = 65536"

(* data, max? *)
typedef mem = "UNIV :: ((byte list) \<times> nat option) set" ..
setup_lifting type_definition_mem
declare Quotient_mem[transfer_rule]

lift_definition mem_mk :: "limit_t \<Rightarrow> mem" is "(\<lambda>lim. ((bytes_replicate ((l_min lim) * Ki64) 0), l_max lim))" .

lift_definition byte_at :: "mem \<Rightarrow> nat \<Rightarrow> byte" is "(\<lambda>(m,max) n. m!n)::((byte list) \<times> nat option) \<Rightarrow> nat \<Rightarrow> byte" .
lift_definition mem_length :: "mem \<Rightarrow> nat" is "(\<lambda>(m,max). length m)" .
lift_definition mem_max :: "mem \<Rightarrow> nat option" is "(\<lambda>(m,max). max)" .

lift_definition read_bytes :: "mem \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes" is "(\<lambda>(m,max) n l. (take l (drop n m))::(byte list))" .
lift_definition write_bytes :: "mem \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> mem" is "(\<lambda>(m,max) n bs. (((take n m) @ bs @ (drop (n + length bs) m)),max)::(byte list \<times> nat option))" .
lift_definition mem_append :: "mem \<Rightarrow> bytes \<Rightarrow> mem" is "(\<lambda>(m,max) bs. (append m bs, max)::(byte list \<times> nat option))" .

lemma take_drop_map:
  assumes "ind+n \<le> length bs"
  shows "(take n (drop ind bs)) = (map ((!) bs) [ind..<ind + n])"
proof -
  have "(drop ind bs) = (map ((!) bs) [ind..<length bs])"
    using drop_map map_nth
    by (metis add.commute add.right_neutral drop_upt)
  thus ?thesis
    by (simp add: assms(1) take_map)
qed

lemma read_bytes_map:
  assumes "ind+n \<le> mem_length m"
  shows "read_bytes m ind n = (map (\<lambda>k. byte_at m k) [ind..<ind+n])"
  using assms
  unfolding read_bytes_def byte_at_def mem_length_def
  by (simp add: take_drop_map split: prod.splits)

\<comment> \<open>host\<close>
typedecl host
typedecl host_state

datatype \<comment> \<open>value types\<close>
  t = T_i32 | T_i64 | T_f32 | T_f64

datatype \<comment> \<open>packed types\<close>
  tp = Tp_i8 | Tp_i16 | Tp_i32

datatype \<comment> \<open>mutability\<close>
  mut = T_immut | T_mut

record tg = \<comment> \<open>global types\<close>
  tg_mut :: mut
  tg_t :: t

free_constructors case_tg_ext for tg_ext
  using tg.cases_scheme
  by blast+

datatype \<comment> \<open>function types\<close>
  tf = Tf "t list" "t list" ("_ '_> _" 60)

(* TYPING *)
record t_context =
  types_t :: "tf list"
  func_t :: "tf list"
  global :: "tg list"
  table :: "tab_t list"
  memory :: "mem_t list"
  local :: "t list"
  label :: "(t list) list"
  return :: "(t list) option"

datatype
  sx = S | U

datatype
  unop_i = Clz | Ctz | Popcnt

datatype
  unop_f = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt

datatype
  unop = Unop_i unop_i | Unop_f unop_f

datatype
  binop_i = Add | Sub | Mul | Div sx | Rem sx | And | Or | Xor | Shl | Shr sx | Rotl | Rotr

datatype
  binop_f = Addf | Subf | Mulf | Divf | Min | Max | Copysign

datatype
  binop = Binop_i binop_i | Binop_f binop_f

datatype
  testop = Eqz

datatype
  relop_i = Eq | Ne | Lt sx | Gt sx | Le sx | Ge sx

datatype
  relop_f = Eqf | Nef | Ltf | Gtf | Lef | Gef

datatype
  relop = Relop_i relop_i | Relop_f relop_f

datatype
  cvtop = Convert | Reinterpret

datatype \<comment> \<open>values\<close>
  v =
    ConstInt32 i32
    | ConstInt64 i64
    | ConstFloat32 f32
    | ConstFloat64 f64

datatype \<comment> \<open>basic instructions\<close>
  b_e =
    Unreachable
    | Nop
    | Drop
    | Select
    | Block tf "b_e list"
    | Loop tf "b_e list"
    | If tf "b_e list" "b_e list"
    | Br i
    | Br_if i
    | Br_table "i list" i
    | Return
    | Call i
    | Call_indirect i
    | Get_local i
    | Set_local i
    | Tee_local i
    | Get_global i
    | Set_global i
    | Load t "(tp \<times> sx) option" a off
    | Store t "tp option" a off
    | Current_memory
    | Grow_memory
    | EConst v ("C _" 60)
    | Unop t unop
    | Binop t binop
    | Testop t testop
    | Relop t relop
    | Cvtop t cvtop t "sx option"

record inst = \<comment> \<open>instances\<close>
  types :: "tf list"
  funcs :: "i list"
  tabs :: "i list"
  mems :: "i list"
  globs :: "i list"

datatype cl = \<comment> \<open>function closures\<close>
  Func_native inst tf "t list" "b_e list"
| Func_host tf host

type_synonym tabinst = "(i option) list \<times> nat option"

abbreviation "tab_size (t::tabinst) \<equiv> length (fst t)"
abbreviation "tab_max (t::tabinst) \<equiv> snd t"

record global =
  g_mut :: mut
  g_val :: v

record s = \<comment> \<open>store\<close>
  funcs :: "cl list"
  tabs :: "tabinst list"
  mems :: "mem list"
  globs :: "global list"

datatype e = \<comment> \<open>administrative instruction\<close>
  Basic b_e ("$_" 60)
  | Trap
  | Invoke cl
  | Label nat "e list" "e list"
  | Local nat inst "v list" "e list"

datatype Lholed =
    \<comment> \<open>L0 = v* [<hole>] e*\<close>
    LBase "e list" "e list"
    \<comment> \<open>L(i+1) = v* (label n {e* } Li) e*\<close>
    | LRec "e list" nat "e list" Lholed "e list"

end