theory Lifter
  imports  "../Mergeable/Mergeable_Instances" "../Mergeable/Mono"
    "../Composition/Composition" "../Mergeable/Bump"
begin

(*
 * Here we define an abstraction that captures transforming
 * operations on a "smaller" structure (e.g., semantics of a
 * language component) to a larger (in the sense of
 * having "more fields"), ordered structure
 *)

(* When we lift syntaxes we reverse the function arrow *)
type_synonym ('a, 'b) syn_lifting = "('b \<Rightarrow> 'a)"

datatype ('syn, 'a, 'b) lifting =
  LMake  (LUpd : "('syn \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b)")
         (LOut : "('syn \<Rightarrow> 'b \<Rightarrow> 'a)")
         (LBase : "('syn \<Rightarrow> 'b)")

type_synonym ('syn, 'a, 'b) lifting' =
  "('syn, 'a, 'b) lifting"

definition LMap :: "('syn, 'a, 'b) lifting \<Rightarrow> ('syn \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('syn \<Rightarrow> 'b \<Rightarrow> 'b)"
  where
"LMap l f s b =
  LUpd l s (f s (LOut l s b)) b"

definition LNew :: "('syn, 'a, 'b) lifting \<Rightarrow> 'syn \<Rightarrow> 'a \<Rightarrow> 'b"  where
"LNew l s a = LUpd l s a (LBase l s)"

(* TODO: make sure this is a good idea. *)
declare LNew_def [simp]
declare LMap_def [simp]

type_synonym ('syn, 'b) valid_set =
"'syn \<Rightarrow> 'b set"

(* liftings can have several kinds of validity properties, only some of
   which depend on others.
*)

locale lifting_sig =
  fixes l :: "('syn, 'a, 'b :: Pord_Weak) lifting"
  fixes S :: "('syn, 'b) valid_set"

locale lifting_putonly = lifting_sig +
  assumes put_S : "\<And> s a b . LUpd l s a b \<in> S s"

locale lifting_presonly = lifting_sig +
  assumes pres :
    "\<And> v V supr f s .
         v \<in> V \<Longrightarrow>
         V \<subseteq> S s \<Longrightarrow>
         is_sup V supr \<Longrightarrow> supr \<in> S s \<Longrightarrow> is_sup (LMap l f s ` V) (LMap l f s supr)"

locale lifting_valid_presonly =
  lifting_putonly + lifting_presonly

(* weak + (strong?) + (base?) + (ok?) + (pres?) + (pairwise?) *)
(* TODO: support for vsg style reasoning *)
locale lifting_valid_weak =
  lifting_putonly +
  assumes put_get : "\<And> a . LOut l s (LUpd l s a b) = a"
  assumes get_put_weak : "\<And> s b . b \<in> S s \<Longrightarrow> b <[ LUpd l s (LOut l s b) b"

locale lifting_valid_ext = lifting_sig +
  assumes get_put : "\<And> s a b . b <[ LUpd l s a b"

locale lifting_valid = lifting_valid_weak + lifting_valid_ext

locale lifting_valid_base_ext = lifting_sig +
  assumes base : "\<And> s . LBase l s = \<bottom>"

locale lifting_valid_weak_base = lifting_valid_weak + lifting_valid_base_ext

locale lifting_valid_base = lifting_valid + lifting_valid_base_ext

locale lifting_valid_ok_ext =
  lifting_sig +
  assumes ok_S_valid : "\<And> s . ok_S \<subseteq> S s"
  assumes ok_S_put : "\<And> s a b . b \<in> ok_S \<Longrightarrow> LUpd l s a b \<in> ok_S"

locale lifting_valid_weak_ok = lifting_valid_weak + lifting_valid_ok_ext

locale lifting_valid_ok = lifting_valid + lifting_valid_ok_ext

locale lifting_valid_weak_base_ok =
  lifting_valid_weak + lifting_valid_base_ext + lifting_valid_ok_ext

locale lifting_valid_base_ok =
  lifting_valid + lifting_valid_base_ext + lifting_valid_ok_ext

locale lifting_valid_pres_ext = lifting_presonly

locale lifting_valid_weak_pres = lifting_valid_weak +
  lifting_valid_pres_ext

locale lifting_valid_pres = lifting_valid + lifting_valid_pres_ext

locale lifting_valid_base_pres_ext = lifting_valid_pres_ext +
  assumes bot_bad : "\<And> s . \<bottom> \<notin> S s"

locale lifting_valid_weak_base_pres =
  lifting_valid_weak + lifting_valid_base_ext + lifting_valid_base_pres_ext

locale lifting_valid_base_pres =
  lifting_valid + lifting_valid_base_ext + lifting_valid_base_pres_ext

locale lifting_valid_weak_ok_pres =
  lifting_valid_weak + lifting_valid_ok_ext + lifting_valid_pres_ext

locale lifting_valid_ok_pres =
  lifting_valid + lifting_valid_ok_ext + lifting_valid_pres_ext

locale lifting_valid_weak_base_ok_pres =
  lifting_valid_weak + lifting_valid_base_ext + lifting_valid_ok_ext + lifting_valid_base_pres_ext

(* generally we are assuming we won't be using ok and pres separately.
 * we could if we wanted to though. *)
locale lifting_valid_base_ok_pres =
  lifting_valid + lifting_valid_base_ext + lifting_valid_ok_ext + lifting_valid_base_pres_ext

locale lifting_valid_pairwise_ext =
  fixes S :: "('syn, 'b :: {Pordc, Pordps}) valid_set"
  assumes pairwise_S :
    "\<And> x1 x2 x3 s s12 s23 s13 s123 .
      x1 \<in> S s \<Longrightarrow>
      x2 \<in> S s \<Longrightarrow>
      x3 \<in> S s \<Longrightarrow>
      is_sup {x1, x2} s12 \<Longrightarrow>
      s12 \<in> S s \<Longrightarrow>
      is_sup {x2, x3} s23 \<Longrightarrow>
      s23 \<in> S s \<Longrightarrow>
      is_sup {x1, x3} s13 \<Longrightarrow>
      s13 \<in> S s \<Longrightarrow>
      is_sup {x1, x2, x3} s123 \<Longrightarrow>
      s123 \<in> S s"

locale lifting_valid_weak_pairwise = lifting_valid_weak + lifting_valid_pairwise_ext
locale lifting_valid_pairwise = lifting_valid + lifting_valid_pairwise_ext
locale lifting_valid_weak_base_pairwise = lifting_valid_weak_base + lifting_valid_pairwise_ext
locale lifting_valid_base_pairwise = lifting_valid_base + lifting_valid_pairwise_ext
locale lifting_valid_weak_ok_pairwise = lifting_valid_weak_ok + lifting_valid_pairwise_ext
locale lifting_valid_ok_pairwise = lifting_valid_ok + lifting_valid_pairwise_ext
locale lifting_valid_weak_base_ok_pairwise = lifting_valid_weak_base_ok + lifting_valid_pairwise_ext
locale lifting_valid_base_ok_pairwise = lifting_valid_base_ok + lifting_valid_pairwise_ext
locale lifting_valid_weak_pres_pairwise = lifting_valid_weak_pres + lifting_valid_pairwise_ext
locale lifting_valid_pres_pairwise = lifting_valid_pres +  lifting_valid_pairwise_ext
locale lifting_valid_weak_base_pres_pairwise = lifting_valid_weak_base_pres + lifting_valid_pairwise_ext
locale lifting_valid_base_pres_pairwise = lifting_valid_base_pres + lifting_valid_pairwise_ext
locale lifting_valid_weak_ok_pres_pairwise = lifting_valid_weak_ok_pres + lifting_valid_pairwise_ext
locale lifting_valid_ok_pres_pairwise = lifting_valid_ok_pres + lifting_valid_pairwise_ext
locale lifting_valid_weak_base_ok_pres_pairwise = lifting_valid_weak_base_ok_pres + lifting_valid_pairwise_ext
locale lifting_valid_base_ok_pres_pairwise = lifting_valid_base_ok_pres + lifting_valid_pairwise_ext

(* TODO: we could weaken this to not require this to hold for all syntax
 * data but instead for particular ones - for now let's not though. *)
(* TODO: this bump abstraction is probably a failed experiment, leaving it in for now...
 *)
definition gt_compat :: "('syn, 'a, 'b :: Pord_Weak) lifting \<Rightarrow> ('b :: Pord_Weak) \<Rightarrow> 'b \<Rightarrow> bool" where
"gt_compat l x1 x2 =
  (x1 \<noteq> x2 \<and> x1 <[ x2 \<and> (\<forall> s . LOut l s x1 = LOut l s x2))"

lemma gt_compatI :
  assumes "x1 \<noteq> x2"
  assumes "x1 <[ x2"
  assumes "\<And> s . LOut l s x1 = LOut l s x2"
  shows "gt_compat l x1 x2"
  using assms unfolding gt_compat_def
  by auto

lemma gt_compatD1 :
  assumes "gt_compat l x1 x2"
  shows "x1 \<noteq> x2"
  using assms unfolding gt_compat_def
  by auto

lemma gt_compatD2 :
  assumes "gt_compat l x1 x2"
  shows "x1 <[ x2"
  using assms unfolding gt_compat_def
  by auto

lemma gt_compatD3 :
  assumes "gt_compat l x1 x2"
  shows "LOut l s x1 = LOut l s x2"
  using assms unfolding gt_compat_def
  by auto

definition bump_spec :: "('syn, 'a, 'b :: Pord_Weak) lifting \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> bool" where
"bump_spec l bf =
  (\<forall> x . is_least (gt_compat l x) (bf x))"

lemma bump_specI :
  assumes H1 :
    "\<And> x . gt_compat l x (bf x)"
  assumes H2 :
    "\<And> x x' . gt_compat l x x' \<Longrightarrow> bf x <[ x'"
  shows "bump_spec l bf"
  using assms
  unfolding bump_spec_def is_least_def
  by(blast)

lemma bump_specD1 :
  assumes "bump_spec l bf"
  shows "gt_compat l x (bf x)"
  using assms unfolding bump_spec_def is_least_def by auto

lemma bump_specD2 :
  assumes "bump_spec l bf"
  assumes "gt_compat l x x'"
  shows "bf x <[ x'"
  using assms unfolding bump_spec_def is_least_def
  by blast

locale lifting_valid_bump_ext =
  fixes l :: "('syn, 'a, 'b :: Bump) lifting"
  fixes S :: "('syn, 'b) valid_set"
  assumes bump_S : "\<And> s b . b \<in> S s \<Longrightarrow> bump b \<in> S s"
  assumes bump_out :
    "\<And> s b . b \<in> S s \<Longrightarrow> LOut l s (bump b) = LOut l s b"
  assumes bump_bump_spec :
    "bump_spec l (bump :: ('b \<Rightarrow> 'b))"

locale lifting_valid_bump_ok_ext =
  fixes l :: "('syn, 'a, 'b :: {Bump, Okay}) lifting"
  assumes bump_ok_S : "\<And> (b :: 'b) . b \<in> ok_S \<Longrightarrow> bump b \<in> ok_S"

(* "output-consistent"
 * the idea here is
 * if the following hold on 2 pieces of data
  - has a least uppeer bound, which is valid
  - LOut of the two are equal

 * then LOut of the least upper bound is equal to that same value.
*)

(* do we need the supr \<in> S s constraint? *)
locale lifting_valid_oc_ext =
  fixes l :: "('syn, 'a, 'b :: Pord_Weak) lifting"
  fixes S :: "('syn, 'b) valid_set"
  assumes output_consistent :
    "\<And> (Xs :: 'b set) (supr :: 'b) (w :: 'b) (s :: 'syn) (r :: 'a) .
      w \<in> Xs \<Longrightarrow>
      is_sup Xs supr \<Longrightarrow>
      \<comment> \<open> supr \<in> S s \<Longrightarrow> \<close>
      (\<And> x . x \<in> Xs \<Longrightarrow> LOut l s x = r) \<Longrightarrow>
      LOut l s supr = r"

(* orthogonality, used to define merge correctness *)
locale l_ortho' =
  fixes l1 :: "('a, 'b1, 'c :: Pord) lifting"
  fixes S1 :: "'a \<Rightarrow> 'c set"
  fixes l2 :: "('a, 'b2, 'c :: Pord) lifting"
  fixes S2 :: "'a \<Rightarrow> 'c set"

locale l_ortho =
  l_ortho' +

assumes eq_base : "\<And> s . LBase l1 s = LBase l2 s"
  assumes compat : "\<And> s a1 a2 . LUpd l1 s a1 (LUpd l2 s a2 b) = LUpd l2 s a2 (LUpd l1 s a1 b)"
  assumes put1_get2 : "\<And> s a1 . LOut l2 s (LUpd l1 s a1 b) = LOut l2 s b"
  assumes put2_get1 : "\<And> s a2 . LOut l1 s (LUpd l2 s a2 b) = LOut l1 s b"
  assumes put1_S2 : "\<And> s a1 . b \<in> S2 s \<Longrightarrow> LUpd l1 s a1 b \<in> S2 s"
  assumes put2_S1 : "\<And> s a2 . b \<in> S1 s \<Longrightarrow> LUpd l2 s a2 b \<in> S1 s"

locale l_ortho_pres' =
  fixes l1 :: "('a, 'b1, 'c :: Pordb) lifting"
  fixes S1 :: "'a \<Rightarrow> 'c set"
  fixes l2 :: "('a, 'b2, 'c :: Pordb) lifting"
  fixes S2 :: "'a \<Rightarrow> 'c set"

locale l_ortho_pres_ext = l_ortho_pres' +
  assumes compat_pres_sup :
  "\<And> a1 a2 s x . is_sup {LUpd l1 s a1 x, LUpd l2 s a2 x} (LUpd l1 s a1 (LUpd l2 s a2 x))"

locale l_ortho_base' =
  fixes l1 :: "('a, 'b1, 'c :: Pord_Weakb) lifting"
  fixes l2 :: "('a, 'b2, 'c) lifting"

locale l_ortho_base_ext = l_ortho_base' +
  assumes compat_base1 : "\<And> s . LBase l1 s = \<bottom>"
  assumes compat_base2 : "\<And> s . LBase l2 s = \<bottom>"

locale l_ortho_ok' =
  fixes l1 :: "('a, 'b1, 'c :: {Pord_Weakb, Okay}) lifting"
  fixes l2 :: "('a, 'b2, 'c) lifting"

locale l_ortho_ok_ext = l_ortho_ok'

locale l_ortho_pres = l_ortho + l_ortho_pres_ext
locale l_ortho_base = l_ortho + l_ortho_base_ext
locale l_ortho_base_pres = l_ortho + l_ortho_base_ext + l_ortho_pres_ext
locale l_ortho_ok = l_ortho + l_ortho_ok_ext
locale l_ortho_base_ok = l_ortho + l_ortho_base_ext + l_ortho_ok_ext
locale l_ortho_ok_pres = l_ortho + l_ortho_ok_ext + l_ortho_pres_ext
locale l_ortho_base_ok_pres = l_ortho + l_ortho_base_ext + l_ortho_ok_ext + l_ortho_pres_ext

(* lift_map_s is LMap plus a syntax translation *)
definition lift_map_s ::
  "('b1 \<Rightarrow> 'a1) \<Rightarrow>
   ('a1, 'a2, 'b2 :: Pord) lifting \<Rightarrow>
   ('a1 \<Rightarrow> 'a2 \<Rightarrow> 'a2) \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2)" where
"lift_map_s l' l sem syn st =
  LMap l sem (l' syn) st"

(* commutativity of l_ortho *)
sublocale l_ortho \<subseteq> comm :
  l_ortho l2 S2 l1 S1
proof

  fix s
  show "LBase l2 s = LBase l1 s"
    using eq_base by auto
next

  fix b s a1 a2

  show "LUpd l2 s a1 (LUpd l1 s a2 b) = LUpd l1 s a2 (LUpd l2 s a1 b)"
    using compat
    by auto

next

  fix b s a1
  show "LOut l1 s (LUpd l2 s a1 b) = LOut l1 s b"
    using put2_get1
    by auto
next

  fix b s a2
  show "LOut l2 s (LUpd l1 s a2 b) = LOut l2 s b"
    using put1_get2
    by auto

next

  fix b s a1
  assume "b \<in> S1 s"

  then show "LUpd l2 s a1 b \<in> S1 s"
    using put2_S1 by auto
next

  fix b s a2
  assume "b \<in> S2 s"

  then show "LUpd l1 s a2 b \<in> S2 s"
    using put1_S2 by auto
qed

sublocale l_ortho_base_ext \<subseteq> comm :
  l_ortho_base_ext l2 l1
proof
  show "\<And>s. LBase l2 s = \<bottom>"
    using compat_base1 compat_base2 by auto
next
  show "\<And>s. LBase l1 s = \<bottom>"
    using compat_base1 compat_base2 by auto
qed

end


(*<*)
(* Author: Kyndylan Nienhuis *)
(* Author: Thomas Bauereiss *)
theory Proof_methods
  imports Hoare_Extras "HOL-Eisbach.Eisbach_Tools"
begin
(*>*)

section \<open>Helper lemmas\<close>

subsection \<open>Split laws\<close>

lemmas case_split =
  Option.option.split
  List.list.split
  Product_Type.prod.split
  bool.split
  result.split
  ex.split

lemma let_split:
  fixes P
  shows "P (let x = y in f x) = (\<forall>x. x = y \<longrightarrow> P (f x))"
  by simp

lemmas all_split =
  if_splits(1)
  let_split
  case_split

subsection \<open>Congruences\<close>

lemmas default_weak_cong =
  if_weak_cong
  let_weak_cong
  option.case_cong_weak
  list.case_cong_weak
  prod.case_cong_weak
  sum.case_cong_weak
  result.case_cong_weak
  ex.case_cong_weak

lemmas default_cong =
  if_cong
  let_cong
  all_cong
  ball_cong
  imp_cong
  (*conj_cong
  disj_cong*)
  option.case_cong
  list.case_cong
  prod.case_cong
  sum.case_cong
  result.case_cong
  ex.case_cong
  bindS_cong
  iff_allI

subsection \<open>Strong congruence simplifier\<close>

method strong_cong_simp uses add del cong =
  (simp
     add: add
     del: del
     split del: if_splits(1)
     cong del: default_weak_cong
     cong add: default_cong cong)

method strong_cong_simp_all uses add del =
  (simp_all
     add: add
     del: del
     split del: if_splits(1)
     cong del: default_weak_cong
     cong add: default_cong)

method strong_cong_simp_only uses simp =
  (simp
     only: simp
     cong add: default_cong)

lemmas prod_if_distribs[simp] = if_distrib[where f = snd] if_distrib[where f = fst]
lemmas app_if_distrib = if_distrib[where f = "\<lambda>i. i x" for x]

lemma liftState_let_distrib[liftState_simp]: "liftState r (let x = y in m x) = (let x = y in liftState r (m x))"
  by simp

lemmas liftState_prod_distrib[liftState_simp] = prod.case_distrib[where h = "liftState r" for r]

method liftS uses add = (strong_cong_simp_only simp: add liftState_simp comp_def)

subsection \<open>Proving Hoare triples\<close>

text \<open>Tactics that iteratively apply Hoare proof rules and simplify goals, using both the proof
rules in the default collection and any additional rules provided as a parameter.\<close>

method repeat_all_new methods m =
  (m; repeat_all_new \<open>m\<close>)?

lemma PrePostE_if_branch_simp:
  assumes f: "b \<Longrightarrow> PrePostE Pf f Q E" and g: "\<not>b \<Longrightarrow> PrePostE Pg g Q E"
    and P: "\<And>s. P s = (if b then Pf s else Pg s)"
  shows "PrePostE P (if b then f else g) Q E"
  using f g unfolding P by auto

lemmas PrePost_casesI =
  all_split[where P="\<lambda>x. PrePost p x q", THEN iffD2] for p q

lemmas PrePostE_casesI =
  all_split[where P="\<lambda>x. PrePostE p x q e", THEN iffD2] for p q e

method PrePost_cases =
  rule PrePost_casesI PrePostE_casesI;
  (intro conjI impI allI)?;
  PrePost_cases?

method ComputePreAuto uses simp intro cong =
  auto simp: simp
       intro: intro
       cong del: default_weak_cong cong: default_cong cong
       split: option.splits

lemmas PrePost_weakest_pre_cases_arity_1 =
  PrePost_let PrePostE_let
  PrePost_prod_cases PrePostE_prod_cases_split PrePostE_prod_cases

lemmas PrePost_weakest_pre_cases_arity_1_simp =
  PrePost_if_then PrePostE_if_then
  PrePost_if_else PrePostE_if_else
  PrePostE_let_simp

lemmas PrePost_weakest_pre_cases_arity_2 =
  PrePost_bindS_unit PrePostE_bindS_unit
  PrePost_bindS_ignore PrePostE_bindS_ignore
  PrePost_if_branch PrePostE_if_branch
  PrePost_option_cases PrePostE_option_cases
  PrePost_and_boolS PrePostE_and_boolS
  PrePost_or_boolS PrePostE_or_boolS

lemmas PrePost_weakest_pre_cases_arity_2_simp =
  PrePostE_if_branch_simp

lemmas PrePost_weakest_pre_cases =
  PrePost_weakest_pre_cases_arity_1
  PrePost_weakest_pre_cases_arity_2
  PrePostE_bindS_any_simp PrePost_bindS

method ComputePre methods composite atom_simp final uses atomI =
  (composite,
     ComputePre composite atom_simp final atomI: atomI) |
  (rule PrePost_weakest_pre_cases_arity_1_simp,
     solves \<open>atom_simp\<close>,
     ComputePre composite atom_simp final atomI: atomI) |
  (rule PrePost_weakest_pre_cases_arity_2_simp PrePost_weakest_pre_cases
        PrePost_compositeI PrePostE_compositeI,
     ComputePre composite atom_simp final atomI: atomI) |
  (rule atomI PrePost_atomI PrePostE_atomI,
     ComputePre composite atom_simp final atomI: atomI) |
  (solves \<open>atom_simp\<close>, (ComputePre composite atom_simp final atomI: atomI)?) |
  final

text \<open>The following method corresponds to @\<open>method ComputePre\<close> without any recursive calls. The
purpose is to step through the method when debugging.\<close>

method ComputePre_debug_step methods composite atom_simp uses atomI constI bindI intro =
  (rule constI[THEN PrePostE_bindS_left_const] TrueI) |
  (composite) |
  (rule bindI TrueI) |
  (rule PrePost_weakest_pre_cases_arity_1_simp,
     solves \<open>atom_simp\<close>) |
  (rule PrePost_weakest_pre_cases_arity_2_simp PrePost_weakest_pre_cases) |
  (rule PrePost_compositeI PrePostE_compositeI) |
  (rule atomI TrueI) |
  (rule PrePost_atomI PrePostE_atomI) |
  solves \<open>atom_simp\<close>

method ParametricPrePost methods composite atom_simp final uses atomI simp =
  (*PrePost_cases?;*)
  (liftS add: simp)?,
  rule PrePost_strengthen_pre PrePostE_strengthen_pre,
  ComputePre composite atom_simp final atomI: atomI (*,
  (strong_cong_simp add: simp)?*)

method PrePost uses compositeI atomI simp =
  ParametricPrePost \<open>rule compositeI TrueI\<close> \<open>strong_cong_simp add: simp\<close> - atomI: atomI

method PrePostAuto uses compositeI atomI simp intro =
  ParametricPrePost \<open>rule compositeI TrueI\<close> \<open>ComputePreAuto simp: simp intro: intro\<close> \<open>ComputePreAuto simp: simp intro: intro\<close> atomI: atomI

lemma PrePostE_if_pre_then_True:
  assumes "PrePostE (\<lambda>_. True) f Q E"
    and "(*\<not>c \<Longrightarrow>*) PrePostE P g Q E"
  shows "PrePostE P (if c then f else g) Q E"
  by (PrePost atomI: assms)

lemma PrePostE_if_pre_else_True:
  assumes "PrePostE (\<lambda>_. True) g Q E"
    and "(*c \<Longrightarrow>*) PrePostE P f Q E"
  shows "PrePostE P (if c then f else g) Q E"
  by (PrePost atomI: assms)

thm PrePostE_if_then PrePostE_if_else

method ComputePre_if_heuristic =
  (rule PrePostE_if_then, solves \<open>strong_cong_simp\<close>) |
  (rule PrePostE_if_else, solves \<open>strong_cong_simp\<close>) |
  (rule PrePostE_if_pre_then_True, solves \<open>rule PrePostE_strengthen_pre, (rule PrePostE_compositeI PrePostE_atomI)+, strong_cong_simp\<close>) |
  (rule PrePostE_if_pre_else_True, solves \<open>rule PrePostE_strengthen_pre, (rule PrePostE_compositeI PrePostE_atomI)+, strong_cong_simp\<close>) |
  (rule PrePostE_if_branch_simp)

end


theory Hopcroft_Tarjan_2
  imports
    Hopcroft_Tarjan
begin

subsection \<open>Specification of the algorithm\<close>

(* TODO: Rename. *)
datatype 'b T = EOS | Triple (h': nat) (a': 'b) (b': 'b)

type_synonym ('a, 'b) component = "('a, 'b) Directed_Multigraph.edge list"

(* TODO: Add DEGREE. *)
record ('b, 't, 'g, 'm, 'a) state =
  root :: 'b
  tree :: 't
  multigraph :: 'g
  F :: 'm
  ESTACK :: "('a, 'b) Directed_Multigraph.edge list"
  TSTACK :: "'b T list"
  Cs :: "('a, 'b) component list"

(* QUESTION: Create locale Palm_Tree? *)
locale path_search =
  other
  where other = other +
    T: Map
  where empty = T_empty
    and update = T_update
    and delete = T_delete
    and lookup = T_lookup
    and invar = T_invar +
    P: Incidence_Structure
  where insert = insert +
    F: Map
  where empty = F_empty
    and update = F_update
    and delete = F_delete
    and lookup = F_lookup
    and invar = F_invar
  for other :: "('a::linorder, 'b::linorder) Multigraph.edge \<Rightarrow> 'b \<Rightarrow> 'b"
    and T_empty
    and T_update :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and T_delete
    and T_lookup
    and T_invar
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_empty
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm"
    and F_delete
    and F_lookup
    and F_invar +
  fixes while_loop_1 :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state"
  fixes while_loop_2 :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state"
  fixes while_loop_3 :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state"
  fixes while_loop_4 :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state"
  fixes algorithm_5 :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state"
  fixes algorithm_6 :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state"
  assumes root_while_loop_1: "root (while_loop_1 \<sigma>) = root \<sigma>"
  assumes tree_while_loop_1: "tree (while_loop_1 \<sigma>) = tree \<sigma>"
  assumes multigraph_while_loop_1: "multigraph (while_loop_1 \<sigma>) = multigraph \<sigma>"
  assumes F_while_loop_1: "F (while_loop_1 \<sigma>) = F \<sigma>"
  assumes ESTACK_while_loop_1: "ESTACK (while_loop_1 \<sigma>) = ESTACK \<sigma>"
  assumes Cs_while_loop_1: "Cs (while_loop_1 \<sigma>) = Cs \<sigma>"
  assumes root_while_loop_2: "root (while_loop_2 \<sigma>) = root \<sigma>"
  assumes tree_while_loop_2: "tree (while_loop_2 \<sigma>) = tree \<sigma>"
  assumes multigraph_while_loop_2: "multigraph (while_loop_2 \<sigma>) = multigraph \<sigma>"
  assumes F_while_loop_2: "F (while_loop_2 \<sigma>) = F \<sigma>"
  assumes ESTACK_while_loop_2: "ESTACK (while_loop_2 \<sigma>) = ESTACK \<sigma>"
  assumes Cs_while_loop_2: "Cs (while_loop_2 \<sigma>) = Cs \<sigma>"
  assumes root_while_loop_3: "root (while_loop_3 \<sigma>) = root \<sigma>"
  assumes tree_while_loop_3: "tree (while_loop_3 \<sigma>) = tree \<sigma>"
  assumes multigraph_while_loop_3: "multigraph (while_loop_3 \<sigma>) = multigraph \<sigma>"
  assumes F_while_loop_3: "F (while_loop_3 \<sigma>) = F \<sigma>"
  assumes ESTACK_while_loop_3: "ESTACK (while_loop_3 \<sigma>) = ESTACK \<sigma>"
  assumes Cs_while_loop_3: "Cs (while_loop_3 \<sigma>) = Cs \<sigma>"
  assumes root_while_loop_4: "root (while_loop_4 \<sigma>) = root \<sigma>"
  assumes tree_while_loop_4: "tree (while_loop_4 \<sigma>) = tree \<sigma>"
  assumes multigraph_while_loop_4: "multigraph (while_loop_4 \<sigma>) = multigraph \<sigma>"
  assumes F_while_loop_4: "F (while_loop_4 \<sigma>) = F \<sigma>"
  assumes ESTACK_while_loop_4: "ESTACK (while_loop_4 \<sigma>) = ESTACK \<sigma>"
  assumes Cs_while_loop_4: "Cs (while_loop_4 \<sigma>) = Cs \<sigma>"
  assumes root_algorithm_5: "root (algorithm_5 \<sigma>) = root \<sigma>"
  assumes root_algorithm_6: "root (algorithm_6 \<sigma>) = root \<sigma>"
  assumes TSTACK_algorithm_6: "TSTACK (algorithm_6 \<sigma>) = TSTACK \<sigma>"
begin

definition tree_arc_2 :: "('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'm, 'a) state \<Rightarrow> bool" where
  "tree_arc_2 e \<sigma> \<equiv> tree.tree_arc (T_lookup (tree \<sigma>)) e"

(*
definition traverse_tree_arc ::
  "('b \<Rightarrow> nat)
   \<Rightarrow> ('b \<Rightarrow> 'b)
      \<Rightarrow> ('b \<Rightarrow> 'b)
         \<Rightarrow> ('b \<Rightarrow> nat)
            \<Rightarrow> (('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool)
               \<Rightarrow> ('a, 'b) Directed_Multigraph.edge
                  \<Rightarrow> ('b, 't, 'g, 'm, 'a) state
                     \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "traverse_tree_arc N lowpt1 lowpt2 ND START e \<sigma> \<equiv> \<sigma>"
*)

(*
definition traverse_frond ::
  "('b \<Rightarrow> nat)
   \<Rightarrow> ('b \<Rightarrow> 'b)
      \<Rightarrow> ('b \<Rightarrow> 'b)
         \<Rightarrow> ('b \<Rightarrow> nat)
            \<Rightarrow> (('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool)
               \<Rightarrow> ('a, 'b) Directed_Multigraph.edge
                  \<Rightarrow> ('b, 't, 'g, 'm, 'a) state
                     \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "traverse_frond N lowpt1 lowpt2 ND START e \<sigma> \<equiv> \<sigma>"
*)

(*
definition traverse_edge ::
  "('b \<Rightarrow> nat)
   \<Rightarrow> ('b \<Rightarrow> 'b)
      \<Rightarrow> ('b \<Rightarrow> 'b)
         \<Rightarrow> ('b \<Rightarrow> nat)
            \<Rightarrow> (('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool)
               \<Rightarrow> ('a, 'b) Directed_Multigraph.edge
                  \<Rightarrow> ('b, 't, 'g, 'm, 'a) state
                     \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "traverse_edge N lowpt1 lowpt2 ND START e \<sigma> \<equiv>
   if tree_arc e \<sigma> then traverse_tree_arc N lowpt1 lowpt2 ND START e \<sigma>
   else traverse_frond N lowpt1 lowpt2 ND START e \<sigma>"
*)

(* QUESTION: Create locale Directed_Incidence_Structure and move? *)
definition incidence_2 :: "'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Directed_Multigraph.edge list" where
  "incidence_2 G \<equiv> Directed_Multigraph.incidence (\<lambda>v. incidence v G)"

(*
function (domintros) path_search and traverse_edge where
  "traverse_edge N lowpt1 lowpt2 ND START e \<sigma> =
   (if tree_arc e \<sigma>
    then let \<sigma>1 = if START e then while_loop_1 \<sigma> else \<sigma>;
             \<sigma>2 = path_search N lowpt1 lowpt2 ND START (head e) \<sigma>1;
             \<sigma>3 = \<sigma>2\<lparr>ESTACK := e # ESTACK \<sigma>2\<rparr>;
             \<sigma>4 = algorithm_5 \<sigma>3;
             \<sigma>5 = algorithm_6 \<sigma>4;
             \<sigma>6 = if START e then while_loop_2 \<sigma>5 else \<sigma>5;
             \<sigma>7 = while_loop_3 \<sigma>6
         in \<sigma>7
    else let \<sigma>8 = if START e then while_loop_4 \<sigma> else \<sigma>;
             \<sigma>9 = \<sigma>8\<lparr>ESTACK := e # ESTACK \<sigma>8\<rparr>
         in \<sigma>9)" |
  "path_search N lowpt1 lowpt2 ND START v \<sigma> =
   fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>"
  by pat_completeness simp+
thm path_search_traverse_edge.pinduct
*)

function (domintros) path_search ::
  "('b \<Rightarrow> nat)
   \<Rightarrow> ('b \<Rightarrow> 'b)
      \<Rightarrow> ('b \<Rightarrow> 'b)
         \<Rightarrow> ('b \<Rightarrow> nat)
            \<Rightarrow> (('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool)
               \<Rightarrow> 'b
                  \<Rightarrow> ('b, 't, 'g, 'm, 'a) state
                     \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "path_search N lowpt1 lowpt2 ND START v \<sigma> =
   fold
    (\<lambda>e \<sigma>. if tree_arc_2 e \<sigma>
           then let \<sigma>1 = if START e then while_loop_1 \<sigma> else \<sigma>;
                    \<sigma>2 = path_search N lowpt1 lowpt2 ND START (head e) \<sigma>1;
                    \<sigma>3 = \<sigma>2\<lparr>ESTACK := e # ESTACK \<sigma>2\<rparr>;
                    \<sigma>4 = algorithm_5 \<sigma>3;
                    \<sigma>5 = algorithm_6 \<sigma>4;
                    \<sigma>6 = if START e then while_loop_2 \<sigma>5 else \<sigma>5;
                    \<sigma>7 = while_loop_3 \<sigma>6
                in \<sigma>7
           else let \<sigma>8 = if START e then while_loop_4 \<sigma> else \<sigma>;
                    \<sigma>9 = \<sigma>8\<lparr>ESTACK := e # ESTACK \<sigma>8\<rparr>
                in \<sigma>9)
    (incidence_2 (multigraph \<sigma>) v)
    \<sigma>"
  by auto
thm path_search.pinduct

definition traverse_tree_arc where
  "traverse_tree_arc N lowpt1 lowpt2 ND START e \<sigma> \<equiv>
   let \<sigma>1 = if START e then while_loop_1 \<sigma> else \<sigma>;
       \<sigma>2 = path_search N lowpt1 lowpt2 ND START (head e) \<sigma>1;
       \<sigma>3 = \<sigma>2\<lparr>ESTACK := e # ESTACK \<sigma>2\<rparr>;
       \<sigma>4 = algorithm_5 \<sigma>3;
       \<sigma>5 = algorithm_6 \<sigma>4;
       \<sigma>6 = if START e then while_loop_2 \<sigma>5 else \<sigma>5;
       \<sigma>7 = while_loop_3 \<sigma>6
   in \<sigma>7"

definition traverse_frond where
  "traverse_frond N lowpt1 lowpt2 ND START e \<sigma> \<equiv>
   let \<sigma>8 = if START e then while_loop_4 \<sigma> else \<sigma>;
       \<sigma>9 = \<sigma>8\<lparr>ESTACK := e # ESTACK \<sigma>8\<rparr>
   in \<sigma>9"

definition traverse_edge where
  "traverse_edge N lowpt1 lowpt2 ND START e \<sigma> \<equiv>
   if tree_arc_2 e \<sigma> then traverse_tree_arc N lowpt1 lowpt2 ND START e \<sigma>
   else traverse_frond N lowpt1 lowpt2 ND START e \<sigma>"

(*
definition path_search ::
  "('b \<Rightarrow> nat)
   \<Rightarrow> ('b \<Rightarrow> 'b)
      \<Rightarrow> ('b \<Rightarrow> 'b)
         \<Rightarrow> ('b \<Rightarrow> nat)
            \<Rightarrow> (('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool)
               \<Rightarrow> 'b
                  \<Rightarrow> ('b, 't, 'g, 'm, 'a) state
                     \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "path_search N lowpt1 lowpt2 ND START v \<sigma> \<equiv>
   fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>"
*)

end

locale algorithm_3_pre = path_search
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes F :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> 'm"
  fixes lowpt1 :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('b \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> 'b"
  fixes lowpt2 :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('b \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> 'b"
  fixes ND :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> nat"
  fixes START :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool"
begin

definition init :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "init r T P \<equiv>
   \<lparr>root = r,
    tree = T,
    multigraph = P,
    F = F r T P,
    ESTACK = [],
    TSTACK = [EOS],
    Cs = []\<rparr>"

definition algorithm_3 :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) component list" where
  "algorithm_3 r T P N \<equiv>
   let \<sigma> = path_search N (lowpt1 r T P N) (lowpt2 r T P N) (ND r T P) (START r T P) r (init r T P)
   in ESTACK \<sigma> # Cs \<sigma>"

(*
definition algorithm_3 :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) component list" where
  "algorithm_3 r T P N \<equiv>
   ESTACK (path_search N (lowpt1 r T P N) (lowpt2 r T P N) (ND r T P) (START r T P) r (init r T P)) #
   Cs (path_search N (lowpt1 r T P N) (lowpt2 r T P N) (ND r T P) (START r T P) r (init r T P))"
*)

end

(* QUESTION: Create locale Undirected_Incidence_Structure? *)
locale algorithm_3 = algorithm_3_pre
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes T :: "'g \<Rightarrow> 'b \<Rightarrow> 't"
  fixes N :: "'g \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> nat"
  fixes I :: "'g \<Rightarrow> 'b \<Rightarrow> 'g"
  assumes steps_1_2_3_high_3:
    "\<lbrakk> biconnected_multigraph other (P.E G); r \<in> Multigraph.V (P.E G) \<rbrakk> \<Longrightarrow>
     steps_1_2_3_high_3 other r (\<lambda>v. incidence v (I G r)) (N G r) (P.E G) (T_lookup (T G r))"
begin

definition algorithm_3' :: "'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Multigraph.edge list list" where
  "algorithm_3' G r \<equiv> map (map undirect) (algorithm_3 r (T G r) (I G r) (N G r))"

end

subsection \<open>Verification of the correctness of the algorithm\<close>

subsubsection \<open>Assumptions on the input\<close>

locale path_search_valid_input = path_search
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes N :: "'b \<Rightarrow> nat"
  fixes lowpt1 :: "'b \<Rightarrow> 'b"
  fixes lowpt2 :: "'b \<Rightarrow> 'b"
  fixes ND :: "'b \<Rightarrow> nat"
  fixes START :: "('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool"
  fixes v :: 'b
begin

abbreviation path_search' :: "('b, 't, 'g, 'm, 'a) state \<Rightarrow> ('b, 't, 'g, 'm, 'a) state" where
  "path_search' \<equiv> path_search N lowpt1 lowpt2 ND START v"

abbreviation traverse_edge' where
  "traverse_edge' \<equiv> traverse_edge N lowpt1 lowpt2 ND START"

abbreviation traverse_tree_arc' where
  "traverse_tree_arc' \<equiv> traverse_tree_arc N lowpt1 lowpt2 ND START"

abbreviation traverse_frond' where
  "traverse_frond' \<equiv> traverse_frond N lowpt1 lowpt2 ND START"

end

locale algorithm_3_pre_valid_input = algorithm_3_pre
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes r :: 'b
  fixes T :: 't
  fixes P :: 'g
  fixes N :: "'b \<Rightarrow> nat"
  assumes steps_1_2_3_high_2: "steps_1_2_3_high_2 r (\<lambda>v. incidence v P) (T_lookup T) N"
begin

sublocale steps_1_2_3_high_2
  where T = "T_lookup T"
    and I = "\<lambda>v. incidence v P"
  using steps_1_2_3_high_2
  .

(*
sublocale path_search_valid_input
  where lowpt1 = "lowpt1 r T P N"
    and lowpt2 = "lowpt2 r T P N"
    and ND = "ND r T P"
    and START = "START r T P"
  ..
*)

end

abbreviation (in algorithm_3_pre) algorithm_3_pre_valid_input' :: "'b \<Rightarrow> 't \<Rightarrow> 'g \<Rightarrow> ('b \<Rightarrow> nat) \<Rightarrow> bool" where
  "algorithm_3_pre_valid_input' \<equiv>
   algorithm_3_pre_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    F_empty F_delete F_lookup F_invar
    while_loop_1
    while_loop_2
    while_loop_3
    while_loop_4
    algorithm_5
    algorithm_6
    T_update
    insert
    F_update"

locale algorithm_3_valid_input = algorithm_3
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes G :: 'g
  fixes r :: 'b
  assumes biconnected_multigraph: "biconnected_multigraph other (P.E G)"
  assumes r_mem_V: "r \<in> Multigraph.V (P.E G)"
begin

(* TODO: Rename. *)
sublocale steps_1_2_3_high_3
  where N = "N G r"
    and I = "\<lambda>v. incidence v (I G r)"
    and G = "P.E G"
    and T = "T_lookup (T G r)"
  using biconnected_multigraph r_mem_V
  by (intro steps_1_2_3_high_3)

(* TODO: Rename. *)
sublocale algorithm_3_pre_valid_input
  where T = "T G r"
    and P = "I G r"
    and N = "N G r"
  using algorithm_3_pre_axioms steps_1_2_3_high_2_axioms
  by
    (fastforce
      simp add: algorithm_3_pre_valid_input_axioms_def
      intro: algorithm_3_pre_valid_input.intro)

end

(* TODO: Move. *)
lemma (in path_search) edges_from_fun_incidence_eq_A:
  shows "edges_from_fun (\<lambda>v. incidence v P) = P.A P"
  by (force simp add: edges_from_fun_def incidence_def to_edge_def P.A_def)

(* TODO: Move. *)
lemma (in algorithm_3_valid_input) image_undirect_A_eq_E:
  shows "undirect ` P.A (I G r) = P.E G"
  using undirect_P_eq_G
  by (force simp add: edges_from_fun_incidence_eq_A)

(*
function (in path_search) (domintros) flatten_aux :: "'t \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Directed_Multigraph.edge list" where
  "flatten_aux T P u =
   fold
    (\<lambda>(\<epsilon>, v). (@) ((\<epsilon>, u, v) # (if T_lookup T v = Some (\<epsilon>, u) then flatten_aux T P v else [])))
    (incidence u P)
    []"
  by auto

definition (in path_search) flatten :: "'t \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Directed_Multigraph.edge list" where
  "flatten \<equiv> flatten_aux"

function (in path_search) (domintros) agublagu_aux :: "'t \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> 't \<Rightarrow> 't" where
  "agublagu_aux T P u =
   fold
    (\<lambda>(\<epsilon>, v). if T_lookup T v = Some (\<epsilon>, u) then (T_update v (\<epsilon>, u)) \<circ> (agublagu_aux T P v) else id)
    (incidence u P)"
  by auto

definition (in path_search) agublagu :: "'t \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> 't" where
  "agublagu T P v \<equiv> agublagu_aux T P v T_empty"

function (in path_search) (domintros) agublagu_2_aux :: "'t \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> 'g \<Rightarrow> 'g" where
  "agublagu_2_aux T P u =
   fold
    (\<lambda>(\<epsilon>, v). (insert u (\<epsilon>, v) \<circ> (if T_lookup T v = Some (\<epsilon>, u) then agublagu_2_aux T P v else id)))
    (incidence u P)"
  by auto

definition (in path_search) agublagu_2 :: "'t \<Rightarrow> 'g \<Rightarrow> 'b \<Rightarrow> 'g" where
  "agublagu_2 T P v \<equiv> agublagu_2_aux T P v empty"
*)

subsubsection \<open>Loop invariants\<close>

locale path_search_invar = path_search_valid_input
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes \<sigma> :: "('b, 't, 'g, 'm, 'a) state"
    (* QUESTION: Use P.E instead? *)
  assumes finite_multigraph: "finite (undirect ` P.A (multigraph \<sigma>))"
  assumes finite_Cs: "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) finite"
  assumes no_separation_pair_Cs: "\<forall>G\<in>set (map set (map (map undirect) (Cs \<sigma>))). \<not> (\<exists>a b. is_separation_pair G a b)"
    (* TODO: Order. *)
  assumes palm_tree_2: "palm_tree_2 (root \<sigma>) (T_lookup (tree \<sigma>)) (\<lambda>v. incidence v (multigraph \<sigma>))"
begin

abbreviation \<sigma>' :: "('b, 't, 'g, 'm, 'a) state" where
  "\<sigma>' \<equiv> path_search' \<sigma>"

(*
sublocale palm_tree_2
  where r = "root \<sigma>"
    and T = "T_lookup (tree \<sigma>)"
    and I = "\<lambda>v. incidence v (multigraph \<sigma>)"
  using palm_tree_2
  .
*)

sublocale steps_1_2_3_high_3
  where r = "root \<sigma>"
    and T = "T_lookup (tree \<sigma>)"
    and I = "\<lambda>v. incidence v (multigraph \<sigma>)"
    and G = "undirect ` P.A (multigraph \<sigma>)"
  sorry

lemmas mem_D_iff_tree_path = mem_D_iff_tree_path
lemmas tree_path_if_tree_arc' = tree_path_if_tree_arc'
lemmas tree_path_trans = tree_path_trans
lemmas is_type_1_pair'_def = is_type_1_pair'_def
lemmas is_type_1_pair_iff = is_type_1_pair_iff
lemmas lemma_7 = lemma_7

end

(* QUESTION: Should this locale extend path_search_valid_input instead? *)
(* QUESTION: Do we need to fix another state? *)
locale traverse_edge_invar = path_search_invar
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  fixes e
  assumes e_mem_set_incidence_2: "e \<in> set (incidence_2 (multigraph \<sigma>) v)"

locale traverse_edge_invar_tree_arc = traverse_edge_invar
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  assumes tree_arc: "tree_arc_2 e \<sigma>"

locale traverse_edge_invar_frond = traverse_edge_invar
  where T_update = T_update
    and insert = insert
    and F_update = F_update
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
    and F_update :: "'b \<Rightarrow> 'b list \<Rightarrow> 'm \<Rightarrow> 'm" +
  assumes frond: "\<not> tree_arc_2 e \<sigma>"

(* FIXME: *)
abbreviation (in path_search) path_search_invar' ::
  "('b \<Rightarrow> nat)
   \<Rightarrow> ('b \<Rightarrow> 'b)
      \<Rightarrow> ('b \<Rightarrow> 'b)
         \<Rightarrow> ('b \<Rightarrow> nat)
            \<Rightarrow> (('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool)
               \<Rightarrow> 'b
                  \<Rightarrow> ('b, 't, 'g, 'm, 'a) state
                     \<Rightarrow> bool" where
  "path_search_invar' N lowpt1 lowpt2 ND START v \<equiv>
   path_search_invar empty
    delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    F_empty F_delete F_lookup F_invar
    while_loop_1
    while_loop_2
    while_loop_3
    while_loop_4
    algorithm_5
    algorithm_6
    T_update
    insert
    F_update"

abbreviation (in path_search_valid_input) path_search_invar'' where
  "path_search_invar'' \<equiv> path_search_invar' N lowpt1 lowpt2 ND START v"

(*
context algorithm_3_pre_valid_input
begin
sublocale path_search_invar
  where lowpt1 = "lowpt1 r T P N"
    and lowpt2 = "lowpt2 r T P N"
    and ND = "ND r T P"
    and START = "START r T P"
    and v = r
    and \<sigma> = "init r T P"
  sorry
end
*)

lemma (in path_search_invar) finite_multigraph_multigraph:
  shows "Multigraph.finite_multigraph other (undirect ` P.A (multigraph \<sigma>))"
  using finite_multigraph
  sorry

lemma (in path_search_invar) finite_multigraph_Cs:
  shows "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) (Multigraph.finite_multigraph other)"
  sorry

(* QUESTION: Move to more general locale? *)
lemma (in path_search_invar) path_search_invar_mem_V:
  shows
    "is_split_tbd
      (undirect ` P.A (multigraph \<sigma>) # map set (map (map undirect) (Cs \<sigma>)))
      (undirect ` P.A (multigraph \<sigma>') # map set (map (map undirect) (Cs \<sigma>')))"
  sorry

(* QUESTION: Move to more general locale? *)
lemma (in path_search_invar) path_search_invar_2:
  shows "ESTACK \<sigma>' = map (to_edge v) (tree_of_2.flatten (T_lookup (tree \<sigma>')) (\<lambda>v. incidence v (multigraph \<sigma>')) v) @ ESTACK \<sigma>"
  sorry

(* QUESTION: Move to more general locale? *)
(*
lemma (in path_search_invar) root_path_search:
  shows "root \<sigma>' = root \<sigma>"
  sorry
*)

(* QUESTION: Move to more general locale? *)
(* QUESTION: Is there a more concise conclusion? *)
lemma (in path_search_invar) path_search_invar_4:
  assumes "is_separation_pair (undirect ` P.A (multigraph \<sigma>')) a b"
  shows "a \<notin> D (T_lookup (tree \<sigma>')) v \<or> b \<notin> D (T_lookup (tree \<sigma>')) v"
  sorry

lemma (in path_search_invar) path_search_invar_fold:
  shows "path_search_invar'' (fold traverse_edge' (incidence_2 (multigraph \<sigma>) v) \<sigma>)"
  sorry

(* FIXME: *)
lemma (in path_search_invar) path_search_invar_\<sigma>':
  shows "path_search_invar'' \<sigma>'"
  sorry

subsubsection \<open>Termination\<close>

lemma (in path_search_valid_input) path_search_dom:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_dom (N, lowpt1, lowpt2, ND, START, v, \<sigma>)"
  sorry

lemma (in path_search_invar) path_search_dom:
  shows "path_search_dom (N, lowpt1, lowpt2, ND, START, v, \<sigma>)"
  using path_search_invar_axioms
  by (intro path_search_dom)

lemma (in path_search) path_search_simps:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  shows
    "path_search N lowpt1 lowpt2 ND START v \<sigma> =
     fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>"
  unfolding traverse_edge_def traverse_tree_arc_def traverse_frond_def
  using assms
  by (intro path_search_invar.path_search_dom path_search.psimps)

(*
lemma (in path_search_valid_input) path_search_traverse_edge_dom_Inl:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_traverse_edge_dom (Inl (N, lowpt1, lowpt2, ND, START, v, \<sigma>))"
  sorry

lemma (in path_search_valid_input) path_search_traverse_edge_dom_Inr:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_traverse_edge_dom (Inr (N, lowpt1, lowpt2, ND, START, e, \<sigma>))"
  sorry

lemma (in path_search_invar) path_search_traverse_edge_dom_Inl:
  shows "path_search_traverse_edge_dom (Inl (N, lowpt1, lowpt2, ND, START, v, \<sigma>))"
  sorry

lemma (in path_search_invar) path_search_traverse_edge_dom_Inr:
  shows "path_search_traverse_edge_dom (Inr (N, lowpt1, lowpt2, ND, START, e, \<sigma>))"
  sorry
*)

(*
lemma (in path_search) path_search_traverse_edge_induct:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes
    "\<And>N lowpt1 lowpt2 ND START e \<sigma>.
        (tree_arc e \<sigma> \<Longrightarrow> P N lowpt1 lowpt2 ND START (head e) (if START e then while_loop_1 \<sigma> else \<sigma>)) \<Longrightarrow>
        Q N lowpt1 lowpt2 ND START e \<sigma>"
  assumes
    "\<And>N lowpt1 lowpt2 ND START v \<sigma>.
        (\<And>e \<sigma>'. e \<in> set (incidence_2 (multigraph \<sigma>) v) \<Longrightarrow> Q N lowpt1 lowpt2 ND START e \<sigma>') \<Longrightarrow>
        P N lowpt1 lowpt2 ND START v \<sigma>"
  shows
    "P N lowpt1 lowpt2 ND START v \<sigma>"
    "Q N lowpt1 lowpt2 ND START e \<sigma>"
proof -
  show "P N lowpt1 lowpt2 ND START v \<sigma>"
  proof (rule path_search_traverse_edge.pinduct[of N lowpt1 lowpt2 ND START, where ?Q = Q], goal_cases)
    case 1
    then show ?case
      using assms(1)
      by (intro path_search_invar.path_search_traverse_edge_dom_Inl)
  next
    case (2 N lowpt1 lowpt2 ND START e \<sigma>)
    thus ?case
      by (intro assms(2)) simp
  next
    case (3 N lowpt1 lowpt2 ND START v \<sigma>)
    thus ?case
      by (intro assms(3))
  qed
  show "Q N lowpt1 lowpt2 ND START e \<sigma>"
  proof (rule path_search_traverse_edge.pinduct[of N lowpt1 lowpt2 ND START, where ?P = P], goal_cases)
    case 1
    then show ?case
      using assms(1)
      by (intro path_search_invar.path_search_traverse_edge_dom_Inr)
  next
    case (2 N lowpt1 lowpt2 ND START e \<sigma>)
    thus ?case
      by (intro assms(2)) simp
  next
    case (3 N lowpt1 lowpt2 ND START v \<sigma>)
    thus ?case
      by (intro assms(3))
  qed
qed
*)

lemma (in path_search) path_search_induct:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes
    "\<And>N lowpt1 lowpt2 ND START v \<sigma>.
        (\<And>e \<sigma>'.
            e \<in> set (incidence_2 (multigraph \<sigma>) v) \<Longrightarrow>
            tree_arc_2 e \<sigma>' \<Longrightarrow>
            P N lowpt1 lowpt2 ND START (head e) (if START e then while_loop_1 \<sigma>' else \<sigma>')) \<Longrightarrow>
        P N lowpt1 lowpt2 ND START v \<sigma>"
  shows "P N lowpt1 lowpt2 ND START v \<sigma>"
    (* TODO: Remove of part. *)
proof (rule path_search.pinduct[of N lowpt1 lowpt2 ND START v \<sigma>], goal_cases)
  case 1
  show ?case
    using assms(1)
    by (intro path_search_invar.path_search_dom)
next
  case (2 N lowpt1 lowpt2 ND START v \<sigma>)
  thus ?case
    by (auto intro: assms(2))
qed

subsubsection \<open>Correctness\<close>

lemma a01:
  shows "set (flatten T I v) = E (agublagu_2 T I v)"
  sorry

lemma a02:
  assumes "is_tbd_tree r T (E  I)"
  shows "agublagu_2 T I r = I"
  sorry

(*
lemma (in path_search) root_path_search:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  shows
    "root (path_search N lowpt1 lowpt2 ND START v \<sigma>) = root \<sigma>"
    "root (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>) = root \<sigma>"
  using assms
  thm path_search_traverse_edge_induct[OF assms, of _ _ N lowpt1 lowpt2 ND START]
proof (induct rule: path_search_traverse_edge_induct[OF assms, of _ _ N lowpt1 lowpt2 ND START])
  case (1 N lowpt1 lowpt2 ND START e \<sigma>)
  then show ?case sorry
next
  case (2 N lowpt1 lowpt2 ND START v \<sigma>)
  then show ?case sorry
qed
*)

lemma root_fold:
  assumes "\<And>e \<sigma>. e \<in> set l \<Longrightarrow> root (f e \<sigma>) = root \<sigma>"
  shows "root (fold f l \<sigma>) = root \<sigma>"
  using assms
proof (induct l arbitrary: \<sigma>)
  case Nil
  thus ?case
    by fastforce
next
  case (Cons e es)
  have "root (fold f (e # es) \<sigma>) = root (fold f es (f e \<sigma>))"
    by fastforce
  also have "... = root (f e \<sigma>)"
    using Cons.prems
    by (intro Cons.hyps) simp
  also have "... = root \<sigma>"
    by (intro Cons.prems) simp
  finally show ?case
    .
qed

lemma (in path_search) root_traverse_edge:
  assumes
    "tree_arc_2 e \<sigma> \<Longrightarrow>
     root (path_search N lowpt1 lowpt2 ND START (head e) (if START e then while_loop_1 \<sigma> else \<sigma>)) =
     root (if START e then while_loop_1 \<sigma> else \<sigma>)"
  shows "root (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>) = root \<sigma>"
proof (cases "tree_arc_2 e \<sigma>")
  case True
  hence
    "root (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>) =
     root (path_search N lowpt1 lowpt2 ND START (head e) (if START e then while_loop_1 \<sigma> else \<sigma>))"
    by (simp add: traverse_edge_def traverse_tree_arc_def Let_def root_while_loop_3 root_while_loop_2 root_algorithm_6 root_algorithm_5)
  also have "... = root (if START e then while_loop_1 \<sigma> else \<sigma>)"
    using True
    by (intro assms)
  also have "... = root \<sigma>"
    by (simp add: root_while_loop_1)
  finally show ?thesis
    .
next
  case False
  thus ?thesis
    using root_while_loop_4
    by (simp add: traverse_edge_def traverse_frond_def Let_def)
qed

lemma (in path_search) root_path_search_aux:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes "e \<in> set (incidence_2 (multigraph \<sigma>) v)"
  assumes "tree_arc_2 e \<sigma>'"
  shows "path_search_invar' N lowpt1 lowpt2 ND START v (if START e then while_loop_1 \<sigma>' else \<sigma>')"
  sorry

lemma (in path_search) root_path_search:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  shows "root (path_search N lowpt1 lowpt2 ND START v \<sigma>) = root \<sigma>"
  using assms
proof (induct rule: path_search_induct[OF assms, of _ N lowpt1 lowpt2 ND START v])
  case (1 N lowpt1 lowpt2 ND START v \<sigma>)
  have "root (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>) = root \<sigma>"
  proof -
    { fix e \<sigma>'
      assume "e \<in> set (incidence_2 (multigraph \<sigma>) v)"
      hence "root (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>') = root \<sigma>'"
        using "1.prems"
        by (auto intro: root_path_search_aux "1.hyps" root_traverse_edge) }
    thus ?thesis
      by (intro root_fold)
  qed
  thm root_traverse_edge
  thm root_fold
  thus ?case
    using "1.prems"
    by (simp add: path_search_simps)
qed

(*
lemma (in path_search) idk_fold:
  shows "a \<notin> tree.D (T_lookup (tree (fold f l \<sigma>))) v \<or> b \<notin> tree.D (T_lookup (tree (fold f l \<sigma>))) v"
  sorry
*)

lemma (in path_search) idk_traverse_edge:
  shows
    "a \<notin> tree.D (T_lookup (tree (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>))) (head e) \<or>
     b \<notin> tree.D (T_lookup (tree (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>))) (head e)"
proof (cases "tree_arc_2 e \<sigma>")
  case True
  then show ?thesis sorry
next
  case False
  then show ?thesis sorry
qed

(* QQQ *)
lemma (in path_search) idk_aux_1:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes "N a < N b"
  assumes
    "steps_1_2_3_high.is_type_1_pair
      (\<lambda>x. incidence x (multigraph (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>)))
      (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) N a b s t"
  shows
    "b \<notin> tree.D (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) v \<or>
     s \<notin> tree.D (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) v"
  using assms
proof (induct rule: path_search_induct[OF assms(1), of _ N lowpt1 lowpt2 ND START v])
  case (1 N lowpt1 lowpt2 ND START v \<sigma>)
  then show ?case sorry
qed

lemma (in path_search) idk_aux_2:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes "N a < N b"
  assumes
    "steps_1_2_3_high.is_type_2_pair'
      (\<lambda>x. incidence x (multigraph (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>)))
      (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) N a b"
  shows
    "a \<notin> tree.D (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) v \<or>
     b \<notin> tree.D (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) v"
  using assms
proof (induct rule: path_search_induct[OF assms(1), of _ N lowpt1 lowpt2 ND START v])
  case (1 N lowpt1 lowpt2 ND START v \<sigma>)
  then show ?case sorry
qed

lemma (in path_search)
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes "N a < N b"
  assumes "is_separation_pair (undirect ` P.A (multigraph (path_search N lowpt1 lowpt2 ND START v \<sigma>))) a b"
  shows
    "a \<notin> tree.D (T_lookup (tree (path_search N lowpt1 lowpt2 ND START v \<sigma>))) v \<or>
     b \<notin> tree.D (T_lookup (tree (path_search N lowpt1 lowpt2 ND START v \<sigma>))) v"
proof (rule ccontr, goal_cases)
  let ?\<sigma>' = "fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>"
  let ?I = "\<lambda>v. incidence v (multigraph ?\<sigma>')"
  let ?T = "T_lookup (tree ?\<sigma>')"
  let ?G = "undirect ` P.A (multigraph ?\<sigma>')"
  case 1
  hence
    assm: "a \<in> tree.D ?T v"
    "b \<in> tree.D ?T v"
    using assms(1)
    by (simp_all add: path_search_simps)
  consider
    "steps_1_2_3_high.is_type_1_pair' ?I ?T N a b" |
    "steps_1_2_3_high.is_type_2_pair' ?I ?T N a b" |
    "is_multiple_edge ?G {a, b} \<and> 4 \<le> card ?G"
    using assms(3)[unfolded path_search_simps[OF assms(1)]]
    by (auto simp add: path_search_invar.lemma_7[OF path_search_invar.path_search_invar_fold[OF assms(1)] assms(2)])
  thus ?case
  proof (cases)
    case 1
    then obtain s t where
      s_t: "steps_1_2_3_high.is_type_1_pair ?I ?T N a b s t"
      by (auto simp add: path_search_invar.is_type_1_pair'_def[OF path_search_invar.path_search_invar_fold[OF assms(1)]])
    hence "b \<notin> tree.D ?T v \<or> s \<notin> tree.D ?T v"
      using assms(1, 2)
      by (intro idk_aux_1)
    moreover have
      "s \<in> tree.D ?T v"
    proof -
      have
        "tree.tree_arc' ?T b s"
        using s_t
        by (simp add: path_search_invar.is_type_1_pair_iff[OF path_search_invar.path_search_invar_fold[OF assms(1)]])
      thus ?thesis
        using assm(2)
        by (auto simp add: path_search_invar.mem_D_iff_tree_path[OF path_search_invar.path_search_invar_fold[OF assms(1)]] dest: path_search_invar.tree_path_if_tree_arc'[OF path_search_invar.path_search_invar_fold[OF assms(1)]] path_search_invar.tree_path_trans[OF path_search_invar.path_search_invar_fold[OF assms(1)]])
    qed
    ultimately show ?thesis
      using assm(2)
      by fast
  next
    case 2
    hence "a \<notin> tree.D ?T v \<or> b \<notin> tree.D ?T v"
      using assms(1, 2)
      by (intro idk_aux_2)
    thus ?thesis
      using assm
      by blast
  next
    case 3
    then show ?thesis sorry
  qed
qed

lemma (in path_search)
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  assumes "is_separation_pair (undirect ` P.A (multigraph (path_search N lowpt1 lowpt2 ND START v \<sigma>))) a b"
  shows
    "a \<notin> tree.D (T_lookup (tree (path_search N lowpt1 lowpt2 ND START v \<sigma>))) v \<or>
     b \<notin> tree.D (T_lookup (tree (path_search N lowpt1 lowpt2 ND START v \<sigma>))) v"
  using assms
proof (induct rule: path_search_induct[OF assms(1), of _ N lowpt1 lowpt2 ND START v])
  case (1 N lowpt1 lowpt2 ND START v \<sigma>)
  have
    "a \<notin> tree.D (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) v \<or>
     b \<notin> tree.D (T_lookup (tree (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>))) v"
  proof -
    { fix e \<sigma>'
      assume "e \<in> set (incidence_2 (multigraph \<sigma>) v)"
      hence
        "a \<notin> tree.D (T_lookup (tree (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>'))) (head e) \<or>
         b \<notin> tree.D (T_lookup (tree (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>'))) (head e)"
        using idk_traverse_edge
        by fast }
    thus ?thesis
      using idk_fold
      by blast
  qed
  thus ?case
    using "1.prems"(1)
    by (simp add: path_search_simps)
qed

lemma (in path_search) root_path_search:
  assumes "path_search_invar' N lowpt1 lowpt2 ND START v \<sigma>"
  shows "root (path_search N lowpt1 lowpt2 ND START v \<sigma>) = root \<sigma>"
  using assms
  thm path_search_induct
proof (induct rule: path_search_induct[OF assms, of _ N lowpt1 lowpt2 ND START v])
  case (1 N lowpt1 lowpt2 ND START v \<sigma>)
  hence "root (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>) = root \<sigma>"
  proof (induct "incidence_2 (multigraph \<sigma>) v" arbitrary: \<sigma>)
    case Nil
    thus ?case
      by simp
  next
    case (Cons e es)
    let ?\<sigma>' = "traverse_edge N lowpt1 lowpt2 ND START e \<sigma>"
    have
      "root (fold (traverse_edge N lowpt1 lowpt2 ND START) (incidence_2 (multigraph \<sigma>) v) \<sigma>) =
       root (fold (traverse_edge N lowpt1 lowpt2 ND START) es ?\<sigma>')"
      by (simp add: Cons.hyps(2)[symmetric])
    also have "... = root ?\<sigma>'"
    proof -
      have "es = incidence_2 (multigraph ?\<sigma>') v"
        thm Cons.prems(1)
        thm Cons.hyps(2)
        sorry
      moreover have "path_search_invar' N lowpt1 lowpt2 ND START v ?\<sigma>'"
        sorry
      ultimately show ?thesis
        using Cons.prems(1)
        thm Cons.hyps(1)
        by (auto simp add: Cons.hyps(2)[symmetric] intro: Cons.hyps(1))
    qed
    also have "... = root \<sigma>"
    proof (cases "tree_arc e \<sigma>")
      case True
      thm traverse_edge_def
      hence
        "root (traverse_edge N lowpt1 lowpt2 ND START e \<sigma>) =
         root (path_search N lowpt1 lowpt2 ND START (head e) (if START e then while_loop_1 \<sigma> else \<sigma>))"
        by (simp add: traverse_edge_def Let_def root_while_loop_3 root_while_loop_2 root_algorithm_6 root_algorithm_5)
      also have "... = root (if START e then while_loop_1 \<sigma> else \<sigma>)"
      proof -
        have "e \<in> set (incidence_2 (multigraph \<sigma>) v)"
          by (simp add: Cons.hyps(2)[symmetric])
        moreover have "path_search_invar' N lowpt1 lowpt2 ND START v (if START e then while_loop_1 \<sigma> else \<sigma>)"
          sorry
        ultimately show ?thesis
          using True
          by (auto dest: Cons.prems(1))
      qed
      also have "... = root \<sigma>"
        by (simp add: root_while_loop_1)
      finally show ?thesis
        .
    next
      case False
      thus ?thesis
        using root_while_loop_4
        by (simp add: traverse_edge_def Let_def)
    qed
    finally show ?case
      .
  qed
  thus ?case
    using "1.prems"
    by (simp add: path_search_simps)
qed

lemma (in algorithm_3_pre_valid_input) set_ESTACK_eq_A:
  shows "set (ESTACK \<sigma>') = P.A (multigraph \<sigma>')"
  sorry
proof -
  thm tree_of_2.flatten.psimps
  have "set (ESTACK \<sigma>') = set (flatten (T_lookup (tree \<sigma>')) (incidence_2 (multigraph \<sigma>')) (root \<sigma>'))"
    unfolding path_search_invar_2 root_path_search
    by (simp add: init_def)
  also have "... = E (agublagu_2 (T_lookup (tree \<sigma>')) (incidence_2 (multigraph \<sigma>')) (root \<sigma>'))"
    by (simp add: a01)
  also have "... = E (incidence_2 (multigraph \<sigma>'))"
    using path_search_invar_\<sigma>'
    by
      (fastforce
        simp add: a02
        dest: path_search_invar.palm_tree palm_treeD(1))
  also have "... = P.A (multigraph \<sigma>')"
    by (simp add: edges_from_fun_incidence_eq_A)
  finally show ?thesis
    .
qed

(* QUESTION: Define abbreviation for map set (map (map undirect))? *)
lemma (in algorithm_3_pre_valid_input) algorithm_3_correct:
  shows "are_split_components (undirect ` P.A P) (map set (map (map undirect) (algorithm_3 r T P N)))"
  unfolding algorithm_3_def Let_def
proof (intro are_split_componentsI_2, goal_cases)
  case 1
  have "Multigraph.finite_multigraph other (undirect ` set (ESTACK \<sigma>'))"
    using path_search_invar_\<sigma>'
    by
      (auto
        simp add: set_ESTACK_eq_A
        dest: path_search_invar.finite_multigraph_multigraph)
  moreover have "Ball (set (map set (map (map undirect) (Cs \<sigma>')))) (Multigraph.finite_multigraph other)"
    using path_search_invar_\<sigma>'
    by (auto simp add: dest: path_search_invar.finite_multigraph_Cs)
  ultimately show ?case
    by simp
next
  case 2
  show ?case
    using path_search_invar_mem_V set_ESTACK_eq_A
    by (simp add: init_def)
next
  case 3
  have "\<not> (\<exists>a b. is_separation_pair (undirect ` set (ESTACK \<sigma>')) a b)"
  proof
    assume "\<exists>a b. is_separation_pair (undirect ` set (ESTACK \<sigma>')) a b"
    then obtain a b where
      is_separation_pair: "is_separation_pair (undirect ` P.A (multigraph \<sigma>')) a b"
      by (auto simp add: set_ESTACK_eq_A)
    hence
      "a \<notin> Directed_Multigraph.V (edges_from_fun (\<lambda>v. incidence v (multigraph \<sigma>'))) \<or>
       b \<notin> Directed_Multigraph.V (edges_from_fun (\<lambda>v. incidence v (multigraph \<sigma>')))"
      using path_search_invar_\<sigma>' root_path_search
      sledgehammer
      thm path_search_invar_4
      using path_search_invar_4 by fastforce
      by
        (fastforce
          simp add: init_def idk_20
          dest: path_search_invar_4 path_search_invar.palm_tree)
    thus False
      using is_separation_pair
      by (auto simp add: edges_from_fun_incidence_eq_A V_image_undirect_eq dest: separation_pair_mem_V)
  qed
  moreover have "\<forall>G\<in>set (map set (map (map undirect) (Cs \<sigma>'))). \<not> (\<exists>a b. is_separation_pair G a b)"
    using path_search_invar_\<sigma>'
    by (auto simp add: dest: path_search_invar.no_separation_pair_Cs)
  ultimately show ?case
    by simp
qed

lemma (in algorithm_3_valid_input) algorithm_3'_correct:
  shows "are_split_components (P.E G) (map set (algorithm_3' G r))"
  unfolding image_undirect_A_eq_E[symmetric] algorithm_3'_def
  using algorithm_3_correct
  .

end


(*  Title:      HOL/Library/Old_Datatype.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Stefan Berghofer and Markus Wenzel, TU Muenchen
*)

section \<open>Old Datatype package: constructing datatypes from Cartesian Products and Disjoint Sums\<close>

theory Old_Datatype
imports Main
keywords "sub_atomic_old_datatype" "atomic_old_datatype" "old_datatype" :: thy_decl
begin

ML_file "~~/src/HOL/Tools/datatype_realizer.ML"

subsection \<open>The datatype universe\<close>

definition "Node = {p. \<exists>f x k. p = (f :: nat => 'b + nat, x ::'a + nat) \<and> f k = Inr 0}"

typedef ('a, 'b) node = "Node :: ((nat => 'b + nat) * ('a + nat)) set"
  morphisms Rep_Node Abs_Node
  unfolding Node_def by auto

text\<open>Datatypes will be represented by sets of type \<open>node\<close>\<close>

type_synonym 'a item        = "('a, unit) node set"
type_synonym ('a, 'b) dtree = "('a, 'b) node set"

definition Push :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
  (*crude "lists" of nats -- needed for the constructions*)
  where "Push == (%b h. case_nat b h)"

definition Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
  where "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"

(** operations on S-expressions -- sets of nodes **)

(*S-expression constructors*)
definition Atom :: "('a + nat) => ('a, 'b) dtree"
  where "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
definition Scons :: "[('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree"
  where "Scons M N == (Push_Node (Inr 1) ` M) Un (Push_Node (Inr (Suc 1)) ` N)"

(*Leaf nodes, with arbitrary or nat labels*)
definition Leaf :: "'a => ('a, 'b) dtree"
  where "Leaf == Atom \<circ> Inl"
definition Numb :: "nat => ('a, 'b) dtree"
  where "Numb == Atom \<circ> Inr"

(*Injections of the "disjoint sum"*)
definition In0 :: "('a, 'b) dtree => ('a, 'b) dtree"
  where "In0(M) == Scons (Numb 0) M"
definition In1 :: "('a, 'b) dtree => ('a, 'b) dtree"
  where "In1(M) == Scons (Numb 1) M"

(*Function spaces*)
definition Lim :: "('b => ('a, 'b) dtree) => ('a, 'b) dtree"
  where "Lim f == \<Union>{z. \<exists>x. z = Push_Node (Inl x) ` (f x)}"

(*the set of nodes with depth less than k*)
definition ndepth :: "('a, 'b) node => nat"
  where "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
definition ntrunc :: "[nat, ('a, 'b) dtree] => ('a, 'b) dtree"
  where "ntrunc k N == {n. n\<in>N \<and> ndepth(n)<k}"

(*products and sums for the "universe"*)
definition uprod :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
  where "uprod A B == UN x:A. UN y:B. { Scons x y }"
definition usum :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
  where "usum A B == In0`A Un In1`B"

(*the corresponding eliminators*)
definition Split :: "[[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
  where "Split c M == THE u. \<exists>x y. M = Scons x y \<and> u = c x y"

definition Case :: "[[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
  where "Case c d M == THE u. (\<exists>x . M = In0(x) \<and> u = c(x)) \<or> (\<exists>y . M = In1(y) \<and> u = d(y))"

(** equality for the "universe" **)

definition dprod :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
      => (('a, 'b) dtree * ('a, 'b) dtree)set"
  where "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"

definition dsum :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
      => (('a, 'b) dtree * ('a, 'b) dtree)set"
  where "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un (UN (y,y'):s. {(In1(y),In1(y'))})"

lemma apfst_convE:
    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R
     |] ==> R"
by (force simp add: apfst_def)

(** Push -- an injection, analogous to Cons on lists **)

lemma Push_inject1: "Push i f = Push j g  ==> i=j"
apply (simp add: Push_def fun_eq_iff)
apply (drule_tac x=0 in spec, simp)
done

lemma Push_inject2: "Push i f = Push j g  ==> f=g"
apply (auto simp add: Push_def fun_eq_iff)
apply (drule_tac x="Suc x" in spec, simp)
done

lemma Push_inject:
    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P |] ==> P"
by (blast dest: Push_inject1 Push_inject2)

lemma Push_neq_K0: "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P"
by (auto simp add: Push_def fun_eq_iff split: nat.split_asm)

lemmas Abs_Node_inj = Abs_Node_inject [THEN [2] rev_iffD1]

(*** Introduction rules for Node ***)

lemma Node_K0_I: "(\<lambda>k. Inr 0, a) \<in> Node"
by (simp add: Node_def)

lemma Node_Push_I: "p \<in> Node \<Longrightarrow> apfst (Push i) p \<in> Node"
apply (simp add: Node_def Push_def)
apply (fast intro!: apfst_conv nat.case(2)[THEN trans])
done

subsection\<open>Freeness: Distinctness of Constructors\<close>

(** Scons vs Atom **)

lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"
unfolding Atom_def Scons_def Push_Node_def One_nat_def
by (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I]
         dest!: Abs_Node_inj
         elim!: apfst_convE sym [THEN Push_neq_K0])

lemmas Atom_not_Scons [iff] = Scons_not_Atom [THEN not_sym]

(*** Injectiveness ***)

(** Atomic nodes **)

lemma inj_Atom: "inj(Atom)"
apply (simp add: Atom_def)
apply (blast intro!: inj_onI Node_K0_I dest!: Abs_Node_inj)
done
lemmas Atom_inject = inj_Atom [THEN injD]

lemma Atom_Atom_eq [iff]: "(Atom(a)=Atom(b)) = (a=b)"
by (blast dest!: Atom_inject)

lemma inj_Leaf: "inj(Leaf)"
apply (simp add: Leaf_def o_def)
apply (rule inj_onI)
apply (erule Atom_inject [THEN Inl_inject])
done

lemmas Leaf_inject [dest!] = inj_Leaf [THEN injD]

lemma inj_Numb: "inj(Numb)"
apply (simp add: Numb_def o_def)
apply (rule inj_onI)
apply (erule Atom_inject [THEN Inr_inject])
done

lemmas Numb_inject [dest!] = inj_Numb [THEN injD]

(** Injectiveness of Push_Node **)

lemma Push_Node_inject:
    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P
     |] ==> P"
apply (simp add: Push_Node_def)
apply (erule Abs_Node_inj [THEN apfst_convE])
apply (rule Rep_Node [THEN Node_Push_I])+
apply (erule sym [THEN apfst_convE])
apply (blast intro: Rep_Node_inject [THEN iffD1] trans sym elim!: Push_inject)
done

(** Injectiveness of Scons **)

lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"
unfolding Scons_def One_nat_def
by (blast dest!: Push_Node_inject)

lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"
unfolding Scons_def One_nat_def
by (blast dest!: Push_Node_inject)

lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"
apply (erule equalityE)
apply (iprover intro: equalityI Scons_inject_lemma1)
done

lemma Scons_inject2: "Scons M N = Scons M' N' ==> N=N'"
apply (erule equalityE)
apply (iprover intro: equalityI Scons_inject_lemma2)
done

lemma Scons_inject:
    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P |] ==> P"
by (iprover dest: Scons_inject1 Scons_inject2)

lemma Scons_Scons_eq [iff]: "(Scons M N = Scons M' N') = (M=M' \<and> N=N')"
by (blast elim!: Scons_inject)

(*** Distinctness involving Leaf and Numb ***)

(** Scons vs Leaf **)

lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"
unfolding Leaf_def o_def by (rule Scons_not_Atom)

lemmas Leaf_not_Scons  [iff] = Scons_not_Leaf [THEN not_sym]

(** Scons vs Numb **)

lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"
unfolding Numb_def o_def by (rule Scons_not_Atom)

lemmas Numb_not_Scons [iff] = Scons_not_Numb [THEN not_sym]

(** Leaf vs Numb **)

lemma Leaf_not_Numb [iff]: "Leaf(a) \<noteq> Numb(k)"
by (simp add: Leaf_def Numb_def)

lemmas Numb_not_Leaf [iff] = Leaf_not_Numb [THEN not_sym]

(*** ndepth -- the depth of a node ***)

lemma ndepth_K0: "ndepth (Abs_Node(%k. Inr 0, x)) = 0"
by (simp add: ndepth_def  Node_K0_I [THEN Abs_Node_inverse] Least_equality)

lemma ndepth_Push_Node_aux:
     "case_nat (Inr (Suc i)) f k = Inr 0 \<longrightarrow> Suc(LEAST x. f x = Inr 0) \<le> k"
apply (induct_tac "k", auto)
apply (erule Least_le)
done

lemma ndepth_Push_Node:
    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))"
apply (insert Rep_Node [of n, unfolded Node_def])
apply (auto simp add: ndepth_def Push_Node_def
                 Rep_Node [THEN Node_Push_I, THEN Abs_Node_inverse])
apply (rule Least_equality)
apply (auto simp add: Push_def ndepth_Push_Node_aux)
apply (erule LeastI)
done

(*** ntrunc applied to the various node sets ***)

lemma ntrunc_0 [simp]: "ntrunc 0 M = {}"
by (simp add: ntrunc_def)

lemma ntrunc_Atom [simp]: "ntrunc (Suc k) (Atom a) = Atom(a)"
by (auto simp add: Atom_def ntrunc_def ndepth_K0)

lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"
unfolding Leaf_def o_def by (rule ntrunc_Atom)

lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"
unfolding Numb_def o_def by (rule ntrunc_Atom)

lemma ntrunc_Scons [simp]:
    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"
unfolding Scons_def ntrunc_def One_nat_def
by (auto simp add: ndepth_Push_Node)

(** Injection nodes **)

lemma ntrunc_one_In0 [simp]: "ntrunc (Suc 0) (In0 M) = {}"
apply (simp add: In0_def)
apply (simp add: Scons_def)
done

lemma ntrunc_In0 [simp]: "ntrunc (Suc(Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)"
by (simp add: In0_def)

lemma ntrunc_one_In1 [simp]: "ntrunc (Suc 0) (In1 M) = {}"
apply (simp add: In1_def)
apply (simp add: Scons_def)
done

lemma ntrunc_In1 [simp]: "ntrunc (Suc(Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)"
by (simp add: In1_def)

subsection\<open>Set Constructions\<close>

(*** Cartesian Product ***)

lemma uprodI [intro!]: "\<lbrakk>M\<in>A; N\<in>B\<rbrakk> \<Longrightarrow> Scons M N \<in> uprod A B"
by (simp add: uprod_def)

(*The general elimination rule*)
lemma uprodE [elim!]:
    "\<lbrakk>c \<in> uprod A B;
        \<And>x y. \<lbrakk>x \<in> A; y \<in> B; c = Scons x y\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: uprod_def)

(*Elimination of a pair -- introduces no eigenvariables*)
lemma uprodE2: "\<lbrakk>Scons M N \<in> uprod A B; \<lbrakk>M \<in> A; N \<in> B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (auto simp add: uprod_def)

(*** Disjoint Sum ***)

lemma usum_In0I [intro]: "M \<in> A \<Longrightarrow> In0(M) \<in> usum A B"
by (simp add: usum_def)

lemma usum_In1I [intro]: "N \<in> B \<Longrightarrow> In1(N) \<in> usum A B"
by (simp add: usum_def)

lemma usumE [elim!]:
    "\<lbrakk>u \<in> usum A B;
        \<And>x. \<lbrakk>x \<in> A; u=In0(x)\<rbrakk> \<Longrightarrow> P;
        \<And>y. \<lbrakk>y \<in> B; u=In1(y)\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: usum_def)

(** Injection **)

lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"
unfolding In0_def In1_def One_nat_def by auto

lemmas In1_not_In0 [iff] = In0_not_In1 [THEN not_sym]

lemma In0_inject: "In0(M) = In0(N) ==>  M=N"
by (simp add: In0_def)

lemma In1_inject: "In1(M) = In1(N) ==>  M=N"
by (simp add: In1_def)

lemma In0_eq [iff]: "(In0 M = In0 N) = (M=N)"
by (blast dest!: In0_inject)

lemma In1_eq [iff]: "(In1 M = In1 N) = (M=N)"
by (blast dest!: In1_inject)

lemma inj_In0: "inj In0"
by (blast intro!: inj_onI)

lemma inj_In1: "inj In1"
by (blast intro!: inj_onI)

(*** Function spaces ***)

lemma Lim_inject: "Lim f = Lim g ==> f = g"
apply (simp add: Lim_def)
apply (rule ext)
apply (blast elim!: Push_Node_inject)
done

(*** proving equality of sets and functions using ntrunc ***)

lemma ntrunc_subsetI: "ntrunc k M <= M"
by (auto simp add: ntrunc_def)

lemma ntrunc_subsetD: "(!!k. ntrunc k M <= N) ==> M<=N"
by (auto simp add: ntrunc_def)

(*A generalized form of the take-lemma*)
lemma ntrunc_equality: "(!!k. ntrunc k M = ntrunc k N) ==> M=N"
apply (rule equalityI)
apply (rule_tac [!] ntrunc_subsetD)
apply (rule_tac [!] ntrunc_subsetI [THEN [2] subset_trans], auto)
done

lemma ntrunc_o_equality:
    "[| !!k. (ntrunc(k) \<circ> h1) = (ntrunc(k) \<circ> h2) |] ==> h1=h2"
apply (rule ntrunc_equality [THEN ext])
apply (simp add: fun_eq_iff)
done

(*** Monotonicity ***)

lemma uprod_mono: "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'"
by (simp add: uprod_def, blast)

lemma usum_mono: "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'"
by (simp add: usum_def, blast)

lemma Scons_mono: "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'"
by (simp add: Scons_def, blast)

lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"
by (simp add: In0_def Scons_mono)

lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"
by (simp add: In1_def Scons_mono)

(*** Split and Case ***)

lemma Split [simp]: "Split c (Scons M N) = c M N"
by (simp add: Split_def)

lemma Case_In0 [simp]: "Case c d (In0 M) = c(M)"
by (simp add: Case_def)

lemma Case_In1 [simp]: "Case c d (In1 N) = d(N)"
by (simp add: Case_def)

(**** UN x. B(x) rules ****)

lemma ntrunc_UN1: "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))"
by (simp add: ntrunc_def, blast)

lemma Scons_UN1_x: "Scons (UN x. f x) M = (UN x. Scons (f x) M)"
by (simp add: Scons_def, blast)

lemma Scons_UN1_y: "Scons M (UN x. f x) = (UN x. Scons M (f x))"
by (simp add: Scons_def, blast)

lemma In0_UN1: "In0(UN x. f(x)) = (UN x. In0(f(x)))"
by (simp add: In0_def Scons_UN1_y)

lemma In1_UN1: "In1(UN x. f(x)) = (UN x. In1(f(x)))"
by (simp add: In1_def Scons_UN1_y)

(*** Equality for Cartesian Product ***)

lemma dprodI [intro!]:
    "\<lbrakk>(M,M') \<in> r; (N,N') \<in> s\<rbrakk> \<Longrightarrow> (Scons M N, Scons M' N') \<in> dprod r s"
by (auto simp add: dprod_def)

(*The general elimination rule*)
lemma dprodE [elim!]:
    "\<lbrakk>c \<in> dprod r s;
        \<And>x y x' y'. \<lbrakk>(x,x') \<in> r; (y,y') \<in> s;
                        c = (Scons x y, Scons x' y')\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: dprod_def)

(*** Equality for Disjoint Sum ***)

lemma dsum_In0I [intro]: "(M,M') \<in> r \<Longrightarrow> (In0(M), In0(M')) \<in> dsum r s"
by (auto simp add: dsum_def)

lemma dsum_In1I [intro]: "(N,N') \<in> s \<Longrightarrow> (In1(N), In1(N')) \<in> dsum r s"
by (auto simp add: dsum_def)

lemma dsumE [elim!]:
    "\<lbrakk>w \<in> dsum r s;
        \<And>x x'. \<lbrakk> (x,x') \<in> r;  w = (In0(x), In0(x')) \<rbrakk> \<Longrightarrow> P;
        \<And>y y'. \<lbrakk> (y,y') \<in> s;  w = (In1(y), In1(y')) \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: dsum_def)

(*** Monotonicity ***)

lemma dprod_mono: "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'"
by blast

lemma dsum_mono: "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'"
by blast

(*** Bounding theorems ***)

lemma dprod_Sigma: "(dprod (A \<times> B) (C \<times> D)) <= (uprod A C) \<times> (uprod B D)"
by blast

lemmas dprod_subset_Sigma = subset_trans [OF dprod_mono dprod_Sigma]

(*Dependent version*)
lemma dprod_subset_Sigma2:
    "(dprod (Sigma A B) (Sigma C D)) <= Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"
by auto

lemma dsum_Sigma: "(dsum (A \<times> B) (C \<times> D)) <= (usum A C) \<times> (usum B D)"
by blast

lemmas dsum_subset_Sigma = subset_trans [OF dsum_mono dsum_Sigma]

(*** Domain theorems ***)

lemma Domain_dprod [simp]: "Domain (dprod r s) = uprod (Domain r) (Domain s)"
  by auto

lemma Domain_dsum [simp]: "Domain (dsum r s) = usum (Domain r) (Domain s)"
  by auto

text \<open>hides popular names\<close>
hide_type (open) node item
hide_const (open) Push Node Atom Leaf Numb Lim Split Case

ML_file "~~/src/HOL/Tools/Old_Datatype/old_datatype.ML"
ML_file "~~/src/HOL/Tools/inductive_realizer.ML"

end


(*<*)
theory SPRView
imports
  KBPsAuto
begin
(*>*)

subsection\<open>The Synchronous Perfect-Recall View\<close>

text\<open>

\label{sec:kbps-theory-pr-view}

The synchronous perfect-recall (SPR) view records all observations the
agent has made on a given trace. This is the canonical
full-information synchronous view; all others are functions of this
one.

Intuitively it maintains a list of all observations made on the trace,
with the length of the list recording the time:

\<close>

definition (in Environment) spr_jview :: "('a, 's, 'obs Trace) JointView" where
  "spr_jview a = tMap (envObs a)"
(*<*)

context Environment
begin

lemma spr_jview_length_eq:
  "tLength (spr_jview a t) = tLength t"
  by (simp add: spr_jview_def)

lemma spr_jview_tInit_inv[simp]:
  "spr_jview a t = tInit obs \<longleftrightarrow> (\<exists>s. t = tInit s \<and> envObs a s = obs)"
  by (cases t) (simp_all add: spr_jview_def)

lemma spr_jview_tStep_eq_inv:
  "spr_jview a t' = spr_jview a (t \<leadsto> s) \<Longrightarrow> \<exists>t'' s'. t' = t'' \<leadsto> s'"
  by (cases t') (simp_all add: spr_jview_def)

lemma spr_jview_prefix_closed[dest]:
  "spr_jview a (t \<leadsto> s) = spr_jview a (t' \<leadsto> s') \<Longrightarrow> spr_jview a t = spr_jview a t'"
  by (simp add: spr_jview_def)

end

(*>*)
text\<open>

The corresponding incremental view appends a new observation to the
existing ones:

\<close>

definition (in Environment) spr_jviewInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 'obs Trace" where
  "spr_jviewInit \<equiv> \<lambda>a obs. tInit obs"

definition (in Environment)
  spr_jviewIncr :: "'a \<Rightarrow> 'obs \<Rightarrow> 'obs Trace \<Rightarrow> 'obs Trace"
where
  "spr_jviewIncr \<equiv> \<lambda>a obs' tobs. tobs \<leadsto> obs'"

sublocale Environment
        < SPR: IncrEnvironment jkbp envInit envAction envTrans envVal
                spr_jview envObs spr_jviewInit spr_jviewIncr
(*<*)
proof
  { fix a t t' assume "spr_jview a t = spr_jview a t'"
    hence "tLength t = tLength t'"
      using spr_jview_length_eq[where a=a, symmetric] by simp }
  thus "\<forall>a t t'. spr_jview a t = spr_jview a t' \<longrightarrow> tLength t = tLength t'"
    by blast
next
  show "\<forall>a s. spr_jviewInit a (envObs a s) = spr_jview a (tInit s)"
    unfolding spr_jviewInit_def by (simp add: spr_jview_def)
next
  show "\<forall>a t s. spr_jview a (t \<leadsto> s) = spr_jviewIncr a (envObs a s) (spr_jview a t)"
    unfolding spr_jviewIncr_def by (simp add: spr_jview_def)
qed

(* These need to follow the locale instantiation as we appeal to
sync. *)

lemma (in Environment) spr_tFirst[dest]:
  assumes v: "spr_jview a t = spr_jview a t'"
  shows "envObs a (tFirst t) = envObs a (tFirst t')"
  using SPR.sync[rule_format, OF v] v
  apply (induct rule: trace_induct2)
  apply (simp_all add: spr_jview_def)
  done

lemma (in Environment) spr_tLast[dest]:
  assumes v: "spr_jview a t = spr_jview a t'"
  shows "envObs a (tLast t) = envObs a (tLast t')"
  using SPR.sync[rule_format, OF v] v
  apply (induct rule: trace_induct2)
  apply (simp_all add: spr_jview_def)
  done

(*>*)

text\<open>

\citet[Theorem~5]{Ron:1996} showed that it is not the case that
finite-state implementations always exist with respect to the SPR
view, and so we consider three special cases:
\begin{itemize}

\item[\S\ref{sec:kbps-spr-single-agent}] where there is a single
agent;

\item[\S\ref{sec:kbps-theory-spr-deterministic-protocols}] when the
protocols of the agents are deterministic and communication is by
broadcast; and

\item[\S\ref{sec:kbps-theory-spr-non-deterministic-protocols}] when
the agents use non-deterministic protocols and again use broadcast to
communicate.

\end{itemize}
Note that these cases do overlap but none is wholly
contained in another.

\<close>

(*<*)
end
(*>*)


(*  Title:      HOL/NanoJava/AxSem.thy
    Author:     David von Oheimb, Technische Universitaet Muenchen
*)

section "Axiomatic Semantics"

theory AxSem imports State begin

type_synonym assn = "state => bool"
type_synonym vassn = "val => assn"
type_synonym triple = "assn \<times> stmt \<times>  assn"
type_synonym etriple = "assn \<times> expr \<times> vassn"
translations
  (type) "assn" \<leftharpoondown> (type) "state => bool"
  (type) "vassn" \<leftharpoondown> (type) "val => assn"
  (type) "triple" \<leftharpoondown> (type) "assn \<times> stmt \<times> assn"
  (type) "etriple" \<leftharpoondown> (type) "assn \<times> expr \<times> vassn"

subsection "Hoare Logic Rules"

inductive
 hoare :: "[triple set, triple set] => bool"  ("_ |\<turnstile>/ _" [61, 61] 60)
 and ehoare :: "[triple set, etriple] => bool"  ("_ |\<turnstile>\<^sub>e/ _" [61, 61] 60)
 and hoare1 :: "[triple set, assn,stmt,assn] => bool"
   ("_ \<turnstile>/ ({(1_)}/ (_)/ {(1_)})" [61, 3, 90, 3] 60)
 and ehoare1 :: "[triple set, assn,expr,vassn]=> bool"
   ("_ \<turnstile>\<^sub>e/ ({(1_)}/ (_)/ {(1_)})" [61, 3, 90, 3] 60)
where

  "A  \<turnstile> {P}c{Q} \<equiv> A |\<turnstile> {(P,c,Q)}"
| "A  \<turnstile>\<^sub>e {P}e{Q} \<equiv> A |\<turnstile>\<^sub>e (P,e,Q)"

| Skip:  "A \<turnstile> {P} Skip {P}"

| Comp: "[| A \<turnstile> {P} c1 {Q}; A \<turnstile> {Q} c2 {R} |] ==> A \<turnstile> {P} c1;;c2 {R}"

| Cond: "[| A \<turnstile>\<^sub>e {P} e {Q};
            \<forall>v. A \<turnstile> {Q v} (if v \<noteq> Null then c1 else c2) {R} |] ==>
            A \<turnstile> {P} If(e) c1 Else c2 {R}"

| Loop: "A \<turnstile> {\<lambda>s. P s \<and> s<x> \<noteq> Null} c {P} ==>
         A \<turnstile> {P} While(x) c {\<lambda>s. P s \<and> s<x> = Null}"

| LAcc: "A \<turnstile>\<^sub>e {\<lambda>s. P (s<x>) s} LAcc x {P}"

| LAss: "A \<turnstile>\<^sub>e {P} e {\<lambda>v s.  Q (lupd(x\<mapsto>v) s)} ==>
         A \<turnstile>  {P} x:==e {Q}"

| FAcc: "A \<turnstile>\<^sub>e {P} e {\<lambda>v s. \<forall>a. v=Addr a --> Q (get_field s a f) s} ==>
         A \<turnstile>\<^sub>e {P} e..f {Q}"

| FAss: "[| A \<turnstile>\<^sub>e {P} e1 {\<lambda>v s. \<forall>a. v=Addr a --> Q a s};
        \<forall>a. A \<turnstile>\<^sub>e {Q a} e2 {\<lambda>v s. R (upd_obj a f v s)} |] ==>
            A \<turnstile>  {P} e1..f:==e2 {R}"

| NewC: "A \<turnstile>\<^sub>e {\<lambda>s. \<forall>a. new_Addr s = Addr a --> P (Addr a) (new_obj a C s)}
                new C {P}"

| Cast: "A \<turnstile>\<^sub>e {P} e {\<lambda>v s. (case v of Null => True
                                 | Addr a => obj_class s a \<preceq>C C) --> Q v s} ==>
         A \<turnstile>\<^sub>e {P} Cast C e {Q}"

| Call: "[| A \<turnstile>\<^sub>e {P} e1 {Q}; \<forall>a. A \<turnstile>\<^sub>e {Q a} e2 {R a};
    \<forall>a p ls. A \<turnstile> {\<lambda>s'. \<exists>s. R a p s \<and> ls = s \<and>
                    s' = lupd(This\<mapsto>a)(lupd(Par\<mapsto>p)(del_locs s))}
                  Meth (C,m) {\<lambda>s. S (s<Res>) (set_locs ls s)} |] ==>
             A \<turnstile>\<^sub>e {P} {C}e1..m(e2) {S}"

| Meth: "\<forall>D. A \<turnstile> {\<lambda>s'. \<exists>s a. s<This> = Addr a \<and> D = obj_class s a \<and> D \<preceq>C C \<and>
                        P s \<and> s' = init_locs D m s}
                  Impl (D,m) {Q} ==>
             A \<turnstile> {P} Meth (C,m) {Q}"

  \<comment> \<open>\<open>\<Union>Z\<close> instead of \<open>\<forall>Z\<close> in the conclusion and\\
       Z restricted to type state due to limitations of the inductive package\<close>
| Impl: "\<forall>Z::state. A\<union> (\<Union>Z. (\<lambda>Cm. (P Z Cm, Impl Cm, Q Z Cm))`Ms) |\<turnstile>
                            (\<lambda>Cm. (P Z Cm, body Cm, Q Z Cm))`Ms ==>
                      A |\<turnstile> (\<lambda>Cm. (P Z Cm, Impl Cm, Q Z Cm))`Ms"

\<comment> \<open>structural rules\<close>

| Asm:  "   a \<in> A ==> A |\<turnstile> {a}"

| ConjI: " \<forall>c \<in> C. A |\<turnstile> {c} ==> A |\<turnstile> C"

| ConjE: "[|A |\<turnstile> C; c \<in> C |] ==> A |\<turnstile> {c}"

  \<comment> \<open>Z restricted to type state due to limitations of the inductive package\<close>
| Conseq:"[| \<forall>Z::state. A \<turnstile> {P' Z} c {Q' Z};
             \<forall>s t. (\<forall>Z. P' Z s --> Q' Z t) --> (P s --> Q t) |] ==>
            A \<turnstile> {P} c {Q }"

  \<comment> \<open>Z restricted to type state due to limitations of the inductive package\<close>
| eConseq:"[| \<forall>Z::state. A \<turnstile>\<^sub>e {P' Z} e {Q' Z};
             \<forall>s v t. (\<forall>Z. P' Z s --> Q' Z v t) --> (P s --> Q v t) |] ==>
            A \<turnstile>\<^sub>e {P} e {Q }"

subsection "Fully polymorphic variants, required for Example only"

axiomatization where
  Conseq:"[| \<forall>Z. A \<turnstile> {P' Z} c {Q' Z};
             \<forall>s t. (\<forall>Z. P' Z s --> Q' Z t) --> (P s --> Q t) |] ==>
                 A \<turnstile> {P} c {Q }"

axiomatization where
  eConseq:"[| \<forall>Z. A \<turnstile>\<^sub>e {P' Z} e {Q' Z};
             \<forall>s v t. (\<forall>Z. P' Z s --> Q' Z v t) --> (P s --> Q v t) |] ==>
                 A \<turnstile>\<^sub>e {P} e {Q }"

axiomatization where
  Impl: "\<forall>Z. A\<union> (\<Union>Z. (\<lambda>Cm. (P Z Cm, Impl Cm, Q Z Cm))`Ms) |\<turnstile>
                          (\<lambda>Cm. (P Z Cm, body Cm, Q Z Cm))`Ms ==>
                    A |\<turnstile> (\<lambda>Cm. (P Z Cm, Impl Cm, Q Z Cm))`Ms"

subsection "Derived Rules"

lemma Conseq1: "\<lbrakk>A \<turnstile> {P'} c {Q}; \<forall>s. P s \<longrightarrow> P' s\<rbrakk> \<Longrightarrow> A \<turnstile> {P} c {Q}"
apply (rule hoare_ehoare.Conseq)
apply  (rule allI, assumption)
apply fast
done

lemma Conseq2: "\<lbrakk>A \<turnstile> {P} c {Q'}; \<forall>t. Q' t \<longrightarrow> Q t\<rbrakk> \<Longrightarrow> A \<turnstile> {P} c {Q}"
apply (rule hoare_ehoare.Conseq)
apply  (rule allI, assumption)
apply fast
done

lemma eConseq1: "\<lbrakk>A \<turnstile>\<^sub>e {P'} e {Q}; \<forall>s. P s \<longrightarrow> P' s\<rbrakk> \<Longrightarrow> A \<turnstile>\<^sub>e {P} e {Q}"
apply (rule hoare_ehoare.eConseq)
apply  (rule allI, assumption)
apply fast
done

lemma eConseq2: "\<lbrakk>A \<turnstile>\<^sub>e {P} e {Q'}; \<forall>v t. Q' v t \<longrightarrow> Q v t\<rbrakk> \<Longrightarrow> A \<turnstile>\<^sub>e {P} e {Q}"
apply (rule hoare_ehoare.eConseq)
apply  (rule allI, assumption)
apply fast
done

lemma Weaken: "\<lbrakk>A |\<turnstile> C'; C \<subseteq> C'\<rbrakk> \<Longrightarrow> A |\<turnstile> C"
apply (rule hoare_ehoare.ConjI)
apply clarify
apply (drule hoare_ehoare.ConjE)
apply  fast
apply assumption
done

lemma Thin_lemma:
  "(A' |\<turnstile>  C         \<longrightarrow> (\<forall>A. A' \<subseteq> A \<longrightarrow> A |\<turnstile>  C       )) \<and>
   (A'  \<turnstile>\<^sub>e {P} e {Q} \<longrightarrow> (\<forall>A. A' \<subseteq> A \<longrightarrow> A  \<turnstile>\<^sub>e {P} e {Q}))"
apply (rule hoare_ehoare.induct)
apply (tactic "ALLGOALS(EVERY'[clarify_tac \<^context>, REPEAT o smp_tac \<^context> 1])")
apply (blast intro: hoare_ehoare.Skip)
apply (blast intro: hoare_ehoare.Comp)
apply (blast intro: hoare_ehoare.Cond)
apply (blast intro: hoare_ehoare.Loop)
apply (blast intro: hoare_ehoare.LAcc)
apply (blast intro: hoare_ehoare.LAss)
apply (blast intro: hoare_ehoare.FAcc)
apply (blast intro: hoare_ehoare.FAss)
apply (blast intro: hoare_ehoare.NewC)
apply (blast intro: hoare_ehoare.Cast)
apply (erule hoare_ehoare.Call)
apply   (rule, drule spec, erule conjE, tactic "smp_tac \<^context> 1 1", assumption)
apply  blast
apply (blast intro!: hoare_ehoare.Meth)
apply (blast intro!: hoare_ehoare.Impl)
apply (blast intro!: hoare_ehoare.Asm)
apply (blast intro: hoare_ehoare.ConjI)
apply (blast intro: hoare_ehoare.ConjE)
apply (rule hoare_ehoare.Conseq)
apply  (rule, drule spec, erule conjE, tactic "smp_tac \<^context> 1 1", assumption+)
apply (rule hoare_ehoare.eConseq)
apply  (rule, drule spec, erule conjE, tactic "smp_tac \<^context> 1 1", assumption+)
done

lemma cThin: "\<lbrakk>A' |\<turnstile> C; A' \<subseteq> A\<rbrakk> \<Longrightarrow> A |\<turnstile> C"
by (erule (1) conjunct1 [OF Thin_lemma, rule_format])

lemma eThin: "\<lbrakk>A' \<turnstile>\<^sub>e {P} e {Q}; A' \<subseteq> A\<rbrakk> \<Longrightarrow> A \<turnstile>\<^sub>e {P} e {Q}"
by (erule (1) conjunct2 [OF Thin_lemma, rule_format])

lemma Union: "A |\<turnstile> (\<Union>Z. C Z) = (\<forall>Z. A |\<turnstile> C Z)"
by (auto intro: hoare_ehoare.ConjI hoare_ehoare.ConjE)

lemma Impl1':
   "\<lbrakk>\<forall>Z::state. A\<union> (\<Union>Z. (\<lambda>Cm. (P Z Cm, Impl Cm, Q Z Cm))`Ms) |\<turnstile>
                 (\<lambda>Cm. (P Z Cm, body Cm, Q Z Cm))`Ms;
    Cm \<in> Ms\<rbrakk> \<Longrightarrow>
                A   \<turnstile>  {P Z Cm} Impl Cm {Q Z Cm}"
apply (drule AxSem.Impl)
apply (erule Weaken)
apply (auto del: image_eqI intro: rev_image_eqI)
done

lemmas Impl1 = AxSem.Impl [of _ _ _ "{Cm}", simplified] for Cm

end


(*  Title:      HOL/SPARK/SPARK.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG

Declaration of proof functions for SPARK/Ada verification environment.
*)

theory SPARK
imports SPARK_Setup
begin

text \<open>Bitwise logical operators\<close>

spark_proof_functions
  bit__and (integer, integer) : integer = "(AND)"
  bit__or (integer, integer) : integer = "(OR)"
  bit__xor (integer, integer) : integer = "(XOR)"

lemmas [simp] =
  OR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 8, simplified]
  OR_upper [of _ 16, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 16, simplified]
  OR_upper [of _ 32, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 32, simplified]
  OR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 64, simplified]

lemmas [simp] =
  XOR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 8, simplified]
  XOR_upper [of _ 16, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 16, simplified]
  XOR_upper [of _ 32, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 32, simplified]
  XOR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 64, simplified]

lemma bit_not_spark_eq:
  "NOT (word_of_int x :: ('a::len0) word) =
  word_of_int (2 ^ LENGTH('a) - 1 - x)"
proof -
  have "word_of_int x + NOT (word_of_int x) =
    word_of_int x + (word_of_int (2 ^ LENGTH('a) - 1 - x)::'a word)"
    by (simp only: bwsimps bin_add_not Min_def)
      (simp add: word_of_int_hom_syms word_of_int_2p_len)
  then show ?thesis by (rule add_left_imp_eq)
qed

lemmas [simp] =
  bit_not_spark_eq [where 'a=8, simplified]
  bit_not_spark_eq [where 'a=16, simplified]
  bit_not_spark_eq [where 'a=32, simplified]
  bit_not_spark_eq [where 'a=64, simplified]

text \<open>Minimum and maximum\<close>

spark_proof_functions
  integer__min = "min :: int \<Rightarrow> int \<Rightarrow> int"
  integer__max = "max :: int \<Rightarrow> int \<Rightarrow> int"

end


(*<*)
theory HO_Transition_System
imports Heard_Of.HOModel Refinement
begin
(*>*)

subsection \<open>Transition system semantics for HO models\<close>

text \<open>The HO development already defines two trace semantics for algorithms in this model, the
coarse- and fine-grained ones. However, both of these are defined on infinite traces. Since the
semantics of our transition systems are defined on finite traces, we also provide such a semantics
for the HO model. Since we only use refinement for safety properties, the result also extend to
infinite traces (although we do not prove this in Isabelle).\<close>

definition CHO_trans where
"CHO_trans A HOs SHOs coord =
  {((r, st), (r', st'))|r r' st st'.
      r' = Suc r
      \<and> CSHOnextConfig A r st (HOs r) (SHOs r) (coord r) st'
  }"

definition CHO_to_TS ::
  "('proc, 'pst, 'msg) CHOAlgorithm
  \<Rightarrow> (nat \<Rightarrow> 'proc HO)
  \<Rightarrow> (nat \<Rightarrow> 'proc HO)
  \<Rightarrow> (nat \<Rightarrow> 'proc coord)
  \<Rightarrow> (nat \<times> ('proc \<Rightarrow> 'pst)) TS"
where
  "CHO_to_TS A HOs SHOs coord \<equiv> \<lparr>
    init = {(0, st)|st. CHOinitConfig A st (coord 0)},
    trans = CHO_trans A HOs SHOs coord
  \<rparr>"

definition get_msgs ::
  "('proc \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> 'msg)
  \<Rightarrow> ('proc \<Rightarrow> 'pst)
  \<Rightarrow> 'proc HO
  \<Rightarrow> 'proc HO
  \<Rightarrow> 'proc \<Rightarrow> ('proc \<rightharpoonup> 'msg)set"
where
  "get_msgs snd_f cfg HO SHO \<equiv> \<lambda>p.
   {\<mu>. (\<forall>q. q \<in> HO p \<longleftrightarrow> \<mu> q \<noteq> None)
     \<and> (\<forall>q. q \<in> SHO p \<inter> HO p \<longrightarrow> \<mu> q = Some (snd_f q p (cfg q)))}"

definition CSHO_trans_alt
  ::
  "(nat \<Rightarrow> 'proc \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> 'msg)
  \<Rightarrow> (nat \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> ('proc \<rightharpoonup> 'msg) \<Rightarrow> 'proc \<Rightarrow> 'pst \<Rightarrow> bool)
  \<Rightarrow> (nat \<Rightarrow> 'proc HO)
  \<Rightarrow> (nat \<Rightarrow> 'proc HO)
  \<Rightarrow> (nat \<Rightarrow> 'proc \<Rightarrow> 'proc)
  \<Rightarrow> ((nat \<times> ('proc \<Rightarrow> 'pst)) \<times> (nat \<times> ('proc \<Rightarrow> 'pst)))set"
where
  "CSHO_trans_alt snd_f nxt_st HOs SHOs coords \<equiv>
    \<Union>r \<mu>. {((r, cfg), (Suc r, cfg'))|cfg cfg'. \<forall>p.
      \<mu> p \<in> (get_msgs (snd_f r) cfg (HOs r) (SHOs r) p)
      \<and> (\<forall>p. nxt_st r p (cfg p) (\<mu> p) (coords r p) (cfg' p))
    }"

lemma CHO_trans_alt:
  "CHO_trans A HOs SHOs coords = CSHO_trans_alt (sendMsg A) (CnextState A) HOs SHOs coords"
  apply(rule equalityI)
   apply(force simp add: CHO_trans_def CSHO_trans_alt_def CSHOnextConfig_def SHOmsgVectors_def
    get_msgs_def restrict_map_def map_add_def choice_iff)
  apply(force simp add: CHO_trans_def CSHO_trans_alt_def CSHOnextConfig_def SHOmsgVectors_def
    get_msgs_def restrict_map_def map_add_def)
  done

definition K where
  "K y \<equiv> \<lambda>x. y"

lemma SHOmsgVectors_get_msgs:
  "SHOmsgVectors A r p cfg HOp SHOp = get_msgs (sendMsg A r) cfg (K HOp) (K SHOp) p"
  by(auto simp add: SHOmsgVectors_def get_msgs_def K_def)

lemma CSHORun_get_msgs:
  "CSHORun (A ::  ('proc, 'pst, 'msg) CHOAlgorithm) rho HOs SHOs coords = (
     CHOinitConfig A (rho 0) (coords 0)
   \<and> (\<forall>r. \<exists>\<mu>.
    (\<forall>p.
      \<mu> p \<in> get_msgs (sendMsg A r) (rho r) (HOs r) (SHOs r) p
      \<and> CnextState A r p (rho r p) (\<mu> p) (coords (Suc r) p) (rho (Suc r) p))))"
   by(auto simp add: CSHORun_def CSHOnextConfig_def SHOmsgVectors_get_msgs nextState_def get_msgs_K
     Bex_def choice_iff)

lemmas CSHORun_step = CSHORun_get_msgs[THEN iffD1, THEN conjunct2]

lemma get_msgs_dom:
  "msgs \<in> get_msgs send s HOs SHOs p \<Longrightarrow> dom msgs = HOs p"
  by(auto simp add: get_msgs_def)

lemma get_msgs_benign:
  "get_msgs snd_f cfg HOs HOs p = { (Some o (\<lambda>q. (snd_f q p (cfg q)))) |` (HOs p)}"
  by(auto simp add: get_msgs_def restrict_map_def)

end