(*  Title:      HOL/Auth/Guard/List_Msg.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Lists of Messages and Lists of Agents\<close>

theory List_Msg imports Extensions begin

subsection\<open>Implementation of Lists by Messages\<close>

subsubsection\<open>nil is represented by any message which is not a pair\<close>

abbreviation (input)
  cons :: "msg => msg => msg" where
  "cons x l == \<lbrace>x,l\<rbrace>"

subsubsection\<open>induction principle\<close>

lemma lmsg_induct: "[| !!x. not_MPair x ==> P x; !!x l. P l ==> P (cons x l) |]
==> P l"
by (induct l) auto

subsubsection\<open>head\<close>

primrec head :: "msg => msg" where
"head (cons x l) = x"

subsubsection\<open>tail\<close>

primrec tail :: "msg => msg" where
"tail (cons x l) = l"

subsubsection\<open>length\<close>

fun len :: "msg => nat" where
"len (cons x l) = Suc (len l)" |
"len other = 0"

lemma len_not_empty: "n < len l ==> EX x l'. l = cons x l'"
by (cases l) auto

subsubsection\<open>membership\<close>

fun isin :: "msg * msg => bool" where
"isin (x, cons y l) = (x=y | isin (x,l))" |
"isin (x, other) = False"

subsubsection\<open>delete an element\<close>

fun del :: "msg * msg => msg" where
"del (x, cons y l) = (if x=y then l else cons y (del (x,l)))" |
"del (x, other) = other"

lemma notin_del [simp]: "~ isin (x,l) ==> del (x,l) = l"
by (induct l) auto

lemma isin_del [rule_format]: "isin (y, del (x,l)) --> isin (y,l)"
by (induct l) auto

subsubsection\<open>concatenation\<close>

fun app :: "msg * msg => msg" where
"app (cons x l, l') = cons x (app (l,l'))" |
"app (other, l') = l'"

lemma isin_app [iff]: "isin (x, app(l,l')) = (isin (x,l) | isin (x,l'))"
by (induct l) auto

subsubsection\<open>replacement\<close>

fun repl :: "msg * nat * msg => msg" where
"repl (cons x l, Suc i, x') = cons x (repl (l,i,x'))" |
"repl (cons x l, 0, x') = cons x' l" |
"repl (other, i, M') = other"

subsubsection\<open>ith element\<close>

fun ith :: "msg * nat => msg" where
"ith (cons x l, Suc i) = ith (l,i)" |
"ith (cons x l, 0) = x" |
"ith (other, i) = other"

lemma ith_head: "0 < len l ==> ith (l,0) = head l"
by (cases l) auto

subsubsection\<open>insertion\<close>

fun ins :: "msg * nat * msg => msg" where
"ins (cons x l, Suc i, y) = cons x (ins (l,i,y))" |
"ins (l, 0, y) = cons y l"

lemma ins_head [simp]: "ins (l,0,y) = cons y l"
by (cases l) auto

subsubsection\<open>truncation\<close>

fun trunc :: "msg * nat => msg" where
"trunc (l,0) = l" |
"trunc (cons x l, Suc i) = trunc (l,i)"

lemma trunc_zero [simp]: "trunc (l,0) = l"
by (cases l) auto

subsection\<open>Agent Lists\<close>

subsubsection\<open>set of well-formed agent-list messages\<close>

abbreviation
  nil :: msg where
  "nil == Number 0"

inductive_set agl :: "msg set"
where
  Nil[intro]: "nil:agl"
| Cons[intro]: "[| A:agent; I:agl |] ==> cons (Agent A) I :agl"

subsubsection\<open>basic facts about agent lists\<close>

lemma del_in_agl [intro]: "I:agl ==> del (a,I):agl"
by (erule agl.induct, auto)

lemma app_in_agl [intro]: "[| I:agl; J:agl |] ==> app (I,J):agl"
by (erule agl.induct, auto)

lemma no_Key_in_agl: "I:agl ==> Key K ~:parts {I}"
by (erule agl.induct, auto)

lemma no_Nonce_in_agl: "I:agl ==> Nonce n ~:parts {I}"
by (erule agl.induct, auto)

lemma no_Key_in_appdel: "[| I:agl; J:agl |] ==>
Key K ~:parts {app (J, del (Agent B, I))}"
by (rule no_Key_in_agl, auto)

lemma no_Nonce_in_appdel: "[| I:agl; J:agl |] ==>
Nonce n ~:parts {app (J, del (Agent B, I))}"
by (rule no_Nonce_in_agl, auto)

lemma no_Crypt_in_agl: "I:agl ==> Crypt K X ~:parts {I}"
by (erule agl.induct, auto)

lemma no_Crypt_in_appdel: "[| I:agl; J:agl |] ==>
Crypt K X ~:parts {app (J, del (Agent B,I))}"
by (rule no_Crypt_in_agl, auto)

end


(* Author: Matthias Brun,   ETH Zürich, 2019 *)
(* Author: Dmitriy Traytel, ETH Zürich, 2019 *)

section \<open>Agreement Relation\<close>

(*<*)
theory Agreement
  imports Semantics
begin
(*>*)

inductive agree :: "tyenv \<Rightarrow> term \<Rightarrow> term \<Rightarrow> term \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _, _, _ : _" [150,0,0,0,150] 149) where
  a_Unit: "\<Gamma> \<turnstile> Unit, Unit, Unit : One" |
  a_Var: "\<Gamma> $$ x = Some \<tau>
    \<Longrightarrow> \<Gamma> \<turnstile> Var x, Var x, Var x : \<tau>" |
  a_Lam: "\<lbrakk> atom x \<sharp> \<Gamma>; \<Gamma>(x $$:= \<tau>\<^sub>1) \<turnstile> e, eP, eV : \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Lam x e, Lam x eP, Lam x eV : Fun \<tau>\<^sub>1 \<tau>\<^sub>2" |
  a_App: "\<lbrakk> \<Gamma> \<turnstile> e\<^sub>1, eP\<^sub>1, eV\<^sub>1 : Fun \<tau>\<^sub>1 \<tau>\<^sub>2; \<Gamma> \<turnstile> e\<^sub>2, eP\<^sub>2, eV\<^sub>2 : \<tau>\<^sub>1 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2, App eP\<^sub>1 eP\<^sub>2, App eV\<^sub>1 eV\<^sub>2 : \<tau>\<^sub>2" |
  a_Let: "\<lbrakk> atom x \<sharp> (\<Gamma>, e\<^sub>1, eP\<^sub>1, eV\<^sub>1); \<Gamma> \<turnstile> e\<^sub>1, eP\<^sub>1, eV\<^sub>1 : \<tau>\<^sub>1; \<Gamma>(x $$:= \<tau>\<^sub>1) \<turnstile> e\<^sub>2, eP\<^sub>2, eV\<^sub>2 : \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Let e\<^sub>1 x e\<^sub>2, Let eP\<^sub>1 x eP\<^sub>2, Let eV\<^sub>1 x eV\<^sub>2 : \<tau>\<^sub>2" |
  a_Rec: "\<lbrakk> atom x \<sharp> \<Gamma>; atom y \<sharp> (\<Gamma>,x); \<Gamma>(x $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile> Lam y e, Lam y eP, Lam y eV : Fun \<tau>\<^sub>1 \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Rec x (Lam y e), Rec x (Lam y eP), Rec x (Lam y eV) : Fun \<tau>\<^sub>1 \<tau>\<^sub>2" |
  a_Inj1: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : \<tau>\<^sub>1 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Inj1 e, Inj1 eP, Inj1 eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2" |
  a_Inj2: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Inj2 e, Inj2 eP, Inj2 eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2" |
  a_Case: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2; \<Gamma> \<turnstile> e\<^sub>1, eP\<^sub>1, eV\<^sub>1 : Fun \<tau>\<^sub>1 \<tau>; \<Gamma> \<turnstile> e\<^sub>2, eP\<^sub>2, eV\<^sub>2 : Fun \<tau>\<^sub>2 \<tau> \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Case e e\<^sub>1 e\<^sub>2, Case eP eP\<^sub>1 eP\<^sub>2, Case eV eV\<^sub>1 eV\<^sub>2 : \<tau>" |
  a_Pair: "\<lbrakk> \<Gamma> \<turnstile> e\<^sub>1, eP\<^sub>1, eV\<^sub>1 : \<tau>\<^sub>1; \<Gamma> \<turnstile> e\<^sub>2, eP\<^sub>2, eV\<^sub>2 : \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Pair e\<^sub>1 e\<^sub>2, Pair eP\<^sub>1 eP\<^sub>2, Pair eV\<^sub>1 eV\<^sub>2 : Prod \<tau>\<^sub>1 \<tau>\<^sub>2" |
  a_Prj1: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : Prod \<tau>\<^sub>1 \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Prj1 e, Prj1 eP, Prj1 eV : \<tau>\<^sub>1" |
  a_Prj2: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : Prod \<tau>\<^sub>1 \<tau>\<^sub>2 \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Prj2 e, Prj2 eP, Prj2 eV : \<tau>\<^sub>2" |
  a_Roll: "\<lbrakk> atom \<alpha> \<sharp> \<Gamma>; \<Gamma> \<turnstile> e, eP, eV : subst_type \<tau> (Mu \<alpha> \<tau>) \<alpha> \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Roll e, Roll eP, Roll eV : Mu \<alpha> \<tau>" |
  a_Unroll: "\<lbrakk> atom \<alpha> \<sharp> \<Gamma>; \<Gamma> \<turnstile> e, eP, eV : Mu \<alpha> \<tau> \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Unroll e, Unroll eP, Unroll eV : subst_type \<tau> (Mu \<alpha> \<tau>) \<alpha>" |
  a_Auth: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : \<tau> \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Auth e, Auth eP, Auth eV : AuthT \<tau>" |
  a_Unauth: "\<lbrakk> \<Gamma> \<turnstile> e, eP, eV : AuthT \<tau> \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> Unauth e, Unauth eP, Unauth eV : \<tau>" |
  a_HashI: "\<lbrakk> {$$} \<turnstile> v, vP, \<lparr>vP\<rparr> : \<tau>; hash \<lparr>vP\<rparr> = h; value v; value vP \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> v, Hashed h vP, Hash h : AuthT \<tau>"

declare agree.intros[intro]

equivariance agree
nominal_inductive agree
  avoids a_Lam: x
       | a_Rec: x and y
       | a_Let: x
       | a_Roll: \<alpha>
       | a_Unroll: \<alpha>
  by (auto simp: fresh_Pair fresh_subst_type)

lemma Abs_lst_eq_3tuple:
  fixes x x' :: var
  fixes e eP eV e' eP' eV' :: "term"
  assumes "[[atom x]]lst. e = [[atom x']]lst. e'"
  and     "[[atom x]]lst. eP = [[atom x']]lst. eP'"
  and     "[[atom x]]lst. eV = [[atom x']]lst. eV'"
  shows   "[[atom x]]lst. (e, eP, eV) = [[atom x']]lst. (e', eP', eV')"
  using assms by (simp add: fresh_Pair)

lemma agree_fresh_env_fresh_term:
  fixes a :: var
  assumes "\<Gamma> \<turnstile> e, eP, eV : \<tau>" "atom a \<sharp> \<Gamma>"
  shows   "atom a \<sharp> (e, eP, eV)"
  using assms proof (nominal_induct \<Gamma> e eP eV \<tau> avoiding: a rule: agree.strong_induct)
  case (a_Var \<Gamma> x \<tau>)
  then show ?case
    by (cases "a = x") (auto simp: fresh_tyenv_None)
qed (simp_all add: fresh_Cons fresh_fmap_update fresh_Pair)

lemma agree_empty_fresh[dest]:
  fixes a :: var
  assumes "{$$} \<turnstile> e, eP, eV : \<tau>"
  shows   "{atom a} \<sharp>* {e, eP, eV}"
  using assms by (auto simp: fresh_Pair dest: agree_fresh_env_fresh_term)

text \<open>Inversion rules for agreement.\<close>

declare [[simproc del: alpha_lst]]

lemma a_Lam_inv_I[elim]:
  assumes "\<Gamma> \<turnstile> (Lam x e'), eP, eV : (Fun \<tau>\<^sub>1 \<tau>\<^sub>2)"
  and     "atom x \<sharp> \<Gamma>"
  obtains eP' eV' where "eP = Lam x eP'" "eV = Lam x eV'" "\<Gamma>(x $$:= \<tau>\<^sub>1) \<turnstile> e', eP', eV' : \<tau>\<^sub>2"
  using assms
proof (atomize_elim, nominal_induct \<Gamma> "Lam x e'" eP eV "Fun \<tau>\<^sub>1 \<tau>\<^sub>2" avoiding: x e' \<tau>\<^sub>1 \<tau>\<^sub>2 rule: agree.strong_induct)
  case (a_Lam x \<Gamma> \<tau>\<^sub>1 e eP eV \<tau>\<^sub>2 y e')
  show ?case
  proof (intro exI conjI)
    from a_Lam show "Lam x eP = Lam y ((x \<leftrightarrow> y) \<bullet> eP)"
      by (auto intro!: Abs_lst_eq_flipI  dest!: agree_fresh_env_fresh_term
        simp: fresh_fmap_update fresh_Pair)
    from a_Lam show "Lam x eV = Lam y ((x \<leftrightarrow> y) \<bullet> eV)"
      by (auto intro!: Abs_lst_eq_flipI  dest!: agree_fresh_env_fresh_term
        simp: fresh_fmap_update fresh_Pair)
    from a_Lam(1-6,8,10) show "\<Gamma>(y $$:= \<tau>\<^sub>1) \<turnstile> e', (x \<leftrightarrow> y) \<bullet> eP, (x \<leftrightarrow> y) \<bullet> eV : \<tau>\<^sub>2"
      by (auto simp: perm_supp_eq Abs1_eq_iff(3)
        dest!: agree.eqvt[where p = "(x \<leftrightarrow> y)", of "\<Gamma>(x $$:= \<tau>\<^sub>1)"])
  qed
qed

lemma a_Lam_inv_P[elim]:
  assumes "{$$} \<turnstile> v, (Lam x vP'), vV : (Fun \<tau>\<^sub>1 \<tau>\<^sub>2)"
  obtains v' vV' where "v = Lam x v'" "vV = Lam x vV'" "{$$}(x $$:= \<tau>\<^sub>1) \<turnstile> v', vP', vV' : \<tau>\<^sub>2"
  using assms
proof (atomize_elim, nominal_induct "{$$}::tyenv" v "Lam x vP'" vV "Fun \<tau>\<^sub>1 \<tau>\<^sub>2" avoiding: x vP' rule: agree.strong_induct)
  case (a_Lam x' e eP eV)
  show ?case
  proof (intro exI conjI)
    from a_Lam show "Lam x' e = Lam x ((x' \<leftrightarrow> x) \<bullet> e)"
      by (auto intro!: Abs_lst_eq_flipI  dest!: agree_fresh_env_fresh_term
        simp: fresh_fmap_update fresh_Pair)
    from a_Lam show "Lam x' eV = Lam x ((x' \<leftrightarrow> x) \<bullet> eV)"
      by (auto intro!: Abs_lst_eq_flipI  dest!: agree_fresh_env_fresh_term
        simp: fresh_fmap_update fresh_Pair)
    from a_Lam(1-4,6) show "{$$}(x $$:= \<tau>\<^sub>1) \<turnstile> (x' \<leftrightarrow> x) \<bullet> e, vP', (x' \<leftrightarrow> x) \<bullet> eV : \<tau>\<^sub>2"
      by (auto simp: perm_supp_eq Abs1_eq_iff(3)
        dest!: agree.eqvt[where p = "(x' \<leftrightarrow> x)", of "{$$}(x' $$:= \<tau>\<^sub>1)"])
  qed
qed

lemma a_Lam_inv_V[elim]:
  assumes "{$$} \<turnstile> v, vP, (Lam x vV') : (Fun \<tau>\<^sub>1 \<tau>\<^sub>2)"
  obtains v' vP' where "v = Lam x v'" "vP = Lam x vP'" "{$$}(x $$:= \<tau>\<^sub>1) \<turnstile> v', vP', vV' : \<tau>\<^sub>2"
  using assms
proof (atomize_elim, nominal_induct "{$$}::tyenv" v vP "Lam x vV'" "Fun \<tau>\<^sub>1 \<tau>\<^sub>2" avoiding: x vV' rule: agree.strong_induct)
  case (a_Lam x' e eP eV)
  show ?case
  proof (intro exI conjI)
    from a_Lam show "Lam x' e = Lam x ((x' \<leftrightarrow> x) \<bullet> e)"
      by (auto intro!: Abs_lst_eq_flipI  dest!: agree_fresh_env_fresh_term
        simp: fresh_fmap_update fresh_Pair)
    from a_Lam show "Lam x' eP = Lam x ((x' \<leftrightarrow> x) \<bullet> eP)"
      by (auto intro!: Abs_lst_eq_flipI  dest!: agree_fresh_env_fresh_term
        simp: fresh_fmap_update fresh_Pair)
    from a_Lam(1-4,6) show "{$$}(x $$:= \<tau>\<^sub>1) \<turnstile> (x' \<leftrightarrow> x) \<bullet> e, (x' \<leftrightarrow> x) \<bullet> eP, vV' : \<tau>\<^sub>2"
      by (auto simp: perm_supp_eq Abs1_eq_iff(3)
        dest!: agree.eqvt[where p = "(x' \<leftrightarrow> x)", of "{$$}(x' $$:= \<tau>\<^sub>1)"])
  qed
qed

lemma a_Rec_inv_I[elim]:
  assumes "\<Gamma> \<turnstile> Rec x e, eP, eV : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
  and     "atom x \<sharp> \<Gamma>"
  obtains y e' eP' eV'
  where "e = Lam y e'" "eP = Rec x (Lam y eP')" "eV = Rec x (Lam y eV')" "atom y \<sharp> (\<Gamma>,x)"
        "\<Gamma>(x $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile> Lam y e', Lam y eP', Lam y eV' : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
  using assms
proof (atomize_elim, nominal_induct \<Gamma> "Rec x e" eP eV "Fun \<tau>\<^sub>1 \<tau>\<^sub>2" avoiding: x e rule: agree.strong_induct)
  case (a_Rec x' \<Gamma> y e' eP eV)
  then show ?case
  proof (nominal_induct e avoiding: x x' y rule: term.strong_induct)
    case Unit
    from Unit(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Var x)
    from Var(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Lam z ee)
    show ?case
    proof (intro conjI exI)
      from Lam(1-3,5-13,15) show "Lam z ee = Lam y ((z \<leftrightarrow> y) \<bullet> ee)"
        by (auto intro: Abs_lst_eq_flipI simp: fresh_fmap_update fresh_Pair)
      from Lam(1-3,5-13,15) show "Rec x' (Lam y eP) = Rec x (Lam y ((x' \<leftrightarrow> x) \<bullet> eP))"
        using Abs_lst_eq_flipI[of x "Lam y eP" x']
        by (elim agree_fresh_env_fresh_term[where a = x, elim_format])
          (simp_all add: fresh_fmap_update fresh_Pair)
      from Lam(1-3,5-13,15) show "Rec x' (Lam y eV) = Rec x (Lam y ((x' \<leftrightarrow> x) \<bullet> eV))"
        using Abs_lst_eq_flipI[of x "Lam y eV" x']
        by (elim agree_fresh_env_fresh_term[where a = x, elim_format])
          (simp_all add: fresh_fmap_update fresh_Pair)
      from Lam(7,10) show "atom y \<sharp> (\<Gamma>, x)"
        by simp
      from Lam(1-3,5-11,13) have "(x' \<leftrightarrow> x) \<bullet> e' = (z \<leftrightarrow> y) \<bullet> ee"
        by (simp add: Abs1_eq_iff flip_commute swap_permute_swap fresh_perm fresh_at_base)
      with Lam(1-2,7,9,11-12,15) show "\<Gamma>(x $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile>
        Lam y ((z \<leftrightarrow> y) \<bullet> ee), Lam y ((x' \<leftrightarrow> x) \<bullet> eP), Lam y ((x' \<leftrightarrow> x) \<bullet> eV) : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
        by (elim agree.eqvt[of _ "Lam y e'" _ _ _ "(x' \<leftrightarrow> x)", elim_format]) (simp add:  perm_supp_eq)
    qed
  next
    case (Rec x1 x2a)
    from Rec(13) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Inj1 x)
    from Inj1(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Inj2 x)
    from Inj2(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Pair x1 x2a)
    from Pair(11) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Roll x)
    from Roll(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Let x1 x2a x3)
    from Let(14) show ?case by (simp add: Abs1_eq_iff)
  next
    case (App x1 x2a)
    from App(11) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Case x1 x2a x3)
    from Case(12) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Prj1 x)
    from Prj1(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Prj2 x)
    from Prj2(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Unroll x)
    from Unroll(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Auth x)
    from Auth(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Unauth x)
    from Unauth(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Hash x)
    from Hash(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Hashed x1 x2a)
    from Hashed(10) show ?case by (simp add: Abs1_eq_iff)
  qed
qed

lemma a_Rec_inv_P[elim]:
  assumes "\<Gamma> \<turnstile> e, Rec x eP, eV : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
  and     "atom x \<sharp> \<Gamma>"
  obtains y e' eP' eV'
  where "e = Rec x (Lam y e')" "eP = Lam y eP'" "eV = Rec x (Lam y eV')" "atom y \<sharp> (\<Gamma>,x)"
        "\<Gamma>(x $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile> Lam y e', Lam y eP', Lam y eV' : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
  using assms
proof (atomize_elim,nominal_induct \<Gamma> e "Rec x eP" eV "Fun \<tau>\<^sub>1 \<tau>\<^sub>2" avoiding: x eP rule: agree.strong_induct)
  case (a_Rec x \<Gamma> y e eP eV x' eP')
  then show ?case
  proof (nominal_induct eP' avoiding: x' x y rule: term.strong_induct)
    case Unit
    from Unit(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Var x)
    from Var(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Lam ya eP')
    show ?case
    proof (intro conjI exI)
      from Lam(1-3,5-13,15) show "Rec x (Lam y e) = Rec x' (Lam y ((x \<leftrightarrow> x') \<bullet> e))"
        using Abs_lst_eq_flipI[of x' "Lam y e" x]
        by (elim agree_fresh_env_fresh_term[where a = x', elim_format])
          (simp_all add: fresh_fmap_update fresh_Pair)
      from Lam(1-3,5-13,15) show "Lam ya eP' = Lam y ((x \<leftrightarrow> x') \<bullet> eP)"
        unfolding trans[OF eq_sym_conv Abs1_eq_iff(3)]
        by (simp add: flip_commute fresh_at_base)
      from Lam(1-3,5-13,15) show "Rec x (Lam y eV) = Rec x' (Lam y ((x \<leftrightarrow> x') \<bullet> eV))"
        using Abs_lst_eq_flipI[of x' "Lam y eV" x]
        by (elim agree_fresh_env_fresh_term[where a = x', elim_format])
          (simp_all add: fresh_fmap_update fresh_Pair)
      from Lam(7,10) show "atom y \<sharp> (\<Gamma>, x')"
        by simp
      with Lam(1-2,7,9,11-12,15) show "\<Gamma>(x' $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile>
        Lam y ((x \<leftrightarrow> x') \<bullet> e), Lam y ((x \<leftrightarrow> x') \<bullet> eP), Lam y ((x \<leftrightarrow> x') \<bullet> eV) : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
        by (elim agree.eqvt[of _ "Lam y _" _ _ _ "(x' \<leftrightarrow> x)", elim_format])
          (simp add:  perm_supp_eq flip_commute)
    qed
  next
    case (Rec x1 x2a)
    from Rec(13) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Inj1 x)
    from Inj1(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Inj2 x)
    from Inj2(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Pair x1 x2a)
    from Pair(11) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Roll x)
    from Roll(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Let x1 x2a x3)
    from Let(14) show ?case by (simp add: Abs1_eq_iff)
  next
    case (App x1 x2a)
    from App(11) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Case x1 x2a x3)
    from Case(12) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Prj1 x)
    from Prj1(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Prj2 x)
    from Prj2(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Unroll x)
    from Unroll(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Auth x)
    from Auth(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Unauth x)
    from Unauth(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Hash x)
    from Hash(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Hashed x1 x2a)
    from Hashed(10) show ?case by (simp add: Abs1_eq_iff)
  qed
qed

lemma a_Rec_inv_V[elim]:
  assumes "\<Gamma> \<turnstile> e, eP, Rec x eV : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
    and     "atom x \<sharp> \<Gamma>"
  obtains y e' eP' eV'
  where "e = Rec x (Lam y e')" "eP = Rec x (Lam y eP')" "eV = Lam y eV'" "atom y \<sharp> (\<Gamma>,x)"
    "\<Gamma>(x $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile> Lam y e', Lam y eP', Lam y eV' : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
  using assms
proof (atomize_elim, nominal_induct \<Gamma> e eP "Rec x eV" "Fun \<tau>\<^sub>1 \<tau>\<^sub>2" avoiding: x eV rule: agree.strong_induct)
  case (a_Rec x \<Gamma> y e eP eV x' eV')
  then show ?case
  proof (nominal_induct eV' avoiding: x' x y rule: term.strong_induct)
    case Unit
    from Unit(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Var x)
    from Var(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Lam ya eV')
    show ?case
    proof (intro conjI exI)
      from Lam(1-3,5-13,15) show "Rec x (Lam y e) = Rec x' (Lam y ((x \<leftrightarrow> x') \<bullet> e))"
        using Abs_lst_eq_flipI[of x' "Lam y e" x]
        by (elim agree_fresh_env_fresh_term[where a = x', elim_format])
          (simp_all add: fresh_fmap_update fresh_Pair)
      from Lam(1-3,5-13,15) show "Lam ya eV' = Lam y ((x \<leftrightarrow> x') \<bullet> eV)"
        unfolding trans[OF eq_sym_conv Abs1_eq_iff(3)]
        by (simp add: flip_commute fresh_at_base)
      from Lam(1-3,5-13,15) show "Rec x (Lam y eP) = Rec x' (Lam y ((x \<leftrightarrow> x') \<bullet> eP))"
        using Abs_lst_eq_flipI[of x' "Lam y eP" x]
        by (elim agree_fresh_env_fresh_term[where a = x', elim_format])
          (simp_all add: fresh_fmap_update fresh_Pair)
      from Lam(7,10) show "atom y \<sharp> (\<Gamma>, x')"
        by simp
      with Lam(1-2,7,9,11-12,15) show "\<Gamma>(x' $$:= Fun \<tau>\<^sub>1 \<tau>\<^sub>2) \<turnstile>
        Lam y ((x \<leftrightarrow> x') \<bullet> e), Lam y ((x \<leftrightarrow> x') \<bullet> eP), Lam y ((x \<leftrightarrow> x') \<bullet> eV) : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"
        by (elim agree.eqvt[of _ "Lam y _" _ _ _ "(x' \<leftrightarrow> x)", elim_format])
          (simp add:  perm_supp_eq flip_commute)
    qed
  next
    case (Rec x1 x2a)
    from Rec(13) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Inj1 x)
    from Inj1(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Inj2 x)
    from Inj2(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Pair x1 x2a)
    from Pair(11) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Roll x)
    from Roll(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Let x1 x2a x3)
    from Let(14) show ?case by (simp add: Abs1_eq_iff)
  next
    case (App x1 x2a)
    from App(11) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Case x1 x2a x3)
    from Case(12) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Prj1 x)
    from Prj1(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Prj2 x)
    from Prj2(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Unroll x)
    from Unroll(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Auth x)
    from Auth(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Unauth x)
    from Unauth(10) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Hash x)
    from Hash(9) show ?case by (simp add: Abs1_eq_iff)
  next
    case (Hashed x1 x2a)
    from Hashed(10) show ?case by (simp add: Abs1_eq_iff)
  qed
qed

inductive_cases a_Inj1_inv_I[elim]: "\<Gamma> \<turnstile> Inj1 e, eP, eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Inj1_inv_P[elim]: "\<Gamma> \<turnstile> e, Inj1 eP, eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Inj1_inv_V[elim]: "\<Gamma> \<turnstile> e, eP, Inj1 eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"

inductive_cases a_Inj2_inv_I[elim]: "\<Gamma> \<turnstile> Inj2 e, eP, eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Inj2_inv_P[elim]: "\<Gamma> \<turnstile> e, Inj2 eP, eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Inj2_inv_V[elim]: "\<Gamma> \<turnstile> e, eP, Inj2 eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"

inductive_cases a_Pair_inv_I[elim]: "\<Gamma> \<turnstile> Pair e\<^sub>1 e\<^sub>2, eP, eV : Prod \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Pair_inv_P[elim]: "\<Gamma> \<turnstile> e, Pair eP\<^sub>1 eP\<^sub>2, eV : Prod \<tau>\<^sub>1 \<tau>\<^sub>2"

lemma a_Roll_inv_I[elim]:
  assumes "\<Gamma> \<turnstile> Roll e', eP, eV : Mu \<alpha> \<tau>"
  obtains eP' eV'
  where "eP = Roll eP'" "eV = Roll eV'" "\<Gamma> \<turnstile> e', eP', eV' : subst_type \<tau> (Mu \<alpha> \<tau>) \<alpha>"
  using assms
  by (nominal_induct \<Gamma> "Roll e'" eP eV "Mu \<alpha> \<tau>" avoiding: \<alpha> \<tau> rule: agree.strong_induct)
     (simp add: Abs1_eq(3) Abs_lst_eq_flipI subst_type_perm_eq)

lemma a_Roll_inv_P[elim]:
  assumes "\<Gamma> \<turnstile> e, Roll eP', eV : Mu \<alpha> \<tau>"
  obtains e' eV'
  where "e = Roll e'" "eV = Roll eV'" "\<Gamma> \<turnstile> e', eP', eV' : subst_type \<tau> (Mu \<alpha> \<tau>) \<alpha>"
  using assms
  by (nominal_induct \<Gamma> e "Roll eP'" eV "Mu \<alpha> \<tau>" avoiding: \<alpha> \<tau> rule: agree.strong_induct)
     (simp add: Abs1_eq(3) Abs_lst_eq_flipI subst_type_perm_eq)

lemma a_Roll_inv_V[elim]:
  assumes "\<Gamma> \<turnstile> e, eP, Roll eV' : Mu \<alpha> \<tau>"
  obtains e' eP'
  where "e = Roll e'" "eP = Roll eP'" "\<Gamma> \<turnstile> e', eP', eV' : subst_type \<tau> (Mu \<alpha> \<tau>) \<alpha>"
  using assms
  by (nominal_induct \<Gamma> e eP "Roll eV'" "Mu \<alpha> \<tau>" avoiding: \<alpha> \<tau> rule: agree.strong_induct)
     (simp add: Abs1_eq(3) Abs_lst_eq_flipI subst_type_perm_eq)

inductive_cases a_HashI_inv[elim]: "\<Gamma> \<turnstile> v, Hashed (hash \<lparr>vP\<rparr>) vP, Hash (hash \<lparr>vP\<rparr>) : AuthT \<tau>"

text \<open>Inversion on types for agreement.\<close>

lemma a_AuthT_value_inv:
  assumes "{$$} \<turnstile> v, vP, vV : AuthT \<tau>"
  and     "value v" "value vP" "value vV"
  obtains vP' where "vP = Hashed (hash \<lparr>vP'\<rparr>) vP'" "vV = Hash (hash \<lparr>vP'\<rparr>)" "value vP'"
  using assms by (atomize_elim, induct "{$$}::tyenv" v vP vV "AuthT \<tau>" rule: agree.induct) simp_all

inductive_cases a_Mu_inv[elim]: "\<Gamma> \<turnstile> e, eP, eV : Mu \<alpha> \<tau>"
inductive_cases a_Sum_inv[elim]: "\<Gamma> \<turnstile> e, eP, eV : Sum \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Prod_inv[elim]: "\<Gamma> \<turnstile> e, eP, eV : Prod \<tau>\<^sub>1 \<tau>\<^sub>2"
inductive_cases a_Fun_inv[elim]: "\<Gamma> \<turnstile> e, eP, eV : Fun \<tau>\<^sub>1 \<tau>\<^sub>2"

declare [[simproc add: alpha_lst]]

lemma agree_weakening_1:
  assumes "\<Gamma> \<turnstile> e, eP, eV : \<tau>" "atom y \<sharp> e" "atom y \<sharp> eP" "atom y \<sharp> eV"
  shows   "\<Gamma>(y $$:= \<tau>') \<turnstile> e, eP, eV : \<tau>"
using assms proof (nominal_induct \<Gamma> e eP eV \<tau> avoiding: y \<tau>' rule: agree.strong_induct)
  case (a_Lam x \<Gamma> \<tau>\<^sub>1 e eP eV \<tau>\<^sub>2)
  then show ?case
    by (force simp add: fresh_at_base fresh_fmap_update fmupd_reorder_neq)
next
  case (a_App v\<^sub>1 v\<^sub>2 vP\<^sub>1 vP\<^sub>2 vV\<^sub>1 vV\<^sub>2 \<Gamma> \<tau>\<^sub>1 \<tau>\<^sub>2)
  then show ?case
    using term.fresh(9) by blast
next
  case (a_Let x \<Gamma> e\<^sub>1 eP\<^sub>1 eV\<^sub>1 \<tau>\<^sub>1 e\<^sub>2 eP\<^sub>2 eV\<^sub>2 \<tau>\<^sub>2)
  then show ?case
    by (auto simp add: fresh_at_base fresh_Pair fresh_fmap_update fmupd_reorder_neq[of x y]
      intro!: a_Let(10) agree.a_Let[of x])
next
  case (a_Rec x \<Gamma> z \<tau>\<^sub>1 \<tau>\<^sub>2 e eP eV)
  then show ?case
    by (auto simp add: fresh_at_base fresh_Pair fresh_fmap_update fmupd_reorder_neq[of x y]
      intro!: a_Rec(9) agree.a_Rec[of x])
next
  case (a_Case v v\<^sub>1 v\<^sub>2 vP vP\<^sub>1 vP\<^sub>2 vV vV\<^sub>1 vV\<^sub>2 \<Gamma> \<tau>\<^sub>1 \<tau>\<^sub>2 \<tau>)
  then show ?case
    by (fastforce simp: fresh_at_base)
next
  case (a_Prj1 v vP vV \<Gamma> \<tau>\<^sub>1 \<tau>\<^sub>2)
  then show ?case
    by (fastforce simp: fresh_at_base)
next
  case (a_Prj2 v vP vV \<Gamma> \<tau>\<^sub>1 \<tau>\<^sub>2)
  then show ?case
    by (fastforce simp: fresh_at_base)
qed (auto simp: fresh_fmap_update)

lemma agree_weakening_2:
  assumes "\<Gamma> \<turnstile> e, eP, eV : \<tau>" "atom y \<sharp> \<Gamma>"
  shows   "\<Gamma>(y $$:= \<tau>') \<turnstile> e, eP, eV : \<tau>"
proof -
  from assms have "{atom y} \<sharp>* {e, eP, eV}" by (auto simp: fresh_Pair dest: agree_fresh_env_fresh_term)
  with assms show "\<Gamma>(y $$:= \<tau>') \<turnstile> e, eP, eV : \<tau>" by (simp add: agree_weakening_1)
qed

lemma agree_weakening_env:
  assumes "{$$} \<turnstile> e, eP, eV : \<tau>"
  shows   "\<Gamma> \<turnstile> e, eP, eV : \<tau>"
using assms proof (induct \<Gamma>)
  case fmempty
  then show ?case by assumption
next
  case (fmupd x y \<Gamma>)
  then show ?case
    by (simp add: fresh_tyenv_None agree_weakening_2)
qed

(*<*)
end
(*>*)


theory Scratch
imports Main
"../thy_lib/FiniteGraph"
"$AFP/Graph_Theory/Pair_Digraph"
"$AFP/Collections/Refine_Dflt"
"$AFP/Collections/Examples/Autoref/Nested_DFS"
begin

(*BROKEN DEPENDENCIES*)

definition graph_to_afp_graph :: "'v graph \<Rightarrow> 'v pair_pre_digraph" where
  "graph_to_afp_graph G \<equiv> \<lparr> pverts = nodes G, parcs = edges G \<rparr>"

lemma "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> pair_wf_digraph (graph_to_afp_graph G)"
  apply(unfold_locales)
  by(auto simp add: valid_graph_def graph_to_afp_graph_def)

lemma "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> pair_fin_digraph (graph_to_afp_graph G)"
  apply(unfold_locales)
  by(auto simp add: valid_graph_def graph_to_afp_graph_def)

lemma "with_proj (graph_to_afp_graph G) =  \<lparr> verts = nodes G, arcs = edges G, tail = fst, head = snd \<rparr>"
  by(simp add: graph_to_afp_graph_def)

definition "has_directed_cycle" :: "'v graph \<Rightarrow> ('v \<times> 'v) awalk \<Rightarrow> bool" where
  "has_directed_cycle G p \<equiv> pre_digraph.cycle (with_proj (graph_to_afp_graph G)) p"

lemma fixes G::"'v graph" and Gafp::"('v, 'v \<times> 'v) pre_digraph"
  assumes transl: "Gafp = with_proj (graph_to_afp_graph G)"
  shows "has_directed_cycle G p = (\<exists>u. pre_digraph.awalk Gafp u p u \<and> distinct (tl (pre_digraph.awalk_verts Gafp u p)) \<and> p \<noteq> [])"
  by(simp add: has_directed_cycle_def pre_digraph.cycle_def transl)

(*hmm, for my purposes, this almost looks executable enough! \<dots>*)
definition pcycle :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> 'v \<Rightarrow> bool" where
  "pcycle V E v0 \<equiv> \<exists>v\<in>V. (v0,v)\<in>E\<^sup>* \<and> (v,v)\<in>E\<^sup>+"
(*for my purpose, it might be enough:
  \<forall> reachable v0 x. (x,x) \<notin> view^+ but this does not find undirected cycles! *)
(*is basic routing loop detection*)

hide_const(open) succ (*my succ in my graph*)

definition nodes_of :: "('v \<times> 'v) set \<Rightarrow> 'v set" where "nodes_of E \<equiv> (fst ` E \<union> snd ` E)"

(*Collections&Refinement tests*)

(*requires: no loops (x,x) \<in> E*)
(*V=worklist, (vertex, parent)*)
definition cycles_dfs_imp :: "('a \<times>'a) set \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "cycles_dfs_imp E v0 \<equiv>  do {
      (_,_,cycle) \<leftarrow> WHILE (\<lambda> (W,Discovered,cycle). W \<noteq> {} \<and> \<not> cycle) (\<lambda> (W,Discovered,cycle). do {
        (vparent,v) \<leftarrow> SPEC (\<lambda>v. v\<in>W);
        if v \<in> snd ` Discovered (* \<or> v \<in> fst ` Discovered evtl auch fst`?? test in python first!*)
        then
          RETURN (W,Discovered,True)
        else do {
          let succs = {v'. (v,v')\<in>E \<or> (v',v)\<in>E} - {vparent,v}; (*exclude self-loops*)
          let W = W - {(vparent,v)};
          let Discovered = insert (vparent,v) Discovered;
          let W = W \<union> ({v} \<times> succs);
          RETURN (W,Discovered,cycle)
        }
      }) ({(v0,v0 (*probably: succs v0????*))},{},False);
      RETURN cycle
  }"

lemma pcas_append: "pcas a p b \<Longrightarrow> pcas a (p @ [(b, c)]) c"
  by(induction a p b rule: pcas.induct, simp_all)

lemma pcas_iff_trancl: assumes "x \<noteq> y" shows "(\<exists> p. set p \<subseteq> D \<and> pcas x p y) \<longleftrightarrow> (x,y) \<in> D\<^sup>+"
proof
  assume "\<exists>p. set p \<subseteq> D \<and> pcas x p y"
  from this obtain p where pset: "set p \<subseteq> D" and pcas: "pcas x p y" by auto
  have "x \<noteq> y \<longrightarrow> set p \<subseteq> D \<longrightarrow> pcas x p y \<longrightarrow> (x, y) \<in> D\<^sup>+"
    apply(induction p arbitrary: x y)
    apply(simp)
    apply(clarify)
    apply(simp)
    using trancl_into_trancl2 by (metis r_into_trancl')
  from this assms pset pcas
  show "(x, y) \<in> D\<^sup>+" by simp
next
  show "(x,y) \<in> D\<^sup>+ \<Longrightarrow> (\<exists> p. set p \<subseteq> D \<and> pcas x p y)"
  apply(induction rule: trancl_induct)
  apply(rule_tac x="[(x,y)]" in exI)
  apply(simp)
  apply(erule exE)
  apply(rule_tac x="p@[(y,z)]" in exI)
  apply(simp add: pcas_append)
  done
qed

lemma pcas_start_in_pawalkvert: "pcas a p b \<Longrightarrow> a \<in> set (pawalk_verts a p)"
  by(induction p, simp_all)
lemma pcas_end_in_pawalkvert: "pcas a p b \<Longrightarrow> b \<in> set (pawalk_verts a p)"
  by(induction p arbitrary: a, simp_all)
lemma pcas_distinct_len: "pcas a p b \<Longrightarrow>  a \<noteq> b \<Longrightarrow> length p \<ge> 1"
  by(induction a p b rule:pcas.induct, simp_all)
lemma pawalk_verts_length: "length (pawalk_verts a p) = Suc (length p)"
  by(induction p arbitrary: a, simp_all)

value "dropWhile (\<lambda>x. x \<noteq> (1::nat)) [2,3,4,1,2,3]"

lemma "pcas x p y \<Longrightarrow> \<exists>p'. pcas x p' y \<and> set (pawalk_verts x p') \<subseteq> set (pawalk_verts x p) \<and> distinct (tl (pawalk_verts x p'))"
  apply(induction x p y rule: pcas.induct)
  apply(simp)
  apply(rule_tac x="[]" in exI)
  apply(simp)
  apply(simp)
  apply(erule_tac exE)
  apply(clarsimp)
  apply(case_tac "a = b")
  apply(rule_tac x="p'" in exI)
  apply(simp)
  using pcas_start_in_pawalkvert apply fast
  apply(case_tac "b \<notin> (set (pawalk_verts b p'))")
  apply(rule_tac x="(a,b)#p'" in exI)
  apply(simp)
  apply (metis pcas_start_in_pawalkvert)
  apply(rule_tac x="dropWhile (\<lambda>(x1,x2). x1 \<noteq> b) p'" in exI) (*TODO need to cut out circle ....*)
  apply(simp)
  nitpick
sorry (*TODOTODO*)

(*everything reachable from V'*)
lemma "{y. \<exists>x \<in> V'. (x,y) \<in> E\<^sup>*} = E\<^sup>*``V'" by blast

definition restrict_to :: "('v \<times> 'v) set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set" where
  "restrict_to E V \<equiv> {(a,b)\<in>E. a\<in>V \<and> b\<in>V}"

definition bi :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
  "bi E = E \<union> backflows E"

lemma bi_insert: "bi (insert (x,y) X) = {(x,y), (y,x)} \<union> bi X"
  by(auto simp add: bi_def backflows_def)
lemma bi_sym: "sym (bi X)"
  by(simp add: sym_def bi_def backflows_def)
lemma bi_union: "bi A \<union> bi B = bi (A \<union> B)"
  by(auto simp add: sym_def bi_def backflows_def)

definition uni_restrict_to :: "('v \<times> 'v) set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set" where
  "uni_restrict_to E V \<equiv> restrict_to (bi E) V"

lemma uni_restrict_to_mono: "D' \<subseteq> D \<Longrightarrow> uni_restrict_to E D' \<subseteq> uni_restrict_to E D"
  by(simp add: uni_restrict_to_def restrict_to_def, fast)

definition has_undirected_cycle_in :: "('a \<times> 'a) set \<Rightarrow> bool" where
  "has_undirected_cycle_in E \<equiv>
  \<exists> u \<in> nodes_of E. \<exists> p. set p \<subseteq> bi E \<and> pcas u p u \<and> distinct (tl (Pair_Digraph.pawalk_verts u p)) \<and> length p \<ge> 3"

definition cycles_dfs_imp_WHILE_invar :: "('v \<times> 'v) set \<Rightarrow> 'v \<Rightarrow> ('v\<times>'v) set \<times> ('v\<times>'v) set \<times> bool \<Rightarrow> bool" where
  "cycles_dfs_imp_WHILE_invar E v0 \<sigma> \<equiv> let (W,D,cycle) = \<sigma> in
        W \<subseteq> bi E \<and> D \<subseteq> bi E
        \<and> (\<forall> (a,_) \<in> W. \<exists> (_,d) \<in> D. (d,a) \<in> D)
        \<and> W \<inter> D = {}
        \<and> (\<forall> x\<in>snd`D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)
        \<and> (cycle \<longrightarrow> has_undirected_cycle_in (D \<union> W))
        (*\<and> (\<forall> x\<in>Discovered. \<forall> y\<in>Discovered. x \<noteq> y \<longrightarrow>
            (\<exists> p. set p \<subseteq> uni_restrict_to E (Discovered) \<and> pcas x p y \<and> distinct (Pair_Digraph.pawalk_verts x p)))*)
        (*E\<^sup>*``(fst ` V') \<union> fst ` Discovered = E\<^sup>*``{v0} \<and> *)"

lemma "(\<forall> x\<in>snd`(bi D). \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+) \<Longrightarrow> (\<forall> x\<in>fst`D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)"
  apply(clarsimp)
  apply(rename_tac a b x y)
  apply(erule_tac x="(b,a)" in ballE)
  apply(erule_tac x="(x,y)" in ballE)
  apply(simp_all)
  by(simp add: bi_def backflows_def)

lemma distinct_xyz_length: "distinct [x,y,z] \<Longrightarrow> x \<in> set X \<Longrightarrow> y \<in> set X \<Longrightarrow> z \<in> set X \<Longrightarrow> length X \<ge> 3"
by (smt distinct_length_2_or_more length_pos_if_in_set list.size(4) list_decomp_2 list_tail_coinc set_ConsD)

lemma assumes D_path: "(\<forall> x\<in>nodes_of D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)" (*replace snd with nodes_of*)
    and ad2W: "(a, d2) \<in> W" and d1d2D: "(d1, d2) \<in> D"
    and WD_edge: "(\<forall> (a,_) \<in> W. \<exists> (_,d) \<in> D. (d,a) \<in> D)"
    and nreflW: "\<forall> (x,y) \<in> W. x \<noteq> y"
    (*and nreflD: "\<forall> (x,y) \<in> D. x \<noteq> y"*)
    and disjunct: "bi W \<inter> bi D = {}"
   shows "has_undirected_cycle_in (D \<union> {(a,d2)})"
   proof(unfold has_undirected_cycle_in_def)
    from ad2W WD_edge have "\<exists> (x,y) \<in> D. (y, a) \<in> D" by fast
    from this obtain y where yD: "(y, a) \<in> D" by blast (*maybe add y to the path to prolong it?*)
    have "a \<noteq> d2" using ad2W nreflW by blast
    have "y \<noteq> a" sorry
    from `y \<noteq> a` `a \<noteq> d2` disjunct ad2W yD have "y \<noteq> d2" by(simp add: bi_def backflows_def, blast)
    (* d2 \<longrightarrow> y \<longrightarrow> (y,a) \<longrightarrow> a,d2 <-- in W*) (*need d2 \<noteq> y*)
    (*from yD have "set [(y,a)] \<subseteq> bi D \<and> pcas y [(y,a)] a" by (auto simp: bi_def)*)
    from yD d1d2D D_path have "y \<noteq> d2 \<longrightarrow> (y, d2) \<in> (bi D)\<^sup>+"
      by(simp add: nodes_of_def, force)
    from this `y \<noteq> d2` have "(d2, y) \<in> (bi D)\<^sup>+" using bi_sym by (metis symD sym_trancl)
    from this pcas_iff_trancl[symmetric] `y \<noteq> d2` have "\<exists>p. set p \<subseteq> (bi D) \<and> pcas d2 p y" by metis
    from this obtain p where p: "set p \<subseteq> (bi D) \<and> pcas d2 p y" and pdist: "distinct (pawalk_verts d2 p)" sorry
    from pcas_distinct_len p `y \<noteq> d2` have plength: "length p \<ge> 1" by metis
    let ?pa = "p@[(y,a)]"
    from p yD have pa: "set ?pa \<subseteq> (bi D) \<and> pcas d2 ?pa a" by(simp add: bi_def pcas_append)
    have "pcas d2 p y \<Longrightarrow> pawalk_verts d2 (p @ [(y, a)]) = (pawalk_verts d2 p)@[a]"
      by(induction p arbitrary: d2, simp_all)
    from this p have pawalk_verts_simp: "pawalk_verts d2 (p @ [(y, a)]) = (pawalk_verts d2 p)@[a]" by simp
    have a_in_path_length: "a \<in> set (pawalk_verts d2 p) \<Longrightarrow> length p \<ge> 2"
    proof -
      assume 0: "a \<in> set (pawalk_verts d2 p)"
      from `y \<noteq> a` `a \<noteq> d2` `y \<noteq> d2` have 1: "distinct [d2, y, a]" by auto
      from p have 2: "d2 \<in> set (pawalk_verts d2 p)" by (metis pcas_start_in_pawalkvert)
      from p have 3: "y \<in> set (pawalk_verts d2 p)" using pcas_end_in_pawalkvert by metis
      from distinct_xyz_length 0 1 2 3 have "length (pawalk_verts d2 p) \<ge> 3" by fast
      from this pawalk_verts_length show "length p \<ge> 2" by (metis le_numeral_Suc pred_numeral_simps(3))
    qed
    from pdist have padist: "a \<notin> set (pawalk_verts d2 p) \<Longrightarrow> distinct (pawalk_verts d2 ?pa)"
      by(simp add: pawalk_verts_simp)
    (*if a in pa: let ?pa = p*)
    from plength have palength: "length ?pa \<ge> 2" by simp
    from ad2W have ad2biW: "(d2,a) \<in> bi W" by(simp add: bi_def backflows_def)
    hence "set [(a, d2)] \<subseteq> bi {(a,d2)} \<and> pcas a [(a, d2)] d2" by (simp add: bi_def)
    from this pa have 1: "set ((a, d2)#?pa) \<subseteq> bi {(a,d2)} \<union> bi D \<and> pcas a ((a, d2)#?pa) a" by auto
    from padist have 2: "distinct (tl (pawalk_verts a ((a, d2)#?pa)))" by simp

   show "\<exists>u\<in>nodes_of (D \<union> {(a, d2)}). \<exists>p. set p \<subseteq> bi (D \<union> {(a, d2)}) \<and> pcas u p u \<and> distinct (tl (pawalk_verts u p)) \<and> 3 \<le> length p"
    apply(case_tac "a \<notin> set (pawalk_verts d2 p)")
    apply(rule_tac x=a in bexI)
    apply(rule_tac x="(a, d2)#?pa" in exI)
    apply(rule conjI)
    using bi_union 1 apply blast
    apply(rule conjI)
    using 1 apply blast
    apply(rule conjI)
    using padist apply simp
    apply(simp add: plength[simplified])
    apply(simp add: nodes_of_def)
oops

lemma cycles_dfs_imp_WHILE_invar_step1:
  assumes "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, cycle)"
       "(a, snd (d1, d2)) \<in> W" "(d1, d2) \<in> Discovered" "W \<noteq> {}" "\<not> cycle"
  shows "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, True)"
  using assms unfolding cycles_dfs_imp_WHILE_invar_def
  apply(simp)
  (*a is snd`discovered \<longrightarrow> (d2,a) \<in> D^+ \<longrightarrow> need W disjunct D \<longrightarrow> path: d2,a + (a,d2)*)
  (*TODO*)
  apply(simp add: has_undirected_cycle_in_def)
  proof -
  show "\<exists>u\<in>nodes_of (Discovered \<union> W). \<exists>p. set p \<subseteq> bi (Discovered \<union> W) \<and> pcas u p u \<and> distinct (tl (pawalk_verts u p)) \<and> 3 \<le> length p"
oops

lemma nodes_of_backflows_snd: "nodes_of E = snd ` E \<union> snd ` (backflows E)"
    apply(simp add: nodes_of_def backflows_alt_fstsnd) by force
lemma nodes_of_subset_backflows_b: "v0 \<in> nodes_of E \<Longrightarrow> V \<subseteq> insert (v0,v0) (E \<union> backflows E) \<Longrightarrow> (a, b) \<in> V \<Longrightarrow> b \<in> nodes_of E"
    apply(simp add: nodes_of_backflows_snd) by force

lemma "y \<in> snd ` (V - {(a, b)} \<union> {b} \<times> ({v'. (b, v') \<in> E \<or> (v', b) \<in> E} - {a, b})) \<Longrightarrow>
         b \<noteq> y \<Longrightarrow>  y \<notin> snd ` V \<Longrightarrow> False" oops

lemma cycles_dfs_imp_WHILE_invar_step2:
  assumes "v0 \<in> nodes_of E" and "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, False)"
       "(w1, w2) \<in> W"
       "w2 \<notin> snd ` Discovered"
       "W \<noteq> {}"
       "\<not> cycle"
  shows "cycles_dfs_imp_WHILE_invar E v0 (W - {(w1, w2)} \<union> {w2} \<times> ({v'. (w2, v') \<in> E \<or> (v', w2) \<in> E} - {w1, w2}), insert (w1, w2) Discovered, False)"
  using assms unfolding cycles_dfs_imp_WHILE_invar_def
  apply(simp)
  apply(rule conjI)
  apply(auto)[1]
  apply(rule conjI)
  apply(auto simp add: bi_def backflows_def)[1]
  apply(rule conjI)
  apply(auto simp add: bi_def backflows_def)[1]
  apply(rule conjI)
  apply blast
  apply(rule conjI)
  nitpick (*dis*)
  apply(simp add: bi_insert)[1]
  apply(clarsimp)
  apply(erule_tac x="(w1,w2)" in ballE, simp)
  prefer 2 apply simp
  apply(erule bexE)
  apply(clarify)
  (*holds but needs proof ...*)
    using nodes_of_subset_backflows_b
oops

lemma cycles_dfs_imp_sound:
  fixes succ and v0
  assumes F: "finite E"
  shows "cycles_dfs_imp E v0 \<le> SPEC (\<lambda>r. r \<longleftrightarrow> has_undirected_cycle_in (uni_restrict_to E (E\<^sup>*``{v0})))"
proof -

  from F show ?thesis
    unfolding cycles_dfs_imp_def
    apply(intro WHILE_rule[where I="cycles_dfs_imp_WHILE_invar E v0"] refine_vcg)
    apply(auto simp add: cycles_dfs_imp_WHILE_invar_def restrict_to_def has_undirected_cycle_in_def nodes_of_def)[1]
    apply(clarify, rename_tac A W C V Discovered cycle I J a L d1 d2)
    apply(simp add: cycles_dfs_imp_WHILE_invar_step1)
    apply(clarsimp)
    apply(rename_tac W Discovered cycle w1 w2)
    apply(auto simp add: cycles_dfs_imp_WHILE_invar_def)[1]
    apply(simp add: cycles_dfs_imp_WHILE_invar_def)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply clarify
    using v0 try0
    oops

(*no idea what's wrong here*)
definition cycles_dfs_recX :: "('a \<Rightarrow>'a set) \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "cycles_dfs_recX succ v0 \<equiv> REC (\<lambda>D (V,v).
    if v \<in> V then RETURN True
    else do {
      let V=insert v V;
      FOREACH (succ v) (\<lambda>v' _. D (V,v')) False }
  ) ({},v0)"
lemma cycles_dfs_rec_sound:
  fixes succ and v0
  defines "E \<equiv> {(v,v'). v'\<in>succ v}"
  defines "V \<equiv> {v. (v0,v)\<in>E\<^sup>*}"
  assumes F: "finite V"
  shows "cycles_dfs_recX succ v0 \<le> SPEC (\<lambda>r. r \<longrightarrow> (\<forall>x\<in>V. (v0,x)\<in>E\<^sup>* \<longrightarrow> (x,x)\<notin>E\<^sup>+))"
proof -
  have S: "\<And>v. succ v = E``{v}"
    by (auto simp: E_def)

  from F show ?thesis
    unfolding cycles_dfs_recX_def S
    apply(intro REC_rule[where \<Phi>="\<lambda>(V',v'). (v0,v')\<in>E\<^sup>* \<and> V'\<subseteq>V \<and> (\<forall>x\<in>V'. (v0,x)\<in>E\<^sup>* \<longrightarrow> (x,x)\<notin>E\<^sup>+)"]
        FOREACH_rule[where I="\<lambda>Succs r. XXX"] refine_vcg) (*r \<longrightarrow> (\<forall>v\<in>V. (v0,v)\<in>E\<^sup>* \<longrightarrow> (v,v)\<notin>E\<^sup>+)*)
    apply(refine_mono) (*REC is somehow undocumented*)
    apply(simp)
    apply(simp_all)
    apply(rename_tac V' v')
    oops

fun fibdef :: "nat \<Rightarrow> nat" where
  "fibdef 0 = 1" |
  "fibdef (Suc 0) = 1" |
  "fibdef (Suc (Suc n)) = fibdef (Suc n) + fibdef n"
value "fibdef 4"

definition fibref :: "nat \<Rightarrow> nat nres"
  where
  "fibref n \<equiv> REC (\<lambda>D (n).
    if n = 0 then RETURN 1
    else if n = 1 then RETURN 1
    else do {
      x \<leftarrow> (D (n - 1));
      y \<leftarrow> (D (n - 2));
      RETURN (x + y)
      }
    ) (n)"

lemma fibref:
  shows "fibref n \<le> SPEC (\<lambda>r. r = fibdef n)"
proof -
  show ?thesis
    unfolding fibref_def
    apply (refine_rcg refine_vcg REC_rule[where \<Phi>="\<lambda>n. n \<ge> 0"])
    apply(simp_all)[3]
    apply(simp add: RETURN_def)
    apply(auto)
    oops

section{*TEST TEST TES TEST of UNIO*}
  lemma "UNION {1::nat,2,3} (\<lambda>n. {n+1}) = {2,3,4}" by eval
  lemma "(\<Union>n\<in>{1::nat, 2, 3}. {n + 1}) = {2, 3, 4}" by eval
  lemma "UNION {1::nat,2,3} (\<lambda>n. {n+1}) = set (map (\<lambda>n. n+1) [1,2,3])" by eval

(*
  locale X =
    fixes N1 N2
    assumes well_n1: "wellformed_network N1"
    assumes well_n2: "wellformed_network N2"
  begin
  end

  sublocale X \<subseteq> n1!: wellformed_network N1
    by (rule well_n1)
  sublocale X \<subseteq> n2!: wellformed_network N2
    by (rule well_n2)

    context X
    begin

    end
*)

end