(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Tests\<close>

theory Relation_Algebra_Tests
  imports Relation_Algebra
begin

subsection \<open>Tests\<close>

text \<open>Tests or subidentities provide another way of modelling sets. Once more
we prove the basic properties, most of which stem from Maddux's book.\<close>

context relation_algebra
begin

definition is_test :: "'a \<Rightarrow> bool"
  where "is_test x \<equiv> x \<le> 1'"

lemma test_conv: "is_test x \<Longrightarrow> is_test (x\<^sup>\<smile>)"
by (metis conv_e conv_iso is_test_def)

lemma test_conv_var: "is_test x \<Longrightarrow> x\<^sup>\<smile> \<le> 1'"
by (metis test_conv is_test_def)

lemma test_eq_conv [simp]: "is_test x \<Longrightarrow> x\<^sup>\<smile> = x"
proof (rule order.antisym)
  assume hyp: "is_test x"
  hence "x \<le> x ; (1' \<cdot> x\<^sup>\<smile> ; 1')"
    by (metis inf.commute inf_absorb2 inf_le2 modular_1' mult.right_neutral is_test_def)
  thus "x \<le> x\<^sup>\<smile>"
    by (metis comp_unitr conv_contrav conv_invol order.eq_iff hyp inf_absorb2 mult_subdistl test_conv_var)
  thus "x\<^sup>\<smile> \<le> x"
    by (metis conv_invol conv_times le_iff_inf)
qed

lemma test_sum: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x + y)"
by (simp add: is_test_def)

lemma test_prod: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x \<cdot> y)"
by (metis le_infI2 is_test_def)

lemma test_comp: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x ; y)"
by (metis mult_isol comp_unitr order_trans is_test_def)

lemma test_comp_eq_mult:
  assumes "is_test x"
    and "is_test y"
  shows "x ; y = x \<cdot> y"
proof (rule order.antisym)
  show "x ; y \<le> x \<cdot> y"
    by (metis assms comp_unitr inf_absorb2 le_inf_iff mult_onel mult_subdistl mult_subdistr is_test_def)
next
  have "x \<cdot> y \<le> x ; (1' \<cdot> x\<^sup>\<smile> ; y)"
    by (metis comp_unitr modular_1_var)
  thus "x \<cdot> y \<le> x ; y"
    by (metis assms(1) inf_absorb2 le_infI2 mult.left_neutral mult_isol mult_subdistr order_trans test_eq_conv is_test_def)
qed

lemma test_1 [simp]: "is_test x \<Longrightarrow> x ; 1 \<cdot> y = x ; y"
by (metis inf.commute inf.idem inf_absorb2 mult.left_neutral one_conv ra_1 test_comp_eq_mult test_eq_conv is_test_def)

lemma maddux_32 [simp]: "is_test x \<Longrightarrow> -(x ; 1) \<cdot> 1' = -x \<cdot> 1'"
proof (rule order.antisym)
  assume "is_test x"
  show "-(x ; 1) \<cdot> 1' \<le> -x \<cdot> 1'"
    by (metis maddux_20 comp_anti inf.commute meet_isor)
next
  assume "is_test x"
  have one: "x ; 1 \<cdot> (-x \<cdot> 1') \<le> x ; x\<^sup>\<smile> ; (-x \<cdot> 1')"
    by (metis maddux_16 inf_top_left mult.assoc)
  hence two: "x ; 1 \<cdot> (-x \<cdot> 1') \<le> -x"
    by (metis inf.commute inf_le1 le_infE)
  hence "x ; 1 \<cdot> (-x \<cdot> 1') \<le> x"
    by (metis one inf.commute le_infE meet_iso one_conv \<open>is_test x\<close> order.eq_iff test_1 test_eq_conv)
  hence "x ; 1 \<cdot> (-x \<cdot> 1') = 0"
    by (metis two galois_aux2 le_iff_inf)
  thus "-x \<cdot> 1' \<le> -(x ; 1) \<cdot> 1'"
    by (metis double_compl galois_aux2 inf.commute inf_le1 le_inf_iff)
qed

lemma test_distr_1 :
  assumes "is_test x"
    and "is_test y"
  shows "x ; z \<cdot> y ; z = (x \<cdot> y) ; z"
proof (rule order.antisym)
  have "x ; z \<cdot> y ; z \<le> x ; 1 \<cdot> y ; z"
    by (metis inf_top_left meet_iso mult_subdistl)
  also have "\<dots> = x ; y ; z"
    by (metis assms(1) mult.assoc test_1)
  finally show "x ; z \<cdot> y ; z \<le> (x \<cdot> y) ; z"
    by (metis assms test_comp_eq_mult)
next
  show "(x \<cdot> y) ; z \<le> x ; z \<cdot> y ; z"
    by (metis mult_subdistr_var)
qed

lemma maddux_35: "is_test x \<Longrightarrow> x ; y \<cdot> -z = x ; y \<cdot> -(x ; z)"
proof (rule order.antisym)
  assume "is_test x"
  show "x ; y \<cdot> -z \<le> x ; y \<cdot> -(x ; z)"
    by (metis \<open>is_test x\<close> comp_anti mult_isor mult_onel is_test_def inf.commute inf_le2 le_infI le_infI1)
  have one: "x ; y \<cdot> -(x ; z) \<le> x ; (y \<cdot> -z)"
    by (metis order.eq_iff le_infE maddux_23)
  hence two: "x ; y \<cdot> -(x ; z) \<le> x ; y"
    by (metis inf_le1)
  have "x ; y \<cdot> -(x ; z) \<le>  x ; -z"
    using one
    by (metis galois_1 le_iff_sup distrib_left sup_compl_top sup_top_right)
  hence "x ; y \<cdot> -(x ; z) \<le> -z"
    by (metis \<open>is_test x\<close> mult_isor mult_onel is_test_def order_trans)
  thus "x ; y \<cdot> -(x ; z) \<le> x ; y \<cdot> -z"
    using two
    by (metis le_inf_iff)
qed

subsection \<open>Test Complements\<close>

text \<open>Text complements are complements of elements that are ``pushed below''
the multiplicative unit.\<close>

definition tc :: "'a \<Rightarrow> 'a"
  where "tc x = 1' \<cdot> -x"

lemma test_compl_1 [simp]: "is_test x \<Longrightarrow> x + tc x = 1'"
  by (metis is_test_def local.aux4 local.inf.absorb_iff1 local.inf_commute tc_def)

lemma test_compl_2 [simp]: "is_test x \<Longrightarrow> x \<cdot> tc x = 0"
  by (metis galois_aux inf.commute inf_le2 tc_def)

lemma test_test_compl: "is_test x \<Longrightarrow> is_test (tc x)"
  by (simp add: is_test_def tc_def)

lemma test_compl_de_morgan_1: "tc (x + y) = tc x \<cdot> tc y"
  by (metis compl_sup inf.left_commute inf.left_idem meet_assoc tc_def)

lemma test_compl_de_morgan_2: "tc (x \<cdot> y) = tc x + tc y"
  by (metis compl_inf inf_sup_distrib1 tc_def)

lemma test_compl_three [simp]: "tc (tc (tc x)) = tc x"
  by (metis aux4 aux6 de_morgan_3 inf.commute inf_sup_absorb tc_def)

lemma test_compl_double [simp]: "is_test x \<Longrightarrow> tc (tc x) = x"
  by (metis aux6_var compl_inf double_compl inf.commute le_iff_inf tc_def is_test_def)

end (* relation_algebra *)

end


(*  Title:      HOL/HOLCF/Up.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of lifted values\<close>

theory Up
imports Cfun
begin

default_sort cpo

subsection \<open>Definition of new type for lifting\<close>

datatype 'a u  ("(_\<^sub>\<bottom>)" [1000] 999) = Ibottom | Iup 'a

primrec Ifup :: "('a \<rightarrow> 'b::pcpo) \<Rightarrow> 'a u \<Rightarrow> 'b" where
    "Ifup f Ibottom = \<bottom>"
 |  "Ifup f (Iup x) = f\<cdot>x"

subsection \<open>Ordering on lifted cpo\<close>

instantiation u :: (cpo) below
begin

definition
  below_up_def:
    "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
      (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"

instance ..
end

lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
by (simp add: below_up_def)

lemma not_Iup_below [iff]: "Iup x \<notsqsubseteq> Ibottom"
by (simp add: below_up_def)

lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
by (simp add: below_up_def)

subsection \<open>Lifted cpo is a partial order\<close>

instance u :: (cpo) po
proof
  fix x :: "'a u"
  show "x \<sqsubseteq> x"
    unfolding below_up_def by (simp split: u.split)
next
  fix x y :: "'a u"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
    unfolding below_up_def
    by (auto split: u.split_asm intro: below_antisym)
next
  fix x y z :: "'a u"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    unfolding below_up_def
    by (auto split: u.split_asm intro: below_trans)
qed

subsection \<open>Lifted cpo is a cpo\<close>

lemma is_lub_Iup:
  "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
unfolding is_lub_def is_ub_def ball_simps
by (auto simp add: below_up_def split: u.split)

lemma up_chain_lemma:
  assumes Y: "chain Y" obtains "\<forall>i. Y i = Ibottom"
  | A k where "\<forall>i. Iup (A i) = Y (i + k)" and "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
proof (cases "\<exists>k. Y k \<noteq> Ibottom")
  case True
  then obtain k where k: "Y k \<noteq> Ibottom" ..
  define A where "A i = (THE a. Iup a = Y (i + k))" for i
  have Iup_A: "\<forall>i. Iup (A i) = Y (i + k)"
  proof
    fix i :: nat
    from Y le_add2 have "Y k \<sqsubseteq> Y (i + k)" by (rule chain_mono)
    with k have "Y (i + k) \<noteq> Ibottom" by (cases "Y k", auto)
    thus "Iup (A i) = Y (i + k)"
      by (cases "Y (i + k)", simp_all add: A_def)
  qed
  from Y have chain_A: "chain A"
    unfolding chain_def Iup_below [symmetric]
    by (simp add: Iup_A)
  hence "range A <<| (\<Squnion>i. A i)"
    by (rule cpo_lubI)
  hence "range (\<lambda>i. Iup (A i)) <<| Iup (\<Squnion>i. A i)"
    by (rule is_lub_Iup)
  hence "range (\<lambda>i. Y (i + k)) <<| Iup (\<Squnion>i. A i)"
    by (simp only: Iup_A)
  hence "range (\<lambda>i. Y i) <<| Iup (\<Squnion>i. A i)"
    by (simp only: is_lub_range_shift [OF Y])
  with Iup_A chain_A show ?thesis ..
next
  case False
  then have "\<forall>i. Y i = Ibottom" by simp
  then show ?thesis ..
qed

instance u :: (cpo) cpo
proof
  fix S :: "nat \<Rightarrow> 'a u"
  assume S: "chain S"
  thus "\<exists>x. range (\<lambda>i. S i) <<| x"
  proof (rule up_chain_lemma)
    assume "\<forall>i. S i = Ibottom"
    hence "range (\<lambda>i. S i) <<| Ibottom"
      by (simp add: is_lub_const)
    thus ?thesis ..
  next
    fix A :: "nat \<Rightarrow> 'a"
    assume "range S <<| Iup (\<Squnion>i. A i)"
    thus ?thesis ..
  qed
qed

subsection \<open>Lifted cpo is pointed\<close>

instance u :: (cpo) pcpo
by intro_classes fast

text \<open>for compatibility with old HOLCF-Version\<close>
lemma inst_up_pcpo: "\<bottom> = Ibottom"
by (rule minimal_up [THEN bottomI, symmetric])

subsection \<open>Continuity of \emph{Iup} and \emph{Ifup}\<close>

text \<open>continuity for @{term Iup}\<close>

lemma cont_Iup: "cont Iup"
apply (rule contI)
apply (rule is_lub_Iup)
apply (erule cpo_lubI)
done

text \<open>continuity for @{term Ifup}\<close>

lemma cont_Ifup1: "cont (\<lambda>f. Ifup f x)"
by (induct x, simp_all)

lemma monofun_Ifup2: "monofun (\<lambda>x. Ifup f x)"
apply (rule monofunI)
apply (case_tac x, simp)
apply (case_tac y, simp)
apply (simp add: monofun_cfun_arg)
done

lemma cont_Ifup2: "cont (\<lambda>x. Ifup f x)"
proof (rule contI2)
  fix Y assume Y: "chain Y" and Y': "chain (\<lambda>i. Ifup f (Y i))"
  from Y show "Ifup f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. Ifup f (Y i))"
  proof (rule up_chain_lemma)
    fix A and k
    assume A: "\<forall>i. Iup (A i) = Y (i + k)"
    assume "chain A" and "range Y <<| Iup (\<Squnion>i. A i)"
    hence "Ifup f (\<Squnion>i. Y i) = (\<Squnion>i. Ifup f (Iup (A i)))"
      by (simp add: lub_eqI contlub_cfun_arg)
    also have "\<dots> = (\<Squnion>i. Ifup f (Y (i + k)))"
      by (simp add: A)
    also have "\<dots> = (\<Squnion>i. Ifup f (Y i))"
      using Y' by (rule lub_range_shift)
    finally show ?thesis by simp
  qed simp
qed (rule monofun_Ifup2)

subsection \<open>Continuous versions of constants\<close>

definition
  up  :: "'a \<rightarrow> 'a u" where
  "up = (\<Lambda> x. Iup x)"

definition
  fup :: "('a \<rightarrow> 'b::pcpo) \<rightarrow> 'a u \<rightarrow> 'b" where
  "fup = (\<Lambda> f p. Ifup f p)"

translations
  "case l of XCONST up\<cdot>x \<Rightarrow> t" == "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
  "case l of (XCONST up :: 'a)\<cdot>x \<Rightarrow> t" => "CONST fup\<cdot>(\<Lambda> x. t)\<cdot>l"
  "\<Lambda>(XCONST up\<cdot>x). t" == "CONST fup\<cdot>(\<Lambda> x. t)"

text \<open>continuous versions of lemmas for @{typ "('a)u"}\<close>

lemma Exh_Up: "z = \<bottom> \<or> (\<exists>x. z = up\<cdot>x)"
apply (induct z)
apply (simp add: inst_up_pcpo)
apply (simp add: up_def cont_Iup)
done

lemma up_eq [simp]: "(up\<cdot>x = up\<cdot>y) = (x = y)"
by (simp add: up_def cont_Iup)

lemma up_inject: "up\<cdot>x = up\<cdot>y \<Longrightarrow> x = y"
by simp

lemma up_defined [simp]: "up\<cdot>x \<noteq> \<bottom>"
by (simp add: up_def cont_Iup inst_up_pcpo)

lemma not_up_less_UU: "up\<cdot>x \<notsqsubseteq> \<bottom>"
by simp (* FIXME: remove? *)

lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
by (simp add: up_def cont_Iup)

lemma upE [case_names bottom up, cases type: u]:
  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
apply (cases p)
apply (simp add: inst_up_pcpo)
apply (simp add: up_def cont_Iup)
done

lemma up_induct [case_names bottom up, induct type: u]:
  "\<lbrakk>P \<bottom>; \<And>x. P (up\<cdot>x)\<rbrakk> \<Longrightarrow> P x"
by (cases x, simp_all)

text \<open>lifting preserves chain-finiteness\<close>

lemma up_chain_cases:
  assumes Y: "chain Y" obtains "\<forall>i. Y i = \<bottom>"
  | A k where "\<forall>i. up\<cdot>(A i) = Y (i + k)" and "chain A" and "(\<Squnion>i. Y i) = up\<cdot>(\<Squnion>i. A i)"
apply (rule up_chain_lemma [OF Y])
apply (simp_all add: inst_up_pcpo up_def cont_Iup lub_eqI)
done

lemma compact_up: "compact x \<Longrightarrow> compact (up\<cdot>x)"
apply (rule compactI2)
apply (erule up_chain_cases)
apply simp
apply (drule (1) compactD2, simp)
apply (erule exE)
apply (drule_tac f="up" and x="x" in monofun_cfun_arg)
apply (simp, erule exI)
done

lemma compact_upD: "compact (up\<cdot>x) \<Longrightarrow> compact x"
unfolding compact_def
by (drule adm_subst [OF cont_Rep_cfun2 [where f=up]], simp)

lemma compact_up_iff [simp]: "compact (up\<cdot>x) = compact x"
by (safe elim!: compact_up compact_upD)

instance u :: (chfin) chfin
apply intro_classes
apply (erule compact_imp_max_in_chain)
apply (rule_tac p="\<Squnion>i. Y i" in upE, simp_all)
done

text \<open>properties of fup\<close>

lemma fup1 [simp]: "fup\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (simp add: fup_def cont_Ifup1 cont_Ifup2 inst_up_pcpo cont2cont_LAM)

lemma fup2 [simp]: "fup\<cdot>f\<cdot>(up\<cdot>x) = f\<cdot>x"
by (simp add: up_def fup_def cont_Iup cont_Ifup1 cont_Ifup2 cont2cont_LAM)

lemma fup3 [simp]: "fup\<cdot>up\<cdot>x = x"
by (cases x, simp_all)

end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (mul3 x z y))"
  oops

end


header {* Optimizations for Code Integer *}
theory Optimize_Integer
imports
  Complex_Main
  "~~/src/HOL/Library/Code_Target_Numeral"
begin

text {* TODO: Missing? code post rule? *}

lemma [code_post]: "int_of_integer (- 1) = - 1"
  by simp

text {* shallowly embed log and power *}

definition log2::"int \<Rightarrow> int"
  where "log2 a = floor (log 2 (real a))"

context includes integer.lifting begin

lift_definition log2_integer :: "integer \<Rightarrow> integer"
  is "log2 :: int \<Rightarrow> int"
  .

end

code_printing
  constant "log2_integer :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.log2"

definition power_int::"int \<Rightarrow> int \<Rightarrow> int"
  where "power_int a b = a ^ (nat b)"

context includes integer.lifting begin

lift_definition power_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "power_int :: int \<Rightarrow> int \<Rightarrow> int"
  .

end

code_printing
  constant "power_integer :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.pow ((_), (_))"

lemma [code]: "power_int (int_of_integer a) (int_of_integer b) = int_of_integer (power_integer a b)"
  by (simp add: power_integer.rep_eq)

end


section "Attack Trees"
theory AT
imports MC
begin

text \<open>Attack Trees are an intuitive and practical formal method to analyse and quantify
attacks on security and privacy. They are very useful to identify the steps an attacker
takes through a system when approaching the attack goal. Here, we provide
a proof calculus to analyse concrete attacks using a notion of attack validity.
We define a state based semantics with Kripke models and the temporal logic
CTL in the proof assistant Isabelle \<^cite>\<open>"npw:02"\<close> using its Higher Order Logic
(HOL). We prove the correctness and completeness (adequacy) of Attack Trees in Isabelle
with respect to the model.\<close>

subsection "Attack Tree datatype"
text \<open>The following datatype definition @{text \<open>attree\<close>} defines attack trees.
The simplest case of an attack tree is a base attack.
The principal idea is that base attacks are defined by a pair of
state sets representing the initial states and the {\it attack property}
-- a set of states characterized by the fact that this property holds
in them.
Attacks can also be combined as the conjunction or disjunction of other attacks.
The operator @{text \<open>\<oplus>\<^sub>\<or>\<close>} creates or-trees and @{text \<open>\<oplus>\<^sub>\<and>\<close>} creates and-trees.
And-attack trees @{text \<open>l \<oplus>\<^sub>\<and> s\<close>} and or-attack trees @{text \<open>l \<oplus>\<^sub>\<or> s\<close>}
combine lists of attack trees $l$ either conjunctively or disjunctively and
consist of a list of sub-attacks -- again attack trees.\<close>
datatype ('s :: state) attree = BaseAttack "('s set) * ('s set)" ("\<N>\<^bsub>(_)\<^esub>") |
                  AndAttack "('s attree) list" "('s set) * ('s set)" ("_ \<oplus>\<^sub>\<and>\<^bsup>(_)\<^esup>" 60) |
                  OrAttack  "('s attree) list" "('s set) * ('s set)" ("_ \<oplus>\<^sub>\<or>\<^bsup>(_)\<^esup>" 61)

primrec attack :: "('s :: state) attree \<Rightarrow> ('s set) * ('s set)"
  where
"attack (BaseAttack b) = b"|
"attack (AndAttack as s) = s"  |
"attack (OrAttack as s) = s"

subsection \<open>Attack Tree refinement\<close>
text \<open>When we develop an attack tree, we proceed from an abstract attack, given
by an attack goal, by breaking it down into a series of sub-attacks. This
proceeding corresponds to a process of {\it refinement}. Therefore, as part of
the attack tree calculus, we provide a notion of attack tree refinement.

The relation @{text \<open>refines_to\<close>} "constructs" the attack tree. Here the above
defined attack vectors are used to define how nodes in an attack tree
can be expanded into more detailed (refined) attack sequences. This
process of refinement @{text "\<sqsubseteq>"} allows to eventually reach a fully detailed
attack that can then be proved using @{text "\<turnstile>"}.\<close>
inductive refines_to :: "[('s :: state) attree, 's attree] \<Rightarrow> bool" ("_ \<sqsubseteq> _" [40] 40)
where
refI: "\<lbrakk>  A = ((l @ [ \<N>\<^bsub>(si',si'')\<^esub>] @ l'')\<oplus>\<^sub>\<and>\<^bsup>(si,si''')\<^esup> );
          A' = (l' \<oplus>\<^sub>\<and>\<^bsup>(si',si'')\<^esup>);
          A'' = (l @ l' @ l'' \<oplus>\<^sub>\<and>\<^bsup>(si,si''')\<^esup>)
        \<rbrakk> \<Longrightarrow> A \<sqsubseteq> A''"|
ref_or: "\<lbrakk> as \<noteq> []; \<forall> A' \<in> set(as). (A  \<sqsubseteq> A') \<and> attack A = s \<rbrakk> \<Longrightarrow> A \<sqsubseteq> (as \<oplus>\<^sub>\<or>\<^bsup>s\<^esup>)" |
ref_trans: "\<lbrakk> A \<sqsubseteq> A'; A' \<sqsubseteq> A'' \<rbrakk> \<Longrightarrow> A \<sqsubseteq> A''"|
ref_refl : "A \<sqsubseteq> A"

subsection \<open>Validity of Attack Trees\<close>
text \<open>A valid attack, intuitively, is one which is fully refined into fine-grained
attacks that are feasible in a model. The general model we provide is
a Kripke structure, i.e., a set of states and a generic state transition.
Thus, feasible steps in the model are single steps of the state transition.
We call them valid base attacks.
The composition of sequences of valid base attacks into and-attacks yields
again valid attacks if the base attacks line up with respect to the states
in the state transition. If there are different valid attacks for the same
attack goal starting from the same initial state set, these can be
summarized in an or-attack.
More precisely, the different cases of the validity predicate are distinguished
by pattern matching over the attack tree structure.
\begin{itemize}
\item A  base attack @{text \<open>\<N>(s0,s1)\<close>} is  valid if from all
states in the pre-state set @{text \<open>s0\<close>} we can get with a single step of the
state transition relation to a state in the post-state set \<open>s1\<close>. Note,
that it is sufficient for a post-state to exist for each pre-state. After all,
we are aiming to validate attacks, that is, possible attack paths to some
state that fulfills the attack property.
\item An and-attack @{text \<open>As \<oplus>\<^sub>\<and> (s0,s1)\<close>} is a valid attack
 if either of the following cases holds:
  \begin{itemize}
   \item empty attack sequence @{text \<open>As\<close>}: in this case
       all pre-states in @{text \<open>s0\<close>} must already be attack states
       in @{text \<open>s1\<close>}, i.e., @{text \<open>s0 \<subseteq> s1\<close>};
   \item attack sequence @{text \<open>As\<close>} is singleton: in this case, the
      singleton element attack @{text \<open>a\<close>} in @{text \<open>[a]\<close>},
      must be a valid attack and it must be an attack with pre-state
      @{text \<open>s0\<close>} and post-state @{text \<open>s1\<close>};
   \item otherwise, @{text \<open>As\<close>} must be a list matching @{text \<open>a # l\<close>} for
     some attack @{text \<open>a\<close>} and tail of attack list @{text \<open>l\<close>} such that
     @{text \<open>a\<close>} is a valid attack with pre-state identical to the overall
     pre-state @{text \<open>s0\<close>} and the goal of the tail @{text \<open>l\<close>} is
     @{text \<open>s1\<close>} the goal of the  overall attack. The pre-state of the
     attack represented by @{text \<open>l\<close>} is @{text \<open>snd(attack a)\<close>} since this is
     the post-state set of the first step @{text \<open>a\<close>}.
\end{itemize}
 \item An or-attack @{text \<open>As  \<oplus>\<^sub>\<or>(s0,s1)\<close>} is a valid attack
  if either of the following cases holds:
  \begin{itemize}
   \item the empty attack case is identical to the and-attack above:
       @{text \<open>s0 \<subseteq> s1\<close>};
   \item attack sequence @{text \<open>As\<close>} is singleton: in this case, the
      singleton element attack @{text \<open>a\<close>}
      must be a valid attack and
      its pre-state must include the overall attack pre-state set @{text \<open>s0\<close>}
      (since @{text \<open>a\<close>} is singleton in the or) while the post-state of
      @{text \<open>a\<close>} needs to be included in the global attack goal @{text \<open>s1\<close>};
   \item otherwise, @{text \<open>As\<close>} must be a list  @{text \<open>a # l\<close>} for
     an attack @{text \<open>a\<close>} and a list @{text \<open>l\<close>} of alternative attacks.
     The pre-states can be just a subset of @{text \<open>s0\<close>} (since there are
     other attacks in @{text \<open>l\<close>} that can cover the rest) and the goal
     states @{text \<open>snd(attack a)\<close>} need to lie all in the overall goal
     state @{text \<open>set s1\<close>}. The other or-attacks in @{text \<open>l\<close>} need
     to cover only the pre-states @{text \<open>fst s - fst(attack a)\<close>}
     (where @{text \<open>-\<close>} is set difference) and have the same goal @{text \<open>snd s\<close>}.
   \end{itemize}
\end{itemize}
The proof calculus is thus completely described by one recursive function. \<close>
fun is_attack_tree :: "[('s :: state) attree] \<Rightarrow> bool"  ("\<turnstile>_" [40] 40)
where
att_base:  "(\<turnstile> \<N>\<^bsub>s\<^esub>) = ( (\<forall> x \<in> (fst s). (\<exists> y \<in> (snd s). x  \<rightarrow>\<^sub>i y )))" |
att_and: "(\<turnstile>(As \<oplus>\<^sub>\<and>\<^bsup>s\<^esup>)) =
               (case As of
                  [] \<Rightarrow> (fst s \<subseteq> snd s)
                | [a] \<Rightarrow> ( \<turnstile> a \<and> attack a = s)
                | (a # l) \<Rightarrow> (( \<turnstile> a) \<and> (fst(attack a) = fst s) \<and>
                            (\<turnstile>(l \<oplus>\<^sub>\<and>\<^bsup>(snd(attack a),snd(s))\<^esup>))))" |
att_or: "(\<turnstile>(As \<oplus>\<^sub>\<or>\<^bsup>s\<^esup>)) =
               (case As of
                  [] \<Rightarrow> (fst s \<subseteq> snd s)
                | [a] \<Rightarrow> ( \<turnstile> a \<and> (fst(attack a) \<supseteq> fst s) \<and> (snd(attack a) \<subseteq> snd s))
                | (a # l) \<Rightarrow> (( \<turnstile> a) \<and> fst(attack a) \<subseteq> fst s \<and>
                              snd(attack a) \<subseteq> snd s \<and>
                       ( \<turnstile>(l \<oplus>\<^sub>\<or>\<^bsup>(fst s - fst(attack a), snd s)\<^esup>))))"
text \<open>Since the definition is constructive, code can be generated directly from it, here
into the programming language Scala.\<close>
export_code is_attack_tree in Scala

subsection "Lemmas for Attack Tree validity"
lemma att_and_one: assumes "\<turnstile> a" and  "attack a = s"
  shows  "\<turnstile>([a] \<oplus>\<^sub>\<and>\<^bsup>s\<^esup>)"
proof -
  show " \<turnstile>([a] \<oplus>\<^sub>\<and>\<^bsup>s\<^esup>)" using assms
    by (subst att_and, simp del: att_and att_or)
qed

declare is_attack_tree.simps[simp del]

lemma att_and_empty[rule_format] : " \<turnstile>([] \<oplus>\<^sub>\<and>\<^bsup>(s', s'')\<^esup>) \<longrightarrow> s' \<subseteq> s''"
  by (simp add: is_attack_tree.simps(2))

lemma att_and_empty2: " \<turnstile>([] \<oplus>\<^sub>\<and>\<^bsup>(s, s)\<^esup>)"
  by (simp add: is_attack_tree.simps(2))

lemma att_or_empty[rule_format] : " \<turnstile>([] \<oplus>\<^sub>\<or>\<^bsup>(s', s'')\<^esup>) \<longrightarrow> s' \<subseteq> s''"
  by (simp add: is_attack_tree.simps(3))

lemma att_or_empty_back[rule_format]: " s' \<subseteq> s'' \<longrightarrow>  \<turnstile>([] \<oplus>\<^sub>\<or>\<^bsup>(s', s'')\<^esup>)"
  by (simp add: is_attack_tree.simps(3))

lemma att_or_empty_rev: assumes "\<turnstile>(l \<oplus>\<^sub>\<or>\<^bsup>(s, s')\<^esup>)" and "\<not>(s \<subseteq> s')" shows "l \<noteq> []"
  using assms att_or_empty by blast

lemma att_andD1: " \<turnstile>(x1 # x2 \<oplus>\<^sub>\<and>\<^bsup>s\<^esup>) \<Longrightarrow> \<turnstile> x1"
  by (metis (no_types, lifting) is_attack_tree.simps(2) list.exhaust list.simps(4) list.simps(5))

lemma att_and_nonemptyD2[rule_format]:
       "(x2 \<noteq> [] \<longrightarrow> \<turnstile>(x1 # x2 \<oplus>\<^sub>\<and>\<^bsup>s\<^esup>) \<longrightarrow> \<turnstile> (x2 \<oplus>\<^sub>\<and>\<^bsup>(snd(attack x1),snd s)\<^esup>))"
  by (metis (no_types, lifting) is_attack_tree.simps(2) list.exhaust list.simps(5))

lemma att_andD2 : " \<turnstile>(x1 # x2 \<oplus>\<^sub>\<and>\<^bsup>s\<^esup>) \<Longrightarrow> \<turnstile> (x2 \<oplus>\<^sub>\<and>\<^bsup>(snd(attack x1),snd s)\<^esup>)"
  by (metis (mono_tags, lifting) att_and_empty2 att_and_nonemptyD2 is_attack_tree.simps(2) list.simps(4) list.simps(5))

lemma att_and_fst_lem[rule_format]:
   "\<turnstile>(x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>) \<longrightarrow> xa \<in> fst (attack (x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>))
                     \<longrightarrow> xa \<in> fst (attack x1)"
  by (induction x2a, (subst att_and, simp)+)

lemma att_orD1: " \<turnstile>(x1 # x2 \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>) \<Longrightarrow> \<turnstile> x1"
  by (case_tac x2, (subst (asm) att_or, simp)+)

lemma att_or_snd_hd: " \<turnstile>(a # list \<oplus>\<^sub>\<or>\<^bsup>(aa, b)\<^esup>) \<Longrightarrow> snd(attack a) \<subseteq> b"
  by (case_tac list,  (subst (asm) att_or, simp)+)

lemma att_or_singleton[rule_format]:
   " \<turnstile>([x1] \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>) \<longrightarrow> \<turnstile>([] \<oplus>\<^sub>\<or>\<^bsup>(fst x - fst (attack x1), snd x)\<^esup>)"
  by (subst att_or, simp, rule impI, rule att_or_empty_back, blast)

lemma att_orD2[rule_format]:
     " \<turnstile>(x1 # x2 \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>) \<longrightarrow>  \<turnstile> (x2 \<oplus>\<^sub>\<or>\<^bsup>(fst x - fst(attack x1), snd x)\<^esup>)"
  by (case_tac x2, simp add: att_or_singleton, simp, subst att_or, simp)

lemma att_or_snd_att[rule_format]: "\<forall> x. \<turnstile> (x2 \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>) \<longrightarrow> (\<forall> a \<in> (set x2). snd(attack a) \<subseteq> snd x )"
proof (induction x2)
  case Nil
  then show ?case by (simp add: att_or)
next
  case (Cons a x2)
  then show ?case using att_orD2 att_or_snd_hd by fastforce
qed

lemma singleton_or_lem: " \<turnstile>([x1] \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>)  \<Longrightarrow> fst x \<subseteq> fst(attack x1)"
  by (subst (asm) att_or, simp)+

lemma or_att_fst_sup0[rule_format]: "x2 \<noteq> [] \<longrightarrow> (\<forall> x. (\<turnstile> ((x2 \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>):: ('s :: state) attree)) \<longrightarrow>
                      ((\<Union> y::'s attree\<in> set x2. fst (attack y)) \<supseteq> fst(x))) "
proof (induction x2)
  case Nil
  then show ?case by simp
next
  case (Cons a x2)
  then show ?case using att_orD2 singleton_or_lem by fastforce
qed

lemma or_att_fst_sup:
    assumes "(\<turnstile> ((x1 # x2 \<oplus>\<^sub>\<or>\<^bsup>x\<^esup>):: ('s :: state) attree))"
    shows   "((\<Union> y::'s attree\<in> set (x1 # x2). fst (attack y)) \<supseteq> fst(x))"
  by (rule or_att_fst_sup0, simp, rule assms)

text \<open>The lemma @{text \<open>att_elem_seq\<close>} is the main lemma for Correctness.
  It shows that for a given attack tree x1, for each element in the set of start sets
  of the first attack, we can reach in zero or more steps a state in the states in which
  the attack is successful (the final attack state @{text \<open>snd(attack x1)\<close>}).
  This proof is a big alternative to an earlier version of the proof with
  @{text \<open>first_step\<close>} etc that mapped first on a sequence of sets of states.\<close>
lemma att_elem_seq[rule_format]: "\<turnstile> x1 \<longrightarrow> (\<forall> x \<in> fst(attack x1).
                     (\<exists> y. y \<in> snd(attack x1) \<and> x \<rightarrow>\<^sub>i* y))"
  text \<open>First attack tree induction\<close>
proof (induction x1)
  case (BaseAttack x)
  then show ?case
    by (metis AT.att_base EF_step EF_step_star_rev attack.simps(1))
next
  case (AndAttack x1a x2)
  then show ?case
    apply (rule_tac x = x2 in spec)
    apply (subgoal_tac "(\<forall> x1aa::'a attree.
                              x1aa \<in> set x1a \<longrightarrow>
                               \<turnstile>x1aa \<longrightarrow>
                               (\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y))")
     apply (rule mp)
      prefer 2
      apply (rotate_tac -1)
      apply assumption
    text \<open>Induction for @{text \<open>\<and>\<close>}: the manual instantiation seems tedious but in the @{text \<open>\<and>\<close>}
            case necessary to get the right induction hypothesis.\<close>
  proof (rule_tac list = "x1a" in list.induct)
    text \<open>The @{text \<open>\<and>\<close>} induction empty case\<close>
    show "(\<forall>x1aa::'a attree.
           x1aa \<in> set [] \<longrightarrow>
           \<turnstile>x1aa \<longrightarrow> (\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y)) \<longrightarrow>
       (\<forall>x::'a set \<times> 'a set.
           \<turnstile>([] \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>) \<longrightarrow>
           (\<forall>xa::'a\<in>fst (attack ([] \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)). \<exists>y::'a. y \<in> snd (attack ([] \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<and> xa \<rightarrow>\<^sub>i* y))"
      using att_and_empty state_transition_refl_def by fastforce
    text \<open>The @{text \<open>\<and>\<close>} induction case nonempty\<close>
  next show "\<And>(x1a::'a attree list) (x2::'a set \<times> 'a set) (x1::'a attree) (x2a::'a attree list).
       (\<And>x1aa::'a attree.
           (x1aa \<in> set x1a) \<Longrightarrow>
           ((\<turnstile>x1aa) \<longrightarrow> (\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y))) \<Longrightarrow>
       \<forall>x1aa::'a attree.
          (x1aa \<in> set x1a) \<longrightarrow>
          (\<turnstile>x1aa) \<longrightarrow> ((\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y)) \<Longrightarrow>
       (\<forall>x1aa::'a attree.
           (x1aa \<in> set x2a) \<longrightarrow>
           (\<turnstile>x1aa) \<longrightarrow> (\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y)) \<longrightarrow>
       (\<forall>x::'a set \<times> 'a set.
           (\<turnstile>(x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<longrightarrow>
           ((\<forall>xa::'a\<in>fst (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)). \<exists>y::'a. y \<in> snd (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<and> xa \<rightarrow>\<^sub>i* y))) \<Longrightarrow>
       ((\<forall>x1aa::'a attree.
           (x1aa \<in> set (x1 # x2a)) \<longrightarrow>
           (\<turnstile>x1aa) \<longrightarrow> ((\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y))) \<longrightarrow>
       (\<forall>x::'a set \<times> 'a set.
          ( \<turnstile>(x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<longrightarrow>
           (\<forall>xa::'a\<in>fst (attack (x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)).
               (\<exists>y::'a. y \<in> snd (attack (x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<and> (xa \<rightarrow>\<^sub>i* y)))))"
      apply (rule impI, rule allI, rule impI)
      text \<open>Set free the Induction Hypothesis: this is necessary to provide the grounds for specific
              instantiations in the step.\<close>
      apply (subgoal_tac "(\<forall>x::'a set \<times> 'a set.
                             \<turnstile>(x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>) \<longrightarrow>
                             (\<forall>xa::'a\<in>fst (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)).
                              \<exists>y::'a. y \<in> snd (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<and> xa \<rightarrow>\<^sub>i* y))")
       prefer 2
       apply simp
      text \<open>The following induction step for @{text \<open>\<and>\<close>} needs a number of manual instantiations
              so that the proof is not found automatically. In the subsequent case for @{text \<open>\<or>\<close>},
              sledgehammer finds the proof.\<close>
    proof -
      show "\<And>(x1a::'a attree list) (x2::'a set \<times> 'a set) (x1::'a attree) (x2a::'a attree list) x::'a set \<times> 'a set.
       \<forall>x1aa::'a attree.
          x1aa \<in> set (x1 # x2a) \<longrightarrow>
          \<turnstile>x1aa \<longrightarrow> (\<forall>x::'a\<in>fst (attack x1aa). \<exists>y::'a. y \<in> snd (attack x1aa) \<and> x \<rightarrow>\<^sub>i* y) \<Longrightarrow>
       \<turnstile>(x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>) \<Longrightarrow>
       \<forall>x::'a set \<times> 'a set.
          \<turnstile>(x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>) \<longrightarrow>
          (\<forall>xa::'a\<in>fst (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)). \<exists>y::'a. y \<in> snd (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<and> xa \<rightarrow>\<^sub>i* y) \<Longrightarrow>
       \<forall>xa::'a\<in>fst (attack (x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)). \<exists>y::'a. y \<in> snd (attack (x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) \<and> xa \<rightarrow>\<^sub>i* y"
        apply (rule ballI)
        apply (rename_tac xa)
        text \<open>Prepare the steps\<close>
        apply (drule_tac x = "(snd(attack x1), snd x)" in spec)
        apply (rotate_tac -1)
        apply (erule impE)
         apply (erule att_andD2)
        text \<open>Premise for x1\<close>
        apply (drule_tac x = x1 in spec)
        apply (drule mp)
         apply simp
        apply (drule mp)
         apply (erule att_andD1)
        text \<open>Instantiate first step for xa\<close>
        apply (rotate_tac -1)
        apply (drule_tac x = xa in bspec)
         apply (erule att_and_fst_lem, assumption)
        apply (erule exE)
        apply (erule conjE)
        text \<open>Take this y and put it as first into the second part\<close>
        apply (drule_tac x = y in bspec)
         apply simp
        apply (erule exE)
        apply (erule conjE)
        text \<open>Bind the first @{text \<open>xa \<rightarrow>\<^sub>i* y\<close>} and second @{text \<open>y \<rightarrow>\<^sub>i* ya\<close>} together for solution\<close>
        apply (rule_tac x = ya in exI)
        apply (rule conjI)
         apply simp
        by (simp add: state_transition_refl_def)
    qed
  qed auto
next
  case (OrAttack x1a x2)
  then show ?case
  proof (induction x1a arbitrary: x2)
    case Nil
    then show ?case
      by (metis EF_lem2a EF_step_star_rev att_or_empty attack.simps(3) subsetD surjective_pairing)
  next
    case (Cons a x1a)
    then show ?case
      by (smt DiffI att_orD1 att_orD2 att_or_snd_att attack.simps(3) insert_iff list.set(2) prod.sel(1) snd_conv subset_iff)
  qed
qed

lemma att_elem_seq0: "\<turnstile> x1 \<Longrightarrow> (\<forall> x \<in> fst(attack x1).
                     (\<exists> y. y \<in> snd(attack x1) \<and> x \<rightarrow>\<^sub>i* y))"
  by (simp add: att_elem_seq)

subsection \<open>Valid refinements\<close>
definition valid_ref :: "[('s :: state) attree, 's attree] \<Rightarrow> bool" ("_ \<sqsubseteq>\<^sub>V _" 50)
  where
"A \<sqsubseteq>\<^sub>V A' \<equiv>  ( (A \<sqsubseteq> A') \<and>  \<turnstile> A')"

definition ref_validity :: "[('s :: state) attree] \<Rightarrow> bool" ("\<turnstile>\<^sub>V _" 50)
  where
"\<turnstile>\<^sub>V A  \<equiv>  (\<exists> A'. (A \<sqsubseteq>\<^sub>V A'))"

lemma ref_valI: " A \<sqsubseteq> A'\<Longrightarrow>  \<turnstile> A' \<Longrightarrow> \<turnstile>\<^sub>V A"
  using ref_validity_def valid_ref_def by blast

section "Correctness and Completeness"
text \<open>This section presents the main theorems of Correctness and Completeness
      between AT and Kripke, essentially:

@{text \<open>\<turnstile> (init K, p) \<equiv>  K \<turnstile> EF p\<close>}.

First, we proof a number of lemmas needed for both directions before we
show the Correctness theorem followed by the Completeness theorem.
\<close>
subsection \<open>Lemma for Correctness and Completeness\<close>
lemma nth_app_eq[rule_format]:
              "\<forall> sl x. sl \<noteq> [] \<longrightarrow> sl ! (length sl - Suc (0)) = x
              \<longrightarrow> (l @ sl) ! (length l + length sl - Suc (0)) = x"
  by (induction l) auto

lemma nth_app_eq1[rule_format]: "i < length sla \<Longrightarrow> (sla @ sl) ! i = sla ! i"
  by (simp add: nth_append)

lemma nth_app_eq1_rev:   "i < length sla \<Longrightarrow>  sla ! i = (sla @ sl) ! i"
  by (simp add: nth_append)

lemma nth_app_eq2[rule_format]: "\<forall> sl i. length sla \<le> i \<and> i < length (sla @ sl)
                     \<longrightarrow> (sla @ sl) ! i = sl ! (i - (length sla))"
  by (simp add: nth_append)

lemma tl_ne_ex[rule_format]: "l \<noteq> [] \<longrightarrow> (? x . l = x # (tl l))"
  by (induction l, auto)

lemma tl_nempty_lngth[rule_format]: "tl sl \<noteq> [] \<longrightarrow> 2 \<le> length(sl)"
  using le_less by fastforce

lemma list_app_one_length: "length l = n \<Longrightarrow> (l @ [s]) ! n = s"
  by (erule subst, simp)

lemma tl_lem1[rule_format]: "l \<noteq> [] \<longrightarrow> tl l = [] \<longrightarrow> length l = 1"
  by (induction l, simp+)

lemma nth_tl_length[rule_format]: "tl sl \<noteq> [] \<longrightarrow>
      tl sl ! (length (tl sl) - Suc (0)) = sl ! (length sl - Suc (0))"
  by (induction sl, simp+)

lemma nth_tl_length1[rule_format]: "tl sl \<noteq> [] \<longrightarrow>
      tl sl ! n = sl ! (n + 1)"
  by (induction sl, simp+)

lemma ineq1: "i < length sla - n  \<Longrightarrow>
       (0) \<le> n \<Longrightarrow> i < length sla"
by simp

lemma ineq2[rule_format]: "length sla \<le> i \<longrightarrow> i + (1) - length sla = i - length sla + 1"
by arith

lemma ineq3: "tl sl \<noteq> []  \<Longrightarrow> length sla \<le> i \<Longrightarrow> i < length (sla @ tl sl) - (1)
              \<Longrightarrow> i - length sla + (1) < length sl - (1)"
by simp

lemma tl_eq1[rule_format]: "sl \<noteq> [] \<longrightarrow> tl sl ! (0) = sl ! Suc (0)"
  by (induction sl, simp+)

lemma tl_eq2[rule_format]: "tl sl = [] \<longrightarrow> sl ! (0) = sl ! (length sl - (1))"
  by (induction sl, simp+)

lemma tl_eq3[rule_format]: "tl sl \<noteq> [] \<longrightarrow>
    tl sl ! (length sl - Suc (Suc (0))) = sl ! (length sl - Suc (0))"
  by (induction sl, simp+)

lemma nth_app_eq3: assumes "tl sl \<noteq> []"
  shows "(sla @ tl sl) ! (length (sla @ tl sl) - (1)) = sl ! (length sl - (1))"
  using assms nth_app_eq nth_tl_length by fastforce

lemma not_empty_ex: "A \<noteq> {} \<Longrightarrow> ? x. x \<in> A"
by force

lemma fst_att_eq: "(fst x # sl) ! (0) = fst (attack (al \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>))"
by simp

lemma list_eq1[rule_format]: "sl \<noteq> [] \<longrightarrow>
     (fst x # sl) ! (length (fst x # sl) - (1)) = sl ! (length sl - (1))"
  by (induction sl, auto)

lemma attack_eq1: "snd (attack (x1 # x2a \<oplus>\<^sub>\<and>\<^bsup>x\<^esup>)) = snd (attack (x2a \<oplus>\<^sub>\<and>\<^bsup>(snd (attack x1), snd x)\<^esup>))"
by simp

lemma fst_lem1[rule_format]: "\<forall> (a:: 's set) b (c :: 's set) d. (a, c) = (b, d) \<longrightarrow> a = b"
by auto

lemma fst_eq1: "(sla ! (0), y) = attack x1 \<Longrightarrow>
       sla ! (0) = fst (attack x1)"
  by (rule_tac c = y and d = "snd(attack  x1)" in fst_lem1, simp)

lemma base_att_lem1: " y0 \<subseteq> y1 \<Longrightarrow> \<turnstile> \<N>\<^bsub>(y1, y)\<^esub> \<Longrightarrow>\<turnstile> \<N>\<^bsub>(y0, y)\<^esub>"
  by (simp add: att_base, blast)

lemma ref_pres_att: "A \<sqsubseteq> A' \<Longrightarrow> attack A = attack A'"
proof (erule refines_to.induct)
  show "\<And>(A::'a attree) (l::'a attree list) (si'::'a set) (si''::'a set) (l''::'a attree list) (si::'a set)
       (si'''::'a set) (A'::'a attree) (l'::'a attree list) A''::'a attree.
       A = (l @ [\<N>\<^bsub>(si', si'')\<^esub>] @ l'' \<oplus>\<^sub>\<and>\<^bsup>(si, si''')\<^esup>) \<Longrightarrow>
       A' = (l' \<oplus>\<^sub>\<and>\<^bsup>(si', si'')\<^esup>) \<Longrightarrow> A'' = (l @ l' @ l'' \<oplus>\<^sub>\<and>\<^bsup>(si, si''')\<^esup>) \<Longrightarrow> attack A = attack A''"
    by simp
next show "\<And>(as::'a attree list) (A::'a attree) (s::'a set \<times> 'a set).
       as \<noteq> [] \<Longrightarrow>
       (\<forall>A'::'a attree\<in> (set as). ((A \<sqsubseteq> A') \<and> (attack A = attack A')) \<and> attack A = s) \<Longrightarrow>
       attack A = attack (as \<oplus>\<^sub>\<or>\<^bsup>s\<^esup>)"
    using last_in_set by auto
next show "\<And>(A::'a attree) (A'::'a attree) A''::'a attree.
       A \<sqsubseteq> A' \<Longrightarrow> attack A = attack A' \<Longrightarrow> A' \<sqsubseteq> A'' \<Longrightarrow> attack A' = attack A'' \<Longrightarrow> attack A = attack A''"
    by simp
next show "\<And>A::'a attree. attack A = attack A" by (rule refl)
qed

lemma  base_subset:
    assumes "xa \<subseteq> xc"
    shows  "\<turnstile>\<N>\<^bsub>(x, xa)\<^esub> \<Longrightarrow> \<turnstile>\<N>\<^bsub>(x, xc)\<^esub>"
proof (simp add: att_base)
  show " \<forall>x::'a\<in>x. \<exists>xa::'a\<in>xa. x \<rightarrow>\<^sub>i xa \<Longrightarrow> \<forall>x::'a\<in>x. \<exists>xa::'a\<in>xc. x \<rightarrow>\<^sub>i xa"
    by (meson assms in_mono)
qed

subsection "Correctness Theorem"
text \<open>Proof with induction over the definition of EF using the main
lemma @{text \<open>att_elem_seq0\<close>}.

There is also a second version of Correctness for valid refinements.\<close>

theorem ATV_EF: "\<lbrakk> \<turnstile>\<^sub>V A; (I,s) = attack A \<rbrakk> \<Longrightarrow>
 (Kripke {s. \<exists> i \<in> I. (i \<rightarrow>\<^sub>i* s) } I  \<turnstile> EF s)"
  by (metis (full_types) AT_EF ref_pres_att ref_validity_def valid_ref_def)

subsection "Completeness Theorem"
text \<open>This section contains the completeness direction, informally:

@{text \<open>\<turnstile> EF s \<Longrightarrow> \<exists> A. \<turnstile> A \<and> attack A = (I,s)\<close>}.

The main theorem is presented last since its
proof just summarises a number of main lemmas @{text \<open>Compl_step1, Compl_step2,
Compl_step3, Compl_step4\<close>} which are presented first together with other
auxiliary lemmas.\<close>

subsubsection "Lemma @{text \<open>Compl_step1\<close>}"
lemma Compl_step1:
"Kripke {s :: ('s :: state). \<exists> i \<in> I. (i \<rightarrow>\<^sub>i* s)} I  \<turnstile> EF s
\<Longrightarrow> \<forall> x \<in> I. \<exists> y \<in> s. x \<rightarrow>\<^sub>i* y"
  by (simp add: EF_step_star_rev valEF_E)

subsubsection "Lemma @{text \<open>Compl_step2\<close>}"
text \<open>First, we prove some auxiliary lemmas.\<close>
lemma rtrancl_imp_singleton_seq2: "x \<rightarrow>\<^sub>i* y \<Longrightarrow>
          x = y \<or> (\<exists> s. s \<noteq> [] \<and> (tl s \<noteq> []) \<and> s ! 0 = x \<and> s ! (length s - 1) = y \<and>
               (\<forall> i < (length s - 1). (s ! i) \<rightarrow>\<^sub>i (s ! (Suc i))))"

  unfolding state_transition_refl_def
proof (induction rule: rtrancl_induct)
  case base
  then show ?case
    by simp
next
  case (step y z)
  show ?case
    using step.IH
  proof (elim disjE exE conjE)
    assume "x=y"
    with step.hyps show ?case
      by (force intro!: exI [where x="[y,z]"])
  next
    show "\<And>s. \<lbrakk>s \<noteq> []; tl s \<noteq> []; s ! 0 = x;
          s ! (length s - 1) = y;
          \<forall>i<length s - 1.
             s ! i \<rightarrow>\<^sub>i s ! Suc i\<rbrakk>
         \<Longrightarrow> x = z \<or>
             (\<exists>s. s \<noteq> [] \<and>
                  tl s \<noteq> [] \<and> s ! 0 = x \<and>
                  s ! (length s - 1) = z \<and>
                  (\<forall>i<length s - 1. s ! i \<rightarrow>\<^sub>i s ! Suc i))"
      apply (rule disjI2)
      apply (rule_tac x="s @ [z]" in exI)
      apply (auto simp: nth_append)
      by (metis One_nat_def Suc_lessI diff_Suc_1 mem_Collect_eq old.prod.case step.hyps(2))
  qed
qed

lemma tl_nempty_length[rule_format]: "s \<noteq> [] \<longrightarrow> tl s \<noteq> [] \<longrightarrow> 0 < length s - 1"
  by (induction s, simp+)

lemma tl_nempty_length2[rule_format]: "s \<noteq> [] \<longrightarrow> tl s \<noteq> [] \<longrightarrow> Suc 0 < length s"
  by (induction s, simp+)

lemma length_last[rule_format]: "(l @ [x]) ! (length (l @ [x]) - 1) = x"
  by (induction l, simp+)

lemma Compl_step2: "\<forall> x \<in> I. \<exists> y \<in> s. x \<rightarrow>\<^sub>i* y \<Longrightarrow>
                   ( \<forall> x \<in> I.  x \<in> s \<or> (\<exists> (sl :: ((('s :: state) set)list)).
                  (sl \<noteq> []) \<and> (tl sl \<noteq> []) \<and>
                 (sl ! 0, sl ! (length sl - 1)) = ({x},s) \<and>
                 (\<forall> i < (length sl - 1).  \<turnstile> \<N>\<^bsub>(sl ! i,sl ! (i+1) )\<^esub>
                         )))"
proof (rule ballI, drule_tac x = x in bspec, assumption, erule bexE)
  fix x y
  assume a: "x \<in> I" and b: "y \<in> s" and  c: "x \<rightarrow>\<^sub>i* y"
  show "x \<in> s \<or>
       (\<exists>sl::'s set list.
           sl \<noteq> [] \<and>
           tl sl \<noteq> [] \<and>
           (sl ! (0), sl ! (length sl - (1))) = ({x}, s) \<and>
           (\<forall>i<length sl - (1). \<turnstile>\<N>\<^bsub>(sl ! i, sl ! (i + (1)))\<^esub>))"
  proof -
    have d : "x = y \<or>
       (\<exists>s'. s' \<noteq> [] \<and>
           tl s' \<noteq> [] \<and>
           s' ! (0) = x \<and>
           s' ! (length s' - (1)) = y \<and> (\<forall>i<length s' - (1). s' ! i \<rightarrow>\<^sub>i s' ! Suc i))"
      using c rtrancl_imp_singleton_seq2 by blast
    thus "x \<in> s \<or>
       (\<exists>sl::'s set list.
           sl \<noteq> [] \<and>
           tl sl \<noteq> [] \<and>
           (sl ! (0), sl ! (length sl - (1))) = ({x}, s) \<and>
           (\<forall>i<length sl - (1). \<turnstile>\<N>\<^bsub>(sl ! i, sl ! (i + (1)))\<^esub>))"
      apply (rule disjE)
      using b apply blast
      apply (rule disjI2, elim conjE exE)
      apply (rule_tac x = "[{s' ! j}. j \<leftarrow> [0..<(length s' - 1)]] @ [s]" in exI)
      apply (auto simp: nth_append)
        apply (metis AT.att_base Suc_lessD fst_conv prod.sel(2) singletonD singletonI)
       apply (metis AT.att_base Suc_lessI b fst_conv prod.sel(2) singletonD)
      using tl_nempty_length2 by blast
  qed
qed

subsubsection "Lemma @{text \<open>Compl_step3\<close>}"
text \<open>First, we need a few lemmas.\<close>
lemma map_hd_lem[rule_format] : "n > 0 \<longrightarrow> (f 0 #  map (\<lambda>i. f i) [1..<n]) = map  (\<lambda>i. f i) [0..<n]"
  by (simp add : hd_map upt_rec)

lemma map_Suc_lem[rule_format] : "n > 0 \<longrightarrow> map (\<lambda> i:: nat. f i)[1..<n] =
                                  map (\<lambda> i:: nat. f(Suc i))[0..<(n - 1)]"
proof -
  have "(f 0 # map (\<lambda>n. f (Suc n)) [0..<n - 1] = f 0 # map f [1..<n]) = (map (\<lambda>n. f (Suc n)) [0..<n - 1] = map f [1..<n])"
    by blast
  then show ?thesis
    by (metis Suc_pred' map_hd_lem map_upt_Suc)
qed

lemma forall_ex_fun: "finite S \<Longrightarrow> (\<forall> x \<in> S. (\<exists> y. P y x)) \<longrightarrow> (\<exists> f. \<forall> x \<in> S. P (f x) x)"
proof (induction rule: finite.induct)
  case emptyI
  then show ?case
    by simp
next
  case (insertI F x)
  then show ?case
  proof (clarify)
    assume d: "(\<forall>x::'a\<in>insert x F. \<exists>y::'b. P y x)"
    have "(\<forall>x::'a\<in>F. \<exists>y::'b. P y x)"
      using d by blast
    then obtain f where f: "\<forall>x::'a\<in>F. P (f x) x"
      using insertI.IH by blast
    from d obtain y where "P y x" by blast
    thus "(\<exists>f::'a \<Rightarrow> 'b. \<forall>x::'a\<in>insert x F. P (f x) x)" using f
      by (rule_tac x = "\<lambda> z. if z = x then y else f z" in exI, simp)
  qed
qed

primrec nodup :: "['a, 'a list] \<Rightarrow> bool"
  where
    nodup_nil: "nodup a [] = True" |
    nodup_step: "nodup a (x # ls) = (if x = a then (a \<notin> (set ls)) else nodup a ls)"

definition nodup_all:: "'a list \<Rightarrow> bool"
  where
    "nodup_all l \<equiv> \<forall> x \<in> set l. nodup x l"

lemma nodup_all_lem[rule_format]:
  "nodup_all (x1 # a # l) \<longrightarrow> (insert x1 (insert a (set l)) - {x1}) = insert a (set l)"
  by (induction l, (simp add: nodup_all_def)+)

lemma nodup_all_tl[rule_format]: "nodup_all (x # l) \<longrightarrow> nodup_all l"
  by (induction l, (simp add: nodup_all_def)+)

lemma finite_nodup: "finite I \<Longrightarrow> \<exists> l. set l = I \<and> nodup_all l"
proof (induction rule: finite.induct)
  case emptyI
  then show ?case
    by (simp add: nodup_all_def)
next
  case (insertI A a)
  then show ?case
    by (metis insertE insert_absorb list.simps(15) nodup_all_def nodup_step)
qed

lemma Compl_step3: "I \<noteq> {} \<Longrightarrow> finite I \<Longrightarrow>
     ( \<forall> x \<in> I.  x \<in> s \<or> (\<exists> (sl :: ((('s :: state) set)list)).
                  (sl \<noteq> []) \<and> (tl sl \<noteq> []) \<and>
                 (sl ! 0, sl ! (length sl - 1)) = ({x},s) \<and>
                 (\<forall> i < (length sl - 1).  \<turnstile> \<N>\<^bsub>(sl ! i,sl ! (i+1) )\<^esub>
                         )) \<Longrightarrow>
     (\<exists> lI. set lI = {x :: 's :: state. x \<in> I \<and> x \<notin> s} \<and> (\<exists> Sj :: ((('s :: state) set)list) list.
               length Sj = length lI \<and> nodup_all lI \<and>
            (\<forall> j < length Sj. (((Sj ! j)  \<noteq> []) \<and> (tl (Sj ! j) \<noteq> []) \<and>
                 ((Sj ! j) ! 0, (Sj ! j) ! (length (Sj ! j) - 1)) = ({lI ! j},s) \<and>
                 (\<forall> i < (length (Sj ! j) - 1).  \<turnstile> \<N>\<^bsub>((Sj ! j) ! i, (Sj ! j) ! (i+1) )\<^esub>
                         ))))))"
proof -
  assume i: "I \<noteq> {}" and f: "finite I" and
      fa: "\<forall>x::'s\<in>I.
       x \<in> s \<or>
       (\<exists>sl::'s set list.
           sl \<noteq> [] \<and>
           tl sl \<noteq> [] \<and>
           (sl ! (0), sl ! (length sl - (1))) = ({x}, s) \<and>
           (\<forall>i<length sl - (1). \<turnstile>\<N>\<^bsub>(sl ! i, sl ! (i + (1)))\<^esub>))"
  have a: "\<exists> lI. set lI = {x::'s \<in> I. x \<notin> s} \<and> nodup_all lI"
    by (simp add: f finite_nodup)
  from this obtain lI where b: "set lI = {x::'s \<in> I. x \<notin> s} \<and> nodup_all lI"
    by (erule exE)
  thus "\<exists>lI::'s list.
       set lI = {x::'s \<in> I. x \<notin> s} \<and>
       (\<exists>Sj::'s set list list.
           length Sj = length lI \<and>
           nodup_all lI \<and>
           (\<forall>j<length Sj.
               Sj ! j \<noteq> [] \<and>
               tl (Sj ! j) \<noteq> [] \<and>
               (Sj ! j ! (0), Sj ! j ! (length (Sj ! j) - (1))) = ({lI ! j}, s) \<and>
               (\<forall>i<length (Sj ! j) - (1). \<turnstile>\<N>\<^bsub>(Sj ! j ! i, Sj ! j ! (i + (1)))\<^esub>)))"
    apply (rule_tac x = lI in exI)
    apply (rule conjI)
     apply (erule conjE, assumption)
  proof -
    have c:  "\<forall> x \<in> set(lI). (\<exists> sl::'s set list.
              sl \<noteq> [] \<and>
              tl sl \<noteq> [] \<and>
              (sl ! (0), sl ! (length sl - (1))) = ({x}, s) \<and>
              (\<forall>i<length sl - (1). \<turnstile>\<N>\<^bsub>(sl ! i, sl ! (i + (1)))\<^esub>))"
      using b fa by fastforce
    thus "\<exists>Sj::'s set list list.
       length Sj = length lI \<and>
       nodup_all lI \<and>
       (\<forall>j<length Sj.
           Sj ! j \<noteq> [] \<and>
           tl (Sj ! j) \<noteq> [] \<and>
           (Sj ! j ! (0), Sj ! j ! (length (Sj ! j) - (1))) = ({lI ! j}, s) \<and>
           (\<forall>i<length (Sj ! j) - (1). \<turnstile>\<N>\<^bsub>(Sj ! j ! i, Sj ! j ! (i + (1)))\<^esub>))"
      apply (subgoal_tac "finite (set lI)")
       apply (rotate_tac -1)
       apply (drule forall_ex_fun)
       apply (drule mp)
        apply assumption
       apply (erule exE)
       apply (rule_tac x = "[f (lI ! j). j \<leftarrow> [0..<(length lI)]]" in exI)
       apply simp
       apply (insert b)
       apply (erule conjE, assumption)
      apply (rule_tac A = "set lI" and B = I in finite_subset)
       apply blast
      by (rule f)
  qed
qed

subsubsection \<open>Lemma @{text \<open>Compl_step4\<close>}\<close>
text \<open>Again, we need some additional lemmas first.\<close>
lemma list_one_tl_empty[rule_format]: "length l = Suc (0 :: nat) \<longrightarrow> tl l = []"
  by (induction l, simp+)

lemma list_two_tl_not_empty[rule_format]: "\<forall> list. length l = Suc (Suc (length list)) \<longrightarrow> tl l \<noteq> []"
  by (induction l, simp+, force)

lemma or_empty: "\<turnstile>([] \<oplus>\<^sub>\<or>\<^bsup>({}, s)\<^esup>)" by (simp add: att_or)

text \<open>Note, this is not valid for any l, i.e., @{text \<open>\<turnstile> l \<oplus>\<^sub>\<or>\<^bsup>({}, s)\<^esup>\<close>} is not a theorem.\<close>
lemma list_or_upt[rule_format]:
 "\<forall> l . lI \<noteq> [] \<longrightarrow> length l = length lI \<longrightarrow> nodup_all lI \<longrightarrow>
  (\<forall> i < length lI. (\<turnstile> (l ! i)) \<and> (attack (l ! i) = ({lI ! i}, s)))
                \<longrightarrow> ( \<turnstile> (l \<oplus>\<^sub>\<or>\<^bsup>(set lI, s)\<^esup>))"
proof (induction lI, simp, clarify)
  fix x1 x2 l
  show "\<forall>l::'a attree list.
          x2 \<noteq> [] \<longrightarrow>
          length l = length x2 \<longrightarrow>
          nodup_all x2 \<longrightarrow>
          (\<forall>i<length x2. \<turnstile>(l ! i) \<and> attack (l ! i) = ({x2 ! i}, s)) \<longrightarrow> \<turnstile>(l \<oplus>\<^sub>\<or>\<^bsup>(set x2, s)\<^esup>) \<Longrightarrow>
       x1 # x2 \<noteq> [] \<Longrightarrow>
       length l = length (x1 # x2) \<Longrightarrow>
       nodup_all (x1 # x2) \<Longrightarrow>
       \<forall>i<length (x1 # x2). \<turnstile>(l ! i) \<and> attack (l ! i) = ({(x1 # x2) ! i}, s) \<Longrightarrow> \<turnstile>(l \<oplus>\<^sub>\<or>\<^bsup>(set (x1 # x2), s)\<^esup>)"
    apply (case_tac x2, simp, subst att_or, case_tac l, simp+)
    text \<open>Case @{text \<open>\<forall>i<Suc (Suc (length list)). \<turnstile>l ! i \<and> attack (l ! i) = ({(x1 # a # list) ! i}, s) \<Longrightarrow>
       x2 = a # list \<Longrightarrow>  \<turnstile>l \<oplus>\<^sub>\<or>\<^bsup>(insert x1 (insert a (set list)), s)\<^esup>\<close>}\<close>
    apply (subst att_or, case_tac l, simp, clarify, simp, rename_tac lista, case_tac lista, simp+)
    text \<open>Remaining conjunct of three conditions: @{text \<open> \<turnstile>aa \<and>
       fst (attack aa) \<subseteq> insert x1 (insert a (set list)) \<and>
       snd (attack aa) \<subseteq> s \<and> \<turnstile>ab # listb \<oplus>\<^sub>\<or>\<^bsup>(insert x1 (insert a (set list)) - fst (attack aa), s)\<^esup>\<close>}\<close>
    apply (rule conjI)
    text \<open>First condition @{text \<open> \<turnstile>aa\<close>}\<close>
     apply (drule_tac x = 0 in spec, drule mp, simp, (erule conjE)+, simp, rule conjI)
    text \<open>Second condition @{text \<open>fst (attack aa) \<subseteq> insert x1 (insert a (set list))\<close>}\<close>
     apply (drule_tac x = 0 in spec, drule mp, simp, erule conjE, simp)
    text \<open>The remaining conditions

          @{text \<open>snd (attack aa) \<subseteq> s \<and> \<turnstile>ab # listb \<oplus>\<^sub>\<or>\<^bsup>(insert x1 (insert a (set list)) - fst (attack aa), s)\<^esup>\<close>}

          are solved automatically!\<close>
    by (metis Suc_mono add.right_neutral add_Suc_right list.size(4) nodup_all_lem nodup_all_tl nth_Cons_0 nth_Cons_Suc order_refl prod.sel(1) prod.sel(2) zero_less_Suc)
qed

lemma app_tl_empty_hd[rule_format]: "tl (l @ [a]) = [] \<longrightarrow> hd (l @ [a]) = a"
  by (induction l) auto

lemma tl_hd_empty[rule_format]: "tl (l @ [a]) = [] \<longrightarrow> l = []"
  by (induction l) auto

lemma tl_hd_not_empty[rule_format]: "tl (l @ [a]) \<noteq> [] \<longrightarrow> l \<noteq> []"
  by (induction l) auto

lemma app_tl_empty_length[rule_format]: "tl (map f [0..<length l] @ [a]) = []
                                        \<Longrightarrow> l = []"
  by (drule tl_hd_empty, simp)

lemma not_empty_hd_fst[rule_format]: "l \<noteq> [] \<longrightarrow> hd(l @ [a]) = l ! 0"
  by (induction l) auto

lemma app_tl_hd_list[rule_format]: "tl (map f [0..<length l] @ [a]) \<noteq> []
                             \<Longrightarrow> hd(map f [0..<length l] @ [a]) = (map f [0..<length l]) ! 0"
  by (drule tl_hd_not_empty, erule not_empty_hd_fst)

lemma tl_app_in[rule_format]: "l \<noteq> [] \<longrightarrow>
   map f [0..<(length l - (Suc 0:: nat))] @ [f(length l - (Suc 0 :: nat))] = map f [0..<length l]"
  by (induction l) auto

lemma map_fst[rule_format]: "n > 0 \<longrightarrow> map f [0..<n] = f 0 # (map f [1..<n])"
  by (induction n) auto

lemma step_lem[rule_format]:  "l \<noteq> [] \<Longrightarrow>
       tl (map (\<lambda> i. f((x1 # a # l) ! i)((a # l) ! i)) [0..<length l]) =
       map (\<lambda>i. f((a # l) ! i)(l ! i)) [0..<length l - (1)]"
proof (simp)
  assume l: "l \<noteq> []"
    have a: "map (\<lambda>i. f ((x1 # a # l) ! i) ((a # l) ! i)) [0..<length l] =
                 (f(x1)(a) # (map (\<lambda>i. f ((a # l) ! i) (l ! i)) [0..<(length l - 1)]))"
    proof -
      have b : "map (\<lambda>i. f ((x1 # a # l) ! i) ((a # l) ! i)) [0..<length l] =
                     f ((x1 # a # l) ! 0) ((a # l) ! 0) #
                     (map (\<lambda>i. f ((x1 # a # l) ! i) ((a # l) ! i)) [1..<length l])"
        by (rule map_fst, simp, rule l)
      have c: "map (\<lambda>i. f ((x1 # a # l) ! i) ((a # l) ! i)) [Suc (0)..<length l] =
                map (\<lambda>i. f ((x1 # a # l) ! Suc i) ((a # l) ! Suc i)) [(0)..<(length l - 1)]"
        by (subgoal_tac "[Suc (0)..<length l] = map Suc [0..<(length l - 1)]",
             simp, simp add: map_Suc_upt l)
      thus "map (\<lambda>i. f ((x1 # a # l) ! i) ((a # l) ! i)) [0..<length l] =
             f x1 a # map (\<lambda>i. f ((a # l) ! i) (l ! i)) [0..<length l - (1)]"
         by (simp add: b c)
    qed
    thus "l \<noteq> [] \<Longrightarrow>
    tl (map (\<lambda>i. f ((x1 # a # l) ! i) ((a # l) ! i)) [0..<length l]) =
    map (\<lambda>i. f ((a # l) ! i) (l ! i)) [0..<length l - Suc (0)]"
      by (subst a, simp)
  qed

lemma step_lem2a[rule_format]: "0 < length list \<Longrightarrow> map (\<lambda>i. \<N>\<^bsub>((x1 # a # list) ! i, (a # list) ! i)\<^esub>)
        [0..<length list] @
       [\<N>\<^bsub>((x1 # a # list) ! length list, (a # list) ! length list)\<^esub>] =
       aa # listb \<longrightarrow> \<N>\<^bsub>((x1, a))\<^esub> = aa"
  by (subst map_fst, assumption, simp)

lemma step_lem2b[rule_format]: "0 = length list \<Longrightarrow> map (\<lambda>i. \<N>\<^bsub>((x1 # a # list) ! i, (a # list) ! i)\<^esub>)
        [0..<length list] @
       [\<N>\<^bsub>((x1 # a # list) ! length list, (a # list) ! length list)\<^esub>] =
       aa # listb \<longrightarrow> \<N>\<^bsub>((x1, a))\<^esub> = aa"
by simp

lemma step_lem2: "map (\<lambda>i. \<N>\<^bsub>((x1 # a # list) ! i, (a # list) ! i)\<^esub>)
        [0..<length list] @
       [\<N>\<^bsub>((x1 # a # list) ! length list, (a # list) ! length list)\<^esub>] =
       aa # listb \<Longrightarrow> \<N>\<^bsub>((x1, a))\<^esub> = aa"
proof (case_tac "length list", rule step_lem2b, erule sym, assumption)
  show "\<And>nat.
       map (\<lambda>i. \<N>\<^bsub>((x1 # a # list) ! i, (a # list) ! i)\<^esub>) [0..<length list] @
       [\<N>\<^bsub>((x1 # a # list) ! length list, (a # list) ! length list)\<^esub>] =
       aa # listb \<Longrightarrow>
       length list = Suc nat \<Longrightarrow> \<N>\<^bsub>(x1, a)\<^esub> = aa"
    by (rule_tac list = list in step_lem2a, simp)
qed

lemma base_list_and[rule_format]: "Sji \<noteq> [] \<longrightarrow> tl Sji \<noteq> [] \<longrightarrow>
         (\<forall> li.  Sji ! (0) = li \<longrightarrow>
        Sji! (length (Sji) - 1) = s \<longrightarrow>
       (\<forall>i<length (Sji) - 1. \<turnstile>\<N>\<^bsub>(Sji ! i, Sji ! Suc i)\<^esub>) \<longrightarrow>
       \<turnstile> (map (\<lambda>i. \<N>\<^bsub>(Sji ! i, Sji ! Suc i)\<^esub>)
          [0..<length (Sji) - Suc (0)] \<oplus>\<^sub>\<and>\<^bsup>(li, s)\<^esup>))"
proof (induction Sji)
  case Nil
  then show ?case by simp
next
  case (Cons a Sji)
  then show ?case
    apply (subst att_and, case_tac Sji, simp, simp)
    apply (rule impI)+
  proof -
    fix aa list
    show "list \<noteq> [] \<longrightarrow>
       list ! (length list - Suc 0) = s \<longrightarrow>
       (\<forall>i<length list. \<turnstile>\<N>\<^bsub>((aa # list) ! i, list ! i)\<^esub>) \<longrightarrow>
       \<turnstile>(map (\<lambda>i. \<N>\<^bsub>((aa # list) ! i, list ! i)\<^esub>) [0..<length list] \<oplus>\<^sub>\<and>\<^bsup>(aa, s)\<^esup>) \<Longrightarrow>
       Sji = aa # list \<Longrightarrow>
       (aa # list) ! length list = s \<Longrightarrow>
       \<forall>i<Suc (length list). \<turnstile>\<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub> \<Longrightarrow>
       case map (\<lambda>i. \<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub>) [0..<length list] @
            [\<N>\<^bsub>((a # aa # list) ! length list, s)\<^esub>] of
       [] \<Rightarrow> fst (a, s) \<subseteq> snd (a, s) | [aa] \<Rightarrow> \<turnstile>aa \<and> attack aa = (a, s)
       | aa # ab # list \<Rightarrow>
           \<turnstile>aa \<and> fst (attack aa) = fst (a, s) \<and> \<turnstile>(ab # list \<oplus>\<^sub>\<and>\<^bsup>(snd (attack aa), snd (a, s))\<^esup>)"
    proof (case_tac "map (\<lambda>i. \<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub>) [0..<length list] @
            [\<N>\<^bsub>((a # aa # list) ! length list, s)\<^esub>]", simp, clarify, simp)
      fix ab lista
      have *: "tl (map (\<lambda>i. \<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub>) [0..<length list])
                    =  (map (\<lambda>i. \<N>\<^bsub>((aa # list) ! i, (list) ! i)\<^esub>) [0..<(length list - 1)])"
        if "list \<noteq> []"
        apply (subgoal_tac "tl (map (\<lambda>i. \<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub>) [0..<length list])
                    =  (map (\<lambda>i. \<N>\<^bsub>((aa # list) ! i, (list) ! i)\<^esub>) [0..<(length list - 1)])")
         apply blast
        apply (subst step_lem [OF that])
        apply simp
        done
      show "list \<noteq> [] \<longrightarrow>
       (\<forall>i<length list. \<turnstile>\<N>\<^bsub>((aa # list) ! i, list ! i)\<^esub>) \<longrightarrow>
       \<turnstile>(map (\<lambda>i. \<N>\<^bsub>((aa # list) ! i, list ! i)\<^esub>)
          [0..<length list] \<oplus>\<^sub>\<and>\<^bsup>(aa, list ! (length list - Suc 0))\<^esup>) \<Longrightarrow>
       Sji = aa # list \<Longrightarrow>
       \<forall>i<Suc (length list). \<turnstile>\<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub> \<Longrightarrow>
       map (\<lambda>i. \<N>\<^bsub>((a # aa # list) ! i, (aa # list) ! i)\<^esub>) [0..<length list] @
       [\<N>\<^bsub>((a # aa # list) ! length list, (aa # list) ! length list)\<^esub>] =
       ab # lista \<Longrightarrow>
       s = (aa # list) ! length list \<Longrightarrow>
       case lista of [] \<Rightarrow> \<turnstile>ab \<and> attack ab = (a, (aa # list) ! length list)
       | aba # lista \<Rightarrow>
           \<turnstile>ab \<and> fst (attack ab) = a \<and> \<turnstile>(aba # lista \<oplus>\<^sub>\<and>\<^bsup>(snd (attack ab), (aa # list) ! length list)\<^esup>)"
        apply (auto simp: split: list.split)
           apply (metis (no_types, lifting) app_tl_hd_list length_greater_0_conv list.sel(1) list.sel(3) list.simps(3) list.simps(8) list.size(3) map_fst nth_Cons_0 self_append_conv2 upt_0 zero_less_Suc)
          apply (metis (no_types, lifting) app_tl_hd_list attack.simps(1) fst_conv length_greater_0_conv list.sel(1) list.sel(3) list.simps(3) list.simps(8) list.size(3) map_fst nth_Cons_0 self_append_conv2 upt_0)
         apply (metis (mono_tags, lifting) app_tl_hd_list attack.simps(1) fst_conv length_greater_0_conv list.sel(1) list.sel(3) list.simps(3) list.simps(8) list.size(3) map_fst nth_Cons_0 self_append_conv2 upt_0)
        by (smt * One_nat_def app_tl_hd_list attack.simps(1) length_greater_0_conv list.sel(1) list.sel(3) list.simps(3) list.simps(8) list.size(3) map_fst nth_Cons_0 nth_Cons_pos self_append_conv2 snd_conv tl_app_in tl_append2 upt_0)
    qed
  qed
qed

lemma Compl_step4: "I \<noteq> {} \<Longrightarrow> finite I \<Longrightarrow> \<not> I \<subseteq> s \<Longrightarrow>
(\<exists> lI. set lI = {x. x \<in> I \<and> x \<notin> s} \<and> (\<exists> Sj :: ((('s :: state) set)list) list.
               length Sj = length lI \<and> nodup_all lI \<and>
            (\<forall> j < length Sj. (((Sj ! j)  \<noteq> []) \<and> (tl (Sj ! j) \<noteq> []) \<and>
                 ((Sj ! j) ! 0, (Sj ! j) ! (length (Sj ! j) - 1)) = ({lI ! j},s) \<and>
                 (\<forall> i < (length (Sj ! j) - 1).  \<turnstile> \<N>\<^bsub>((Sj ! j) ! i, (Sj ! j) ! (i+1) )\<^esub>
                         )))))
 \<Longrightarrow>  \<exists> (A :: ('s :: state) attree).  \<turnstile> A \<and> attack A = (I,s)"
proof (erule exE, erule conjE, erule exE, erule conjE)
  fix lI Sj
  assume  a: "I \<noteq> {}" and b: "finite I" and c: "\<not> I \<subseteq> s"
    and d: "set lI = {x::'s \<in> I. x \<notin> s}" and e: "length Sj = length lI"
    and f: "nodup_all lI \<and>
              (\<forall>j<length Sj. Sj ! j \<noteq> [] \<and>
                             tl (Sj ! j) \<noteq> [] \<and>
           (Sj ! j ! (0), Sj ! j ! (length (Sj ! j) - (1))) = ({lI ! j}, s) \<and>
           (\<forall>i<length (Sj ! j) - (1). \<turnstile>\<N>\<^bsub>(Sj ! j ! i, Sj ! j ! (i + (1)))\<^esub>))"
  show    "\<exists>A::'s attree. \<turnstile>A \<and> attack A = (I, s)"
    apply (rule_tac x =
        "[([] \<oplus>\<^sub>\<or>\<^bsup>({x. x \<in> I \<and> x \<in> s}, s)\<^esup>),
    ([[ \<N>\<^bsub>((Sj ! j) ! i, (Sj ! j) ! (i + (1)))\<^esub>.
      i \<leftarrow> [0..<(length (Sj ! j)-(1))]] \<oplus>\<^sub>\<and>\<^bsup>(({lI ! j},s))\<^esup>. j \<leftarrow> [0..<(length Sj)]]
     \<oplus>\<^sub>\<or>\<^bsup>({x. x \<in> I \<and> x \<notin> s},s)\<^esup>)] \<oplus>\<^sub>\<or>\<^bsup>(I, s)\<^esup>" in exI)
  proof
    show  "\<turnstile>([[] \<oplus>\<^sub>\<or>\<^bsup>({x::'s \<in> I. x \<in> s}, s)\<^esup>,
       map (\<lambda>j.
               ((map (\<lambda>i. \<N>\<^bsub>(Sj ! j ! i, Sj ! j ! (i + (1)))\<^esub>)
                [0..<length (Sj ! j) - (1)]) \<oplus>\<^sub>\<and>\<^bsup>({lI ! j}, s)\<^esup>))
       [0..<length Sj] \<oplus>\<^sub>\<or>\<^bsup>({x::'s \<in> I. x \<notin> s}, s)\<^esup>] \<oplus>\<^sub>\<or>\<^bsup>(I, s)\<^esup>)"
    proof -
      have g: "I - {x::'s \<in> I. x \<in> s} = {x::'s \<in> I. x \<notin> s}" by blast
      thus "\<turnstile>([[] \<oplus>\<^sub>\<or>\<^bsup>({x::'s \<in> I. x \<in> s}, s)\<^esup>,
       (map (\<lambda>j.
               ((map (\<lambda>i. \<N>\<^bsub>(Sj ! j ! i, Sj ! j ! (i + (1)))\<^esub>)
                [0..<length (Sj ! j) - (1)]) \<oplus>\<^sub>\<and>\<^bsup>({lI ! j}, s)\<^esup>))
       [0..<length Sj]) \<oplus>\<^sub>\<or>\<^bsup>({x::'s \<in> I. x \<notin> s}, s)\<^esup>] \<oplus>\<^sub>\<or>\<^bsup>(I, s)\<^esup>)"
        apply (subst att_or, simp)
      proof
        show "I - {x \<in> I. x \<in> s} = {x \<in> I. x \<notin> s} \<Longrightarrow> \<turnstile>([] \<oplus>\<^sub>\<or>\<^bsup>({x \<in> I. x \<in> s}, s)\<^esup>)"
          by (metis (no_types, lifting) CollectD att_or_empty_back subsetI)
      next show "I - {x \<in> I. x \<in> s} = {x \<in> I. x \<notin> s} \<Longrightarrow>
    \<turnstile>([map (\<lambda>j. ((map (\<lambda>i. \<N>\<^bsub>(Sj ! j ! i, Sj ! j ! Suc i)\<^esub>) [0..<length (Sj ! j) - Suc 0]) \<oplus>\<^sub>\<and>\<^bsup>({lI ! j}, s)\<^esup>))
        [0..<length Sj] \<oplus>\<^sub>\<or>\<^bsup>({x \<in> I. x \<notin> s}, s)\<^esup>] \<oplus>\<^sub>\<or>\<^bsup>({x \<in> I. x \<notin> s}, s)\<^esup>)"
          text \<open>Use lemma @{text \<open>list_or_upt\<close>} to distribute attack validity  over list lI\<close>
        proof (erule ssubst, subst att_or, simp, rule subst, rule d, rule_tac lI = lI in list_or_upt)
          show "lI \<noteq> []"
            using c d by auto
        next show "\<And>i.
       i < length lI \<Longrightarrow>
       \<turnstile>(map (\<lambda>j.
                 ((map (\<lambda>i. \<N>\<^bsub>(Sj ! j ! i, Sj ! j ! Suc i)\<^esub>)
                  [0..<length (Sj ! j) - Suc (0)]) \<oplus>\<^sub>\<and>\<^bsup>({lI ! j}, s)\<^esup>))
          [0..<length Sj] !
         i) \<and>
       (attack
        (map (\<lambda>j.
                 ((map (\<lambda>i. \<N>\<^bsub>(Sj ! j ! i, Sj ! j ! Suc i)\<^esub>)
                  [0..<length (Sj ! j) - Suc (0)]) \<oplus>\<^sub>\<and>\<^bsup>({lI ! j}, s)\<^esup>))
          [0..<length Sj] !
         i) =
       ({lI ! i}, s))"
          proof (simp add: a b c d e f)
            show "\<And>i.
                i < length lI \<Longrightarrow>
                \<turnstile>(map (\<lambda>ia. \<N>\<^bsub>(Sj ! i ! ia, Sj ! i ! Suc ia)\<^esub>)
                [0..<length (Sj ! i) - Suc (0)] \<oplus>\<^sub>\<and>\<^bsup>({lI ! i}, s)\<^esup>)"
            proof -
              fix i :: nat
              assume a1: "i < length lI"
              have "\<forall>n. \<turnstile>map (\<lambda>na. \<N>\<^bsub>(Sj ! n ! na, Sj ! n ! Suc na)\<^esub>) [0..< length (Sj ! n) - 1] \<oplus>\<^sub>\<and>\<^bsup>(Sj ! n ! 0, Sj ! n ! (length (Sj ! n) - 1))\<^esup> \<or> \<not> n < length Sj"
                by (metis (no_types) One_nat_def add.right_neutral add_Suc_right base_list_and f)
              then show "\<turnstile>map (\<lambda>n. \<N>\<^bsub>(Sj ! i ! n, Sj ! i ! Suc n)\<^esub>) [0..< length (Sj ! i) - Suc 0] \<oplus>\<^sub>\<and>\<^bsup>({lI ! i}, s)\<^esup>"
                using a1 by (metis (no_types) One_nat_def e f)
            qed
          qed
        qed (auto simp add: e f)
      qed
    qed
  qed auto
qed

subsubsection \<open>Main Theorem Completeness\<close>
theorem Completeness: "I \<noteq> {} \<Longrightarrow> finite I \<Longrightarrow>
Kripke {s :: ('s :: state). \<exists> i \<in> I. (i \<rightarrow>\<^sub>i* s)} (I :: ('s :: state)set)  \<turnstile> EF s
\<Longrightarrow> \<exists> (A :: ('s :: state) attree). \<turnstile> A \<and> attack A = (I,s)"
proof (case_tac "I \<subseteq> s")
  show "I \<noteq> {} \<Longrightarrow> finite I \<Longrightarrow>
    Kripke {s::'s. \<exists>i::'s\<in>I. i \<rightarrow>\<^sub>i* s} I \<turnstile> EF s \<Longrightarrow> I \<subseteq> s \<Longrightarrow> \<exists>A::'s attree. \<turnstile>A \<and> attack A = (I, s)"
    using att_or_empty_back attack.simps(3) by blast
next
  show "I \<noteq> {} \<Longrightarrow> finite I \<Longrightarrow>
    Kripke {s::'s. \<exists>i::'s\<in>I. i \<rightarrow>\<^sub>i* s} I \<turnstile> EF s \<Longrightarrow> \<not> I \<subseteq> s
   \<Longrightarrow> \<exists>A::'s attree. \<turnstile>A \<and> attack A = (I, s)"
    by (iprover intro: Compl_step1 Compl_step2 Compl_step3 Compl_step4 elim: )
qed

subsubsection \<open>Contrapositions of Correctness and Completeness\<close>
lemma contrapos_compl:
  "I \<noteq> {} \<Longrightarrow> finite I \<Longrightarrow>
  (\<not> (\<exists> (A :: ('s :: state) attree). \<turnstile> A \<and> attack A = (I, - s))) \<Longrightarrow>
\<not> (Kripke {s. \<exists>i\<in>I. i \<rightarrow>\<^sub>i* s} I \<turnstile> EF (- s))"
  using Completeness by auto

lemma contrapos_corr:
"(\<not>(Kripke {s :: ('s :: state). \<exists> i \<in> I. (i \<rightarrow>\<^sub>i* s)} I  \<turnstile> EF s))
\<Longrightarrow> attack A = (I,s)
\<Longrightarrow> \<not> (\<turnstile> A)"
  using AT_EF by blast

end


theory Tutorial5
imports IMPArrayHoare "~~/src/HOL/Library/Multiset"
begin

context Imp_Array_Examples begin

section \<open>New Features\<close>

subsection \<open>Logical Variables\<close>
text \<open>
  Logical variables are included in Hoare-Triple
    \<open>(\<Turnstile> {P} c {Q}) = (\<forall>s t z. P z s \<and> (c, s) \<Rightarrow> t \<longrightarrow> Q z t)\<close>

    \<^item> Are the same in pre and post condition
    \<^item> Used to carry over information
\<close>

text \<open>Examples\<close>

text \<open>Result in terms of previous variables\<close>
lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} x::=$x*\<acute>5 {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*5}"
  by vcg

text \<open>Use tuples for multiple logical variables\<close>
lemma "\<Turnstile>\<^sub>t {\<lambda>(x\<^sub>0,y\<^sub>0). vars x y in x=x\<^sub>0 \<and> y=y\<^sub>0} x::=$x*$y {\<lambda>(x\<^sub>0,y\<^sub>0). vars x in x=x\<^sub>0*y\<^sub>0}"
  by vcg

text \<open>Use dummy argument for no logical variables\<close>
lemma "\<Turnstile>\<^sub>t {\<lambda>_. vars x in x\<noteq>0} x ::= $x div $x {\<lambda>_. vars x in x=1}"
  by vcg

text \<open>Logical variables must be the same on both sides!\<close>
lemma "\<Turnstile>\<^sub>t {\<lambda>(x\<^sub>0,y\<^sub>0). vars x y in x=x\<^sub>0 \<and> y=y\<^sub>0} x::=$x*$y {\<lambda>(x\<^sub>0). vars x in x=x\<^sub>0*y\<^sub>0}"
  oops (** type error! *)

text \<open>
  \<^item> Hoare-Rules do not significantly change due to introduction of logical variables.
  \<^item> But while-rule for total correctness becomes simpler
    \<^item> Uses logical variable to ensure decreasing states
    \<^item> Added to logical variables only for one precondition

\<close>
lemma
  assumes "wf R"
  assumes "\<Turnstile>\<^sub>t {Ph} c {\<lambda>(z,s\<^sub>0) s. P z s \<and> (s, s\<^sub>0) \<in> R}"
  assumes "\<And>z s. \<lbrakk>P z s; bval b s\<rbrakk> \<Longrightarrow> Ph (z,s) s"
  assumes "\<And>z s. \<lbrakk>P z s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q z s"
  shows "\<Turnstile>\<^sub>t {P} WHILE b DO c {Q}"
  using assms while_trule by blast

subsection \<open>Modified Specification\<close>

text \<open>
  Logical variables can be used to express which variables are not modified
  by a program.

    \<open>\<Turnstile>\<^sub>t {\<lambda>s\<^sub>0 s. P s \<and> s\<^sub>0=s } c {\<lambda>s\<^sub>0 t. Q t \<and> s\<^sub>0 = t on X}\<close>

    \<^item> Store previous state in logical variable, and specify unmodified
      variables in postcondition.
    \<^item> @{term "s = t on X"}: States \<open>s\<close> and \<open>t\<close> equal on variables in set \<open>X\<close>
\<close>

text \<open>
  \<^item> More convenient to specify \<^emph>\<open>modified\<close> variables (it's only finitely many!)
  \<^item> Annotate them to Hoare-triples
  \<^item> Annotation is approximation: May contain more variables than actually modified, but never less!
\<close>

lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} x::=$x*\<acute>5 {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*5} mod {''x''}"
  by vcg

(* Too many variables are OK *)
lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} x::=$x*\<acute>5 {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*5} mod {''x'',''y'',''z''}"
  by vcg

(* Too few are not! *)
lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} CLR y;; x::=$x*\<acute>5 {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*5} mod {''x''}"
  apply vcg
  (* Typical error message if modified variable annotation misses something *)
  oops

subsubsection \<open>Syntactic Approximation\<close>
text \<open>
  \<^item> Indeed, by default a syntactic approximation will be used by VCG
  \<^item> Just take all variables occurring on LHS of assignments or are cleared

    @{term_type "lhs_vars :: com \<Rightarrow> vname set"}

  \<^item> The VCG uses the following lemma:
\<close>
lemma
  assumes "lhs_vars c \<subseteq> X"
  assumes "\<Turnstile>\<^sub>t {P} c {Q}"
  shows "\<Turnstile>\<^sub>t {P} c {Q} mod X"
  using assms hoaret_modI by blast

(* x = 2^x\<^sub>0   *)
lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0 \<and> 0\<le>x} power2_prog {\<lambda>x\<^sub>0. vars x in x=2^nat x\<^sub>0} mod {''x''}"
  oops

subsection \<open>Framing\<close>

text \<open>
  \<^item> We have proven a nice specification of a complex program
\<close>
definition "mult5_prog \<equiv> x::=$x*\<acute>5"

lemma mult5_correct: "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} mult5_prog {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*5} mod {''x''}"
  unfolding mult5_prog_def
  by vcg

(* Declare lhs-vars for mult5_prog! *)

definition "mult25_prog \<equiv> mult5_prog;; mult5_prog"

lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} mult25_prog {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*25} mod {''x''}"
  unfolding mult25_prog_def
  apply vcg
  using mult5_correct
  oops

text \<open>
  \<^item> Problem: Specification not suited for VCG: It must work for all postconditions!

  \<^item> Solution: Frame rule (@{thm frame_rule}, @{thm frame_trule})
    \<open>   \<Turnstile> {P} c {Q}
    \<Longrightarrow> \<Turnstile> {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<longrightarrow> R z t)} c {R}\<close>

    Intuition:
      To ensure \<open>R\<close> after executing \<open>c\<close>, the precondition must ensure
        \<^item> P, (precondition to execute c)
        \<^item> R in the state \<open>t\<close> after executing c.
          The only thing we know about \<open>t\<close> is that it will satisfy \<open>Q\<close>

      Moreover, we allow different sets of logical variables for
        specification and program to be proved (\<open>z\<close> vs. \<open>z'\<close>)
\<close>

text \<open>
  \<^item> We also instantiate the frame rule for specifications with
    modifies-annotations

    \<open>
        \<Turnstile> {P} c {Q} mod X
    \<Longrightarrow> \<Turnstile> {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<and> s = t on - X \<longrightarrow> R z t)} c {R}\<close>

    \<^item> Here, we additionally know that the new state \<open>t\<close> is equal to the
      start state \<open>s\<close> on all unmodified variables

  \<^item> These rules are integrated with the VCG, just declare the specification as
    @{attribute vcg_rules}

\<close>

declare mult5_correct[vcg_rules]

lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0} mult25_prog {\<lambda>x\<^sub>0. vars x in x=x\<^sub>0*25} mod {''x''}"
  unfolding mult25_prog_def
  by vcg

(* Common error: Forgetting to CLR variable. *)

lemma "\<Turnstile>\<^sub>t {\<lambda>x\<^sub>0. vars x y z in x=x\<^sub>0} (*CLR r;;*) r::=$x {\<lambda>x\<^sub>0. vars r x y z in r=x\<^sub>0} mod {''r''}"
  apply vcg oops

section \<open>Case Study: Minsort\<close>

subsection \<open>Extracting a Range of an Array to a List\<close>
function (sequential) lran :: "(int \<Rightarrow> val) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> val list" where
  "lran a l h = (if l<h then a l # lran a (l+1) h else [])"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(_,l,h). nat (h-l))") auto

declare lran.simps[simp del]

text \<open>
  \<open>lran a l h\<close> is the list \<open>[a\<^sub>l,a\<^sub>l\<^sub>+\<^sub>1,...,a\<^sub>h\<^sub>-\<^sub>1]\<close>
\<close>

subsubsection \<open>Auxiliary Lemmas\<close>

lemma lran_empty[simp]:
  "lran a l l = []"
  "lran a l h = [] \<longleftrightarrow> h\<le>l"
  by (rewrite lran.simps; auto)+

lemma lran_bwd_simp: "lran a l h = (if l<h then lran a l (h-1)@[a (h-1)] else [])"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply (rewrite in "_ = \<hole>" lran.simps)
  by (auto simp: less_le)

lemma lran_append1[simp]: "l\<le>h \<Longrightarrow> lran a l (h + 1) = lran a l h @ [a h]"
  by (rewrite in "\<hole> = _" lran_bwd_simp) auto

lemma lran_prepend1[simp]: "l\<le>h \<Longrightarrow> lran a (l-1) h = a(l-1) # lran a l h"
  by (rewrite in "\<hole> = _" lran.simps) auto

lemma lran_tail[simp]: "lran a (l+1) h = tl (lran a l h)"
  apply (rewrite in "_ = \<hole>" lran.simps)
  apply auto
  done

lemma lran_butlast[simp]: "lran a l (h-1) = butlast (lran a l h)"
  apply (rewrite in "_ = \<hole>" lran_bwd_simp)
  apply auto
  done

lemma lran_upd_outside[simp]:
  "i<l \<Longrightarrow> lran (a(i:=x)) l h = lran a l h"
  "h\<le>i \<Longrightarrow> lran (a(i:=x)) l h = lran a l h"
  subgoal
    apply (induction a l h rule: lran.induct)
    apply (rewrite in "\<hole> = _" lran.simps)
    apply (rewrite in "_ = \<hole>" lran.simps)
    by (auto)
  subgoal
    apply (induction a l h rule: lran.induct)
    apply (rewrite in "\<hole> = _" lran.simps)
    apply (rewrite in "_ = \<hole>" lran.simps)
    by (auto)
  done

lemma lran_eq_iff: "lran a l h = lran a' l h \<longleftrightarrow> (\<forall>i. l\<le>i \<and> i<h \<longrightarrow> a i = a' i)"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply (rewrite in "_ = \<hole>" lran.simps)
  apply auto
  by (metis antisym_conv not_less zless_imp_add1_zle)

lemma set_lran[simp]: "set (lran a l h) = a`{l..<h}"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply auto
  by (metis atLeastLessThan_iff image_iff not_less not_less_iff_gr_or_eq zless_imp_add1_zle)

lemma atLeastLessThan_lower_incr: "l<h \<Longrightarrow> {l::int..<h} = insert l ({l+1..<h})" by auto

lemma mset_lran[simp]: "mset (lran a l h) = image_mset a (mset_set {l..<h})"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  by (auto simp: atLeastLessThan_lower_incr)

subsubsection \<open>Find Minimum\<close>

text \<open>Find index of minimum element in \<open>a i, ..., a (h-1)\<close>, return in \<open>j\<close>\<close>
definition "find_min \<equiv>
  CLR j;; CLR k;; CLR m;;
  j::=$i;; k::=$i+\<acute>1;; m::=a\<^bold>[$j\<^bold>];;
  WHILE $k<$h DO (
    (* m stores current minimum element, j stores its index *)
    IF a\<^bold>[$k\<^bold>] < $m THEN
      m ::= a\<^bold>[$k\<^bold>];;
      j::=$k
    ELSE SKIP;;
    k::=$k+\<acute>1
  )"

lemma [simp]: "lhs_vars find_min
  = {''k'', ''j'', ''m''}"
  unfolding find_min_def by auto

(* Augment the type signature as long as no type variables ('a,'b,...) occur
  in the output of the definition command! *)
definition find_min_invar :: "int \<Rightarrow> int \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> _"
  where
  "find_min_invar i h a j k m \<equiv>
      i\<le>j \<and> j<h \<and> i<k \<and> k\<le>h            (* Everything in range *)
    \<and> m = a j \<and> a j = Min (a`{i..<k})"  (* m stores minimum element, j its index *)

lemma set_intv_singleton[simp]: "{i::int..<i + 1} = {i}" by auto

lemma set_intv_plus:
  fixes l :: int shows "l\<^sub>0\<le>l \<Longrightarrow> {l\<^sub>0..<l + 1} = insert l {l\<^sub>0..<l}"
  by auto

lemma fmi_vcs_aux1: "i\<^sub>0 < k \<Longrightarrow> \<forall>x\<in>{i\<^sub>0..<k}. a\<^sub>0 k < (a\<^sub>0::int\<Rightarrow>int) x \<Longrightarrow> a\<^sub>0 k = Min (a\<^sub>0 ` {i\<^sub>0..<k + 1})"
  apply (rule Min_eqI[symmetric])
  apply (auto simp: Ball_def)
  using eq_iff by fastforce

lemma fmi_vcs:
  "\<lbrakk>k < h; find_min_invar i h a j k m; a k < m\<rbrakk> \<Longrightarrow> find_min_invar i h a k (k + 1) (a k)"
  "\<lbrakk>k < h; find_min_invar i h a j k m; \<not> a k < m\<rbrakk> \<Longrightarrow> find_min_invar i h a j (k + 1) m"
  "\<lbrakk>\<not> k < h; find_min_invar i h a j k m\<rbrakk> \<Longrightarrow> i \<le> j \<and> j < h \<and> a j = Min (a ` {i..<h})"
  "i < h \<Longrightarrow> find_min_invar i h a i (i + 1) (a i)"
  unfolding find_min_invar_def
  apply (simp_all add: fmi_vcs_aux1)
  subgoal
    apply (clarsimp simp add: set_intv_plus min_def not_less)
    apply (rule Min_eqI)
    apply auto
    by (metis atLeastLessThan_iff eq_iff image_eqI)
  done

lemma find_min_correct[vcg_rules]: "\<Turnstile>\<^sub>t
  {\<lambda>_. vars i h (a:imap) in i<h}
    find_min
  {\<lambda>_. vars i h (a:imap) j in i\<le>j \<and> j<h \<and> (a j = Min (a`{i..<h}))}
  mod {''j'',''k'',''m''}"
  unfolding find_min_def
  apply (rewrite annot_tinvar[where
    R="measure_exp ($h - $k)" and
    I="\<lambda>_. vars i h (a:imap) j k m in find_min_invar i h a j k m"
  ])
  apply vcg_all

  (* If the VCs make the simplifier loop, some more 'creative' techniques may help.

    using fmi_vcs by metis+

    Or, apply them one by one!
  *)
  using fmi_vcs(1) apply assumption
  using fmi_vcs(2) apply assumption
  using fmi_vcs(3) apply metis
  using fmi_vcs(3) apply metis
  using fmi_vcs(3) apply metis
  using fmi_vcs(4) apply metis
  done

text \<open>Sort the array \<open>a\<close> in between indices \<open>l\<close> and \<open>h\<close>.
  Idea: Find minimum element in remaining part array,
    swap to end of already sorted part.

    \<open>i\<close> points to first element of unsorted part.
\<close>
definition "minsort \<equiv>
  CLR i;;
  i::=$l;;
  WHILE $i<$h DO (
    find_min;;

    CLR t;;
    t ::= a\<^bold>[$i\<^bold>];;
    a\<^bold>[$i\<^bold>] ::= a\<^bold>[$j\<^bold>];;
    a\<^bold>[$j\<^bold>] ::= $t;;

    i::=$i+\<acute>1
  )"

definition "sorted_spec l l' \<equiv> mset l' = mset l \<and> sorted l'"

(* verify that all types are inferred as int, and no polymorphic ('a) types remain! *)
definition "I_minsort a\<^sub>0 l\<^sub>0 h\<^sub>0 a i \<equiv>
    l\<^sub>0\<le>i \<and> i\<le>h\<^sub>0
  \<and> mset (lran a\<^sub>0 l\<^sub>0 h\<^sub>0) = mset (lran a l\<^sub>0 h\<^sub>0)   (* Array contains original elements *)
  \<and> sorted (lran a l\<^sub>0 i)                        (* Sorted part is sorted *)
  \<and> (\<forall>k1\<in>{l\<^sub>0..<i}. \<forall>k2\<in>{i..<h\<^sub>0}. a k1 \<le> a k2)  (* Every element of unsorted part \<ge> sorted part *)
  "

lemma [simp]: "lhs_vars minsort = {''i'', ''a'', ''t'', ''k'', ''j'', ''m''}"
  unfolding minsort_def by auto

lemma atLeastThan_insert_lower: "l\<le>h \<Longrightarrow> {l-1..<h} = insert (l-1) {l::int..<h}" by auto

lemma image_mset_subst_in_range:
  assumes "i\<in>{l::int..<h}"
  shows "image_mset (f(i:=x)) (mset_set {l..<h}) = image_mset f (mset_set {l..<h}) - {#f i#} + {#x#}"
proof -
  from assms have "l<h" "l\<le>i" "i<h" by auto
  then show ?thesis
    apply (induction rule: int_less_induct)
    apply (auto simp: atLeastThan_insert_lower image_mset_subst_outside)
    apply (simp add: antisym_conv)
    done
qed

lemma minsort_vcs:
  "\<lbrakk>I_minsort z l ha aa ia; ia \<le> j; j < ha; aa j = Min (aa ` {ia..<ha})\<rbrakk>
       \<Longrightarrow> I_minsort z l ha (aa(ia := Min (aa ` {ia..<ha}), j := aa ia)) (ia + 1)"
  "\<lbrakk>\<not> i < h; I_minsort z l h a i\<rbrakk> \<Longrightarrow> sorted_spec (lran z l h) (lran a l h)"
  "l \<le> h \<Longrightarrow> I_minsort z l h z l"
  subgoal
    unfolding I_minsort_def
    apply (auto simp: sorted_append)
    apply (metis fun_upd_triv)
    apply (auto simp: image_mset_subst_in_range)
    done
  subgoal
    unfolding I_minsort_def sorted_spec_def
    by (auto)

  subgoal
    unfolding I_minsort_def
    by (auto)

  done

lemma minsort_correct: "\<Turnstile>\<^sub>t
  {\<lambda>a\<^sub>0. vars l h (a:imap) in l\<le>h \<and> a=a\<^sub>0}
    minsort
  {\<lambda>a\<^sub>0. vars l h (a:imap) in sorted_spec (lran a\<^sub>0 l h) (lran a l h) }
    mod {''i'',''t'',''j'',''k'',''m'',''a''}"

  unfolding minsort_def
  apply (rewrite annot_tinvar[where
    R = "measure_exp ($h - $i)" and
    I = "\<lambda>a\<^sub>0. vars l h (a:imap) i in I_minsort a\<^sub>0 l h a i"
    ])
  supply minsort_vcs[simp]
  by vcg

end

end