section \<open>Core Lens Laws\<close>

theory Lens_Laws
imports
  Two Interp
begin

subsection \<open>Lens Signature\<close>

text \<open>This theory introduces the signature of lenses and indentifies the core algebraic hierarchy of lens
  classes, including laws for well-behaved, very well-behaved, and bijective lenses~\cite{Foster07,Fischer2015,Gibbons17}.\<close>

record ('a, 'b) lens =
  lens_get :: "'b \<Rightarrow> 'a" ("get\<index>")
  lens_put :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("put\<index>")

type_notation
  lens (infixr "\<Longrightarrow>" 0)

text \<open> Alternative parameters ordering, inspired by Back and von Wright's refinement
  calculus~\cite{Back1998}, which similarly uses two functions to characterise updates to variables. \<close>

abbreviation (input) lens_set :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b" ("lset\<index>") where
"lens_set \<equiv> (\<lambda> X v s. put\<^bsub>X\<^esub> s v)"

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Lens}
  \end{center}
  \vspace{-5ex}
  \caption{Visualisation of a simple lens}
  \label{fig:Lens}
  \end{figure}

  A lens $X : \view \lto \src$, for source type $\src$ and view type $\view$, identifies
  $\view$ with a subregion of $\src$~\cite{Foster07,Foster09}, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes
  $X$ and the hatched area denotes the subregion $\view$ it characterises. Transformations on
  $\view$ can be performed without affecting the parts of $\src$ outside the hatched area. The lens
  signature consists of a pair of functions $\lget_X : \src \Rightarrow \view$ that extracts a view
  from a source, and $\lput_X : \src \Rightarrow \view \Rightarrow \src$ that updates a view within
  a given source. \<close>

named_theorems lens_defs

text \<open> @{text lens_source} gives the set of constructible sources; that is those that can be built
  by putting a value into an arbitrary source. \<close>

definition lens_source :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b set" ("\<S>\<index>") where
"lens_source X = {s. \<exists> v s'. s = put\<^bsub>X\<^esub> s' v}"

abbreviation some_source :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b" ("src\<index>") where
"some_source X \<equiv> (SOME s. s \<in> \<S>\<^bsub>X\<^esub>)"

definition lens_create :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("create\<index>") where
[lens_defs]: "create\<^bsub>X\<^esub> v = put\<^bsub>X\<^esub> (src\<^bsub>X\<^esub>) v"

text \<open> Function $\lcreate_X~v$ creates an instance of the source type of $X$ by injecting $v$
  as the view, and leaving the remaining context arbitrary. \<close>

definition lens_update :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b)" ("update\<index>") where
[lens_defs]: "lens_update X f \<sigma> = put\<^bsub>X\<^esub> \<sigma> (f (get\<^bsub>X\<^esub> \<sigma>))"

text \<open> The update function is analogous to the record update function which lifts a function
  on a view type to one on the source type. \<close>

definition lens_obs_eq :: "('b \<Longrightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<simeq>\<index>" 50) where
[lens_defs]: "s\<^sub>1 \<simeq>\<^bsub>X\<^esub> s\<^sub>2 = (s\<^sub>1 = put\<^bsub>X\<^esub> s\<^sub>2 (get\<^bsub>X\<^esub> s\<^sub>1))"

text \<open> This relation states that two sources are equivalent outside of the region characterised
  by lens $X$. \<close>

definition lens_override :: "('b \<Longrightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<triangleleft>\<index>" 95) where
[lens_defs]: "S\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> S\<^sub>2 = put\<^bsub>X\<^esub> S\<^sub>1 (get\<^bsub>X\<^esub> S\<^sub>2)"

abbreviation (input) lens_override' :: "'a \<Rightarrow> 'a \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> 'a" ("_ \<oplus>\<^sub>L _ on _" [95,0,96] 95) where
"S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X \<equiv> S\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> S\<^sub>2"

text \<open>Lens override uses a lens to replace part of a source type with a given value for the
  corresponding view.\<close>

subsection \<open>Weak Lenses\<close>

text \<open> Weak lenses are the least constrained class of lenses in our algebraic hierarchy. They
  simply require that the PutGet law~\cite{Foster09,Fischer2015} is satisfied, meaning that
  $\lget$ is the inverse of $\lput$. \<close>

locale weak_lens =
  fixes x :: "'a \<Longrightarrow> 'b" (structure)
  assumes put_get: "get (put \<sigma> v) = v"
begin
  lemma source_nonempty: "\<exists> s. s \<in> \<S>"
    by (auto simp add: lens_source_def)

  lemma put_closure: "put \<sigma> v \<in> \<S>"
    by (auto simp add: lens_source_def)

  lemma create_closure: "create v \<in> \<S>"
    by (simp add: lens_create_def put_closure)

  lemma src_source [simp]: "src \<in> \<S>"
    using some_in_eq source_nonempty by auto

  lemma create_get: "get (create v) = v"
    by (simp add: lens_create_def put_get)

  lemma create_inj: "inj create"
    by (metis create_get injI)

  lemma get_update: "get (update f \<sigma>) = f (get \<sigma>)"
    by (simp add: put_get lens_update_def)

  lemma view_determination:
    assumes "put \<sigma> u = put \<rho> v"
    shows "u = v"
    by (metis assms put_get)

  lemma put_inj: "inj (put \<sigma>)"
    by (simp add: injI view_determination)

end

declare weak_lens.put_get [simp]
declare weak_lens.create_get [simp]

subsection \<open>Well-behaved Lenses\<close>

text \<open> Well-behaved lenses add to weak lenses that requirement that the GetPut law~\cite{Foster09,Fischer2015}
  is satisfied, meaning that $\lput$ is the inverse of $\lget$. \<close>

locale wb_lens = weak_lens +
  assumes get_put: "put \<sigma> (get \<sigma>) = \<sigma>"
begin

  lemma put_twice: "put (put \<sigma> v) v = put \<sigma> v"
    by (metis get_put put_get)

  lemma put_surjectivity: "\<exists> \<rho> v. put \<rho> v = \<sigma>"
    using get_put by blast

  lemma source_stability: "\<exists> v. put \<sigma> v = \<sigma>"
    using get_put by auto

  lemma source_UNIV [simp]: "\<S> = UNIV"
    by (metis UNIV_eq_I put_closure wb_lens.source_stability wb_lens_axioms)

end

declare wb_lens.get_put [simp]

lemma wb_lens_weak [simp]: "wb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: wb_lens_def)

subsection \<open> Mainly Well-behaved Lenses \<close>

text \<open> Mainly well-behaved lenses extend weak lenses with the PutPut law that shows how one put
  override a previous one. \<close>

locale mwb_lens = weak_lens +
  assumes put_put: "put (put \<sigma> v) u = put \<sigma> u"
begin

  text \<open> Mainly well-behaved lenses give rise to a weakened version of the $get-put$ law,
    where the source must be within the set of constructible sources. \<close>

  lemma weak_get_put: "\<sigma> \<in> \<S> \<Longrightarrow> put \<sigma> (get \<sigma>) = \<sigma>"
    by (auto simp add: lens_source_def put_get put_put)

  lemma weak_source_determination:
    assumes "\<sigma> \<in> \<S>" "\<rho> \<in> \<S>" "get \<sigma> = get \<rho>" "put \<sigma> v = put \<rho> v"
    shows "\<sigma> = \<rho>"
    by (metis assms put_put weak_get_put)

   lemma weak_put_eq:
     assumes "\<sigma> \<in> \<S>" "get \<sigma> = k" "put \<sigma> u = put \<rho> v"
     shows "put \<rho> k = \<sigma>"
     by (metis assms put_put weak_get_put)

  text \<open> Provides $s$ is constructible, then @{term get} can be uniquely determined from @{term put} \<close>

  lemma weak_get_via_put: "s \<in> \<S> \<Longrightarrow> get s = (THE v. put s v = s)"
    by (rule sym, auto intro!: the_equality weak_get_put, metis put_get)

end

abbreviation (input) "partial_lens \<equiv> mwb_lens"

declare mwb_lens.put_put [simp]
declare mwb_lens.weak_get_put [simp]

lemma mwb_lens_weak [simp]:
  "mwb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: mwb_lens.axioms(1))

subsection \<open>Very Well-behaved Lenses\<close>

text \<open>Very well-behaved lenses combine all three laws, as in the literature~\cite{Foster09,Fischer2015}.
  The same set of axioms can be found in Back and von Wright's refinement calculus~\cite{Back1998},
  though with different names for the functions. \<close>

locale vwb_lens = wb_lens + mwb_lens
begin

  lemma source_determination:
    assumes "get \<sigma> = get \<rho>" "put \<sigma> v = put \<rho> v"
    shows "\<sigma> = \<rho>"
    by (metis assms get_put put_put)

 lemma put_eq:
   assumes "get \<sigma> = k" "put \<sigma> u = put \<rho> v"
   shows "put \<rho> k = \<sigma>"
   using assms weak_put_eq[of \<sigma> k u \<rho> v] by (simp)

  text \<open> @{term get} can be uniquely determined from @{term put} \<close>

  lemma get_via_put: "get s = (THE v. put s v = s)"
    by (simp add: weak_get_via_put)

  lemma get_surj: "surj get"
    by (metis put_get surjI)

  text \<open> Observation equivalence is an equivalence relation. \<close>

  lemma lens_obs_equiv: "equivp (\<simeq>)"
  proof (rule equivpI)
    show "reflp (\<simeq>)"
      by (rule reflpI, simp add: lens_obs_eq_def get_put)
    show "symp (\<simeq>)"
      by (rule sympI, simp add: lens_obs_eq_def, metis get_put put_put)
    show "transp (\<simeq>)"
      by (rule transpI, simp add: lens_obs_eq_def, metis put_put)
  qed

end

abbreviation (input) "total_lens \<equiv> vwb_lens"

lemma vwb_lens_wb [simp]: "vwb_lens x \<Longrightarrow> wb_lens x"
  by (simp add: vwb_lens_def)

lemma vwb_lens_mwb [simp]: "vwb_lens x \<Longrightarrow> mwb_lens x"
  using vwb_lens_def by auto

lemma mwb_UNIV_src_is_vwb_lens:
  "\<lbrakk> mwb_lens X; \<S>\<^bsub>X\<^esub> = UNIV \<rbrakk> \<Longrightarrow> vwb_lens X"
  using vwb_lens_def wb_lens_axioms_def wb_lens_def by fastforce

text \<open> Alternative characterisation: a very well-behaved (i.e. total) lens is a mainly well-behaved
  (i.e. partial) lens whose source is the universe set. \<close>

lemma vwb_lens_iff_mwb_UNIV_src:
  "vwb_lens X \<longleftrightarrow> (mwb_lens X \<and> \<S>\<^bsub>X\<^esub> = UNIV)"
  by (meson mwb_UNIV_src_is_vwb_lens vwb_lens_def wb_lens.source_UNIV)

subsection \<open> Ineffectual Lenses \<close>

text \<open>Ineffectual lenses can have no effect on the view type -- application of the $\lput$ function
  always yields the same source. They are thus, trivially, very well-behaved lenses.\<close>

locale ief_lens = weak_lens +
  assumes put_inef: "put \<sigma> v = \<sigma>"
begin

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: put_inef)
  show "put (put \<sigma> v) u = put \<sigma> u"
    by (simp add: put_inef)
qed

lemma ineffectual_const_get:
  "\<exists> v.  \<forall> \<sigma>\<in>\<S>. get \<sigma> = v"
  using put_get put_inef by auto

end

abbreviation "eff_lens X \<equiv> (weak_lens X \<and> (\<not> ief_lens X))"

subsection \<open> Partially Bijective Lenses \<close>

locale pbij_lens = weak_lens +
  assumes put_det: "put \<sigma> v = put \<rho> v"
begin

  sublocale mwb_lens
  proof
    fix \<sigma> v u
    show "put (put \<sigma> v) u = put \<sigma> u"
      using put_det by blast
  qed

  lemma partial_get_put: "\<rho> \<in> \<S> \<Longrightarrow> put \<sigma> (get \<rho>) = \<rho>"
    by (metis put_det weak_get_put)

end

lemma pbij_lens_weak [simp]:
  "pbij_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: pbij_lens_def)

lemma pbij_lens_mwb [simp]: "pbij_lens x \<Longrightarrow> mwb_lens x"
  by (simp add: mwb_lens_axioms.intro mwb_lens_def pbij_lens.put_is_create)

lemma pbij_alt_intro:
  "\<lbrakk> weak_lens X; \<And> s. s \<in> \<S>\<^bsub>X\<^esub> \<Longrightarrow> create\<^bsub>X\<^esub> (get\<^bsub>X\<^esub> s) = s \<rbrakk> \<Longrightarrow> pbij_lens X"
  by (metis pbij_lens_axioms_def pbij_lens_def weak_lens.put_closure weak_lens.put_get)

subsection \<open> Bijective Lenses \<close>

text \<open>Bijective lenses characterise the situation where the source and view type are equivalent:
  in other words the view type full characterises the whole source type. It is often useful
  when the view type and source type are syntactically different, but nevertheless correspond
  precisely in terms of what they observe. Bijective lenses are formulates using
  the strong GetPut law~\cite{Foster09,Fischer2015}.\<close>

locale bij_lens = weak_lens +
  assumes strong_get_put: "put \<sigma> (get \<rho>) = \<rho>"
begin

sublocale pbij_lens
proof
  fix \<sigma> v \<rho>
  show "put \<sigma> v = put \<rho> v"
    by (metis put_get strong_get_put)
qed

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: strong_get_put)
qed

  lemma put_bij: "bij_betw (put \<sigma>) UNIV UNIV"
    by (metis bijI put_inj strong_get_put surj_def)

  lemma get_create: "create (get \<sigma>) = \<sigma>"
    by (simp add: lens_create_def strong_get_put)

end

declare bij_lens.strong_get_put [simp]
declare bij_lens.get_create [simp]

lemma bij_lens_weak [simp]:
  "bij_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: bij_lens_def)

lemma bij_lens_pbij [simp]:
  "bij_lens x \<Longrightarrow> pbij_lens x"
  by (metis bij_lens.get_create bij_lens_def pbij_lens_axioms.intro pbij_lens_def weak_lens.put_get)

lemma bij_lens_vwb [simp]: "bij_lens x \<Longrightarrow> vwb_lens x"
  by (metis bij_lens.strong_get_put bij_lens_weak mwb_lens.intro mwb_lens_axioms.intro vwb_lens_def wb_lens.intro wb_lens_axioms.intro weak_lens.put_get)

text \<open> Alternative characterisation: a bijective lens is a partial bijective lens that is also
  very well-behaved (i.e. total). \<close>

lemma pbij_vwb_is_bij_lens:
  "\<lbrakk> pbij_lens X; vwb_lens X \<rbrakk> \<Longrightarrow> bij_lens X"
  by (unfold_locales, simp_all, meson pbij_lens.put_det vwb_lens.put_eq)

lemma bij_lens_iff_pbij_vwb:
  "bij_lens X \<longleftrightarrow> (pbij_lens X \<and> vwb_lens X)"
  using pbij_vwb_is_bij_lens by auto

subsection \<open>Lens Independence\<close>

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Independence}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Independence}
  \label{fig:Indep}
  \end{figure}

  Lens independence shows when two lenses $X$ and $Y$ characterise disjoint regions of the
  source type, as illustrated in Figure~\ref{fig:Indep}. We specify this by requiring that the $\lput$
  functions of the two lenses commute, and that the $\lget$ function of each lens is unaffected by
  application of $\lput$ from the corresponding lens. \<close>

locale lens_indep =
  fixes X :: "'a \<Longrightarrow> 'c" and Y :: "'b \<Longrightarrow> 'c"
  assumes lens_put_comm: "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<sigma> v) u = put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> u) v"
  and lens_put_irr1: "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<sigma> v) = get\<^bsub>X\<^esub> \<sigma>"
  and lens_put_irr2: "get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> u) = get\<^bsub>Y\<^esub> \<sigma>"

notation lens_indep (infix "\<bowtie>" 50)

lemma lens_indepI:
  "\<lbrakk> \<And> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v;
     \<And> v \<sigma>. get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) = get\<^bsub>x\<^esub> \<sigma>;
     \<And> u \<sigma>. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) = get\<^bsub>y\<^esub> \<sigma> \<rbrakk> \<Longrightarrow> x \<bowtie> y"
  by (simp add: lens_indep_def)

text \<open>Lens independence is symmetric.\<close>

lemma lens_indep_sym:  "x \<bowtie> y \<Longrightarrow> y \<bowtie> x"
  by (simp add: lens_indep_def)

lemma lens_indep_comm:
  "x \<bowtie> y \<Longrightarrow> put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
  by (simp add: lens_indep_def)

lemma lens_indep_get [simp]:
  assumes "x \<bowtie> y"
  shows "get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) = get\<^bsub>x\<^esub> \<sigma>"
  using assms lens_indep_def by fastforce

text \<open> Characterisation of independence for two very well-behaved lenses \<close>

lemma lens_indep_vwb_iff:
  assumes "vwb_lens x" "vwb_lens y"
  shows "x \<bowtie> y \<longleftrightarrow> (\<forall> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v)"
proof
  assume "x \<bowtie> y"
  thus "\<forall> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
    by (simp add: lens_indep_comm)
next
  assume a: "\<forall> u v \<sigma>. put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
  show "x \<bowtie> y"
  proof (unfold_locales)
    fix \<sigma> v u
    from a show "put\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) u = put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) v"
      by auto
    show "get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> \<sigma> v) = get\<^bsub>x\<^esub> \<sigma>"
      by (metis a assms(1) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
    show "get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> \<sigma> u) = get\<^bsub>y\<^esub> \<sigma>"
      by (metis a assms(2) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
  qed
qed

subsection \<open> Lens Compatibility \<close>

text \<open> Lens compatibility is a weaker notion than independence. It allows that two lenses can overlap
  so long as they manipulate the source in the same way in that region. It is most easily defined
  in terms of a function for copying a region from one source to another using a lens. \<close>

definition lens_compat (infix "##\<^sub>L" 50) where
[lens_defs]: "lens_compat X Y = (\<forall>s\<^sub>1 s\<^sub>2. s\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> s\<^sub>2 \<triangleleft>\<^bsub>Y\<^esub> s\<^sub>2 = s\<^sub>1 \<triangleleft>\<^bsub>Y\<^esub> s\<^sub>2 \<triangleleft>\<^bsub>X\<^esub> s\<^sub>2)"

lemma lens_compat_idem [simp]: "x ##\<^sub>L x"
  by (simp add: lens_defs)

lemma lens_compat_sym: "x ##\<^sub>L y \<Longrightarrow> y ##\<^sub>L x"
  by (simp add: lens_defs)

lemma lens_indep_compat [simp]: "x \<bowtie> y \<Longrightarrow> x ##\<^sub>L y"
  by (simp add: lens_override_def lens_compat_def lens_indep_comm)

end


theory BW2

imports "HOL-Word.Word_Bitwise"

begin

text \<open>
Facts about the "carry" value. The carry object for x and y
is, at every bit position, the value that would have been
carried in during an addition of x and y. This can be used
to rewrite additions and inequalities to factor out the
components that move between bit positions.
\<close>

definition
  carry_val :: "('a :: {bit_operations, plus, zero, one}) \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a"
  where
  "carry_val x y c = (x + y + (if c then 1 else 0)) XOR (x XOR y)"

(* easy enough to define, no idea how to prove anything about it *)

text \<open>
Upgrade of the existing Word_Bitwise conversion to booleans.

The main change is, the whole mechanism now permits sharing of
repeated terms using let bindings. Values of word type may be
let bound in input problems. The core tactic produces let
bindings of shared boolean values. A final step can discard
them (compatibility with previous version) or lift them to
fresh meta-bound variables. The latter form seems to be quite
compatible with the Argo solver.
\<close>

lemma rbl_word_if_let: "rev (to_bl (if P then x else y)) =
    (let c = P in map2 (If c) (rev (to_bl x)) (rev (to_bl y)))"
  by (simp add: Product_Type.split_def)

fun carry_chain :: "(bool * bool) list \<Rightarrow> bool \<Rightarrow> bool list"
  where
    "carry_chain [] x = []"
  | "carry_chain (x # xs) y = y # carry_chain xs (carry (fst x) (snd x) y)"

lemma length_carry_chain[simp]:
  "length (carry_chain xs c) = length xs"
  by (induct xs arbitrary: c, simp_all)

lemma carry_chain_eq_Nil[simp]:
  "(carry_chain xs c = []) = (xs = [])"
  by (cases xs, simp_all)

definition carry_word :: "('a :: len) word \<Rightarrow> 'a word \<Rightarrow> bool \<Rightarrow> 'a word"
  where
  "carry_word x y c = of_bl (rev (carry_chain (zip (rev (to_bl x)) (rev (to_bl y))) c))"

lemma rbl_plus_carry_chain:
  "length xs = length ys \<Longrightarrow>
    rbl_plus c xs ys = map (\<lambda>(c, (x, y)). xor3 x y c)
        (zip (carry_chain (zip xs ys) c) (zip xs ys))"
  by (induct arbitrary: c rule: list_induct2, simp_all add: rbl_plus_simps)

lemma carry_word_eq_xor:
  "carry_word x y False = ((x + y) XOR x XOR y)"
  apply (simp only: word_eq_rbl_eq Let_def rbl_word_plus rbl_word_xor)
  apply (simp add: rbl_plus_carry_chain carry_word_def)
  apply (rule nth_equalityI, simp_all)
  apply (simp add: nth_rev xor3_def word_bl.Abs_inverse)
  apply blast
  done

(* the silly cw AND cw part is to stop the let_alt simproc removing the let-binding *)
lemma word_plus_carry_chain:
  fixes x :: "('a :: len) word"
  shows "x + y = (let xnm = x; ynm = y; cw = carry_word xnm ynm False in (xnm XOR ynm) XOR (cw AND cw))"
  apply (simp add: Let_def carry_word_eq_xor)
  apply (simp add: word_eq_iff word_ops_nth_size word_size)
  apply blast
  done

lemmas word_minus_carry_chain = HOL.trans[OF diff_conv_add_uminus word_plus_carry_chain]

lemma rev_bl_order_carry_chain:
  "length xs = length ys \<Longrightarrow>
    rev_bl_order F xs ys = (if xs = [] then F else
        carry (\<not> (last (carry_chain (zip xs (map Not ys)) (\<not> F)))) (\<not> (last xs)) (last ys))"
  apply (induct arbitrary: F rule: list_induct2)
   apply (simp_all add: rev_bl_order_simps zip_eq_Nil_iff)
  apply (intro impI conjI, simp_all)
   apply (simp add: carry_def)
   apply blast
  apply (rule arg_cong[where f="\<lambda>x. carry x _ _"])
  apply simp
  apply (rule arg_cong[where f="last"])
  apply (rule arg_cong[where f="carry_chain _"])
  apply (simp add: carry_def)
  apply blast
  done

lemma rev_bl_order_to_bl_carry_chain:
  fixes x :: "('a :: len) word"
  shows "rev_bl_order F (rev (to_bl x)) (rev (to_bl y)) =
    carry (\<not> msb (carry_word x (NOT y) (\<not> F))) (\<not> msb x) (msb y)"
  apply (simp add: rev_bl_order_carry_chain last_rev word_msb_alt)
  apply (simp add: hd_rev[symmetric] zip_eq_Nil_iff Let_def)
  apply (simp add: carry_word_def word_bl.Abs_inverse bl_word_not rev_map hd_map)
  done

(* the silly cw AND cw part is to stop the let_alt simproc removing the let-binding *)
lemma word_le_carry_chain:
  fixes x :: "('a :: len) word"
  shows "(x \<le> y) = (let xnm = x; ynm = NOT y; cw = carry_word xnm ynm False in
    carry (~ msb (cw AND cw)) (~ msb xnm) (~ msb ynm))"
  by (simp add: word_le_rbl rev_bl_order_to_bl_carry_chain Let_def word_ops_msb)

lemmas word_less_carry_chain = word_le_carry_chain[THEN arg_cong[where f=Not],
    simplified linorder_not_le]

lemma map_last_flip_to_xor:
  fixes x :: "('a :: len) word"
  shows "map_last Not (rev (to_bl x)) = rev (to_bl (x XOR (1 << (size x - 1))))"
  apply (rule nth_equalityI, simp_all add: word_size map_last_def)
  apply (simp add: nth_append nth_rev to_bl_nth nth_tl word_size word_ops_nth_size)
  apply (simp add: nth_shiftl last_conv_nth rev_nth to_bl_nth flip: shiftl_1)
  apply (intro conjI impI arg_cong2[where f="test_bit"], simp_all add: word_size)
  done

lemma word_sle_xor_eq_le[simplified word_size]:
  "(x <=s y) = (x XOR (1 << (size x - 1)) \<le> y XOR (1 << (size x - 1)))"
  by (simp add: word_sle_rbl word_le_rbl map_last_flip_to_xor word_size)

lemma word_sless_xor_eq_le[simplified word_size]:
  "(x <s y) = (x XOR (1 << (size x - 1)) < y XOR (1 << (size x - 1)))"
  by (simp add: word_sless_rbl word_less_rbl map_last_flip_to_xor word_size)

lemma minus_one_nat_case:
  "(n - 1) = (case n of 0 \<Rightarrow> 0 | Suc j \<Rightarrow> j)"
  by (simp split: nat.split)

lemma carry_chain_nth:
  "i < length xs \<Longrightarrow> nth (carry_chain xs F) i = (case i of 0 \<Rightarrow> F | Suc j \<Rightarrow>
    carry (fst (nth xs j)) (snd (nth xs j)) (nth (carry_chain xs F) j))"
proof (induct i arbitrary: F xs)
  case 0
  then show ?case
    by (cases xs; simp)
next
  case (Suc i)
  from Suc.prems show ?case
    apply (cases xs; simp)
    apply (simp add: Suc.hyps)
    apply (simp split: nat.split)
    done
qed

lemma carry_word_nth:
  fixes x :: "('a :: len) word"
  shows "i < LENGTH ('a) \<Longrightarrow>
    test_bit (carry_word x y F) i = (case i of 0 \<Rightarrow> F | Suc j \<Rightarrow> carry (test_bit x j) (test_bit y j)
        (test_bit (carry_word x y F) j))"
  apply (simp add: carry_word_def test_bit_of_bl carry_chain_nth)
  apply (simp add: test_bit_bl word_size carry_word_def split: nat.split)
  apply (simp add: word_bl.Abs_inverse)
  done

lemma carry_word_eq_eq:
  fixes x :: "('a :: len) word"
  shows "(carry_word x y F = z) = (\<forall>i \<in> set (upt 0 (LENGTH ('a))).
    (case i of 0 \<Rightarrow> F | Suc j \<Rightarrow> carry (test_bit x j) (test_bit y j) (test_bit z j)) = test_bit z i)"
  apply (rule iffI)
   apply (clarsimp simp: carry_word_nth)
  apply (simp add: word_eq_iff Ball_def)
  apply (rule allI, induct_tac n)
   apply (intro impI, drule spec, drule(1) mp)
   apply (simp add: carry_word_nth)
  apply (intro impI, drule spec, drule(1) mp)
  apply (simp add: carry_word_nth[where i="Suc _"])
  done

lemma upt_Suc_left:
  "upt (Suc i) j = (if j = 0 then [] else map Suc (upt i (j - 1)))"
  by (cases j, simp_all add: map_Suc_upt)

lemma carry_word_eq_rbl:
  fixes x :: "('a :: len) word"
  shows "(carry_word x y F = z) = (F = test_bit z 0 \<and> (\<forall>(i, (xb, yb)) \<in> set (zip (upt 1 (LENGTH ('a)))
        (zip (rev (to_bl x)) (rev (to_bl y)))).
    carry xb yb (test_bit z (case i of 0 \<Rightarrow> 0 | Suc j \<Rightarrow> j)) = test_bit z i))"
  apply (simp only: carry_word_eq_eq)
  apply (subst upt_rec[where i=0])
  apply (simp add: upt_Suc_left del: set_upt)
  apply (simp add: all_set_conv_all_nth, simp add: Ball_def)
  apply (intro conj_cong arg_cong[where f=All] ext imp_cong refl)
  apply (frule order_less_le_trans[OF _ diff_le_self])
  apply (simp add: test_bit_bl word_size)
  done

lemma word_if_add_let:
  "(if P then (x :: ('a :: len0) word) else y) = (let switch = P in id If switch x y)"
  by simp

lemma rbl_plus_simp_let:
  "rbl_plus cin (x # xs) (y # ys) =
    xor3 x y cin # (let c = carry x y cin in rbl_plus c xs ys)"
  by (simp add: rbl_plus_def)

lemma rev_bl_order_simp_let:
  "rev_bl_order F (x # xs) (y # ys) =
    (let xv = x; yv = y in rev_bl_order ((yv \<and> \<not> xv) \<or> ((yv \<or> \<not> xv) \<and> F)) xs ys)"
  by (simp add: rev_bl_order_simps)

lemma let_cons_expand:
  "(let xs = b # bs in f xs) = (let hd_x = b; tl_xs = bs in f (hd_x # tl_xs))"
  by simp

lemma let_word_rbl:
  "(let x = w in f x) = (let bs = rev (to_bl w) in f (of_bl (rev bs)))"
  by simp

lemma let_reassoc:
  "(let x = (let y = vy in f y) in g x) = (let y = vy; x = f y in g x)"
  by simp

lemma rev_to_bl_of_bl[OF refl, simplified word_size]:
  "w = of_bl xs \<Longrightarrow> rev (to_bl w) = takefill False (size w) (rev xs)"
  by (simp add: word_rev_tf word_size)

lemma lift_let:
  "f (let x = v in g x) = (let x = v in f (g x))"
  by simp

lemmas lift_let_binop = lift_let[where f="\<lambda>x. f x y" for f y] lift_let[where f="f x" for f x]

lemma takefill_last_empty_let:
  "takefill_last z n [] = (let bit = z in replicate n bit)"
  by (simp add: takefill_last_simps)

lemmas takefill_last_simps2 = takefill_last_simps(1-2) takefill_last_empty_let

lemma rbl_succ2_simp_let:
  "rbl_succ2 b (x # xs) = (b \<noteq> x) # (let c = x \<and> b in rbl_succ2 c xs)"
  by (simp_all add: rbl_succ2_def)

lemmas rbl_succ2_simps2 = rbl_succ2_simps(1) rbl_succ2_simp_let

lemmas bitwise_let_lifts =
    lift_let[where f="case_prod f" for f]
    lift_let[where f="case_list y f" for y f]
    lift_let_binop[where f="(=)"]
    lift_let[where f="map f" for f]
    lift_let_binop[where f="zip"]
    lift_let[where f="drop n" for n]
    lift_let[where f="foldr f" for f]
    lift_let[where f="takefill f n" for f n]
    lift_let[where f="drop_nonempty v n" for v n]
    lift_let_binop[where f="rev_bl_order f" for f]
    lift_let_binop[where f="list_all2 f" for f]
    lift_let[where f="rbl_succ2 x" for x]
    lift_let_binop[where f="rbl_plus cin" for cin]
    lift_let_binop[where f="append"]
    lift_let[where f="takefill_last z n" for z n]

lemmas logic_let_lifts =
    lift_let_binop[where f="(\<longrightarrow>)"]
    lift_let_binop[where f="(\<and>)"]
    lift_let_binop[where f="(\<or>)"]
    lift_let_binop[where f="(=)"]
    lift_let[where f="Not"]

lemmas imp_to_id = id_apply[where x="(\<longrightarrow>)", THEN fun_cong, THEN fun_cong, symmetric]

lemma let_eqI:
  "(\<And>x. v = x \<Longrightarrow> f x) \<Longrightarrow> let x = v in f x"
  by simp

lemma let_eq_impI:
  "(\<And>x. v = x \<longrightarrow> P x) \<Longrightarrow> let x = v in P x"
  by simp

ML \<open>
structure Let_Alt = struct

fun is_atom (_ $ _) = false
  | is_atom (Abs _) = false
  | is_atom _ = true

val def = @{thm Let_def}

fun count_bv i (Bound j) = if i = j then 1 else 0
  | count_bv i (f $ x) = count_bv i f + count_bv i x
  | count_bv i (Abs (_, _, t)) = count_bv (i + 1) t
  | count_bv _ _ = 0

fun simproc count ct = case strip_comb (Thm.term_of ct) of
    (_, [v, Abs (_, _, t)]) => if is_atom v then SOME def
    else if count andalso count_bv 0 t <= 1 then SOME def
    else NONE
  | (_, [_, _]) => SOME def
  | _ => NONE

fun has_bv (Bound _) = true
  | has_bv (Abs _) = true
  | has_bv (f $ x) = has_bv f orelse has_bv x
  | has_bv _ = false

fun count_no_bv (t :: ts) tab = let
    val ts = case t of
        f $ x => f :: x :: ts
      | Abs (_, _, t) => t :: ts
      | _ => ts
    val tab = if has_bv t then tab
        else Termtab.map_default (t, 0) (fn i => i + 1) tab
  in count_no_bv ts tab end
  | count_no_bv [] tab = tab

val sym_def = @{thm Let_def[symmetric]}

fun add_let_conv ctxt nm x ct = let
    val abs = Thm.lambda_name (nm, x) ct
  in Drule.infer_instantiate ctxt [(("f", 0), abs), (("s", 0), x)] sym_def end

fun let_gather_dup_conv_1 ctxt f ct = let
    val count = count_no_bv [Thm.term_of ct] Termtab.empty
    val xs = Termtab.dest count
      |> filter (fn (_, j) => j >= 2)
      |> map fst
      |> filter (not o is_atom)
      |> filter f
    fun get_greatest [] t _ = t
      | get_greatest (x :: xs) t sz = if size_of_term x > sz
        then get_greatest xs x (size_of_term x)
        else get_greatest xs t sz
    fun get_greatest2 xs = get_greatest (tl xs) (hd xs) (size_of_term (hd xs))
  in if null xs then Conv.no_conv ct
    else add_let_conv ctxt "x" (Thm.cterm_of ctxt (get_greatest2 xs)) ct
  end

fun let_gather_dup_conv ctxt f = Conv.repeat_conv (let_gather_dup_conv_1 ctxt f)

fun let_gather_dup_tac ctxt f = CONVERSION
    (Conv.params_conv ~1 (fn ctxt => Conv.concl_conv ~1 (Conv.arg_conv
        (let_gather_dup_conv ctxt f))) ctxt)

fun abs_name (Abs (nm, _, _)) = nm
  | abs_name _ = "x"

fun find_let ((t as (Const (@{const_name Let}, _) $ v $ f)) :: _) = SOME (abs_name f, v, t)
  | find_let (f $ x :: xs) = find_let (f :: x :: xs)
  | find_let (_ :: xs) = find_let xs
  | find_let [] = NONE

fun let_atom_conv1 ct = case Thm.term_of ct of
  (Const (@{const_name Let}, _) $ x $ _) =>
    if is_atom x then Conv.rewr_conv @{thm Let_def} ct
    else Conv.no_conv ct
  | _ => Conv.no_conv ct

fun let_atom_conv ctxt = Conv.top_conv (K (Conv.try_conv let_atom_conv1)) ctxt

fun let_to_top_conv ctxt ct = case Thm.term_of ct of
    Const (@{const_name Let}, _) $ _ $ Abs _ =>
    Conv.arg_conv (Conv.abs_conv (let_to_top_conv o snd) ctxt) ct
  | t => (case find_let [t] of
    NONE => Conv.all_conv ct
  | SOME (nm, v, _) => Conv.every_conv [add_let_conv ctxt nm (Thm.cterm_of ctxt v),
    let_atom_conv ctxt, let_to_top_conv ctxt] ct
  )

fun let_to_top_tac ctxt = CONVERSION
    (Conv.params_conv ~1 (fn ctxt => Conv.concl_conv ~1 (Conv.arg_conv
        (let_to_top_conv ctxt))) ctxt)

end
\<close>

simproc_setup let_alt ("Let v f") = \<open>K (K (Let_Alt.simproc true))\<close>
declare [[simproc del: let_alt]]
simproc_setup let_atom ("Let v f") = \<open>K (K (Let_Alt.simproc false))\<close>
declare [[simproc del: let_atom]]

ML \<open>
structure BW_Alt = struct

open Word_Bitwise_Tac

val no_split_ss =
  simpset_of (put_simpset HOL_ss \<^context>
        delsimprocs [@{simproc let_simp}]
    |> Splitter.del_split @{thm if_split});

val init_ss = simpset_of (put_simpset HOL_basic_ss \<^context> addsimps
   @{thms word_eq_rbl_eq word_le_carry_chain word_less_carry_chain
        word_sle_xor_eq_le word_sless_xor_eq_le})

val expand_word_eq_sss = map simpset_of [
   put_simpset no_split_ss \<^context> addsimps
    @{thms rbl_word_plus rbl_word_and rbl_word_or rbl_word_not
                                rbl_word_neg bl_word_sub rbl_word_xor
                                rbl_word_cat rbl_word_slice rbl_word_scast
                                rbl_word_ucast rbl_shiftl rbl_shiftr rbl_sshiftr
                                rbl_word_if_let lift_let[where f=to_bl]
                                lift_let[where f=rev]
                                rev_to_bl_of_bl rev_rev_ident},
   put_simpset no_split_ss \<^context> addsimps
    @{thms to_bl_numeral to_bl_neg_numeral to_bl_0 rbl_word_1},
   put_simpset no_split_ss \<^context> addsimps
    @{thms rev_rev_ident rev_replicate rev_map to_bl_upt word_size minus_one_nat_case}
          addsimprocs [word_len_simproc],
   put_simpset no_split_ss \<^context> addsimps
    @{thms split_conv replicate.simps list.simps
                                zip_Cons_Cons zip_Nil drop_Suc_Cons drop_0 drop_Nil
                                foldr.simps zip.simps(1) takefill_Suc_Cons
                                takefill_Suc_Nil takefill.Z rbl_succ2_simps2
                                rbl_plus_simp_let rbl_plus_simps(2-)
                                rev_bin_to_bl_simps append.simps
                                takefill_last_simps2 drop_nonempty_simps
                                rev_bl_order_simp_let rev_bl_order_simps(1)
                                bitwise_let_lifts let_cons_expand
                                ball_simps nat.simps
                                let_reassoc[where f="_ :: _ \<Rightarrow> _ list" for f]
                                Let_def[where f="\<lambda>_. []"]}
          addsimprocs [expand_upt_simproc,
                       @{simproc let_atom},
                       nat_get_Suc_simproc 1
                         [\<^term>\<open>replicate\<close>, \<^term>\<open>takefill x\<close>,
                          \<^term>\<open>drop\<close>, \<^term>\<open>bin_to_bl\<close>,
                          \<^term>\<open>takefill_last x\<close>,
                          \<^term>\<open>drop_nonempty x\<close>,
                          @{term \<open>nat.case_nat x y\<close>}]],
    put_simpset no_split_ss \<^context> addsimps @{thms xor3_simps carry_simps if_bool_simps
            Let_def[where s=True] Let_def[where s=False] One_nat_def id_apply}
        addsimprocs [@{simproc let_alt}]
  ]

val is_word = can Word_Lib.dest_wordT o fastype_of

fun rev_mp_prems_tac pred ctxt = SUBGOAL (fn (t, i) => let
    val prems = Logic.strip_assums_hyp t
    val idx = find_index (fn t => can HOLogic.dest_Trueprop t andalso pred t) prems
  in
    if idx = ~1 then all_tac
    else EVERY' [rotate_tac idx, eresolve_tac ctxt @{thms rev_mp}, rotate_tac (~ idx),
        rev_mp_prems_tac pred ctxt] i
  end)

fun let_to_imp_step ctxt = FIRST'
  [resolve_tac ctxt @{thms let_eq_impI},
   CHANGED o Let_Alt.let_to_top_tac ctxt,
   CHANGED o Let_Alt.let_gather_dup_tac ctxt is_word]

fun let_to_imp_tac ctxt = TRY o REPEAT_ALL_NEW (let_to_imp_step ctxt)

fun core_tacs ctxt = [
    (CHANGED o safe_full_simp_tac (put_simpset init_ss ctxt addsimprocs [@{simproc let_alt}])),
    rev_mp_prems_tac (exists_Const (fn (s, _) =>
        s = @{const_name to_bl} orelse s = @{const_name carry_word})) ctxt,
    safe_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
        @{thms word_plus_carry_chain word_minus_carry_chain word_if_add_let}),
    let_to_imp_tac ctxt,
    safe_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
        @{thms id_apply carry_word_eq_rbl msb_nth word_bw_same}),
    safe_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms imp_to_id}),
    safe_simp_tac (put_simpset init_ss ctxt)] @
    map (fn ss => safe_simp_tac (put_simpset ss ctxt)) expand_word_eq_sss

fun core_tac ctxt = foldr1 (op THEN_ALL_NEW) (core_tacs ctxt)

fun expand_tac ctxt = core_tac ctxt
    THEN_ALL_NEW safe_full_simp_tac
        (put_simpset no_split_ss ctxt addsimps @{thms Let_def})

fun lift_tac ctxt = core_tac ctxt
    THEN_ALL_NEW simp_tac
        (put_simpset HOL_basic_ss ctxt addsimps @{thms logic_let_lifts})
    THEN_ALL_NEW (TRY o DETERM o REPEAT_ALL_NEW (resolve_tac ctxt @{thms let_eqI}))

end
\<close>

method_setup let_dup_word =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (Let_Alt.let_gather_dup_tac ctxt BW_Alt.is_word 1))\<close>
  "gather repeated word terms using let-binding"

method_setup word_bitwise =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (BW_Alt.expand_tac ctxt 1))\<close>
  "decomposer for word equalities and inequalities into bit propositions"

method_setup word_bitwise_eq =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (BW_Alt.lift_tac ctxt 1))\<close>
  "decomposer for word equalities and inequalities into bit propositions,
    lifting shared booleans to variables"

lemma test_bit_is_slice_check:
  fixes x :: "('a :: len) word"
  shows "test_bit x n = (Word.slice n x = (1 :: 1 word))"
  by (simp add: word_eq_iff nth_slice)

lemma word_set_bit_to_smt:
  fixes x :: "('a :: len0) word"
  shows
  "set_bit x n b = (x AND NOT (Bits.shiftl 1 n)) OR (Bits.shiftl (if b then 1 else 0) n)"
  by (auto simp: word_eq_iff test_bit_set_gen word_ops_nth_size nth_shiftl word_size)

lemma slice_up_is_ucast[OF refl, unfolded word_size]:
  "y = ucast (Bits.shiftr x n) \<Longrightarrow> size x < size y + n \<Longrightarrow> Word.slice n x = y"
  by (simp add: slice_shiftr)

lemma cast_down_is_slice[OF refl, unfolded word_size]:
  "y = Word.slice 0 x \<Longrightarrow>
    size y < size x \<Longrightarrow>
    ucast x = y \<and> scast x = y"
  by (simp add: ucast_slice down_cast_same[symmetric] word_size
    is_down_def source_size_def target_size_def)

named_theorems to_smt_word

lemmas to_smt_word_init[to_smt_word] = test_bit_is_slice_check
    word_set_bit_to_smt
    max_word_def mask_def
    slice_up_is_ucast[unfolded word_size] cast_down_is_slice
    One_nat_def[symmetric]

named_theorems to_smt_word_del
lemmas to_smt_word_del_init[to_smt_word_del] = One_nat_def[to_smt_word_del]

ML \<open>
fun smt_word_tac ctxt = BW_Alt.let_to_imp_tac ctxt
    THEN' full_simp_tac (ctxt
    addsimps Named_Theorems.get ctxt @{named_theorems to_smt_word}
    delsimps Named_Theorems.get ctxt @{named_theorems to_smt_word_del}
    |> Splitter.del_split @{thm if_split})
    THEN' SMT_Solver.smt_tac (ctxt
        |> Config.put SMT_Systems.z3_extensions true
        |> Config.put SMT_Config.oracle true
        |> Config.put SMT_Config.statistics true
) []
\<close>

method_setup smt_word =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (smt_word_tac ctxt 1))\<close>
  "wrapper for oracle-based word/bitvector SMT proofs"

end


theory Arity
imports "../Launchbury/HOLCF-Join-Classes" Lifting
begin

typedef Arity = "UNIV :: nat set"
  morphisms Rep_Arity to_Arity by auto

setup_lifting type_definition_Arity

(*
instantiation Arity :: order
begin
lift_definition less_eq_Arity :: "Arity \<Rightarrow> Arity \<Rightarrow> bool" is "\<lambda> x y . x \<le> y".
lift_definition less_Arity :: "Arity \<Rightarrow> Arity \<Rightarrow> bool" is "\<lambda> x y . x < y".
instance
  apply standard
  apply (transfer, fastforce)+
  done
end
*)

instantiation Arity :: po
begin
lift_definition below_Arity :: "Arity \<Rightarrow> Arity \<Rightarrow> bool" is "\<lambda> x y . y \<le> x".

instance
apply standard
apply ((transfer, auto)+)
done
end

instance Arity :: chfin
proof
  fix S  :: "nat \<Rightarrow> Arity"
  assume "chain S"
  have "LeastM Rep_Arity (\<lambda>x. x \<in> range S) \<in> range S"
    by (rule LeastM_natI) auto
  then obtain n where n: "S n = LeastM Rep_Arity (\<lambda>x. x \<in> range S)" by auto
  have "max_in_chain n S"
  proof(rule max_in_chainI)
    fix j
    assume "n \<le> j" hence "S n \<sqsubseteq> S j" using `chain S` by (metis chain_mono)
    also
    have "Rep_Arity (S n) \<le> Rep_Arity (S j)"
      unfolding n image_def
      by (metis (lifting, full_types) LeastM_nat_lemma UNIV_I mem_Collect_eq)
    hence "S j \<sqsubseteq> S n" by transfer
    finally
    show "S n = S j".
  qed
  thus "\<exists>n. max_in_chain n S"..
qed

instance Arity :: cpo ..

lift_definition inc_Arity :: "Arity \<Rightarrow> Arity" is Suc.
lift_definition pred_Arity :: "Arity \<Rightarrow> Arity" is "(\<lambda> x . x - 1)".

lemma inc_Arity_cont[simp]: "cont inc_Arity"
  apply (rule chfindom_monofun2cont)
  apply (rule monofunI)
  apply (transfer, simp)
  done

lemma pred_Arity_cont[simp]: "cont pred_Arity"
  apply (rule chfindom_monofun2cont)
  apply (rule monofunI)
  apply (transfer, simp)
  done

definition inc :: "Arity \<rightarrow> Arity" where
  "inc = (\<Lambda> x. inc_Arity x)"

definition pred :: "Arity \<rightarrow> Arity" where
  "pred = (\<Lambda> x. pred_Arity x)"

lemma inc_inj[simp]: "inc\<cdot>n = inc\<cdot>n' \<longleftrightarrow> n = n'"
  by (simp add: inc_def pred_def, transfer, simp)

lemma pred_inc[simp]: "pred\<cdot>(inc\<cdot>n) = n"
  by (simp add: inc_def pred_def, transfer, simp)

lemma inc_below_inc[simp]: "inc\<cdot>a \<sqsubseteq> inc\<cdot>b \<longleftrightarrow> a \<sqsubseteq> b"
  by (simp add: inc_def pred_def, transfer, simp)

lemma inc_below_below_pred[elim]:
  "inc\<cdot>a \<sqsubseteq> b \<Longrightarrow> a \<sqsubseteq> pred \<cdot> b"
  by (simp add: inc_def pred_def, transfer, simp)

lemma Rep_Arity_inc[simp]: "Rep_Arity (inc\<cdot>a') = Suc (Rep_Arity a')"
  by (simp add: inc_def pred_def, transfer, simp)

instantiation Arity :: zero
begin
lift_definition zero_Arity :: Arity is 0.
instance..
end

instantiation Arity :: one
begin
lift_definition one_Arity :: Arity is 1.
instance ..
end

lemma one_is_inc_zero: "1 = inc\<cdot>0"
  by (simp add: inc_def, transfer, simp)

lemma inc_not_0[simp]: "inc\<cdot>n = 0 \<longleftrightarrow> False"
  by (simp add: inc_def pred_def, transfer, simp)

lemma pred_0[simp]: "pred\<cdot>0 = 0"
  by (simp add: inc_def pred_def, transfer, simp)

lemma Arity_ind:  "P 0 \<Longrightarrow> (\<And> n. P n \<Longrightarrow> P (inc\<cdot>n)) \<Longrightarrow> P n"
  apply (simp add: inc_def)
  apply transfer
  by (rule nat.induct)

lemma Arity_total:
  fixes x y :: Arity
  shows "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
by transfer auto

instance Arity :: Finite_Join_cpo
proof
  fix x y :: Arity
  show "compatible x y" by (metis Arity_total compatibleI)
qed

lemma Arity_zero_top[simp]: "(x :: Arity) \<sqsubseteq> 0"
  by transfer simp

lemma Arity_above_top[simp]: "0 \<sqsubseteq> (a :: Arity) \<longleftrightarrow> a = 0"
  by transfer simp

lemma Arity_zero_join[simp]: "(x :: Arity) \<squnion> 0 = 0"
  by transfer simp
lemma Arity_zero_join2[simp]: "0 \<squnion> (x :: Arity) = 0"
  by transfer simp

lemma Arity_up_zero_join[simp]: "(x :: Arity\<^sub>\<bottom>) \<squnion> up\<cdot>0 = up\<cdot>0"
  by (cases x) auto
lemma Arity_up_zero_join2[simp]: "up\<cdot>0 \<squnion> (x :: Arity\<^sub>\<bottom>) = up\<cdot>0"
  by (cases x) auto
lemma up_zero_top[simp]: "x \<sqsubseteq> up\<cdot>(0::Arity)"
  by (cases x) auto
lemma Arity_above_up_top[simp]: "up\<cdot>0 \<sqsubseteq> (a :: Arity\<^sub>\<bottom>) \<longleftrightarrow> a = up\<cdot>0"
  by (metis Arity_up_zero_join2 join_self_below(4))

lemma Arity_exhaust: "(y = 0 \<Longrightarrow> P) \<Longrightarrow> (\<And>x. y = inc \<cdot> x \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis Abs_cfun_inverse2 Arity.inc_def Rep_Arity_inverse inc_Arity.abs_eq inc_Arity_cont list_decode.cases zero_Arity_def)

end


(*
  File:     Symmetric_Polynomials_Code.thy
  Author:   Manuel Eberl (TU München)

  Code equations for symmetric polynomials (albeit not very efficient ones)
*)
section \<open>Executable Operations for Symmetric Polynomials\<close>
theory Symmetric_Polynomials_Code
  imports Symmetric_Polynomials "Polynomials.MPoly_Type_Class_FMap"
begin

(* TODO: Quite a few of these code equations should probably be moved to the Polynomials entry. *)

text \<open>
  Lastly, we shall provide some code equations to get executable code for operations related
  to symmetric polynomials, including, most notably, the fundamental theorem of symmetric
  polynomials and the recursive symmetry check.
\<close>

lemma Ball_subset_right:
  assumes "T \<subseteq> S" "\<forall>x\<in>S-T. P x"
  shows   "(\<forall>x\<in>S. P x) = (\<forall>x\<in>T. P x)"
  using assms by auto

(* This is a fairly simple theorem, but the automation somehow has a lot of problems with it *)
lemma compute_less_pp[code]:
  "xs < (ys :: 'a :: linorder \<Rightarrow>\<^sub>0 'b :: {zero, linorder}) \<longleftrightarrow>
    (\<exists>i\<in>keys xs \<union> keys ys. lookup xs i < lookup ys i \<and>
    (\<forall>j\<in>keys xs \<union> keys ys. j < i \<longrightarrow> lookup xs j = lookup ys j))"
proof transfer
  fix f g :: "'a \<Rightarrow> 'b"
  let ?dom = "{i. f i \<noteq> 0} \<union> {i. g i \<noteq> 0}"
  have "less_fun f g \<longleftrightarrow> (\<exists>k. f k < g k \<and> (\<forall>k'<k. f k' = g k'))"
    unfolding less_fun_def ..
  also have "\<dots> \<longleftrightarrow> (\<exists>i. f i < g i \<and> (i \<in> ?dom \<and> (\<forall>j\<in>?dom. j < i \<longrightarrow> f j = g j)))"
  proof (intro iff_exI conj_cong refl)
    fix k assume "f k < g k"
    hence k: "k \<in> ?dom" by auto
    have "(\<forall>k'<k. f k' = g k') = (\<forall>k'\<in>{..<k}. f k' = g k')"
      by auto
    also have "\<dots> \<longleftrightarrow> (\<forall>j\<in>({k. f k \<noteq> 0} \<union> {k. g k \<noteq> 0}) \<inter> {..<k}. f j = g j)"
      by (intro Ball_subset_right) auto
    also have "\<dots> \<longleftrightarrow> (\<forall>j\<in>({k. f k \<noteq> 0} \<union> {k. g k \<noteq> 0}). j < k \<longrightarrow> f j = g j)"
      by auto
    finally show "(\<forall>k'<k. f k' = g k') \<longleftrightarrow> k \<in> ?dom \<and> (\<forall>j\<in>?dom. j < k \<longrightarrow> f j = g j)"
      using k by simp
  qed
  also have "\<dots> \<longleftrightarrow> (\<exists>i\<in>?dom. f i < g i \<and> (\<forall>j\<in>?dom. j < i \<longrightarrow> f j = g j))"
    by (simp add: Bex_def conj_ac)
  finally show "less_fun f g \<longleftrightarrow> (\<exists>i\<in>?dom. f i < g i \<and> (\<forall>j\<in>?dom. j < i \<longrightarrow> f j = g j))" .
qed

lemma compute_le_pp[code]:
  "xs \<le> ys \<longleftrightarrow> xs = ys \<or> xs < (ys :: _ \<Rightarrow>\<^sub>0 _)"
  by (auto simp: order.order_iff_strict)

lemma vars_code [code]:
  "vars (MPoly p) = (\<Union>m\<in>keys p. keys m)"
  unfolding vars_def by transfer' simp

lemma mpoly_coeff_code [code]: "coeff (MPoly p) = lookup p"
  by transfer' simp

lemma sym_mpoly_code [code]:
  "sym_mpoly (set xs) k = (\<Sum>X\<in>Set.filter (\<lambda>X. card X = k) (Pow (set xs)). monom (monom_of_set X) 1)"
  by (simp add: sym_mpoly_altdef Set.filter_def)

lemma monom_of_set_code [code]:
  "monom_of_set (set xs) = Pm_fmap (fmap_of_list (map (\<lambda>x. (x, 1)) xs))"
    (is "?lhs = ?rhs")
proof (intro poly_mapping_eqI)
  fix k
  show "lookup ?lhs k = lookup ?rhs k"
    by (induction xs) (auto simp: lookup_monom_of_set fmlookup_default_def)
qed

lemma restrictpm_code [code]:
  "restrictpm A (Pm_fmap m) = Pm_fmap (fmrestrict_set A m)"
  by (intro poly_mapping_eqI) (auto simp: lookup_restrictpm fmlookup_default_def)

lemmas [code] = check_symmetric_mpoly_correct [symmetric]

notepad
begin
  define X Y Z :: "int mpoly" where "X = Var 1" "Y = Var 2" "Z = Var 3"
  define e1 e2 :: "int mpoly mpoly" where "e1 = Var 1" "e2 = Var 2"
  have "sym_mpoly {1, 2, 3} 2 = X * Y + X * Z + Y * Z"
    unfolding X_Y_Z_def by eval
  have "symmetric_mpoly {1, 2} (X ^ 3 + Y ^ 3)"
    unfolding X_Y_Z_def by eval
  have "fund_sym_poly_wit {1, 2} (X ^ 3 + Y ^ 3) = e1 ^ 3 - 3 * e1 * e2"
    unfolding X_Y_Z_def e1_e2_def by eval
end

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_51
  imports "../../Test_Base"
begin

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

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 z (nil2)) = nil2"
| "butlast (cons2 z (cons2 x2 x3)) =
     cons2 z (butlast (cons2 x2 x3))"

theorem property0 :
  "((butlast (x xs (cons2 y (nil2)))) = xs)"
  oops

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun ordered :: "int list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((z <= y2) & (ordered (cons2 y2 xs)))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 y =
   (case splitAt ((op div) ((2 * (length y)) + 1) 3) y of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
by pat_completeness auto

theorem property0 :
  "ordered (stoogesort2 xs)"
  oops

end


theory Lmap
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Llist"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

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

(*cohipster lmap lhd ltl*)
(* Discovered and proved in ca. 20 seconds*)
lemma lemma_a [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
  by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
  simp

lemma lemma_aa [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
 by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    simp

lemma lemma_ab [thy_expl]: "ltl (lmap y z) = lmap y (ltl z)"
 by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.case_eq_if Llist.collapse(2) Llist.inject lemma_aa lmap.disc_iff(2) lnull_def ltl_def)

end


section\<open>Main ZF Theory: Everything Except AC\<close>

theory ZF imports List_ZF IntDiv_ZF CardinalArith begin

(*The theory of "iterates" logically belongs to Nat, but can't go there because
  primrec isn't available into after Datatype.*)

subsection\<open>Iteration of the function @{term F}\<close>

consts  iterates :: "[i=>i,i,i] => i"   ("(_^_ '(_'))" [60,1000,1000] 60)

primrec
    "F^0 (x) = x"
    "F^(succ(n)) (x) = F(F^n (x))"

definition
  iterates_omega :: "[i=>i,i] => i" ("(_^\<omega> '(_'))" [60,1000] 60) where
    "F^\<omega> (x) == \<Union>n\<in>nat. F^n (x)"

lemma iterates_triv:
     "[| n\<in>nat;  F(x) = x |] ==> F^n (x) = x"
by (induct n rule: nat_induct, simp_all)

lemma iterates_type [TC]:
     "[| n \<in> nat;  a \<in> A; !!x. x \<in> A ==> F(x) \<in> A |]
      ==> F^n (a) \<in> A"
by (induct n rule: nat_induct, simp_all)

lemma iterates_omega_triv:
    "F(x) = x ==> F^\<omega> (x) = x"
by (simp add: iterates_omega_def iterates_triv)

lemma Ord_iterates [simp]:
     "[| n\<in>nat;  !!i. Ord(i) ==> Ord(F(i));  Ord(x) |]
      ==> Ord(F^n (x))"
by (induct n rule: nat_induct, simp_all)

lemma iterates_commute: "n \<in> nat ==> F(F^n (x)) = F^n (F(x))"
by (induct_tac n, simp_all)

subsection\<open>Transfinite Recursion\<close>

text\<open>Transfinite recursion for definitions based on the
    three cases of ordinals\<close>

definition
  transrec3 :: "[i, i, [i,i]=>i, [i,i]=>i] =>i" where
    "transrec3(k, a, b, c) ==
       transrec(k, \<lambda>x r.
         if x=0 then a
         else if Limit(x) then c(x, \<lambda>y\<in>x. r`y)
         else b(Arith.pred(x), r ` Arith.pred(x)))"

lemma transrec3_0 [simp]: "transrec3(0,a,b,c) = a"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_succ [simp]:
     "transrec3(succ(i),a,b,c) = b(i, transrec3(i,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_Limit:
     "Limit(i) ==>
      transrec3(i,a,b,c) = c(i, \<lambda>j\<in>i. transrec3(j,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], force)

declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

end


theory SINVAR_Subnets
imports"../TopoS_Helper"
begin

subsection {* SecurityInvariant Subnets *}

text{*If unsure, maybe you should look at @{file "SINVAR_SubnetsInGW.thy"}*}

datatype subnets = Subnet nat | BorderRouter nat | Unassigned

definition default_node_properties :: "subnets"
  where  "default_node_properties \<equiv> Unassigned"

fun allowed_subnet_flow :: "subnets \<Rightarrow> subnets \<Rightarrow> bool" where
  "allowed_subnet_flow (Subnet s1) (Subnet s2) = (s1 = s2)" |
  "allowed_subnet_flow (Subnet s1) (BorderRouter s2) = (s1 = s2)" |
  "allowed_subnet_flow (Subnet s1) Unassigned = True" |
  "allowed_subnet_flow (BorderRouter s1) (Subnet s2) = False" | (*(s1 = s2) would also be fine*)
  "allowed_subnet_flow (BorderRouter s1) Unassigned = True" |
  "allowed_subnet_flow (BorderRouter s1) (BorderRouter s2) = True" |
  "allowed_subnet_flow Unassigned Unassigned  = True" |
  "allowed_subnet_flow Unassigned _  = False"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> subnets) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. allowed_subnet_flow (nP e1) (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection {*Preliminaries*}

subsubsection{*ENF*}
  lemma Unassigned_only_to_Unassigned: "allowed_subnet_flow Unassigned e2 \<longleftrightarrow> e2 = Unassigned"
    by(case_tac e2, simp_all)
  lemma All_to_Unassigned: "\<forall> e1. allowed_subnet_flow e1 Unassigned"
    by (rule allI, case_tac e1, simp_all)
  lemma Unassigned_default_candidate: "\<forall> nP e1 e2. \<not> allowed_subnet_flow (nP e1) (nP e2) \<longrightarrow> \<not> allowed_subnet_flow Unassigned (nP e2)"
    apply(rule allI)+
    apply(case_tac "nP e2")
      apply simp
     apply simp
    by(simp add: All_to_Unassigned)
  lemma allowed_subnet_flow_refl: "\<forall> e. allowed_subnet_flow e e"
    by(rule allI, case_tac e, simp_all)
  lemma Subnets_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar allowed_subnet_flow"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma Subnets_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar allowed_subnet_flow"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: Subnets_ENF)
    apply(simp add: allowed_subnet_flow_refl)
  done

  definition Subnets_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> subnets) \<Rightarrow> ('v \<times> 'v) set set" where
  "Subnets_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> \<not> allowed_subnet_flow (nP e1) (nP e2)} })"
  lemma Subnets_offending_set:
  "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Subnets_offending_set"
    apply(simp only: fun_eq_iff ENF_offending_set[OF Subnets_ENF] Subnets_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation Subnets: SecurityInvariant_ACS
where default_node_properties = SINVAR_Subnets.default_node_properties
and sinvar = SINVAR_Subnets.sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Subnets_offending_set"
  unfolding SINVAR_Subnets.default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule SecurityInvariant_withOffendingFlows.ENF_fsts_refl_instance[OF Subnets_ENF_refl Unassigned_default_candidate])[1]
     apply(simp_all)[2]
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
    apply(rename_tac mysubnetcase)
    apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := BorderRouter mysubnetcase)" in exI, simp)
    apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
   apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := BorderRouter whatever)" in exI, simp)
   apply(rule_tac x="vertex_1" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(fact Subnets_offending_set)
 done

  lemma TopoS_Subnets: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

subsubsection {* Analysis *}

lemma violating_configurations: "\<not> sinvar G nP \<Longrightarrow>
    \<exists> (e1, e2) \<in> edges G. nP e1 = Unassigned \<or> (\<exists> s1. nP e1 = Subnet s1) \<or> (\<exists> s1. nP e1 = BorderRouter s1)"
  apply simp
  apply clarify
  apply(rename_tac a b)
  apply(case_tac "nP b", simp_all)
    apply(case_tac "nP a", simp_all)
      apply blast
     apply blast
    apply blast
   apply(case_tac "nP a", simp_all)
    apply blast
   apply blast
  apply(simp add: All_to_Unassigned)
done

text {* All cases where the model can become invalid: *}
theorem violating_configurations_exhaust: "\<not> sinvar G nP \<longleftrightarrow>
   (\<exists> (e1, e2) \<in> (edges G).
      nP e1 = Unassigned \<and> nP e2 \<noteq> Unassigned \<or>
      (\<exists> s1 s2. nP e1 = Subnet s1 \<and> s1 \<noteq> s2 \<and> (nP e2 = Subnet s2 \<or> nP e2 = BorderRouter s2)) \<or>
      (\<exists> s1 s2. nP e1 = BorderRouter s1 \<and> nP e2 = Subnet s2)
   )" (is "?l \<longleftrightarrow> ?r")
 proof
  assume ?l
    have violating_configurations_exhaust_Unassigned:
      "(n1, n2) \<in> (edges G) \<Longrightarrow> nP n1 = Unassigned \<Longrightarrow> \<not> allowed_subnet_flow (nP n1) (nP n2) \<Longrightarrow>
        \<exists> (e1, e2) \<in> (edges G).  nP e1 = Unassigned \<and> nP e2 \<noteq> Unassigned " for n1 n2
      by(cases "nP n2", simp_all) force+

    have violating_configurations_exhaust_Subnet:
      "(n1, n2) \<in> (edges G) \<Longrightarrow> nP n1 = Subnet s1' \<Longrightarrow> \<not> allowed_subnet_flow (nP n1) (nP n2) \<Longrightarrow>
      \<exists> (e1, e2) \<in> (edges G). \<exists> s1 s2. nP e1 = Subnet s1 \<and> s1 \<noteq> s2 \<and> (nP e2 = Subnet s2 \<or> nP e2 = BorderRouter s2)"
      for n1 n2 s1' by(cases "nP n2", simp_all) blast+

    have violating_configurations_exhaust_BorderRouter:
    "(n1, n2) \<in> (edges G) \<Longrightarrow> nP n1 = BorderRouter s1' \<Longrightarrow> \<not> allowed_subnet_flow (nP n1) (nP n2) \<Longrightarrow>
      \<exists> (e1, e2) \<in> (edges G). \<exists> s1 s2. nP e1 = BorderRouter s1 \<and> nP e2 = Subnet s2" for n1 n2 s1'
      by(cases "nP n2", simp_all) blast+

    from `?l` show ?r
    apply simp
    apply clarify
    apply(rename_tac n1 n2)
    apply(case_tac "nP n1", simp_all)
      apply(rename_tac s1)
      apply(drule_tac s1'="s1" in violating_configurations_exhaust_Subnet, simp_all)
      apply blast
     apply(rename_tac s1)
     apply(drule_tac s1'="s1" in violating_configurations_exhaust_BorderRouter, simp_all)
     apply blast
    apply(drule_tac violating_configurations_exhaust_Unassigned, simp_all)
    apply blast
    done
  next
  assume ?r thus ?l
    apply simp
    apply(clarify)
    apply(safe)
       apply(rule_tac x="(a,b)" in bexI)
        apply (simp add: Unassigned_only_to_Unassigned; fail)
       apply(simp; fail)
      apply(rule_tac x="(a,b)" in bexI)
       apply(simp; fail)
      apply(simp; fail)
     apply(rule_tac x="(a,b)" in bexI)
      apply(simp; fail)
     apply(simp; fail)
    apply(rule_tac x="(a,b)" in bexI)
     apply(simp; fail)
    apply(simp; fail)
   done
 qed

hide_fact (open) sinvar_mono
hide_const (open) sinvar receiver_violation default_node_properties

end