(*  Title:      HOL/Library/Product_Plus.thy
    Author:     Brian Huffman
*)

section \<open>Additive group operations on product types\<close>

theory Product_Plus
imports MainRLT
begin

subsection \<open>Operations\<close>

instantiation prod :: (zero, zero) zero
begin

definition zero_prod_def: "0 = (0, 0)"

instance ..
end

instantiation prod :: (plus, plus) plus
begin

definition plus_prod_def:
  "x + y = (fst x + fst y, snd x + snd y)"

instance ..
end

instantiation prod :: (minus, minus) minus
begin

definition minus_prod_def:
  "x - y = (fst x - fst y, snd x - snd y)"

instance ..
end

instantiation prod :: (uminus, uminus) uminus
begin

definition uminus_prod_def:
  "- x = (- fst x, - snd x)"

instance ..
end

lemma fst_zero [simp]: "fst 0 = 0"
  unfolding zero_prod_def by simp

lemma snd_zero [simp]: "snd 0 = 0"
  unfolding zero_prod_def by simp

lemma fst_add [simp]: "fst (x + y) = fst x + fst y"
  unfolding plus_prod_def by simp

lemma snd_add [simp]: "snd (x + y) = snd x + snd y"
  unfolding plus_prod_def by simp

lemma fst_diff [simp]: "fst (x - y) = fst x - fst y"
  unfolding minus_prod_def by simp

lemma snd_diff [simp]: "snd (x - y) = snd x - snd y"
  unfolding minus_prod_def by simp

lemma fst_uminus [simp]: "fst (- x) = - fst x"
  unfolding uminus_prod_def by simp

lemma snd_uminus [simp]: "snd (- x) = - snd x"
  unfolding uminus_prod_def by simp

lemma add_Pair [simp]: "(a, b) + (c, d) = (a + c, b + d)"
  unfolding plus_prod_def by simp

lemma diff_Pair [simp]: "(a, b) - (c, d) = (a - c, b - d)"
  unfolding minus_prod_def by simp

lemma uminus_Pair [simp, code]: "- (a, b) = (- a, - b)"
  unfolding uminus_prod_def by simp

subsection \<open>Class instances\<close>

instance prod :: (semigroup_add, semigroup_add) semigroup_add
  by standard (simp add: prod_eq_iff add.assoc)

instance prod :: (ab_semigroup_add, ab_semigroup_add) ab_semigroup_add
  by standard (simp add: prod_eq_iff add.commute)

instance prod :: (monoid_add, monoid_add) monoid_add
  by standard (simp_all add: prod_eq_iff)

instance prod :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
  by standard (simp add: prod_eq_iff)

instance prod :: (cancel_semigroup_add, cancel_semigroup_add) cancel_semigroup_add
    by standard (simp_all add: prod_eq_iff)

instance prod :: (cancel_ab_semigroup_add, cancel_ab_semigroup_add) cancel_ab_semigroup_add
    by standard (simp_all add: prod_eq_iff diff_diff_eq)

instance prod :: (cancel_comm_monoid_add, cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance prod :: (group_add, group_add) group_add
  by standard (simp_all add: prod_eq_iff)

instance prod :: (ab_group_add, ab_group_add) ab_group_add
  by standard (simp_all add: prod_eq_iff)

lemma fst_sum: "fst (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. fst (f x))"
proof (cases "finite A")
  case True
  then show ?thesis by induct simp_all
next
  case False
  then show ?thesis by simp
qed

lemma snd_sum: "snd (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. snd (f x))"
proof (cases "finite A")
  case True
  then show ?thesis by induct simp_all
next
  case False
  then show ?thesis by simp
qed

lemma sum_prod: "(\<Sum>x\<in>A. (f x, g x)) = (\<Sum>x\<in>A. f x, \<Sum>x\<in>A. g x)"
proof (cases "finite A")
  case True
  then show ?thesis by induct (simp_all add: zero_prod_def)
next
  case False
  then show ?thesis by (simp add: zero_prod_def)
qed

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Untyped_Lambda_Calculus
imports Nameless_Representation_Of_Terms
begin
(*>*)

section {* Untyped Lambda-Calculus *}
text {* \label{sec:untyped-lambda-calculus} *}

text {*
The untyped lambda calculus is the first core calculus we formalize. It imports the theory on the
nameless representation of terms (Section~\ref{sec:nameless-rep-of-terms}), which formalizes the
representation used for the syntax of the language. We complete the definitions, by providing the
semantics, and we prove the determinacy of evaluation, the relation between values and normal form,
the uniqueness of normal form and the potentially non-terminating nature of evaluation.
*}

subsection {* Definitions *}

text {*
In the pure $\lambda$-calculus, only function abstractions are considered values:
*}

inductive is_value_UL :: "ulterm \<Rightarrow> bool" where
  "is_value_UL (ULAbs t)"

text {*
Variables are not part of this definition because they are a way to refer to a specific
$\lambda$-abstraction. Since abstractions are themselves values, we do not need to consider their
bound variables. The only ones we could consider as values are the free variables, i.e. variables
referring to non-existing $\lambda$-abstractions. In the following examples, every occurrence of
@{term w} is free:

\begin{displaymath}
  w \qquad (\lambda x. \ x) \ w \qquad (\lambda x. \lambda y. \lambda z. \ w \ x \ y \ z)
\end{displaymath}

There is no consensus on how the semantics should handle such situations. By excluding them from the
set of values, the semantics described in the book defines that such terms are meaningless. This
decision is consistent with many programming languages where the use of an undefined identifier
leads to an error, either at compile-time or at run-time.

The single-step evaluation relation is defined, in the book, with the following inference rules
where $[x \mapsto s] \ t$ is the replacement of variable $x$ by $s$ in $t$:
\setcounter{equation}{0}
\begin{gather}
  \inferrule {t_1 \implies t_1'}{t_1 \ t_2 \implies t_1' \ t_2} \\[0.8em]
  \inferrule {t_2 \implies t_2'}{v_1 \ t_2 \implies v_1 \ t_2'} \\[0.8em]
  \inferrule {}{(\lambda x. \ t_{12}) \ v_2 \implies [x \mapsto v_2] \ t_{12}}
\end{gather}

The first rule states that the left side of an application must be reduced first, the second rule
states that the right side of an application must be reduced second and the third rule states that
an application consists of replacing both the $\lambda$-abstraction and the argument by the
$\lambda$-abstraction's body where the substitution has been performed. We translate these rules
with the following inductive definition:
*}

inductive eval1_UL :: "ulterm \<Rightarrow> ulterm \<Rightarrow> bool" where
  eval1_ULApp1:
    "eval1_UL t1 t1' \<Longrightarrow> eval1_UL (ULApp t1 t2) (ULApp t1' t2)" |
  eval1_ULApp2:
    "is_value_UL v1 \<Longrightarrow> eval1_UL t2 t2' \<Longrightarrow> eval1_UL (ULApp v1 t2)
      (ULApp v1 t2')" |
  eval1_ULApp_ULAbs:
    "is_value_UL v2 \<Longrightarrow> eval1_UL (ULApp (ULAbs t12) v2)
      (shift_UL (-1) 0 (subst_UL 0 (shift_UL 1 0 v2) t12))"

text {*
Apart from the explicit assumption on the nature of @{term v1}, the only difference is the
substitution in the third rule. This is the reason that motivated us to formalize the nameless
representation of terms in the first place. The book uses a high level definition of substitution
where name clashes are not considered. We replace this higher level operation by our concrete
substitution operation on de Bruijn indices. We begin by shifting up by on the concrete argument
because, conceptually, it \emph{enters} the function abstraction. We then perform the proper
substitution of the function's variable, i.e. of index zero. Finally, we shift down every variable
of the resulting body to account for the removed $\lambda$-abstraction.

The multi-step evaluation relation and the normal form definitions follow the usual pattern:
*}

inductive eval_UL :: "ulterm \<Rightarrow> ulterm \<Rightarrow> bool" where
  eval_UL_base:
    "eval_UL t t" |
  eval_UL_step:
    "eval1_UL t t' \<Longrightarrow> eval_UL t' t'' \<Longrightarrow> eval_UL t t''"

definition is_normal_form_UL :: "ulterm \<Rightarrow> bool" where
  "is_normal_form_UL t \<longleftrightarrow> (\<forall>t'. \<not> eval1_UL t t')"

subsection {* Theorems *}

text {*
In the book, this chapter consists mainly of the presentation of the $\lambda$-calculus, of which we
gave a short introduction in the background section (Section~\ref{sec:background-lambda-calculus}),
and does not contains meaningful theorems. Nevertheless, we revisit the properties
introduced with the arithmetic expressions language (Section~\ref{sec:untyped-arith-expr}) and
either prove that they are still theorems or disprove them.
*}

(* Theorem 3.5.4 for Untyped Lambda Calculus *)

text {*
The determinacy of the single-step evaluation still holds:
*}

theorem eval1_UL_determinacy:
  "eval1_UL t t' \<Longrightarrow> eval1_UL t t'' \<Longrightarrow> t' = t''"
proof (induction t t' arbitrary: t'' rule: eval1_UL.induct)
  case (eval1_ULApp1 t1 t1' t2)
  from eval1_ULApp1.hyps eval1_ULApp1.prems show ?case
    by (auto elim: eval1_UL.cases is_value_UL.cases intro: eval1_ULApp1.IH)
next
  case (eval1_ULApp2 t1 t2 t2')
  from eval1_ULApp2.hyps eval1_ULApp2.prems show ?case
    by (auto elim: eval1_UL.cases is_value_UL.cases intro: eval1_ULApp2.IH)
next
  case (eval1_ULApp_ULAbs v2 t12)
  thus ?case by (auto elim: eval1_UL.cases simp: is_value_UL.simps)
qed

(* Definition 3.5.6 for Untyped Lambda Calculus *)

text {*
Every value is in normal form:
*}

(* Theorem 3.5.7 for Untyped Lambda Calculus *)

theorem value_imp_normal_form:
  "is_value_UL t \<Longrightarrow> is_normal_form_UL t"
by (auto elim: is_value_UL.cases eval1_UL.cases simp: is_normal_form_UL_def)

(* Theorem 3.5.8 does not hold for Untyped Lambda calculus *)
text {*
Meanwhile, the converse of the preceding theorem is not true since variables are in normal form but
are not values:
*}

theorem normal_form_does_not_imp_value:
  "\<exists>t. is_normal_form_UL t \<and> \<not> is_value_UL t" (is "\<exists>t. ?P t")
proof
  have a: "\<And>n. is_normal_form_UL (ULVar n)"
    by (auto simp: is_normal_form_UL_def elim: eval1_UL.cases)
  have b: "\<And>n. \<not> is_value_UL (ULVar n)"
    by (auto simp: is_normal_form_UL_def elim: is_value_UL.cases)
  from a b show "\<And>n. ?P (ULVar n)" by simp
qed

(* Corollary 3.5.11 for Untyped Lambda Calculus *)

text {*
The uniqueness of normal form still holds:
*}

corollary uniqueness_of_normal_form:
  "eval_UL t u \<Longrightarrow> eval_UL t u' \<Longrightarrow> is_normal_form_UL u \<Longrightarrow> is_normal_form_UL u' \<Longrightarrow> u = u'"
by (induction t u rule: eval_UL.induct)
  (metis eval_UL.cases is_normal_form_UL_def eval1_UL_determinacy)+

(* Theorem 3.5.12 does not hold for Untyped Lambda calculus *)

text {*
This time, the evaluation relation could be non-terminating. A typical example of term whose
evaluation does not terminate is the self-application combinator
($\omega \: \equiv \: \lambda x. \ x \ x$) applied to itself, resulting in a term called $\Omega$:
*}

(*<*)
lemma eval1_UL_ULVarD: "eval1_UL (ULVar x) t \<Longrightarrow> P"
  by (induction "ULVar x" t rule: eval1_UL.induct)

lemma eval1_UL_ULAbsD: "eval1_UL (ULAbs x) t \<Longrightarrow> P"
  by (induction "ULAbs x" t rule: eval1_UL.induct)
(*>*)

definition \<omega> :: ulterm where
  "\<omega> \<equiv> ULAbs (ULApp (ULVar 0) (ULVar 0))"

definition \<Omega> :: ulterm where
  "\<Omega> \<equiv> ULApp \<omega> \<omega>"

text {*
A single step of evaluation will result in the same term:
*}

lemma eval1_UL_\<Omega>:
  "eval1_UL \<Omega> t \<Longrightarrow> \<Omega> = t"
by (induction \<Omega> t rule: eval1_UL.induct)
  (auto elim: eval1_UL_ULAbsD simp: \<omega>_def \<Omega>_def)

text {*
Since the single-step evaluation is equivalent to the identity, the multi-step evaluation relation
will loop infinitely (e.g. $\Omega \to \Omega \to \dots$):
*}

lemma eval_UL_\<Omega>:
  "eval_UL \<Omega> t \<Longrightarrow> \<Omega> = t"
by (induction \<Omega> t rule: eval_UL.induct) (blast dest: eval1_UL_\<Omega>)+

lemma
  "eval_UL \<Omega> \<Omega>"
by (rule eval_UL.intros)

text {*
Based on this simple example, we can show that there exists some terms which cannot be reduce to a
normal form:
*}

theorem eval_does_not_always_terminate:
  "\<exists>t. \<forall>t'. eval_UL t t' \<longrightarrow> \<not> is_normal_form_UL t'" (is "\<exists>t. \<forall>t'. ?P t t'")
proof
  show "\<forall>t'. ?P \<Omega> t'"
      by (auto dest!: eval_UL_\<Omega>)
      (auto
        intro: eval1_UL.intros is_value_UL.intros
        simp: \<omega>_def \<Omega>_def is_normal_form_UL_def)
qed

(*<*)
end
(*>*)


(*  Title:      Environments.thy
    Author:     Florian Kammuller and Henry Sudhof, 2008
*)

theory Environments imports Main begin

subsection \<open>Type Environments\<close>
text\<open>Some basic properties of our variable environments.\<close>

(* We use a wrapped map and an error element *)
datatype 'a environment =
  Env "(string \<rightharpoonup> 'a)"
| Malformed

(* Adding an entry to an environment. Overwriting an entry switches to the error state*)
primrec
  add :: "('a environment) \<Rightarrow> string \<Rightarrow> 'a \<Rightarrow> 'a environment"
  ("_\<lparr>_:_\<rparr>" [90, 0, 0] 91)
where
  add_def: "(Env e)\<lparr>x:a\<rparr> =
     (if (x \<notin> dom e) then (Env (e(x \<mapsto> a))) else Malformed)"
| add_mal: "Malformed\<lparr>x:a\<rparr> = Malformed"

(* domains of environments, i.e. the set of used variable names *)
primrec
  env_dom :: "('a environment) \<Rightarrow> string set"
where
  env_dom_def: "env_dom (Env e) = dom e"
| env_dom_mal: "env_dom (Malformed) = {}"

(* Retrieving an entry from an environment *)
primrec
  env_get :: "('a environment) \<Rightarrow> string  \<Rightarrow> 'a option" ("_!_")
where
  env_get_def: "env_get (Env e) x = e x "
| env_get_mal: "env_get (Malformed) x = None "

(* Environment well-formedness. For now weaker than usually recommended for LN; just finiteness and not being the error value *)
primrec ok::"('a environment) \<Rightarrow> bool"
where
  OK_Env [intro]: "ok (Env e) = (finite (dom e))"
| OK_Mal [intro]: "ok Malformed = False"

(* commutativity of add *)
lemma subst_add:
  fixes x y
  assumes "x \<noteq> y"
  shows "e\<lparr>x:a\<rparr>\<lparr>y:b\<rparr> = e\<lparr>y:b\<rparr>\<lparr>x:a\<rparr>"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
  proof (cases "x \<in> dom f", simp)
    case False with assms Env show ?thesis
    proof (cases "y \<in> dom f", simp_all, intro ext)
      fix xa :: string
      case False with assms show "(f(x \<mapsto> a,y \<mapsto> b)) xa = (f(y \<mapsto> b,x \<mapsto> a)) xa"
      proof (cases "xa = x", simp)
        case False with assms show ?thesis
          by (cases "xa = y", simp_all)
      qed
    qed
  qed
qed

(* A well-formed environment is finite *)
lemma ok_finite[simp]: "ok e \<Longrightarrow> finite (env_dom e)"
  by (cases e, simp+)

(* A well-formed environment is not malformed *)
lemma ok_ok[simp]: "ok e \<Longrightarrow> \<exists>x. e = (Env x)"
  by (cases e, simp+)

(* If something is in the set of variable names, then it has a value assigned to it *)
lemma env_defined:
  fixes x :: string and e :: "'a environment"
  assumes "x \<in> env_dom e"
  shows "\<exists>T . e!x = Some T"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case Env with assms show ?thesis by (simp, force)
qed

(* adding of new elements does not remove elements *)
lemma env_bigger: "\<lbrakk> a \<notin> env_dom e; x \<in> (env_dom e) \<rbrakk> \<Longrightarrow> x \<in> env_dom (e\<lparr>a:X\<rparr>)"
  by (cases e, simp_all)

(* Added for convenience *)
lemma env_bigger2:
  "\<lbrakk> a \<notin> env_dom e; b \<notin> (env_dom e); x \<in> (env_dom e); a \<noteq> b \<rbrakk>
  \<Longrightarrow> x \<in> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  by (cases e, simp_all)

(* If there is an entry, then the environment is sane. *)
lemma not_malformed: "x \<in> (env_dom e) \<Longrightarrow> \<exists>fun. e = Env fun"
  by (cases e, simp_all)

(* Smaller environments are well formed. *)
lemma not_malformed_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>)"
  shows "ok e"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case (Env f) with ok_finite[OF assms] assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* Elements not in a bigger environment are not in a smaller one either *)
lemma not_in_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>)"
  shows "a \<notin> env_dom e"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* A variable that got added is in the environment *)
lemma in_add:
  fixes e :: "'a environment" and a :: string and X :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>)"
  shows "a \<in> env_dom (e\<lparr>a:X\<rparr>)"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* Similar to subst_add, but using a more convenient premise *)
lemma ok_add_reverse:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  shows "(e\<lparr>b:Y\<rparr>\<lparr>a:X\<rparr>) = (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
proof (cases e)
  case Malformed with assms show ?thesis by simp (* contradiction *)
next
  case (Env f)
  with
    not_in_smaller[OF \<open>ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)\<close>] in_add[OF assms]
    not_in_smaller[OF not_malformed_smaller[OF assms]]
    in_add[OF not_malformed_smaller[OF assms]]
  show ?thesis
    by (simp, intro conjI impI, elim conjE, auto simp: fun_upd_twist)
qed

lemma not_in_env_bigger:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<notin> (env_dom e)" and "x \<noteq> a"
  shows "x \<notin> env_dom (e\<lparr>a:X\<rparr>)"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

lemma not_in_env_bigger_2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and x :: string
  assumes "x \<notin> (env_dom e)" and "x \<noteq> a" and "x \<noteq> b"
  shows "x \<notin> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
proof (cases e)
  case Malformed thus ?thesis by simp
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

lemma not_in_env_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<notin> (env_dom (e\<lparr>a:X\<rparr>))" and "x \<noteq> a" and "ok (e\<lparr>a:X\<rparr>)"
  shows "x \<notin> env_dom e"
proof (cases e)
  case Malformed with assms(3) show ?thesis by simp (* contradiction *)
next
  case (Env f) with assms show ?thesis
    by (cases "a \<notin> dom f", simp_all)
qed

(* Conditions derivable from the well-formedness *)
lemma ok_add_2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  shows "ok e \<and> a \<notin> env_dom e \<and> b \<notin> env_dom e \<and> a \<noteq> b"
proof -
  {
    assume "ok (e\<lparr>b:X\<rparr>\<lparr>b:Y\<rparr>)"
    from not_in_smaller[OF this] in_add[OF not_malformed_smaller[OF this]]
    have False by simp
  } with assms have "a \<noteq> b" by auto
  moreover
  from assms ok_add_reverse[OF assms] have "ok (e\<lparr>b:Y\<rparr>\<lparr>a:X\<rparr>)" by simp
  note not_in_smaller[OF not_malformed_smaller[OF this]]
  ultimately
  show ?thesis
    using
      not_malformed_smaller[OF not_malformed_smaller[OF assms]]
      not_in_smaller[OF not_malformed_smaller[OF assms]]
  by simp
qed

(* A variable that got added is in the environment *)
lemma in_add_2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
  shows "a \<in> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>) \<and> b \<in> env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>)"
proof -
  from ok_add_2[OF assms] show ?thesis
    by (elim conjE, intro conjI, (cases e, simp_all)+)
qed

(* Convenience version *)
lemma ok_add_3:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and c :: string and Z :: 'a
  assumes "ok (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>\<lparr>c:Z\<rparr>)"
  shows
  "a \<notin> env_dom e \<and> b \<notin> env_dom e \<and> c \<notin> env_dom e \<and> a \<noteq> b \<and> b \<noteq> c \<and> a \<noteq> c"
proof -
  {
    assume "ok (e\<lparr>a:X\<rparr>\<lparr>c:Y\<rparr>\<lparr>c:Z\<rparr>)"
    from not_in_smaller[OF this] in_add[OF not_malformed_smaller[OF this]]
    have False by simp
  } with assms have "b \<noteq> c" by auto
  moreover
  from assms ok_add_reverse[OF assms] have "ok (e\<lparr>a:X\<rparr>\<lparr>c:Z\<rparr>\<lparr>b:Y\<rparr>)" by simp
  note ok_add_2[OF not_malformed_smaller[OF this]]
  ultimately
  show ?thesis using ok_add_2[OF not_malformed_smaller[OF assms]]
    by simp
qed

lemma in_env_smaller:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>))" and "x \<noteq> a"
  shows "x \<in> env_dom e"
proof -
  from not_malformed[OF assms(1)] obtain f where f: "e\<lparr>a:X\<rparr> = Env f" by auto
  with assms show ?thesis
  proof (cases e)
    case Malformed with \<open>e\<lparr>a:X\<rparr> = Env f\<close>
    have False by simp
    then show ?thesis ..
  next
    case (Env f') with assms f show ?thesis
      by (simp, cases "a \<in> dom f'", simp_all, force)
  qed
qed

lemma in_env_smaller2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>))" and "x \<noteq> a" and "x \<noteq> b"
  shows "x \<in> env_dom e"
  by (simp add: in_env_smaller[OF in_env_smaller[OF assms(1) assms(3)] assms(2)])

lemma get_env_bigger:
  fixes e :: "'a environment" and a :: string and X :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>))" and "x \<noteq> a"
  shows "e!x = e\<lparr>a:X\<rparr>!x"
proof -
  from not_malformed[OF assms(1)] obtain f where f: "e\<lparr>a:X\<rparr> = Env f" by auto
  thus ?thesis proof (cases e)
    case Malformed with \<open>e\<lparr>a:X\<rparr> = Env f\<close>
    show ?thesis by simp (* contradiction *)
  next
    case (Env f') with assms f show ?thesis
      by (cases "a \<notin> dom f'", auto)
  qed
qed

lemma get_env_bigger2:
  fixes
  e :: "'a environment" and a :: string and X :: 'a and
  b :: string and Y :: 'a and x :: string
  assumes "x \<in> (env_dom (e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>))" and "x \<noteq> a" and "x \<noteq> b"
  shows "e!x = e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>!x"
  by (simp add: get_env_bigger[OF assms(1) assms(3)]
                get_env_bigger[OF in_env_smaller[OF assms(1) assms(3)] assms(2)])

lemma get_env_smaller: "\<lbrakk> x \<in> env_dom e; a \<notin> env_dom e \<rbrakk> \<Longrightarrow> e\<lparr>a:X\<rparr>!x = e!x"
  by (cases e, auto)

lemma get_env_smaller2:
  "\<lbrakk> x \<in> env_dom e; a \<notin> env_dom e; b \<notin> env_dom e; a \<noteq> b \<rbrakk>
  \<Longrightarrow> e\<lparr>a:X\<rparr>\<lparr>b:Y\<rparr>!x = e!x"
  by (cases e, auto)

lemma add_get_eq: "\<lbrakk> xa \<notin> env_dom e; ok e; the e\<lparr>xa:U\<rparr>!xa = T \<rbrakk> \<Longrightarrow> U = T"
  by (cases e, auto)

lemma add_get: "\<lbrakk> xa \<notin> env_dom e; ok e \<rbrakk> \<Longrightarrow> the e\<lparr>xa:U\<rparr>!xa = U"
  by (cases e, auto)

lemma add_get2_1:
  fixes e :: "'a environment" and x :: string and A :: 'a and y :: string and B :: 'a
  assumes "ok (e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>)"
  shows "the e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>!x = A"
proof -
  from ok_add_2[OF assms] show ?thesis
    by (cases e, elim conjE, simp_all)
qed

lemma add_get2_2:
  fixes e :: "'a environment" and x :: string and A :: 'a and y :: string and B :: 'a
  assumes "ok (e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>)"
  shows "the e\<lparr>x:A\<rparr>\<lparr>y:B\<rparr>!y = B"
proof -
  from ok_add_2[OF assms] show ?thesis
    by (cases e, elim conjE, simp_all)
qed

lemma ok_add_ok: "\<lbrakk> ok e; x \<notin> env_dom e \<rbrakk> \<Longrightarrow> ok (e\<lparr>x:X\<rparr>)"
  by (cases e, auto)

lemma env_add_dom:
  fixes e :: "'a environment" and x :: string
  assumes "ok e" and "x \<notin> env_dom e"
  shows "env_dom (e\<lparr>x:X\<rparr>) = env_dom e \<union> {x}"
proof (auto simp: in_add[OF ok_add_ok[OF assms]], rule ccontr)
  fix y assume "y \<in> env_dom (e\<lparr>x:X\<rparr>)" and "y \<notin> env_dom e" and "y \<noteq> x"
  from in_env_smaller[OF this(1) this(3)] this(2) show False by simp
next
  fix y assume "y \<in> env_dom e"
  from env_bigger[OF not_in_smaller[OF ok_add_ok[OF assms]] this]
  show "y \<in> env_dom (e\<lparr>x:X\<rparr>)" by assumption
qed

lemma env_add_dom_2:
  fixes e :: "'a environment" and x :: string and y :: string
  assumes "ok e" and "x \<notin> env_dom e" and "y \<notin> env_dom e" and "x \<noteq> y"
  shows "env_dom (e\<lparr>x:X\<rparr>\<lparr>y:Y\<rparr>) = env_dom e \<union> {x,y}"
proof -
  from env_add_dom[OF assms(1-2)] assms(3-4)
  have "y \<notin> env_dom (e\<lparr>x:X\<rparr>)" by simp
  from
    env_add_dom[OF assms(1-2)]
    env_add_dom[OF ok_add_ok[OF assms(1-2)] this]
  show ?thesis by auto
qed

fun
   env_app :: "('a environment) \<Rightarrow>  ('a environment) \<Rightarrow> ('a environment)" ("_+_")
where
  "env_app (Env a) (Env b) =
  (if (ok (Env a) \<and> ok (Env b) \<and> env_dom (Env b) \<inter> env_dom (Env a) = {})
   then  Env (a ++ b) else Malformed )"

lemma env_app_dom:
  fixes e1 :: "'a environment" and e2 :: "'a environment"
  assumes "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2"
  shows "env_dom (e1+e2) = env_dom e1 \<union> env_dom e2"
proof -
  from ok_ok[OF \<open>ok e1\<close>] ok_ok[OF \<open>ok e2\<close>]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms(2) ok_finite[OF \<open>ok e1\<close>] ok_finite[OF \<open>ok e2\<close>]
  show ?thesis by auto
qed

lemma env_app_same[simp]:
  fixes e1 :: "'a environment" and e2 :: "'a environment" and x :: string
  assumes
  "ok e1" and "x \<in> env_dom e1" and
  "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2"
  shows "the (e1+e2!x) = the e1!x"
proof -
  from ok_ok[OF \<open>ok e1\<close>] ok_ok[OF \<open>ok e2\<close>]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms(2-3) ok_finite[OF \<open>ok e1\<close>] ok_finite[OF \<open>ok e2\<close>]
  show ?thesis proof (auto)
    fix y :: 'a assume "dom f1 \<inter> dom f2 = {}" and "f1 x = Some y"
    from map_add_comm[OF this(1)] this(2) have "(f1 ++ f2) x = Some y"
      by (simp add: map_add_Some_iff)
    thus "the ((f1 ++ f2) x) = y" by auto
  qed
qed

lemma env_app_ok[simp]:
  fixes e1 :: "'a environment" and e2 :: "'a environment"
  assumes "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2"
  shows "ok (e1+e2)"
proof -
  from ok_ok[OF \<open>ok e1\<close>] ok_ok[OF \<open>ok e2\<close>]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms show ?thesis by (simp,force)
qed

lemma env_app_add[simp]:
  fixes e1 :: "'a environment" and e2 :: "'a environment" and x :: string
  assumes
  "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2" and
  "x \<notin> env_dom e1" and "x \<notin> env_dom e2"
  shows "(e1+e2)\<lparr>x:X\<rparr> = e1\<lparr>x:X\<rparr>+e2"
proof -
  from ok_ok[OF \<open>ok e1\<close>] ok_ok[OF \<open>ok e2\<close>]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms show ?thesis proof (clarify, simp, intro impI ext)
    fix xa :: string
    assume "x \<notin> dom f1" and "x \<notin> dom f2"
    thus "((f1 ++ f2)(x \<mapsto> X)) xa = (f1(x \<mapsto> X) ++ f2) xa"
    proof (cases "x = xa", simp_all)
      case False thus "(f1 ++ f2) xa = (f1(x \<mapsto> X) ++ f2) xa"
        by (simp add: map_add_def split: option.split)
    next
      case True with \<open>x \<notin> dom f1\<close> \<open>x \<notin> dom f2\<close>
      have "(f1(xa \<mapsto> X) ++ f2) xa = Some X"
        by (auto simp: map_add_Some_iff)
      thus "Some X = (f1(xa \<mapsto> X) ++ f2) xa" by simp
    qed
  qed
qed

lemma env_app_add2[simp]:
  fixes
  e1 :: "'a environment" and e2 :: "'a environment" and
  x :: string and y :: string
  assumes
  "ok e1" and "env_dom e1 \<inter> env_dom e2 = {}" and "ok e2" and
  "x \<notin> env_dom e1" and "x \<notin> env_dom e2" and "y \<notin> env_dom e1" and
  "y \<notin> env_dom e2" and "x \<noteq> y"
  shows "(e1+e2)\<lparr>x:X\<rparr>\<lparr>y:Y\<rparr> = e1\<lparr>x:X\<rparr>\<lparr>y:Y\<rparr>+e2"
proof -
  from ok_ok[OF \<open>ok e1\<close>] ok_ok[OF \<open>ok e2\<close>]
  obtain f1 f2 where "e1 = Env f1" and "e2 = Env f2" by auto
  with assms show ?thesis proof (clarify, simp, intro impI ext)
    fix xa :: string
    assume "x \<notin> dom f1" and "x \<notin> dom f2" and "y \<notin> dom f1" and "y \<notin> dom f2"
    with \<open>x \<noteq> y\<close>
    show "((f1 ++ f2)(x \<mapsto> X, y \<mapsto> Y)) xa = (f1(x \<mapsto> X, y \<mapsto> Y) ++ f2) xa"
    proof (cases "x = xa", simp)
      case True
      with \<open>x \<noteq> y\<close> \<open>x \<notin> dom f1\<close> \<open>x \<notin> dom f2\<close> \<open>y \<notin> dom f1\<close> \<open>y \<notin> dom f2\<close>
      have "(f1(xa \<mapsto> X,y \<mapsto> Y) ++ f2) xa = Some X"
        by (auto simp: map_add_Some_iff)
      thus "Some X = (f1(xa \<mapsto> X,y \<mapsto> Y) ++ f2) xa" by simp
    next
      case False thus ?thesis
      proof (cases "y = xa", simp_all)
        case False with \<open>x \<noteq> xa\<close>
        show "(f1 ++ f2) xa = (f1(x \<mapsto> X,y \<mapsto> Y) ++ f2) xa"
          by (simp add: map_add_def split: option.split)
      next
        case True
        with \<open>x \<noteq> y\<close> \<open>x \<notin> dom f1\<close> \<open>x \<notin> dom f2\<close> \<open>y \<notin> dom f1\<close> \<open>y \<notin> dom f2\<close>
        have "(f1(x \<mapsto> X,xa \<mapsto> Y) ++ f2) xa = Some Y"
          by (auto simp: map_add_Some_iff)
        thus "Some Y = (f1(x \<mapsto> X, xa \<mapsto> Y) ++ f2) xa" by simp
      qed
    qed
  qed
qed

end


section \<open>Algebra of Monotonic Boolean Transformers\<close>

theory  Mono_Bool_Tran_Algebra
imports Mono_Bool_Tran
begin

text\<open>
In this section we introduce the {\em algebra of monotonic boolean transformers}.
This is a bounded distributive lattice with a monoid operation, a
dual operator and an iteration operator. The standard model for this
algebra is the set of monotonic boolean transformers introduced
in the previous section.
\<close>

class dual =
  fixes dual::"'a \<Rightarrow> 'a" ("_ ^ o" [81] 80)

class omega =
  fixes omega::"'a \<Rightarrow> 'a" ("_ ^ \<omega>" [81] 80)

class star =
  fixes star::"'a \<Rightarrow> 'a" ("(_ ^ *)" [81] 80)

class dual_star =
  fixes dual_star::"'a \<Rightarrow> 'a" ("(_ ^ \<otimes>)" [81] 80)

class mbt_algebra = monoid_mult + dual + omega + distrib_lattice + order_top + order_bot + star + dual_star +
  assumes
      dual_le: "(x \<le> y) = (y ^ o \<le> x ^ o)"
  and dual_dual [simp]: "(x ^ o) ^ o = x"
  and dual_comp: "(x * y) ^ o = x ^ o * y ^ o"
  and dual_one [simp]: "1 ^ o = 1"
  and top_comp [simp]: "\<top> * x = \<top>"
  and inf_comp: "(x \<sqinter> y) * z = (x * z) \<sqinter> (y * z)"
  and le_comp: "x \<le> y \<Longrightarrow> z * x \<le> z * y"
  and dual_neg: "(x * \<top>) \<sqinter> (x ^ o * \<bottom>) = \<bottom>"
  and omega_fix: "x ^ \<omega> = (x * (x ^ \<omega>)) \<sqinter> 1"
  and omega_least: "(x * z) \<sqinter> y \<le> z \<Longrightarrow> (x ^ \<omega>) * y \<le> z"
  and star_fix: "x ^ * = (x * (x ^ *)) \<sqinter> 1"
  and star_greatest: "z \<le> (x * z) \<sqinter> y \<Longrightarrow> z \<le> (x ^ *) * y"
  and dual_star_def: "(x ^ \<otimes>) = (((x ^ o) ^ *) ^ o)"
begin

lemma le_comp_right: "x \<le> y \<Longrightarrow> x * z \<le> y * z"
  apply (cut_tac x = x and y = y and z = z in inf_comp)
  apply (simp add: inf_absorb1)
  apply (subgoal_tac "x * z \<sqinter> (y * z) \<le> y * z")
  apply simp
  by (rule inf_le2)

subclass bounded_lattice
  proof qed

end

instantiation MonoTran :: (complete_boolean_algebra) mbt_algebra
begin

lift_definition dual_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
  is dual_fun
  by (fact mono_dual_fun)

lift_definition omega_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
  is omega_fun
  by (fact mono_omega_fun)

lift_definition star_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
  is star_fun
  by (fact mono_star_fun)

definition dual_star_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
where
  "(x::('a MonoTran)) ^ \<otimes> = ((x ^ o) ^ *) ^ o"

instance proof
  fix x y :: "'a MonoTran" show "(x \<le> y) = (y ^ o \<le> x ^ o)"
    apply transfer
    apply (auto simp add: fun_eq_iff le_fun_def)
    apply (drule_tac x = "-xa" in spec)
    apply simp
    done
next
  fix x :: "'a MonoTran" show "(x ^ o) ^ o = x"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x y :: "'a MonoTran" show "(x * y) ^ o = x ^ o * y ^ o"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  show "(1::'a MonoTran) ^ o = 1"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x :: "'a MonoTran" show "\<top> * x = \<top>"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x y z :: "'a MonoTran" show "(x \<sqinter> y) * z = (x * z) \<sqinter> (y * z)"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x y z :: "'a MonoTran" assume A: "x \<le> y" from A show " z * x \<le> z * y"
    apply transfer
    apply (auto simp add: le_fun_def elim: monoE)
    done
next
  fix x :: "'a MonoTran" show "x * \<top> \<sqinter> (x ^ o * \<bottom>) = \<bottom>"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x :: "'a MonoTran" show "x ^ \<omega> = x * x ^ \<omega> \<sqinter> 1"
    apply transfer
    apply (simp add: fun_eq_iff)
    apply (simp add: omega_fun_def Omega_fun_def)
    apply (subst lfp_unfold, simp_all add: ac_simps)
    apply (auto intro!: mono_comp mono_comp_fun)
    done
next
  fix x y z :: "'a MonoTran" assume A: "x * z \<sqinter> y \<le> z" from A show "x ^ \<omega> * y \<le> z"
    apply transfer
    apply (auto simp add: lfp_omega lfp_def)
    apply (rule Inf_lower)
    apply (auto simp add: Omega_fun_def ac_simps)
    done
next
  fix x :: "'a MonoTran" show "x ^ * = x * x ^ * \<sqinter> 1"
    apply transfer
    apply (auto simp add: star_fun_def Omega_fun_def)
    apply (subst gfp_unfold, simp_all add: ac_simps)
    apply (auto intro!: mono_comp mono_comp_fun)
    done
next
  fix x y z :: "'a MonoTran" assume A: "z \<le> x * z \<sqinter> y" from A show "z \<le> x ^ * * y"
    apply transfer
    apply (auto simp add: gfp_star gfp_def)
    apply (rule Sup_upper)
    apply (auto simp add: Omega_fun_def)
    done
next
  fix x :: "'a MonoTran" show "x ^ \<otimes> = ((x ^ o) ^ *) ^ o"
    by (simp add: dual_star_MonoTran_def)
qed

end

context mbt_algebra begin

lemma dual_top [simp]: "\<top> ^ o = \<bottom>"
  apply (rule antisym, simp_all)
  by (subst dual_le, simp)

lemma dual_bot [simp]: "\<bottom> ^ o = \<top>"
  apply (rule antisym, simp_all)
  by (subst dual_le, simp)

lemma dual_inf: "(x \<sqinter> y) ^ o = (x ^ o) \<squnion> (y ^ o)"
  apply (rule antisym, simp_all, safe)
  apply (subst dual_le, simp, safe)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp)
  by (subst dual_le, simp)

lemma dual_sup: "(x \<squnion> y) ^ o = (x ^ o) \<sqinter> (y ^ o)"
  apply (rule antisym, simp_all, safe)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp, safe)
  apply (subst dual_le, simp)
  by (subst dual_le, simp)

lemma sup_comp: "(x \<squnion> y) * z = (x * z) \<squnion> (y * z)"
  apply (subgoal_tac "((x ^ o \<sqinter> y ^ o) * z ^ o) ^ o = ((x ^ o * z ^ o) \<sqinter> (y ^ o * z ^ o)) ^ o")
  apply (simp add: dual_inf dual_comp)
  by (simp add: inf_comp)

lemma dual_eq: "x ^ o = y ^ o \<Longrightarrow> x = y"
  apply (subgoal_tac "(x ^ o) ^ o = (y ^ o) ^ o")
  apply (subst (asm) dual_dual)
  apply (subst (asm) dual_dual)
  by simp_all

lemma dual_neg_top [simp]: "(x ^ o * \<bottom>) \<squnion> (x * \<top>) = \<top>"
  apply (rule dual_eq)
  by(simp add: dual_sup dual_comp dual_neg)

lemma [simp]: "(x * \<bottom>) * y = x * \<bottom>"
  by (simp add: mult.assoc)

lemma gt_one_comp: "1 \<le> x \<Longrightarrow> y \<le> x * y"
  by (cut_tac x = 1 and y = x and z = y in le_comp_right, simp_all)

  theorem omega_comp_fix: "x ^ \<omega> * y = (x * (x ^ \<omega>) * y) \<sqinter> y"
  apply (subst omega_fix)
  by (simp add: inf_comp)

  theorem dual_star_fix: "x^\<otimes> = (x * (x^\<otimes>)) \<squnion> 1"
    by (metis dual_comp dual_dual dual_inf dual_one dual_star_def star_fix)

  theorem star_comp_fix: "x ^ * * y = (x * (x ^ *) * y) \<sqinter> y"
  apply (subst star_fix)
  by (simp add: inf_comp)

  theorem dual_star_comp_fix: "x^\<otimes> * y = (x * (x^\<otimes>) * y) \<squnion> y"
  apply (subst dual_star_fix)
  by (simp add: sup_comp)

  theorem dual_star_least: "(x * z) \<squnion> y \<le> z \<Longrightarrow> (x^\<otimes>) * y \<le> z"
    apply (subst dual_le)
    apply (simp add: dual_star_def dual_comp)
    apply (rule star_greatest)
    apply (subst dual_le)
    by (simp add: dual_inf dual_comp)

  lemma omega_one [simp]: "1 ^ \<omega> = \<bottom>"
    apply (rule antisym, simp_all)
    by (cut_tac x = "1::'a" and y = 1 and z = \<bottom> in omega_least, simp_all)

  lemma omega_mono: "x \<le> y \<Longrightarrow> x ^ \<omega> \<le> y ^ \<omega>"
    apply (cut_tac x = x and y = 1 and z = "y ^ \<omega>" in omega_least, simp_all)
    apply (subst (2) omega_fix, simp_all)
    apply (rule_tac y = "x * y ^ \<omega>" in order_trans, simp)
    by (rule le_comp_right, simp)
end

sublocale mbt_algebra < conjunctive "inf" "inf" "times"
done
sublocale mbt_algebra < disjunctive "sup" "sup" "times"
done

context mbt_algebra begin
lemma dual_conjunctive: "x \<in> conjunctive \<Longrightarrow> x ^ o \<in> disjunctive"
  apply (simp add: conjunctive_def disjunctive_def)
  apply safe
  apply (rule dual_eq)
  by (simp add: dual_comp dual_sup)

lemma dual_disjunctive: "x \<in> disjunctive \<Longrightarrow> x ^ o \<in> conjunctive"
  apply (simp add: conjunctive_def disjunctive_def)
  apply safe
  apply (rule dual_eq)
  by (simp add: dual_comp dual_inf)

lemma comp_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> x * y \<in> conjunctive"
  apply (subst conjunctive_def, safe)
  by (simp add: mult.assoc conjunctiveD)

lemma comp_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> x * y \<in> disjunctive"
  apply (subst disjunctive_def, safe)
  by (simp add: mult.assoc disjunctiveD)

lemma start_pres_conj: "x \<in> conjunctive \<Longrightarrow> (x ^ *) \<in> conjunctive"
  apply (subst conjunctive_def, safe)
  apply (rule antisym, simp_all)
  apply (metis inf_le1 inf_le2 le_comp)
  apply (rule star_greatest)
  apply (subst conjunctiveD, simp)
  apply (subst star_comp_fix)
  apply (subst star_comp_fix)
  by (metis inf.assoc inf_left_commute mult.assoc order_refl)

lemma dual_star_pres_disj: "x \<in> disjunctive \<Longrightarrow> x^\<otimes> \<in> disjunctive"
  apply (simp add: dual_star_def)
  apply (rule dual_conjunctive)
  apply (rule start_pres_conj)
  by (rule dual_disjunctive, simp)

subsection\<open>Assertions\<close>

text\<open>
Usually, in Kleene algebra with tests or in other progrm algebras, tests or assertions
or assumptions are defined using an existential quantifier. An element of the algebra
is a test if it has a complement with respect to $\bot$ and $1$. In this formalization
assertions can be defined much simpler using the dual operator.
\<close>

definition
   "assertion = {x . x \<le> 1 \<and> (x * \<top>) \<sqinter> (x ^ o) = x}"

lemma assertion_prop: "x \<in> assertion \<Longrightarrow> (x * \<top>) \<sqinter> 1 = x"
  apply (simp add: assertion_def)
  apply safe
  apply (rule antisym)
  apply simp_all
  proof -
    assume [simp]: "x \<le> 1"
    assume A: "x * \<top> \<sqinter> x ^ o = x"
    have "x * \<top> \<sqinter> 1 \<le> x * \<top> \<sqinter> x ^ o"
      apply simp
      apply (rule_tac y = 1 in order_trans)
      apply simp
      apply (subst dual_le)
      by simp
    also have "\<dots> = x" by (cut_tac A, simp)
    finally show "x * \<top> \<sqinter> 1 \<le> x" .
  next
    assume A: "x * \<top> \<sqinter> x ^ o = x"
    have "x = x * \<top> \<sqinter> x ^ o" by (simp add: A)
    also have "\<dots> \<le> x * \<top>" by simp
    finally show "x \<le> x * \<top>" .
  qed

lemma dual_assertion_prop: "x \<in> assertion \<Longrightarrow> ((x ^ o) * \<bottom>) \<squnion> 1 = x ^ o"
  apply (rule dual_eq)
  by (simp add: dual_sup dual_comp assertion_prop)

lemma assertion_disjunctive: "x \<in> assertion \<Longrightarrow> x \<in> disjunctive"
  apply (simp add: disjunctive_def, safe)
  apply (drule assertion_prop)
  proof -
    assume A: "x * \<top> \<sqinter> 1 = x"
    fix y z::"'a"
    have "x * (y \<squnion> z) = (x * \<top> \<sqinter> 1) * (y \<squnion> z)" by (cut_tac  A, simp)
    also have "\<dots> = (x * \<top>) \<sqinter> (y \<squnion> z)" by (simp add: inf_comp)
    also have "\<dots> = ((x * \<top>) \<sqinter> y) \<squnion> ((x * \<top>) \<sqinter> z)" by (simp add: inf_sup_distrib)
    also have "\<dots> = (((x * \<top>) \<sqinter> 1) * y) \<squnion> (((x * \<top>) \<sqinter> 1) * z)" by (simp add: inf_comp)
    also have "\<dots> = x * y \<squnion> x * z" by (cut_tac  A, simp)
    finally show "x * (y \<squnion> z) = x * y \<squnion> x * z" .
  qed

lemma Abs_MonoTran_injective: "mono x \<Longrightarrow> mono y \<Longrightarrow> Abs_MonoTran x = Abs_MonoTran y \<Longrightarrow> x = y"
  apply (subgoal_tac "Rep_MonoTran (Abs_MonoTran x) = Rep_MonoTran (Abs_MonoTran y)")
  apply (subst (asm) Abs_MonoTran_inverse, simp)
  by (subst (asm) Abs_MonoTran_inverse, simp_all)
end

lemma mbta_MonoTran_disjunctive: "Rep_MonoTran ` disjunctive = Apply.disjunctive"
  apply (simp add: disjunctive_def Apply.disjunctive_def)
  apply transfer
  apply auto
  proof -
    fix f :: "'a \<Rightarrow> 'a" and a b
    assume prem: "\<forall>y. mono y \<longrightarrow> (\<forall>z. mono z \<longrightarrow> f \<circ> y \<squnion> z = (f \<circ> y) \<squnion> (f \<circ> z))"
    { fix g h :: "'b \<Rightarrow> 'a"
      assume "mono g" and "mono h"
      then have "f \<circ> g \<squnion> h = (f \<circ> g) \<squnion> (f \<circ> h)"
        using prem by blast
    } note * = this
    assume "mono f"
    show "f (a \<squnion> b) = f a \<squnion> f b" (is "?P = ?Q")
    proof (rule order_antisym)
      show "?P \<le> ?Q"
        using * [of "\<lambda>_. a" "\<lambda>_. b"] by (simp add: comp_def fun_eq_iff)
    next
      from \<open>mono f\<close> show "?Q \<le> ?P" by (rule Lattices.semilattice_sup_class.mono_sup)
    qed
  next
    fix f :: "'a \<Rightarrow> 'a"
    assume "\<forall>y z. f (y \<squnion> z) = f y \<squnion> f z"
    then have *: "\<And>y z. f (y \<squnion> z) = f y \<squnion> f z" by blast
    show "mono f"
    proof
      fix a b :: 'a
      assume "a \<le> b"
      then show "f a \<le> f b"
        unfolding sup.order_iff * [symmetric] by simp
    qed
  qed

lemma assertion_MonoTran: "assertion = Abs_MonoTran ` assertion_fun"
    apply (safe)
    apply (subst assertion_fun_disj_less_one)
    apply (simp add: image_def)
    apply (rule_tac x = "Rep_MonoTran x" in bexI)
    apply (simp add: Rep_MonoTran_inverse)
    apply safe
    apply (drule assertion_disjunctive)
    apply (unfold mbta_MonoTran_disjunctive [THEN sym], simp)
    apply (simp add: assertion_def less_eq_MonoTran_def one_MonoTran_def Abs_MonoTran_inverse)
    apply (simp add: assertion_def)
    by (simp_all add: inf_MonoTran_def less_eq_MonoTran_def
      times_MonoTran_def dual_MonoTran_def top_MonoTran_def Abs_MonoTran_inverse one_MonoTran_def assertion_fun_dual)

context mbt_algebra begin
lemma assertion_conjunctive: "x \<in> assertion \<Longrightarrow> x \<in> conjunctive"
  apply (simp add: conjunctive_def, safe)
  apply (drule assertion_prop)
  proof -
    assume A: "x * \<top> \<sqinter> 1 = x"
    fix y z::"'a"
    have "x * (y \<sqinter> z) = (x * \<top> \<sqinter> 1) * (y \<sqinter> z)" by (cut_tac  A, simp)
    also have "\<dots> = (x * \<top>) \<sqinter> (y \<sqinter> z)" by (simp add: inf_comp)
    also have "\<dots> = ((x * \<top>) \<sqinter> y) \<sqinter> ((x * \<top>) \<sqinter> z)"
      apply (rule antisym, simp_all, safe)
      apply (rule_tac y = "y \<sqinter> z" in order_trans)
      apply (rule inf_le2)
      apply simp
      apply (rule_tac y = "y \<sqinter> z" in order_trans)
      apply (rule inf_le2)
      apply simp_all
      apply (simp add: inf_assoc)
      apply (rule_tac y = " x * \<top> \<sqinter> y" in order_trans)
      apply (rule inf_le1)
      apply simp
      apply (rule_tac y = " x * \<top> \<sqinter> z" in order_trans)
      apply (rule inf_le2)
      by simp
    also have "\<dots> = (((x * \<top>) \<sqinter> 1) * y) \<sqinter> (((x * \<top>) \<sqinter> 1) * z)" by (simp add: inf_comp)
    also have "\<dots> = (x * y) \<sqinter> (x * z)" by (cut_tac  A, simp)
    finally show "x * (y \<sqinter> z) = (x * y) \<sqinter> (x * z)" .
  qed

lemma dual_assertion_conjunctive: "x \<in> assertion \<Longrightarrow> x ^ o \<in> conjunctive"
  apply (drule assertion_disjunctive)
  by (rule dual_disjunctive, simp)

lemma dual_assertion_disjunct: "x \<in> assertion \<Longrightarrow> x ^ o \<in> disjunctive"
  apply (drule assertion_conjunctive)
  by (rule dual_conjunctive, simp)

lemma [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<sqinter> y \<le> x * y"
  apply (simp add: assertion_def, safe)
  proof -
  assume A: "x \<le> 1"
  assume B: "x * \<top> \<sqinter> x ^ o = x"
  assume C: "y \<le> 1"
  assume D: "y * \<top> \<sqinter> y ^ o = y"
  have "x \<sqinter> y = (x * \<top> \<sqinter> x ^ o) \<sqinter> (y * \<top> \<sqinter> y ^ o)" by (cut_tac B D, simp)
  also have "\<dots> \<le> (x * \<top>) \<sqinter> (((x^o) * (y * \<top>)) \<sqinter> ((x^o) * (y^o)))"
    apply (simp, safe)
      apply (rule_tac y = "x * \<top> \<sqinter> x ^ o" in order_trans)
      apply (rule inf_le1)
      apply simp
      apply (rule_tac y = "y * \<top>" in order_trans)
      apply (rule_tac y = "y * \<top> \<sqinter> y ^ o" in order_trans)
      apply (rule inf_le2)
      apply simp
      apply (rule gt_one_comp)
      apply (subst dual_le, simp add: A)
      apply (rule_tac y = "y ^ o" in order_trans)
      apply (rule_tac y = "y * \<top> \<sqinter> y ^ o" in order_trans)
      apply (rule inf_le2)
      apply simp
      apply (rule gt_one_comp)
      by (subst dual_le, simp add: A)
    also have "... = ((x * \<top>) \<sqinter> (x ^ o)) * ((y * \<top>) \<sqinter> (y ^ o))"
      apply (cut_tac x = x in dual_assertion_conjunctive)
      apply (cut_tac A, cut_tac B, simp add: assertion_def)
      by (simp add: inf_comp conjunctiveD)
    also have "... = x * y"
      by (cut_tac B, cut_tac D, simp)
    finally show "x \<sqinter> y \<le> x * y" .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> x * y \<le> y"
  by (unfold assertion_def, cut_tac x = x and y = 1 and z = y in le_comp_right, simp_all)

lemma [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x * y \<le> x"
  apply (subgoal_tac "x * y \<le> (x * \<top>) \<sqinter> (x ^ o)")
  apply (simp add: assertion_def)
  apply (simp, safe)
  apply (rule le_comp, simp)
  apply (rule_tac y = 1 in order_trans)
  apply (rule_tac y = y in order_trans)
  apply simp
  apply (simp add: assertion_def)
  by (subst dual_le, simp add: assertion_def)

lemma assertion_inf_comp_eq: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<sqinter> y = x * y"
  by (rule antisym, simp_all)

lemma one_right_assertion [simp]: "x \<in> assertion \<Longrightarrow> x * 1 = x"
  apply (drule assertion_prop)
  proof -
    assume A: "x * \<top> \<sqinter> 1 = x"
    have "x * 1 = (x * \<top> \<sqinter> 1) * 1" by (simp add: A)
    also have "\<dots> = x * \<top> \<sqinter> 1" by (simp add: inf_comp)
    also have "\<dots> = x" by (simp add: A)
    finally show ?thesis .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> x \<squnion> 1 = 1"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]: "x \<in> assertion \<Longrightarrow> 1 \<squnion> x = 1"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]: "x \<in> assertion \<Longrightarrow> x \<sqinter> 1 = x"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]: "x \<in> assertion \<Longrightarrow> 1 \<sqinter> x = x"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]:  "x \<in> assertion \<Longrightarrow> x \<le> x * \<top>"
  by (cut_tac x = 1 and y = \<top> and z = x in le_comp, simp_all)

lemma [simp]: "x \<in> assertion \<Longrightarrow> x \<le> 1"
  by (simp add: assertion_def)

definition
  "neg_assert (x::'a) = (x ^ o * \<bottom>) \<sqinter> 1"

lemma sup_uminus[simp]: "x \<in> assertion \<Longrightarrow> x \<squnion> neg_assert x = 1"
  apply (simp add: neg_assert_def)
  apply (simp add: sup_inf_distrib)
  apply (rule antisym, simp_all)
  apply (unfold assertion_def)
  apply safe
  apply (subst dual_le)
  apply (simp add: dual_sup dual_comp)
  apply (subst inf_commute)
  by simp

lemma inf_uminus[simp]: "x \<in> assertion \<Longrightarrow> x \<sqinter> neg_assert x = \<bottom>"
  apply (simp add: neg_assert_def)
  apply (rule antisym, simp_all)
  apply (rule_tac y = "x \<sqinter> (x ^ o * \<bottom>)" in order_trans)
  apply simp
  apply (rule_tac y = "x ^ o * \<bottom> \<sqinter> 1" in order_trans)
  apply (rule inf_le2)
  apply simp
  apply (rule_tac y = "(x * \<top>)  \<sqinter> (x ^ o * \<bottom>)" in order_trans)
  apply simp
  apply (rule_tac y = x in order_trans)
  apply simp_all
  by (simp add: dual_neg)

lemma uminus_assertion[simp]: "x \<in> assertion \<Longrightarrow> neg_assert x \<in> assertion"
  apply (subst assertion_def)
  apply (simp add: neg_assert_def)
  apply (simp add: inf_comp dual_inf dual_comp inf_sup_distrib)
  apply (subst inf_commute)
  by (simp add: dual_neg)

lemma uminus_uminus [simp]: "x \<in> assertion \<Longrightarrow> neg_assert (neg_assert x) = x"
  apply (simp add: neg_assert_def)
  by (simp add: dual_inf dual_comp sup_comp assertion_prop)

lemma dual_comp_neg [simp]: "x ^ o * y \<squnion> (neg_assert x) * \<top> = x ^ o * y"
  apply (simp add: neg_assert_def inf_comp)
  apply (rule antisym, simp_all)
  by (rule le_comp, simp)

lemma [simp]: "(neg_assert x) ^ o * y \<squnion> x * \<top> = (neg_assert x) ^ o * y"
  apply (simp add: neg_assert_def inf_comp dual_inf dual_comp sup_comp)
  by (rule antisym, simp_all)

lemma [simp]: " x * \<top> \<squnion> (neg_assert x) ^ o * y= (neg_assert x) ^ o * y"
  by (simp add: neg_assert_def inf_comp dual_inf dual_comp sup_comp)

lemma inf_assertion [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<sqinter> y \<in> assertion"
  apply (subst assertion_def)
  apply safe
  apply (rule_tac y = x in order_trans)
  apply simp_all
  apply (simp add: assertion_inf_comp_eq)
  proof -
    assume A: "x \<in> assertion"
    assume B: "y \<in> assertion"
    have C: "(x * \<top>) \<sqinter> (x ^ o) = x"
      by (cut_tac A, unfold assertion_def, simp)
    have D: "(y * \<top>) \<sqinter> (y ^ o) = y"
      by (cut_tac B, unfold assertion_def, simp)
    have "x * y = ((x * \<top>) \<sqinter> (x ^ o)) * ((y * \<top>) \<sqinter> (y ^ o))" by (simp add: C D)
    also have "\<dots> = x * \<top> \<sqinter> ((x ^ o) * ((y * \<top>) \<sqinter> (y ^ o)))" by (simp add: inf_comp)
    also have "\<dots> =  x * \<top> \<sqinter> ((x ^ o) * (y * \<top>)) \<sqinter> ((x ^ o) *(y ^ o))"
      by (cut_tac A, cut_tac x = x in dual_assertion_conjunctive, simp_all add: conjunctiveD inf_assoc)
    also have "\<dots> = (((x * \<top>) \<sqinter> (x ^ o)) * (y * \<top>)) \<sqinter> ((x ^ o) *(y ^ o))"
      by (simp add: inf_comp)
    also have "\<dots> = (x * y * \<top>)  \<sqinter> ((x * y) ^ o)" by (simp add: C mult.assoc dual_comp)
    finally show "(x * y * \<top>)  \<sqinter> ((x * y) ^ o) = x * y" by simp
  qed

lemma comp_assertion [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x * y \<in> assertion"
  by (subst assertion_inf_comp_eq [THEN sym], simp_all)

lemma sup_assertion [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<squnion> y \<in> assertion"
  apply (subst assertion_def)
  apply safe
  apply (unfold assertion_def)
  apply simp
  apply safe
  proof -
    assume [simp]: "x \<le> 1"
    assume [simp]: "y \<le> 1"
    assume A: "x * \<top> \<sqinter> x ^ o = x"
    assume B: "y * \<top> \<sqinter> y ^ o = y"
    have "(y * \<top>) \<sqinter> (x ^ o) \<sqinter> (y ^ o) = (x ^ o) \<sqinter> (y * \<top>) \<sqinter> (y ^ o)" by (simp add: inf_commute)
    also have "\<dots> = (x ^ o) \<sqinter> ((y * \<top>) \<sqinter> (y ^ o))" by (simp add: inf_assoc)
    also have "\<dots> = (x ^ o) \<sqinter> y" by (simp add: B)
    also have "\<dots> = y"
      apply (rule antisym, simp_all)
      apply (rule_tac y = 1 in order_trans)
      apply simp
      by (subst dual_le, simp)
    finally have [simp]: "(y * \<top>) \<sqinter> (x ^ o) \<sqinter> (y ^ o) = y" .
    have "x * \<top> \<sqinter> (x ^ o) \<sqinter> (y ^ o) = x \<sqinter> (y ^ o)"  by (simp add: A)
    also have "\<dots> = x"
      apply (rule antisym, simp_all)
      apply (rule_tac y = 1 in order_trans)
      apply simp
      by (subst dual_le, simp)
    finally have [simp]: "x * \<top> \<sqinter> (x ^ o) \<sqinter> (y ^ o) = x" .
    have "(x \<squnion> y) * \<top> \<sqinter> (x \<squnion> y) ^ o = (x * \<top> \<squnion> y * \<top>) \<sqinter> ((x ^ o) \<sqinter> (y ^ o))" by (simp add: sup_comp dual_sup)
    also have "\<dots> = x \<squnion> y" by (simp add: inf_sup_distrib inf_assoc [THEN sym])
    finally show "(x \<squnion> y) * \<top> \<sqinter> (x \<squnion> y) ^ o = x \<squnion> y" .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> x * x = x"
  by (simp add: assertion_inf_comp_eq [THEN sym])

lemma [simp]: "x \<in> assertion \<Longrightarrow> (x ^ o) * (x ^ o) = x ^ o"
  apply (rule dual_eq)
  by (simp add: dual_comp assertion_inf_comp_eq [THEN sym])

lemma [simp]: "x \<in> assertion \<Longrightarrow> x * (x ^ o) = x"
  proof -
    assume A: "x \<in> assertion"
    have B: "x * \<top> \<sqinter> (x ^ o) = x" by (cut_tac A, unfold assertion_def, simp)
    have "x * x ^ o = (x * \<top> \<sqinter> (x ^ o)) * x ^ o" by (simp add: B)
    also have "\<dots> = x * \<top> \<sqinter> (x ^ o)" by (cut_tac A, simp add: inf_comp)
    also have "\<dots> = x" by (simp add: B)
    finally show ?thesis .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> (x ^ o) * x = x ^ o"
  apply (rule dual_eq)
  by (simp add: dual_comp)

lemma [simp]: "\<bottom> \<in> assertion"
  by (unfold assertion_def, simp)

lemma [simp]: "1 \<in> assertion"
  by (unfold assertion_def, simp)

subsection \<open>Weakest precondition of true\<close>

definition
  "wpt x = (x * \<top>) \<sqinter> 1"

lemma wpt_is_assertion [simp]: "wpt x \<in> assertion"
  apply (unfold wpt_def assertion_def, safe)
  apply simp
  apply (simp add: inf_comp dual_inf dual_comp inf_sup_distrib)
  apply (rule antisym)
  by (simp_all add: dual_neg)

lemma wpt_comp: "(wpt x) * x = x"
  apply (simp add: wpt_def inf_comp)
  apply (rule antisym, simp_all)
  by (cut_tac x = 1 and y = \<top> and z = x in le_comp, simp_all)

lemma wpt_comp_2: "wpt (x * y) = wpt (x * (wpt y))"
  by (simp add: wpt_def inf_comp mult.assoc)

lemma wpt_assertion [simp]: "x \<in> assertion \<Longrightarrow> wpt x = x"
  by (simp add: wpt_def assertion_prop)

lemma wpt_le_assertion: "x \<in> assertion \<Longrightarrow> x * y = y \<Longrightarrow> wpt y \<le> x"
  apply (simp add: wpt_def)
  proof -
    assume A: "x \<in> assertion"
    assume B: "x * y = y"
    have "y * \<top> \<sqinter> 1 = x * (y * \<top>) \<sqinter> 1" by (simp add: B mult.assoc [THEN sym])
    also have "\<dots> \<le> x * \<top> \<sqinter> 1"
      apply simp
      apply (rule_tac y = "x * (y * \<top>)" in order_trans)
      apply simp_all
      by (rule le_comp, simp)
    also have "\<dots> = x" by (cut_tac A, simp add: assertion_prop)
    finally show "y * \<top> \<sqinter> 1 \<le> x" .
  qed

lemma wpt_choice: "wpt (x \<sqinter> y) = wpt x \<sqinter> wpt y"
  apply (simp add: wpt_def inf_comp)
  proof -
    have "x * \<top> \<sqinter> 1 \<sqinter> (y * \<top> \<sqinter> 1) = x * \<top> \<sqinter> ((y * \<top> \<sqinter> 1) \<sqinter> 1)" apply (subst inf_assoc) by (simp add: inf_commute)
    also have "... = x * \<top> \<sqinter> (y * \<top> \<sqinter> 1)" by (subst inf_assoc, simp)
    also have "... = (x * \<top>) \<sqinter> (y * \<top>) \<sqinter> 1" by (subst inf_assoc, simp)
    finally show "x * \<top> \<sqinter> (y * \<top>) \<sqinter> 1 = x * \<top> \<sqinter> 1 \<sqinter> (y * \<top> \<sqinter> 1)" by simp
  qed
end

context lattice begin
lemma [simp]: "x \<le> y \<Longrightarrow> x \<sqinter> y = x"
  by (simp add: inf_absorb1)
end

context mbt_algebra begin

lemma wpt_dual_assertion_comp: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> wpt ((x ^ o) * y) = (neg_assert x) \<squnion> y"
  apply (simp add: wpt_def neg_assert_def)
  proof -
    assume A: "x \<in> assertion"
    assume B: "y \<in> assertion"
    have C: "((x ^ o) * \<bottom>) \<squnion> 1 = x ^ o"
      by (rule dual_assertion_prop, rule A)
    have "x ^ o * y * \<top> \<sqinter> 1 = (((x ^ o) * \<bottom>) \<squnion> 1) * y * \<top> \<sqinter> 1" by (simp add: C)
    also have "\<dots> = ((x ^ o) * \<bottom> \<squnion> (y * \<top>)) \<sqinter> 1" by (simp add: sup_comp)
    also have "\<dots> = (((x ^ o) * \<bottom>) \<sqinter> 1) \<squnion> ((y * \<top>) \<sqinter> 1)" by (simp add: inf_sup_distrib2)
    also have "\<dots> = (((x ^ o) * \<bottom>) \<sqinter> 1) \<squnion> y" by (cut_tac B, drule assertion_prop, simp)
    finally show "x ^ o * y * \<top> \<sqinter> 1 = (((x ^ o) * \<bottom>) \<sqinter> 1) \<squnion> y" .
  qed

lemma le_comp_left_right: "x \<le> y \<Longrightarrow> u \<le> v \<Longrightarrow> x * u \<le> y * v"
  apply (rule_tac y = "x * v" in order_trans)
  apply (rule le_comp, simp)
  by (rule le_comp_right, simp)

lemma wpt_dual_assertion: "x \<in> assertion \<Longrightarrow> wpt (x ^ o) = 1"
  apply (simp add: wpt_def)
  apply (rule antisym)
  apply simp_all
  apply (cut_tac x = 1 and y = "x ^ o" and u = 1 and v = \<top> in le_comp_left_right)
  apply simp_all
  apply (subst dual_le)
  by simp

lemma assertion_commute: "x \<in> assertion \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> y * x = wpt(y * x) * y"
  apply (simp add: wpt_def)
  apply (simp add: inf_comp)
  apply (drule_tac x = y and y = "x * \<top>" and z = 1 in conjunctiveD)
  by (simp add: mult.assoc [THEN sym] assertion_prop)

lemma wpt_mono: "x \<le> y \<Longrightarrow> wpt x \<le> wpt y"
  apply (simp add: wpt_def)
  apply (rule_tac y = "x * \<top>" in order_trans, simp_all)
  by (rule le_comp_right, simp)

lemma "a \<in> conjunctive \<Longrightarrow> x * a \<le> a * y \<Longrightarrow> (x ^ \<omega>) * a \<le> a * (y ^ \<omega>)"
  apply (rule omega_least)
  apply (simp add: mult.assoc [THEN sym])
  apply (rule_tac y = "a * y * y ^ \<omega> \<sqinter> a" in order_trans)
  apply (simp)
  apply (rule_tac y = "x * a * y ^ \<omega>" in order_trans, simp_all)
  apply (rule le_comp_right, simp)
  apply (simp add: mult.assoc)
  apply (subst (2) omega_fix)
  by (simp add: conjunctiveD)

lemma [simp]: "x \<le> 1 \<Longrightarrow> y * x \<le> y"
  by (cut_tac x = x and y = 1 and z = y in le_comp, simp_all)

lemma [simp]: "x \<le> x * \<top>"
  by (cut_tac x = 1 and y = \<top> and z = x in le_comp, simp_all)

lemma [simp]: "x * \<bottom> \<le> x"
  by (cut_tac x = \<bottom> and y = 1 and z = x in le_comp, simp_all)

end

subsection\<open>Monotonic Boolean trasformers algebra with post condition statement\<close>

definition
  "post_fun (p::'a::order) q = (if p \<le> q then (\<top>::'b::{order_bot,order_top}) else \<bottom>)"

lemma mono_post_fun [simp]: "mono (post_fun (p::_::{order_bot,order_top}))"
  apply (simp add: post_fun_def mono_def, safe)
  apply (subgoal_tac "p \<le> y", simp)
  apply (rule_tac y = x in order_trans)
  apply simp_all
  done

lemma post_refin [simp]: "mono S \<Longrightarrow> ((S p)::'a::bounded_lattice) \<sqinter> (post_fun p) x \<le> S x"
  apply (simp add: le_fun_def assert_fun_def post_fun_def, safe)
  by (rule_tac f = S in monoD, simp_all)

class post_mbt_algebra = mbt_algebra +
  fixes post :: "'a \<Rightarrow> 'a"
  assumes post_1: "(post x) * x * \<top> = \<top>"
  and post_2: "y * x * \<top> \<sqinter> (post x) \<le> y"

instantiation MonoTran :: (complete_boolean_algebra) post_mbt_algebra
begin

lift_definition post_MonoTran :: "'a::complete_boolean_algebra MonoTran \<Rightarrow> 'a::complete_boolean_algebra MonoTran"
  is "\<lambda>x. post_fun (x \<top>)"
  by (rule mono_post_fun)

instance proof
  fix x :: "'a MonoTran" show "post x * x * \<top> = \<top>"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
  fix x y :: "'a MonoTran" show "y * x * \<top> \<sqinter> post x \<le> y"
    apply transfer
    apply (simp add: le_fun_def)
    done
qed

end

subsection\<open>Complete monotonic Boolean transformers algebra\<close>

class complete_mbt_algebra = post_mbt_algebra + complete_distrib_lattice +
  assumes Inf_comp: "(Inf X) * z = (INF x \<in> X . (x * z))"

instance MonoTran :: (complete_boolean_algebra) complete_mbt_algebra
  apply intro_classes
  apply transfer
  apply (simp add: Inf_comp_fun)
  done

context complete_mbt_algebra begin
lemma dual_Inf: "(Inf X) ^ o = (SUP x\<in> X . x ^ o)"
  apply (rule antisym)
  apply (subst dual_le, simp)
  apply (rule Inf_greatest)
  apply (subst dual_le, simp)
  apply (rule SUP_upper, simp)
  apply (rule SUP_least)
  apply (subst dual_le, simp)
  by (rule Inf_lower, simp)

lemma dual_Sup: "(Sup X) ^ o = (INF x\<in> X . x ^ o)"
  apply (rule antisym)
  apply (rule INF_greatest)
  apply (subst dual_le, simp)
  apply (rule Sup_upper, simp)
  apply (subst dual_le, simp)
  apply (rule Sup_least)
  apply (subst dual_le, simp)
  by (rule INF_lower, simp)

lemma INF_comp: "(\<Sqinter>(f ` A)) * z = (INF a \<in> A . (f a) * z)"
  unfolding Inf_comp
  apply (subgoal_tac "((\<lambda>x::'a. x * z) ` f ` A) = ((\<lambda>a::'b. f a * z) ` A)")
  by auto

lemma dual_INF: "(\<Sqinter>(f ` A)) ^ o = (SUP a \<in> A . (f a) ^ o)"
  unfolding Inf_comp dual_Inf
  apply (subgoal_tac "(dual ` f ` A) = ((\<lambda>a::'b. f a ^ o) ` A)")
  by auto

lemma dual_SUP: "(\<Squnion>(f ` A)) ^ o = (INF a \<in> A . (f a) ^ o)"
  unfolding dual_Sup
  apply (subgoal_tac "(dual ` f ` A) = ((\<lambda>a::'b. f a ^ o) ` A)")
  by auto

lemma Sup_comp: "(Sup X) * z = (SUP x \<in> X . (x * z))"
  apply (rule dual_eq)
  by (simp add: dual_comp dual_Sup dual_SUP INF_comp image_comp)

lemma SUP_comp: "(\<Squnion>(f ` A)) * z = (SUP a \<in> A . (f a) * z)"
  unfolding Sup_comp
  apply (subgoal_tac "((\<lambda>x::'a. x * z) ` f ` A) = ((\<lambda>a::'b. f a * z) ` A)")
  by auto

lemma Sup_assertion [simp]: "X \<subseteq> assertion \<Longrightarrow> Sup X \<in> assertion"
  apply (unfold assertion_def)
  apply safe
  apply (rule Sup_least)
  apply blast
  apply (simp add: Sup_comp dual_Sup Sup_inf)
  apply (subgoal_tac "((\<lambda>y . y \<sqinter> \<Sqinter>(dual ` X)) ` (\<lambda>x . x * \<top>) ` X) = X")
  apply simp
  proof -
    assume A: "X \<subseteq> {x. x \<le> 1 \<and> x * \<top> \<sqinter> x ^ o = x}"
    have B [simp]: "!! x . x \<in> X \<Longrightarrow>  x * \<top> \<sqinter> (\<Sqinter>(dual ` X)) = x"
    proof -
      fix x
      assume C: "x \<in> X"
      have "x * \<top> \<sqinter> \<Sqinter>(dual ` X) = x * \<top> \<sqinter> (x ^ o \<sqinter> \<Sqinter>(dual ` X))"
        apply (subgoal_tac "\<Sqinter>(dual ` X) = (x ^ o \<sqinter> \<Sqinter>(dual ` X))", simp)
        apply (rule antisym, simp_all)
        apply (rule Inf_lower, cut_tac C, simp)
        done
      also have "\<dots> = x \<sqinter> \<Sqinter>(dual ` X)" by (unfold  inf_assoc [THEN sym], cut_tac A, cut_tac C, auto)
      also have "\<dots> = x"
        apply (rule antisym, simp_all)
        apply (rule INF_greatest)
        apply (cut_tac A C)
        apply (rule_tac y = 1 in order_trans)
        apply auto[1]
        apply (subst dual_le, auto)
        done
      finally show "x * \<top> \<sqinter> \<Sqinter>(dual ` X) = x" .
      qed
      show "(\<lambda>y. y \<sqinter> \<Sqinter>(dual ` X)) ` (\<lambda>x . x * \<top>) ` X = X"
        by (simp add: image_comp)
    qed

lemma Sup_range_assertion [simp]: "(!!w . p w \<in> assertion) \<Longrightarrow> Sup (range p) \<in> assertion"
  by (rule Sup_assertion, auto)

lemma Sup_less_assertion [simp]: "(!!w . p w \<in> assertion) \<Longrightarrow> Sup_less p w \<in> assertion"
  by (unfold Sup_less_def, rule Sup_assertion, auto)

theorem omega_lfp:
  "x ^ \<omega> * y = lfp (\<lambda> z . (x * z) \<sqinter> y)"
  apply (rule antisym)
  apply (rule lfp_greatest)
  apply (drule omega_least, simp)
  apply (rule lfp_lowerbound)
  apply (subst (2) omega_fix)
  by (simp add: inf_comp mult.assoc)
end

lemma [simp]: "mono (\<lambda> (t::'a::mbt_algebra) . x * t \<sqinter> y)"
  apply (simp add: mono_def, safe)
  apply (rule_tac y = "x * xa" in order_trans, simp)
  by (rule le_comp, simp)

class mbt_algebra_fusion = mbt_algebra +
  assumes fusion: "(\<forall> t . x * t \<sqinter> y \<sqinter> z \<le> u * (t \<sqinter> z) \<sqinter> v)
          \<Longrightarrow> (x ^ \<omega>) * y \<sqinter> z \<le> (u ^ \<omega>) * v "

lemma
    "class.mbt_algebra_fusion (1::'a::complete_mbt_algebra) ((*)) (\<sqinter>) (\<le>) (<) (\<squnion>) dual dual_star omega star \<bottom> \<top>"
    apply unfold_locales
    apply (cut_tac h = "\<lambda> t . t \<sqinter> z" and f = "\<lambda> t . x * t \<sqinter> y" and g = "\<lambda> t . u * t \<sqinter> v" in weak_fusion)
    apply (rule inf_Disj)
    apply simp_all
    apply (simp add: le_fun_def)
    by  (simp add: omega_lfp)

context mbt_algebra_fusion
begin

lemma omega_pres_conj: "x \<in> conjunctive \<Longrightarrow> x ^ \<omega> \<in> conjunctive"
  apply (subst omega_star, simp)
  apply (rule comp_pres_conj)
  apply (rule assertion_conjunctive, simp)
  by (rule start_pres_conj, simp)
end

end


theory SVP_vec

imports BHLE

begin

text \<open>The reduction of SVP to CVP in $l_\infty$ norm\<close>

text \<open>The shortest vector problem.\<close>
definition is_shortest_vec :: "int_lattice  \<Rightarrow> int vec \<Rightarrow> bool" where
  "is_shortest_vec L v \<equiv> (is_lattice L) \<and> (\<forall>x\<in>L. \<parallel>x\<parallel>\<^sub>\<infinity> \<ge> \<parallel>v\<parallel>\<^sub>\<infinity> \<and> v\<in>L) "

text \<open>The decision problem associated with solving SVP exactly.\<close>
definition gap_svp :: "(int_lattice \<times> int) set" where
  "gap_svp \<equiv> {(L, r). (is_lattice L) \<and> (dim_lattice L \<ge> 2) \<and>
      (\<exists>v\<in>L. \<parallel>v\<parallel>\<^sub>\<infinity> \<le> r \<and> v \<noteq> 0\<^sub>v (dim_vec v))}"

text \<open>Generate a lattice to solve SVP for reduction\<close>

text \<open>Here, the factor K'' from the paper "Another NP-complete partition problem
  and the complexity of computing short vectors in a lattice" by Peter van Emde Boas
  was changed to be $2*\textbf{k}*(k+1)*\sum_i \textbf{|| a_i ||}$\<close>

(*Do we need absolute value for a_i in sum as well \<rightarrow> I think yes!*)

definition gen_svp_basis :: "int vec \<Rightarrow> int \<Rightarrow> int mat" where
  "gen_svp_basis a k = mat (dim_vec a + 1) (dim_vec a + 1)
    (\<lambda> (i, j). if (i < dim_vec a) \<and> (j< dim_vec a) then (if i = j then 1 else 0)
      else (if (i < dim_vec a) \<and> (j \<ge> dim_vec a) then 0
      else (if (i \<ge> dim_vec a) \<and> (j < dim_vec a) then (k+1) * (a $ j)
      else 2*k*(k+1)* (\<Sum> i \<in> {0 ..< dim_vec a}. \<bar>a $ i\<bar>) +1 )))"

text \<open>Reduction SVP to bounded homogeneous linear equation problem in $l_\infty$ norm.\<close>
definition reduce_svp_bhle:: "(int vec \<times> int) \<Rightarrow> (int_lattice \<times> int)" where
  "reduce_svp_bhle \<equiv> (\<lambda> (a, k). (gen_lattice (gen_svp_basis a k), k))"

text \<open>Lemmas for proof\<close>

lemma gen_svp_basis_mult:
  assumes "dim_vec z = dim_vec a + 1"
  shows "(gen_svp_basis a k) *\<^sub>v z = vec (dim_vec a + 1)
         (\<lambda>i. if i < dim_vec a then z$i else (k+1) * (\<Sum> i \<in> {0 ..< dim_vec a}. z $ i * a $ i) +
              (2*k*(k+1)* (\<Sum> i \<in> {0 ..< dim_vec a}. \<bar>a $ i\<bar>) +1) * (z$(dim_vec a)))"
using assms proof (subst vec_eq_iff, safe, goal_cases)
case 1
  then show ?case using assms unfolding gen_svp_basis_def by auto
next
case (2 i)
  then show ?case proof (cases "i<dim_vec a")
  case True
    have "{0..<dim_vec a} = insert i {0..<dim_vec a}" using True by auto
    then have "(\<Sum>ia = 0..<dim_vec a. (if i = ia then 1 else 0) * z $ ia) =
      (\<Sum>ia \<in> insert i {0..<dim_vec a}. (if i = ia then 1 else 0) * z $ ia)" by auto
    also have "\<dots> = z$i" by (subst sum.insert_remove, auto)
    finally have "(\<Sum>ia = 0..<dim_vec a. (if i = ia then 1 else 0) * z $ ia) = z $ i"
      by auto
    then show ?thesis unfolding mult_mat_vec_def gen_svp_basis_def scalar_prod_def
      using True assms by auto
  next
  case False
    then have "i = dim_vec a" using 2 by auto
    then show ?thesis unfolding gen_svp_basis_def using assms
      by (auto simp add: scalar_prod_def sum_distrib_left mult.commute mult.left_commute)
  qed
qed

lemma gen_svp_basis_mult_real:
  assumes "dim_vec z = dim_vec a + 1"
  shows "real_of_int_mat (gen_svp_basis a k) *\<^sub>v z = vec (dim_vec a + 1)
         (\<lambda>i. if i < dim_vec a then z$i else (k+1) * (\<Sum> i \<in> {0 ..< dim_vec a}. z $ i * a $ i) +
              (2*k*(k+1)* (\<Sum> i \<in> {0 ..< dim_vec a}. \<bar>a $ i\<bar>) +1) * (z$(dim_vec a)))"
using assms proof (subst vec_eq_iff, safe, goal_cases)
case 1
  then show ?case using assms unfolding gen_svp_basis_def by auto
next
case (2 i)
  then show ?case proof (cases "i<dim_vec a")
  case True
    have "{0..<dim_vec a} = insert i {0..<dim_vec a}" using True by auto
    then have "(\<Sum>ia = 0..<dim_vec a. (if i = ia then 1 else 0) * z $ ia) =
      (\<Sum>ia \<in> insert i {0..<dim_vec a}. (if i = ia then 1 else 0) * z $ ia)" by auto
    also have "\<dots> = z$i" by (subst sum.insert_remove, auto)
    finally have "(\<Sum>ia = 0..<dim_vec a. (if i = ia then 1 else 0) * z $ ia) = z $ i"
      by auto
    then have "(\<Sum>ia = 0..<dim_vec a. real_of_int (if i = ia then 1 else 0) * z $ ia) = z $ i"
      by (smt (verit, best) of_int_hom.hom_one of_int_hom.hom_zero sum.cong)
    then show ?thesis unfolding mult_mat_vec_def gen_svp_basis_def scalar_prod_def
      using True assms by auto
  next
  case False
    then have "i = dim_vec a" using 2 by auto
    then show ?thesis unfolding gen_svp_basis_def using assms
      by (auto simp add: scalar_prod_def sum_distrib_left mult.commute mult.left_commute)
  qed
qed

lemma gen_svp_basis_mult_last:
  assumes "dim_vec z = dim_vec a + 1"
  shows "((gen_svp_basis a k) *\<^sub>v z) $ (dim_vec a) =
         (k+1) * (\<Sum> i \<in> {0 ..< dim_vec a}. z $ i * a $ i) +
              (2*k*(k+1)* (\<Sum> i \<in> {0 ..< dim_vec a}. \<bar>a $ i\<bar>) +1) * (z$(dim_vec a))"
using gen_svp_basis_mult[OF assms] by auto

lemma is_indep_gen_svp_basis:
  assumes "k>0"
  shows "is_indep (real_of_int_mat (gen_svp_basis a k))"
unfolding is_indep_def
proof (safe, goal_cases)
case (1 z)
  have dim_row_dim_vec: "dim_row (gen_svp_basis a k) = dim_vec z"
    using 1 unfolding gen_svp_basis_def by auto
  then have suc_dim_a_dim_z: "dim_vec z = dim_vec a + 1" unfolding gen_svp_basis_def by auto
  have alt1: "(real_of_int_mat (gen_svp_basis a k) *\<^sub>v z) $ i = 0" if "i< dim_vec a +1"for i
    using 1(1) that unfolding gen_svp_basis_def by auto
  have z_upto_last: "z$i = 0" if "i < dim_vec a" for i
  proof -
    have elem: "(real_of_int_mat (gen_svp_basis a k) *\<^sub>v z) $ i = z $ i"
      using gen_svp_basis_mult_real[OF suc_dim_a_dim_z] that by auto
    show ?thesis by (subst elem[symmetric]) (use alt1[of i] that in \<open>auto\<close>)
  qed
  moreover have "z $ (dim_vec a) = 0"
  proof -
    have "0 = (real_of_int_mat (gen_svp_basis a k) *\<^sub>v z) $ (dim_vec a)" using alt1 by auto
    also have "\<dots> = (real_of_int k + 1) * (\<Sum>i = 0..<dim_vec a. z $ i * real_of_int (a $ i)) +
      (2 * real_of_int k * (real_of_int k + 1) * (\<Sum>x = 0..<dim_vec a. real_of_int (\<bar>a $ x\<bar>)) + 1) *
      z $ dim_vec a"
      using gen_svp_basis_mult_real[OF suc_dim_a_dim_z] by auto
    also have "\<dots> =  real_of_int (2 * k * (k + 1) *  (\<Sum>x = 0..<dim_vec a. \<bar>a $ x\<bar>)  + 1 ) * (z$dim_vec a)"
      using suc_dim_a_dim_z using z_upto_last by auto
    finally have "0 = real_of_int (2 * k * (k + 1) *  (\<Sum>x = 0..<dim_vec a. \<bar>a $ x\<bar>) + 1 ) *
                      (z$dim_vec a)" by blast
    moreover have "real_of_int (2 * k * (k + 1) *  (\<Sum>x = 0..<dim_vec a. \<bar>a $ x\<bar>) + 1 ) \<noteq> 0"
    proof (rule ccontr, goal_cases)
    case 1
      then have eq: "real_of_int (\<Sum>x = 0..<dim_vec a. \<bar>a $ x\<bar>) = - 1 / real_of_int (k * (k + 1))"
         using assms
         by (smt (verit, best) mult_minus_right of_int_hom.hom_0 pos_zmult_eq_1_iff
          pos_zmult_eq_1_iff_lemma)
      have "k\<ge>1" using assms by auto
      have "real_of_int (\<Sum>x = 0..<dim_vec a. \<bar>a $ x\<bar>) \<in> \<int>" by auto
      moreover have "- 1 / real_of_int (k * (k + 1)) \<notin> \<int>" using \<open>k\<ge>1\<close>
      by (smt (verit, del_insts) "1" linordered_semiring_strict_class.mult_pos_pos
        mult_minus_right of_int_hom.hom_0 pos_zmult_eq_1_iff)
      ultimately show False using eq by auto
    qed
(*Problems here when changing 2*(k+1) to k*(k+1).
  This is necessary since k'a only is smaller than k'' under the assumtion that z$i\<le>k, not z$i\<le>2.*)
    ultimately show ?thesis by auto
  qed
  ultimately have "z$i =  0" if "i < dim_vec z" for i using that suc_dim_a_dim_z
    by (metis discrete le_eq_less_or_eq verit_comp_simplify1(3))
  then show ?case by auto
qed

lemma insert_set_comprehension:
  "insert (f x) {f i |i. i<(x::nat)} = {f i | i. i<x+1}"
using less_SucE by fastforce

lemma bhle_k_pos:
  assumes "(a,k) \<in> bhle"
  shows "k>0"
using assms unfolding bhle_def
proof (safe, goal_cases)
case (1 v)
  have "\<exists>i<dim_vec v. \<bar>v $ i\<bar> > 0" using 1 by auto
  then have "\<parallel>v\<parallel>\<^sub>\<infinity> > 0" unfolding linf_norm_vec_Max using 1 by (subst Max_gr_iff, auto)
  then show ?thesis using 1 by auto
qed

lemma svp_k_pos:
  assumes "reduce_svp_bhle (a, k) \<in> gap_svp"
  shows "k>0"
proof -
  obtain v where v_in_lattice: "v\<in>gen_lattice (gen_svp_basis a k)"
    and infnorm_v: "\<parallel>v\<parallel>\<^sub>\<infinity> \<le> k"
    and v_nonzero:  "v \<noteq> 0\<^sub>v (dim_vec v)"
    using assms unfolding reduce_svp_bhle_def gap_svp_def by force
  have "\<exists> i < dim_vec v. \<bar>v $ i\<bar> > 0" using v_nonzero by auto
  then have "\<parallel>v\<parallel>\<^sub>\<infinity> > 0" unfolding linf_norm_vec_Max by (subst Max_gr_iff, auto)
  then show ?thesis using infnorm_v by auto
qed

lemma svp_dim_vec_a:
  assumes "reduce_svp_bhle (a, k) \<in> gap_svp"
  shows "dim_vec a > 0"
proof -
  have "2 \<le> dim_lattice (gen_lattice (gen_svp_basis a k))"
    using assms unfolding reduce_svp_bhle_def gap_svp_def by auto
  then have "2 \<le> dim_col (gen_svp_basis a k)"
    using dim_lattice_gen_lattice[of "gen_svp_basis a k",OF is_indep_gen_svp_basis]
      svp_k_pos[OF assms] by auto
  then show ?thesis unfolding gen_svp_basis_def by auto
qed

lemma bhle_dim_vec_a:
  assumes "(a, k) \<in> bhle"
  shows "dim_vec a > 0"
using assms unfolding bhle_def by auto

lemma first_lt_second:
  assumes "k>0" and z_le_k:"\<And>i. i< dim_vec a \<Longrightarrow> \<bar>z $ i\<bar> \<le> k"
  shows "2 * \<bar>(k + 1) * (\<Sum>i = 0..<dim_vec a. z $ i * a $ i)\<bar>
      < (\<bar>2 * k * (k + 1) * (\<Sum>i = 0..<dim_vec a. \<bar>a $ i\<bar>) + 1\<bar>::int)"
proof -
  have take_k1_out: "\<bar>(k + 1) * (\<Sum>i = 0..<dim_vec a. z $ i * a $ i)\<bar> =
    (k+1) * \<bar>\<Sum>i=0..<dim_vec a. z $ i * a $ i\<bar>"
    using \<open>k>0\<close> by (smt (verit, best) mult_minus_right mult_nonneg_nonneg)
  have "\<bar>\<Sum>i = 0..<dim_vec a. z $ i * a $ i\<bar> \<le> (\<Sum>i = 0..<dim_vec a. \<bar>z $ i * a $ i\<bar>)"
    by (subst sum_abs[of "(\<lambda>i. z$i * a$i)" "{0..<dim_vec a}"],simp)
  also have "\<dots> = (\<Sum>i=0..<dim_vec a. \<bar>z $ i\<bar> * \<bar>a $ i\<bar>)"
    by (meson abs_mult)
  also have "\<dots> \<le> (\<Sum>i=0..<dim_vec a.  k * \<bar>a $ i\<bar>)"
    by (subst sum_mono) (auto simp add: z_le_k mult_right_mono)
  also have "\<dots> = k * (\<Sum>i=0..<dim_vec a. \<bar>a $ i\<bar>)"
  by (metis mult_hom.hom_sum)
  finally have "\<bar>(\<Sum>i=0..<dim_vec a. z $ i * a $ i)\<bar> \<le> k * (\<Sum>i=0..<dim_vec a. \<bar>a $ i\<bar>)"
    by blast
  then show ?thesis using take_k1_out using \<open>0 < k\<close> by auto
qed

text \<open>Well-definedness of reduction function\<close>

lemma well_defined_reduction_svp:
  assumes "(a,k) \<in> bhle"
  shows "reduce_svp_bhle (a,k) \<in> gap_svp"
using assms unfolding reduce_svp_bhle_def gap_svp_def bhle_def
proof (safe, goal_cases)
  case (1 x)
  have "k>0" using assms bhle_k_pos by auto
  then show ?case using is_lattice_gen_lattice is_indep_gen_svp_basis by auto
next
  case (2 x)
  have "dim_lattice (gen_lattice (gen_svp_basis a k)) = dim_col (gen_svp_basis a k)"
    using dim_lattice_gen_lattice assms bhle_k_pos is_indep_gen_svp_basis by presburger
  also have "\<dots> =  dim_vec a + 1" unfolding gen_svp_basis_def by auto
  also have "\<dots> \<ge> 2" using bhle_dim_vec_a[OF assms] by auto
  finally show ?case by auto
next
  case (3 x)
  let ?x = "vec (dim_vec x + 1) (\<lambda>i. if i< dim_vec x then x$i else 0)"
  define v where "v = (gen_svp_basis a k) *\<^sub>v ?x"
  have eigen_v: "v = ?x" unfolding v_def
  proof (subst gen_svp_basis_mult[where a= a and k=k and z=" ?x"],
         auto simp add: 3(2) comp_def, subst vec_eq_iff,
         auto simp add: 3(1) scalar_prod_def, goal_cases one two)
    case (one i)
    then show ?case by (auto simp add: comp_def 3(2))
  next
    case (two i)
    have "(\<Sum>i = 0..<dim_vec a. (x $ i) * (a $ i)) = 0"
      using 3 unfolding scalar_prod_def
      by (smt (verit) mult.commute of_int_hom.hom_zero of_int_mult of_int_sum sum.cong)
    then show ?case using 3 by auto
  qed
  have "dim_vec ?x = dim_col (gen_svp_basis a k)"
    using 3(2) unfolding gen_svp_basis_def by auto
  then have "v \<in> gen_lattice (gen_svp_basis a k)"
    unfolding v_def gen_lattice_def by auto
  moreover have "\<parallel>v\<parallel>\<^sub>\<infinity> \<le> k"
  proof -
    have "\<parallel>v\<parallel>\<^sub>\<infinity> \<le> \<parallel>x\<parallel>\<^sub>\<infinity>"
    proof (subst eigen_v, subst linf_norm_vec_Max,subst linf_norm_vec_Max, subst Max.boundedI,
      goal_cases _ _ three)
    case (three b)
      have dim_x_nonzero: "dim_vec x \<noteq> 0" using 3(3) 3(2) by auto
      then have nonempty: "(\<exists>a\<in>{\<bar>x $ i\<bar> |i. i < dim_vec x}. 0 \<le> a)"
        using abs_ge_zero by blast
      have " \<bar>x $ i\<bar> \<le> Max (insert 0 {\<bar>x $ j\<bar> |j. j < dim_vec x})"
        if "i < dim_vec x" for i
      using that by (subst Max_ge, auto)
      moreover have "0 \<le> Max (insert 0 {\<bar>x $ i\<bar> |i. i < dim_vec x})" using 3 nonempty
        by (subst Max_ge_iff, auto)
      ultimately show ?case using three by auto
    qed auto
    then show ?thesis using 3 by auto
  qed
  moreover have "v \<noteq> 0\<^sub>v (dim_vec v)" using 3(3)
  proof (safe)
    assume "0 < dim_vec a"
    assume "v = 0\<^sub>v (dim_vec v)"
    have fst: "x \<noteq> 0\<^sub>v (dim_vec x)" using 3(4) by blast
    have snd: "?x = 0\<^sub>v (dim_vec v)" using \<open>v = 0\<^sub>v (dim_vec v)\<close>  eigen_v by auto
    have "x$i = 0" if "i< dim_vec x" for i using snd
    by (smt (z3) add.commute dim_vec eigen_v index_map_vec(2) index_vec index_zero_vec(1)
      of_int_eq_iff of_int_hom.hom_zero that
      trans_less_add2)
  then show False using fst by auto
  qed
  ultimately show ?case by blast
qed

text \<open>NP-hardness of reduction function\<close>

lemma NP_hardness_reduction_svp:
  assumes "reduce_svp_bhle (a,k) \<in> gap_svp"
  shows "(a,k) \<in> bhle"
proof (cases "(\<Sum>i<dim_vec a. a$i) = 0")
  case True
  have a_nonempty: "dim_vec a > 0" using svp_dim_vec_a[OF assms] by auto
  have "k>0" using svp_k_pos[OF assms] by auto
  define x where "x = vec (dim_vec a) (\<lambda>i. k)"
  have "a \<bullet> x = 0" unfolding x_def scalar_prod_def
  by (auto simp add: True sum_distrib_right[symmetric])
     (metis True lessThan_atLeast0)
  moreover have "dim_vec x = dim_vec a" unfolding x_def by auto
  moreover have "x \<noteq> 0\<^sub>v (dim_vec x)"
  proof -
    have "\<exists>i< dim_vec x. x $ i \<noteq> 0" unfolding x_def using \<open>k>0\<close> a_nonempty by auto
    then show ?thesis using vec_eq_iff[of "x" "0\<^sub>v (dim_vec x)"] by auto
  qed
  moreover have "real_of_int (\<parallel>x\<parallel>\<^sub>\<infinity>) \<le> k"
  proof -
    have "vec (dim_vec a) (\<lambda>i. k) $ j = k" if "j < dim_vec a" for j using that by auto
    then have "Max {\<bar>vec (dim_vec a) (\<lambda>i. k) $ i\<bar> |i. i < dim_vec a} =
               Max {\<bar>k\<bar> |i. i < dim_vec a}" by metis
    also have "\<dots> = Max {k}" using \<open>k>0\<close> a_nonempty
      by (smt (verit, best) Collect_cong singleton_conv)
    also have "\<dots> = k" by auto
    finally have "Max {\<bar>vec (dim_vec a) (\<lambda>i. k) $ i\<bar> |i. i < dim_vec a} = k" by blast
    then show ?thesis unfolding x_def linf_norm_vec_Max using \<open>k>0\<close> by auto
  qed
  ultimately show ?thesis using assms unfolding reduce_svp_bhle_def gap_svp_def bhle_def
    by fastforce
next
  case False
  show ?thesis using assms unfolding reduce_svp_bhle_def gap_svp_def bhle_def
  proof (safe, goal_cases)
    case (1 v)
    have a_nonempty: "dim_vec a > 0" using svp_dim_vec_a[OF assms] by auto
    have "k>0"  unfolding linf_norm_vec_Max
    proof -
      have "\<exists>i<dim_vec v. \<bar>v $ i\<bar> > 0" using 1 by auto
      then have "\<parallel>v\<parallel>\<^sub>\<infinity> > 0" unfolding linf_norm_vec_Max by (subst Max_gr_iff, auto)
      then show ?thesis using 1 by auto
    qed
    then have "k\<ge>1" by auto
    obtain z where z_def:
      "v = (gen_svp_basis a k) *\<^sub>v  z"
      "dim_vec z = dim_vec a + 1"
      using 1 unfolding gen_lattice_def gen_svp_basis_def by auto
    have dim_v_dim_a:"dim_vec v = dim_vec a + 1"
      using 1 unfolding gen_lattice_def gen_svp_basis_def by auto
    define x where "x = vec (dim_vec a) (($) z)"
    have v_eq_z_upto_last: "v $ i = z $ i" if "i< dim_vec a" for i
      by (subst z_def) (subst gen_svp_basis_mult; use that z_def in \<open>auto\<close>)
    have v_le_k: "\<bar>v $ i\<bar> \<le> k" if "i< dim_vec a + 1" for i
      using 1 dim_v_dim_a that unfolding linf_norm_vec_Max
      using Max_le_iff[of "{\<bar>v $ i\<bar> |i. i < dim_vec v}" k]
      by fastforce
    then have z_le_k: "\<bar>z $ i\<bar> \<le> k" if "i< dim_vec a" for i
      using v_eq_z_upto_last[OF that] that
      by (metis less_add_one less_trans)

    have v_last_zero: "v$(dim_vec a) = 0"
    proof (rule ccontr)
      assume ccontr_assms:"v $ dim_vec a \<noteq> 0"
      have v_last: "v$(dim_vec a) =
        (k+1) * (\<Sum>i = 0..<dim_vec a. z $ i * a $ i) +
        (2*k*(k+1) * (\<Sum>x = 0..<dim_vec a. \<bar>a $ x\<bar>) + 1) * (z $ dim_vec a) "
        (is "v$(dim_vec a) = ?first + ?second")
      by (subst z_def(1), subst gen_svp_basis_mult_last, use z_def  in \<open>auto\<close>)
      then have "?first \<noteq> 0 \<or> ?second \<noteq> 0"
        using ccontr_assms by auto
      then consider
        (first) "?first \<noteq> 0 \<and> ?second = 0" |
        (second) "?second \<noteq> 0 \<and> ?first = 0" |
        (both) "?first \<noteq> 0 \<and> ?second \<noteq> 0"
        by blast
      then show False
      proof (cases)
        case first
        then have gr_1: "\<bar>\<Sum>i = 0..<dim_vec a. z $ i * a $ i\<bar> \<ge> 1"
          using \<open>k>0\<close> by auto
        have "\<bar>v$ dim_vec a\<bar> = \<bar>?first\<bar>" using first v_last by auto
        also have "\<dots> = (k+1) * \<bar>\<Sum>i = 0..<dim_vec a. z $ i * a $ i\<bar>"
          using \<open>k>0\<close>
          by (smt (z3) mult_le_0_iff mult_minus_right)
        also have "\<dots> > k" using first gr_1 \<open>k>0\<close>
        by (smt (verit, best) mult_le_cancel_left1)
        finally have "\<bar>v$ dim_vec a\<bar> > k" by auto
        then show ?thesis using v_le_k[of "dim_vec a"] by auto
      next
        case second
        have "\<bar>z $ dim_vec a\<bar> \<ge> 1" using second by auto
        have sum_a_ge_1:"(\<Sum>x<dim_vec a. \<bar>a $ x\<bar>) \<ge>1"
          using False atLeast0LessThan
          by (metis abs_sum_abs int_one_le_iff_zero_less not_less sum_abs zero_less_abs_iff)
        then have "2*k*(k+1)*(\<Sum>x<dim_vec a. \<bar>a $ x\<bar>) + 1 > k"
        proof -
          have "2*(k+1)*(\<Sum>x<dim_vec a. \<bar>a $ x\<bar>)\<ge>1" using \<open>k>0\<close>
            by (smt (verit, ccfv_SIG) int_distrib(2) sum_a_ge_1 zmult_zless_mono2)
          then show ?thesis using \<open>k>0\<close>
            by (smt (verit, best) pos_mult_pos_ge sum_a_ge_1)
        qed
        moreover have "\<bar>?second\<bar> \<ge> \<bar>2*k*(k+1)*(\<Sum>x<dim_vec a. \<bar>a $ x\<bar>) + 1\<bar>"
          using \<open>\<bar>z $ dim_vec a\<bar> \<ge> 1\<close>
          by (subst abs_mult) (simp add: lessThan_atLeast0 mult_le_cancel_left1)
        ultimately have "\<bar>v $ dim_vec a\<bar> > k" using second v_last by linarith
        then show ?thesis using v_le_k[of "dim_vec a"] by auto
      next
        case both
        have z_gr_one:"\<bar>real_of_int (z$dim_vec a)\<bar>\<ge>1" using both by auto
        let ?second' = "2 * k * (k + 1) * (\<Sum>i=0..<dim_vec a. \<bar>a $ i\<bar>) + 1"
        have "(\<Sum>i = 0..<dim_vec a. z $ i * a $ i) \<noteq> 0" using both by auto
        then have one: "k < \<bar>?first\<bar>"
          by (smt (z3) mult_less_cancel_left2 mult_minus_right)
        then have first_nonzero: "\<bar>?first\<bar> \<noteq> 0" using \<open>k>0\<close> by auto
        have two'':"2 * \<bar>?first\<bar> < \<bar>?second'\<bar>"
          using first_lt_second[OF \<open>k>0\<close> z_le_k] by auto
        then have two': "\<bar>real_of_int ?second'  / real_of_int ?first\<bar> > 2"
        proof -
          have "0<real_of_int \<bar>?first\<bar>" using first_nonzero by presburger
          have "2 * real_of_int \<bar>?first\<bar> < real_of_int \<bar>?second'\<bar>" using two'' by linarith
          then have "2 <  real_of_int \<bar>?second'\<bar> / real_of_int \<bar>?first\<bar>"
            by (subst pos_less_divide_eq[OF \<open>0<real_of_int \<bar>?first\<bar>\<close>], auto)
          also have "\<dots> = \<bar>real_of_int ?second' / real_of_int ?first\<bar>" by simp
          finally show ?thesis by presburger
        qed
        then have two:"\<bar>(real_of_int ?second'  / real_of_int ?first) *
            real_of_int (z$dim_vec a)\<bar> > 2"
        proof -
          have "\<bar>(real_of_int ?second'  / real_of_int ?first) *
            real_of_int (z$dim_vec a)\<bar> = \<bar>real_of_int ?second'  / real_of_int ?first\<bar> *
            \<bar>real_of_int (z$dim_vec a)\<bar>" by (subst abs_mult, auto)
          also have ineq: "\<dots> \<ge> \<bar>real_of_int ?second'  / real_of_int ?first\<bar>"
            using z_gr_one by (smt (z3) mult_less_cancel_left2)
          finally have "\<bar>(real_of_int ?second'  / real_of_int ?first) *
            real_of_int (z$dim_vec a)\<bar>\<ge> \<bar>real_of_int ?second'  / real_of_int ?first\<bar>" by blast
          then show ?thesis using two' by linarith
        qed
        have "real_of_int \<bar>v $ dim_vec a\<bar> / real_of_int \<bar>?first\<bar> \<ge> 1"
        proof -
          have "real_of_int \<bar>v $ dim_vec a\<bar> / real_of_int \<bar>?first\<bar> =
            \<bar>real_of_int (v $ dim_vec a)\<bar> / \<bar>real_of_int ?first\<bar>"
            using of_int_abs[of "v $ dim_vec a"] of_int_abs[of "?first"] by auto
          also have "\<dots> = \<bar>real_of_int (v $ dim_vec a) / real_of_int ?first\<bar>"
            using abs_divide[symmetric] by auto
          also have "\<dots> = \<bar>(real_of_int ?first + real_of_int ?second' * real_of_int (z$dim_vec a)) /
            real_of_int ?first\<bar>" using v_last by auto
          also have "\<dots> = \<bar>real_of_int ?first / real_of_int ?first +
            (real_of_int ?second'  / real_of_int ?first)* real_of_int (z$dim_vec a)\<bar>"
            by (metis (no_types, lifting) add_divide_distrib times_divide_eq_left)
          also have "\<dots> = \<bar>1 + (real_of_int ?second'  / real_of_int ?first) *
            real_of_int (z$dim_vec a)\<bar>"
            using first_nonzero by (smt (verit, del_insts) of_int_eq_0_iff one_eq_divide_iff)
          also have "\<dots> \<ge> 1" using two by linarith
          finally show "real_of_int \<bar>v $ dim_vec a\<bar> / real_of_int \<bar>?first\<bar> \<ge> 1" by blast
        qed
        then have "real_of_int \<bar>v $ dim_vec a\<bar> \<ge> real_of_int \<bar>?first\<bar>"
          by (simp add: le_divide_eq_1)
        then have "\<bar>v $ dim_vec a\<bar> \<ge> \<bar>?first\<bar>" using of_int_le_iff by blast
        then have "\<bar>v $ dim_vec a\<bar> > k" using one by auto
        then show ?thesis using v_le_k[of "dim_vec a"] by auto
      qed
    qed
    have z_last_zero: "z$dim_vec a = 0"
    proof (rule ccontr)
      assume ccontr_assms:"z $ dim_vec a \<noteq> 0"
      then have "\<bar>z $ dim_vec a\<bar> \<ge> 1" by auto
      have "(k+1) * (\<Sum> i \<in> {0 ..< dim_vec a}. z $ i * a $ i) +
        (2*k*(k+1)* (\<Sum> i \<in> {0 ..< dim_vec a}. \<bar>a $ i\<bar>) +1) * (z$(dim_vec a)) = 0"
        (is "?first + ?second * (z$(dim_vec a)) = 0")
        using v_last_zero z_def gen_svp_basis_mult_last by auto
      then have abs_eq: "\<bar>?first\<bar> = \<bar>?second * (z$(dim_vec a))\<bar>" by linarith
      moreover have "\<bar>?first\<bar> < \<bar>?second * (z$(dim_vec a))\<bar>"
      proof -
        have "\<bar>?first\<bar> \<le> 2*\<bar>?first\<bar>" by auto
        then have "\<bar>?first\<bar> < \<bar>?second\<bar>" using first_lt_second[OF \<open>k>0\<close> z_le_k, of a] by auto
        moreover have "\<bar>?second\<bar> \<le> \<bar>?second\<bar>*\<bar>z$dim_vec a\<bar>"
          using \<open>\<bar>z $ dim_vec a\<bar> \<ge> 1\<close> by (simp add: mult_le_cancel_left1)
        ultimately have "\<bar>?first\<bar> < \<bar>?second\<bar>*\<bar>z$dim_vec a\<bar>" by linarith
        then show ?thesis by linarith
      qed
      ultimately show False by auto
    qed

    have v_real_z: "v = z" using v_eq_z_upto_last v_last_zero z_last_zero
      by (metis Suc_eq_plus1 dim_v_dim_a less_Suc_eq vec_eq_iff z_def(2))

    have "a \<bullet> x = 0"
    proof -
      have "0 = ((gen_svp_basis a k) *\<^sub>v  z) $ (dim_vec a)"
        using v_last_zero z_def by auto
      also have "\<dots> = (k+1) * (\<Sum> i \<in> {0 ..< dim_vec a}. z $ i * a $ i)"
        by (subst gen_svp_basis_mult, auto simp add: z_def z_last_zero)
      finally have zero: "(k+1) * (\<Sum> i \<in> {0 ..< dim_vec a}. z $ i * a $ i) = 0" by auto
      then show ?thesis unfolding scalar_prod_def using x_def \<open>k>0\<close>
      by (smt (verit, ccfv_SIG) atLeastLessThan_iff dim_vec index_vec mult.commute
         mult_eq_0_iff of_int_hom.hom_0 sum.cong)
    qed
    moreover have "dim_vec x = dim_vec a" unfolding x_def by auto
    moreover have "x \<noteq> 0\<^sub>v (dim_vec x)"
    proof -
      have "\<exists>i< dim_vec a + 1. v$i \<noteq> 0" using 1 unfolding gen_lattice_def gen_svp_basis_def by auto
      then have "\<exists>i< dim_vec a. v$i \<noteq> 0" using v_last_zero
        by (metis add_le_cancel_right discrete nat_less_le)
      then obtain i where "i<dim_vec a" "v$i\<noteq>0" by blast
      then have "z$i \<noteq> 0" using v_real_z z_def
        by (auto)
      then have "\<exists>i< dim_vec a. x$i \<noteq> 0" using x_def \<open>i<dim_vec a\<close> by auto
      then show ?thesis using x_def by auto
    qed
    moreover have "\<parallel>x\<parallel>\<^sub>\<infinity> \<le> k"
    proof -
      have "\<bar>z$i\<bar> = \<bar>vec (dim_vec a) (($) z) $ i\<bar>" if "i < dim_vec a" for i using that by auto
      then have "Max (insert 0 {\<bar>vec (dim_vec a) (($) z) $ i\<bar> |i. i < dim_vec a}) =
            Max (insert 0 {\<bar>z $ i\<bar> |i. i < dim_vec a})"
        by (smt (z3) Collect_cong Setcompr_eq_image mem_Collect_eq)
      also have "\<dots> = Max (insert 0 {\<bar>z $ i\<bar> |i. i < dim_vec a + 1})"
      proof -
        have "Max (insert 0 {\<bar>z $ i\<bar> |i. i < dim_vec a}) =
          Max (insert 0 (insert ( \<bar>z$dim_vec a\<bar>) {\<bar>z $ i\<bar> |i. i < dim_vec a}))"
        proof -
          have "Max {\<bar>z $ i\<bar> |i. i < dim_vec a} \<ge> 0"
            using \<open>dim_vec a >0\<close> by (subst Max_ge_iff, auto)
          then have "Max {\<bar>z $ i\<bar> |i. i < dim_vec a} \<ge> \<bar>z$dim_vec a\<bar>"
            using z_last_zero by simp
          then have max_subst: "Max {\<bar>z $ i\<bar> |i. i < dim_vec a} =
              Max (insert \<bar>z $ dim_vec a\<bar> {\<bar>z $ i\<bar> |i. i < dim_vec a})"
            using \<open>dim_vec a > 0\<close> by (subst Max_insert)+ (auto)
          then show ?thesis using \<open>dim_vec a > 0\<close> by (subst Max_insert)+ (auto)
        qed
        then show ?thesis
          using insert_set_comprehension[of "(\<lambda>i. \<bar>z $ i\<bar>)" "dim_vec a"] by auto
      qed
      finally have "Max (insert 0 {\<bar>vec (dim_vec a) (($) z) $ i\<bar> |i. i < dim_vec a}) =
                    Max (insert 0 {\<bar>z $ i\<bar> |i. i < dim_vec a +1})"
        by blast
      then have "\<parallel>x\<parallel>\<^sub>\<infinity> = \<parallel>v\<parallel>\<^sub>\<infinity>" unfolding linf_norm_vec_Max
        using x_def z_def v_real_z  by auto
      then show ?thesis using 1 by auto
    qed
    ultimately show ?case by force
  qed
qed

text \<open>The Gap-SVP is NP-hard.\<close>
lemma "is_reduction reduce_svp_bhle bhle gap_svp"
unfolding is_reduction_def
proof (safe, goal_cases)
  case (1 as s)
  then show ?case using well_defined_reduction_svp by auto
next
  case (2 as s)
  then show ?case using NP_hardness_reduction_svp by auto
qed

end