(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory StringMap

(* assumes CParser or AutoCorres to find StaticFun *)
imports StaticFun

begin

datatype LexOrdString = LexOrdString "string"

instantiation LexOrdString :: linorder begin

definition
  less_LexOrdString_def[simp]:
  "(s < t) = (case s of LexOrdString s' \<Rightarrow> case t of LexOrdString t' \<Rightarrow>
    (s', t') \<in> lexord {(c, c'). nat_of_char c < nat_of_char c'})"

definition
  le_LexOrdString_def[simp]:
  "(s \<le> t) = ((s :: LexOrdString) < t \<or> s = t)"

lemma nat_of_char_trans:
  "transP (\<lambda>c c'. nat_of_char c < nat_of_char c')"
  by (auto intro!: transI)

instance
  apply intro_classes
      apply (clarsimp split: LexOrdString.split)
      apply safe[1]
       apply (drule(1) lexord_trans[OF _ _ nat_of_char_trans])
       apply (simp add: lexord_irreflexive)
      apply (simp add: lexord_irreflexive)
     apply (clarsimp)
    apply (clarsimp split: LexOrdString.split_asm)
    apply safe[1]
    apply (erule(1) lexord_trans)
    apply (rule nat_of_char_trans)
   apply (clarsimp split: LexOrdString.split_asm)
   apply safe[1]
   apply (drule(1) lexord_trans[OF _ _ nat_of_char_trans])
   apply (simp add: lexord_irreflexive)
  apply (clarsimp split: LexOrdString.split)
  apply (cut_tac x=list and y=lista in lexord_linear)
   defer
   apply blast
  apply (auto simp: nat_of_char_eq_iff)
  done

end

ML {*

structure StringMap = struct

fun define_string_map name assocs ctxt = let
    val th_names = map (prefix (Binding.name_of name ^ "_") o fst) assocs
    val mappings = map (apfst HOLogic.mk_string) assocs
  in StaticFun.define_tree_and_save_thms name th_names mappings
    @{term LexOrdString} @{thms nat_of_char_def} ctxt end

end

*}

text {* Testing *}

(*
local_setup {* StringMap.define_string_map @{binding foo}
  [("x", @{term "1 :: nat"}), ("y", @{term "2 :: nat"})]
  #> snd
*}
*)

end


theory Incredible_Completeness
imports Natural_Deduction Incredible_Deduction Build_Incredible_Tree
begin

text \<open>
This theory takes the tree produced in @{theory Incredible_Proof_Machine.Build_Incredible_Tree}, globalizes it using
@{term globalize}, and then builds the incredible proof graph out of it.
\<close>

type_synonym 'form vertex = "('form \<times> nat list)"
type_synonym ('form, 'var) edge'' = "('form vertex, 'form, 'var) edge'"

locale Solved_Task =
  Abstract_Task  freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP antecedent consequent rules assumptions conclusions
   for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form"
    and antecedent :: "'rule \<Rightarrow> ('form, 'var) antecedent list"
    and consequent :: "'rule \<Rightarrow> 'form list"
    and rules :: "'rule stream"
    and assumptions :: "'form list"
    and conclusions :: "'form list" +
  assumes solved: solved
begin

text \<open>Let us get our hand on concrete trees.\<close>

definition ts :: "'form \<Rightarrow> (('form entailment) \<times> ('rule \<times> 'form) NatRule) tree" where
  "ts c = (SOME t. snd (fst (root t)) = c \<and> fst (fst (root t)) |\<subseteq>| ass_forms \<and> wf t \<and> tfinite t)"

lemma
  assumes "c |\<in>| conc_forms"
  shows ts_conc: "snd (fst (root (ts c))) = c"
  and   ts_context: "fst (fst (root (ts c))) |\<subseteq>| ass_forms"
  and   ts_wf: "wf (ts c)"
  and   ts_finite[simp]: "tfinite (ts c)"
  unfolding atomize_conj conj_assoc ts_def
  apply (rule someI_ex)
  using solved assms
  by (force simp add: solved_def)

abbreviation it' where
  "it' c \<equiv> globalize [fidx conc_forms c, 0] (freshenLC v_away) (to_it (ts c))"

definition vertices :: "'form vertex fset"  where
  "vertices = Abs_fset (Union ( set (map (\<lambda> c. insert (c, []) ((\<lambda> p. (c, 0 # p)) ` (it_paths (it' c))))  conclusions)))"

lemma mem_vertices: "v |\<in>| vertices \<longleftrightarrow>  (fst v \<in> set conclusions \<and> (snd v = [] \<or> snd v \<in> ((#) 0) ` it_paths (it' (fst v))))"
  unfolding vertices_def fmember.rep_eq ffUnion.rep_eq
  by (cases v)(auto simp add: Abs_fset_inverse Bex_def )

lemma prefixeq_vertices: "(c,is) |\<in>| vertices \<Longrightarrow> prefix is' is \<Longrightarrow> (c, is') |\<in>| vertices"
  by (cases is') (auto simp add: mem_vertices intro!: imageI elim: it_paths_prefix)

lemma none_vertices[simp]: "(c, []) |\<in>| vertices \<longleftrightarrow> c \<in> set conclusions"
  by (simp add: mem_vertices)

lemma some_vertices[simp]: "(c, i#is) |\<in>| vertices \<longleftrightarrow> c \<in> set conclusions \<and> i = 0 \<and> is \<in> it_paths (it' c)"
  by (auto simp add: mem_vertices)

lemma vertices_cases[consumes 1, case_names None Some]:
  assumes "v |\<in>| vertices"
  obtains c where "c \<in> set conclusions" and "v = (c, [])"
      |   c "is" where "c \<in> set conclusions" and "is \<in> it_paths (it' c)" and "v = (c, 0#is)"
using assms by (cases v; rename_tac "is"; case_tac "is"; auto)

lemma vertices_induct[consumes 1, case_names None Some]:
  assumes "v |\<in>| vertices"
  assumes "\<And> c. c \<in> set conclusions \<Longrightarrow> P (c, [])"
  assumes "\<And> c is . c \<in> set conclusions \<Longrightarrow> is \<in> it_paths (it' c) \<Longrightarrow> P (c, 0#is)"
  shows "P v"
using assms by (cases v; rename_tac "is"; case_tac "is"; auto)

fun nodeOf :: "'form vertex \<Rightarrow> ('form, 'rule) graph_node" where
  "nodeOf (pf, []) = Conclusion pf"
| "nodeOf (pf, i#is) = iNodeOf (tree_at (it' pf) is)"

fun inst where
  "inst (c,[]) = empty_subst"
 |"inst (c, i#is) = iSubst (tree_at (it' c) is)"

lemma terminal_is_nil[simp]: "v |\<in>| vertices \<Longrightarrow> outPorts (nodeOf v) = {||} \<longleftrightarrow> snd v = []"
 by (induction v rule: nodeOf.induct)
    (auto elim: iNodeOf_outPorts[rotated] iwf_it)

sublocale Vertex_Graph nodes inPorts outPorts vertices nodeOf.

definition edge_from :: "'form \<Rightarrow> nat list => ('form vertex \<times> ('form,'var) out_port)" where
  "edge_from c is = ((c, 0 # is),  Reg (iOutPort (tree_at (it' c) is)))"

lemma fst_edge_from[simp]: "fst (edge_from c is) = (c, 0 # is)"
  by (simp add: edge_from_def)

fun in_port_at :: "('form \<times> nat list) \<Rightarrow> nat \<Rightarrow> ('form,'var) in_port" where
    "in_port_at (c, [])  _  = plain_ant c"
  | "in_port_at (c, _#is) i = inPorts' (iNodeOf (tree_at (it' c) is)) ! i"

definition edge_to :: "'form \<Rightarrow> nat list => ('form vertex \<times> ('form,'var) in_port)"  where
 "edge_to c is =
    (case rev is of   []   \<Rightarrow> ((c, []),           in_port_at (c, []) 0)
                    | i#is \<Rightarrow> ((c, 0 # (rev is)), in_port_at (c, (0#rev is)) i))"

lemma edge_to_Nil[simp]: "edge_to c [] = ((c, []), plain_ant c)"
  by (simp add: edge_to_def)

lemma edge_to_Snoc[simp]: "edge_to c (is@[i]) = ((c, 0 # is), in_port_at ((c, 0 # is)) i)"
  by (simp add: edge_to_def)

definition edge_at :: "'form \<Rightarrow> nat list => ('form, 'var) edge''"  where
   "edge_at c is = (edge_from c is, edge_to c is)"

lemma fst_edge_at[simp]: "fst (edge_at c is) = edge_from c is" by (simp add: edge_at_def)
lemma snd_edge_at[simp]: "snd (edge_at c is) = edge_to c is" by (simp add: edge_at_def)

lemma hyps_exist':
  assumes "c \<in> set conclusions"
  assumes "is \<in> it_paths (it' c)"
  assumes "tree_at (it' c) is = (HNode i s ants)"
  shows "subst s (freshen i anyP) \<in> hyps_along (it' c) is"
proof-
  from assms(1)
  have "plain_iwf (it' c) (fst (root (ts c)))" by (rule iwf_it)
  moreover
  note assms(2,3)
  moreover
  have "fst (fst (root (ts c))) |\<subseteq>| ass_forms"
    by (simp add: assms(1) ts_context)
  ultimately
  show ?thesis by (rule iwf_hyps_exist)
qed

definition hyp_edge_to :: "'form \<Rightarrow> nat list => ('form vertex \<times> ('form,'var) in_port)" where
  "hyp_edge_to c is = ((c, 0 # is),  plain_ant anyP)"

(* TODO: Replace n and s by "subst s (freshen n anyP)" *)
definition hyp_edge_from :: "'form \<Rightarrow> nat list => nat \<Rightarrow> 'subst \<Rightarrow> ('form vertex \<times> ('form,'var) out_port)" where
  "hyp_edge_from c is n s =
    ((c, 0 # hyp_port_path_for (it' c) is (subst s (freshen n anyP))),
     hyp_port_h_for (it' c) is (subst s (freshen n anyP)))"

definition hyp_edge_at  :: "'form \<Rightarrow> nat list => nat \<Rightarrow> 'subst \<Rightarrow> ('form, 'var) edge''" where
  "hyp_edge_at c is n s = (hyp_edge_from c is n s, hyp_edge_to c is)"

lemma fst_hyp_edge_at[simp]:
  "fst (hyp_edge_at c is n s) = hyp_edge_from c is n s" by (simp add:hyp_edge_at_def)
lemma snd_hyp_edge_at[simp]:
  "snd (hyp_edge_at c is n s) = hyp_edge_to c is" by (simp add:hyp_edge_at_def)

inductive_set edges where
  regular_edge: "c \<in> set conclusions \<Longrightarrow> is \<in> it_paths (it' c) \<Longrightarrow> edge_at c is \<in> edges"
  | hyp_edge: "c \<in> set conclusions \<Longrightarrow> is \<in> it_paths (it' c) \<Longrightarrow> tree_at (it' c) is = HNode n s ants \<Longrightarrow> hyp_edge_at c is n s \<in> edges"

sublocale Pre_Port_Graph nodes inPorts outPorts vertices nodeOf edges.

lemma edge_from_valid_out_port:
  assumes "p \<in> it_paths (it' c)"
  assumes "c \<in> set conclusions"
  shows "valid_out_port (edge_from c p)"
using assms
by (auto simp add: edge_from_def intro: iwf_outPort iwf_it)

lemma edge_to_valid_in_port:
  assumes "p \<in> it_paths (it' c)"
  assumes "c \<in> set conclusions"
  shows "valid_in_port (edge_to c p)"
  using assms
  apply (auto simp add: edge_to_def inPorts_fset_of split: list.split elim!: it_paths_SnocE)
  apply (rule nth_mem)
  apply (drule (1) iwf_length_inPorts[OF iwf_it])
  apply auto
  done

lemma hyp_edge_from_valid_out_port:
  assumes "is \<in> it_paths (it' c)"
  assumes "c \<in> set conclusions"
  assumes "tree_at (it' c) is = HNode n s ants"
  shows "valid_out_port (hyp_edge_from c is n s)"
using assms
by(auto simp add: hyp_edge_from_def intro: hyp_port_outPort it_paths_strict_prefix hyp_port_strict_prefix hyps_exist')

lemma hyp_edge_to_valid_in_port:
  assumes "is \<in> it_paths (it' c)"
  assumes "c \<in> set conclusions"
  assumes "tree_at (it' c) is = HNode n s ants"
  shows "valid_in_port (hyp_edge_to c is)"
using assms by (auto simp add: hyp_edge_to_def)

inductive scope' :: "'form vertex \<Rightarrow> ('form,'var) in_port \<Rightarrow> 'form \<times> nat list \<Rightarrow> bool" where
  "c \<in> set conclusions \<Longrightarrow>
   is' \<in> ((#) 0) ` it_paths (it' c) \<Longrightarrow>
   prefix (is@[i]) is' \<Longrightarrow>
   ip = in_port_at (c,is) i \<Longrightarrow>
   scope' (c, is) ip (c, is')"

inductive_simps scope_simp: "scope' v i v'"
inductive_cases scope_cases: "scope' v i v'"

lemma scope_valid:
  "scope' v i v' \<Longrightarrow> v' |\<in>| vertices"
by (auto elim: scope_cases)

lemma scope_valid_inport:
  "v' |\<in>| vertices \<Longrightarrow> scope' v ip  v' \<longleftrightarrow> (\<exists> i. fst v = fst v' \<and> prefix (snd v@[i]) (snd v') \<and> ip = in_port_at v i)"
by (cases v; cases v')  (auto simp add: scope'.simps mem_vertices)

definition terminal_path_from :: "'form \<Rightarrow> nat list => ('form, 'var) edge'' list" where
   "terminal_path_from c is = map (edge_at c) (rev (prefixes is))"

lemma terminal_path_from_Nil[simp]:
  "terminal_path_from c [] = [edge_at c []]"
  by (simp add: terminal_path_from_def)

lemma terminal_path_from_Snoc[simp]:
  "terminal_path_from c (is @ [i]) = edge_at  c (is@[i]) # terminal_path_from c is"
  by (simp add: terminal_path_from_def)

lemma path_terminal_path_from:
  "c \<in> set conclusions \<Longrightarrow>
  is \<in> it_paths (it' c) \<Longrightarrow>
  path (c, 0 # is) (c, []) (terminal_path_from c is)"
by (induction "is" rule: rev_induct)
   (auto simp add: path_cons_simp intro!: regular_edge elim: it_paths_SnocE)

lemma edge_step:
  assumes "(((a, b), ba), ((aa, bb), bc)) \<in> edges"
  obtains
    i where "a = aa" and "b = bb@[i]" and "bc = in_port_at (aa,bb) i"  and "hyps (nodeOf (a, b)) ba = None"
  | i where "a = aa" and "prefix (b@[i]) bb" and "hyps (nodeOf (a, b)) ba = Some (in_port_at (a,b) i)"
using assms
proof(cases rule: edges.cases[consumes 1, case_names Reg Hyp])
  case (Reg c "is")
  then obtain i where  "a = aa" and "b = bb@[i]" and "bc = in_port_at (aa,bb) i"  and "hyps (nodeOf (a, b)) ba = None"
    by (auto elim!: edges.cases simp add: edge_at_def edge_from_def edge_to_def split: list.split list.split_asm)
  thus thesis by (rule that)
next
  case (Hyp c "is" n s)
  let ?i = "hyp_port_i_for (it' c) is (subst s (freshen n anyP))"
  from Hyp have "a = aa" and "prefix (b@[?i]) bb" and
    "hyps (nodeOf (a, b)) ba = Some (in_port_at (a,b) ?i)"
  by (auto simp add: edge_at_def edge_from_def edge_to_def hyp_edge_at_def hyp_edge_to_def hyp_edge_from_def
      intro: hyp_port_prefix hyps_exist' hyp_port_hyps)
  thus thesis by (rule that)
qed

lemma path_has_prefixes:
  assumes "path v v' pth"
  assumes "snd v' = []"
  assumes "prefix (is' @ [i]) (snd v)"
  shows "((fst v, is'), (in_port_at (fst v, is') i)) \<in> snd ` set pth"
  using assms
  by (induction rule: path.induct)(auto elim!: edge_step dest: prefix_snocD)

lemma in_scope: "valid_in_port (v', p') \<Longrightarrow> v \<in> scope (v', p') \<longleftrightarrow> scope' v' p' v"
proof
  assume "v \<in> scope (v', p')"
  hence "v |\<in>| vertices" and "\<And> pth t.  path v t pth \<Longrightarrow> terminal_vertex t \<Longrightarrow> (v', p') \<in> snd ` set pth"
    by (auto simp add: scope.simps)
  from this
  show "scope' v' p' v"
  proof (induction  rule: vertices_induct)
    case (None c)
    from None(2)[of "(c, [])" "[]", simplified, OF None(1)]
    have False.
    thus "scope' v' p' (c, [])"..
  next
    case (Some c "is")

    from \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close>
    have "path (c, 0#is) (c, []) (terminal_path_from c is)"
      by (rule path_terminal_path_from)
    moreover
    from \<open>c \<in> set conclusions\<close>
    have "terminal_vertex (c, [])" by simp
    ultimately
    have "(v', p') \<in> snd ` set (terminal_path_from c is)"
      by (rule Some(3))
    hence "(v',p') \<in> set (map (edge_to c) (prefixes is))"
      unfolding terminal_path_from_def by auto
    then obtain is' where "prefix is' is" and "(v',p') = edge_to c is'"
      by auto
    show "scope' v' p' (c, 0#is)"
    proof(cases "is'" rule: rev_cases)
      case Nil
      with \<open>(v',p') = edge_to c is'\<close>
      have "v' = (c, [])" and "p' = plain_ant c"
        by (auto simp add: edge_to_def)
      with \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close>
      show ?thesis  by (auto intro!: scope'.intros)
    next
      case (snoc is'' i)
      with \<open>(v',p') = edge_to c is'\<close>
      have "v' = (c, 0 # is'')" and "p' = in_port_at v' i"
        by (auto simp add: edge_to_def)
      with \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close> \<open>prefix is' is\<close>[unfolded snoc]
      show ?thesis
        by (auto intro!: scope'.intros)
    qed
  qed
next
  assume "valid_in_port (v', p')"
  assume "scope' v' p' v"
  then obtain c is' i "is" where
    "v' = (c, is')" and "v = (c, is)" and "c \<in> set conclusions" and
    "p' = in_port_at v' i" and
    "is \<in> (#) 0 ` it_paths (it' c)" and  "prefix (is' @ [i]) is"
    by (auto simp add: scope'.simps)

  from \<open>scope' v' p' v\<close>
  have "(c, is) |\<in>| vertices" unfolding \<open>v = _\<close> by (rule scope_valid)
  hence "(c, is) \<in> scope ((c, is'), p')"
  proof(rule scope.intros)
    fix pth t
    assume "path (c,is) t pth"

    assume "terminal_vertex t"
    hence "snd t = []" by auto

    from path_has_prefixes[OF \<open>path (c,is) t pth\<close> \<open>snd t = []\<close>, simplified, OF \<open>prefix (is' @ [i]) is\<close>]
    show "((c, is'), p') \<in> snd ` set pth" unfolding \<open>p' = _ \<close> \<open>v' = _ \<close>.
  qed
  thus "v \<in> scope (v', p')" using \<open>v =_\<close> \<open>v' = _\<close> by simp
qed

sublocale Port_Graph nodes inPorts outPorts vertices nodeOf edges
proof
  show "nodeOf ` fset vertices \<subseteq> sset nodes"
    apply (auto simp add: fmember.rep_eq[symmetric] mem_vertices)
    apply (auto simp add: stream.set_map dest: iNodeOf_tree_at[OF iwf_it])
    done
  next

  have "\<forall> e \<in> edges. valid_out_port (fst e) \<and> valid_in_port (snd e)"
    by (auto elim!: edges.cases simp add: edge_at_def
        dest: edge_from_valid_out_port edge_to_valid_in_port
        dest: hyp_edge_from_valid_out_port hyp_edge_to_valid_in_port)

  thus "\<forall>(ps1, ps2)\<in>edges. valid_out_port ps1 \<and> valid_in_port ps2" by auto
qed

sublocale Scoped_Graph nodes inPorts outPorts vertices nodeOf edges hyps..

lemma hyps_free_path_length:
  assumes "path v v' pth"
  assumes "hyps_free pth"
  shows "length pth + length (snd v') = length (snd v)"
using assms by induction (auto elim!: edge_step )

fun vidx :: "'form vertex \<Rightarrow> nat" where
   "vidx (c, [])   = isidx [fidx conc_forms c]"
  |"vidx (c, _#is) = iAnnot (tree_at (it' c) is)"

lemma my_vidx_inj: "inj_on vidx (fset vertices)"
  by (rule inj_onI)
     (auto simp add:  mem_vertices[unfolded fmember.rep_eq] iAnnot_globalize simp del: iAnnot.simps)

lemma vidx_not_v_away[simp]: "v |\<in>| vertices \<Longrightarrow> vidx v \<noteq> v_away"
  by (cases v rule:vidx.cases) (auto simp add: iAnnot_globalize  simp del: iAnnot.simps)

sublocale Instantiation inPorts outPorts nodeOf hyps  nodes edges vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst
proof
  show "inj_on vidx (fset vertices)" by (rule my_vidx_inj)
qed

sublocale  Well_Scoped_Graph nodes inPorts outPorts vertices nodeOf edges hyps
proof
  fix v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2 p'
  assume assms: "((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) \<in> edges" "hyps (nodeOf v\<^sub>1) p\<^sub>1 = Some p'"
  from assms(1) hyps_correct[OF assms(2)]
  have "valid_out_port (v\<^sub>1, p\<^sub>1)" and "valid_in_port (v\<^sub>2, p\<^sub>2)" and "valid_in_port (v\<^sub>1, p')" and "v\<^sub>2 |\<in>| vertices"
    using valid_edges by auto

  from assms
  have "\<exists> i. fst v\<^sub>1 = fst v\<^sub>2 \<and> prefix (snd v\<^sub>1@[i]) (snd v\<^sub>2) \<and> p' = in_port_at v\<^sub>1 i"
    by (cases v\<^sub>1; cases v\<^sub>2; auto elim!: edge_step)
  hence "scope' v\<^sub>1 p' v\<^sub>2"
    unfolding scope_valid_inport[OF \<open>v\<^sub>2 |\<in>| vertices\<close>].
  hence "v\<^sub>2 \<in> scope (v\<^sub>1, p')"
    unfolding in_scope[OF \<open>valid_in_port (v\<^sub>1, p')\<close>].
  thus "(v\<^sub>2, p\<^sub>2) = (v\<^sub>1, p') \<or> v\<^sub>2 \<in> scope (v\<^sub>1, p')" ..
qed

sublocale Acyclic_Graph nodes inPorts outPorts vertices nodeOf edges hyps
proof
  fix v pth
  assume "path v v pth" and "hyps_free pth"
  from hyps_free_path_length[OF this]
  show "pth = []" by simp
qed

sublocale Saturated_Graph nodes inPorts outPorts vertices nodeOf edges
proof
  fix v p
  assume "valid_in_port (v, p)"
  thus "\<exists>e\<in>edges. snd e = (v, p)"
  proof(induction v)
    fix c cis
    assume "valid_in_port ((c, cis), p)"
    hence "c \<in> set conclusions" by (auto simp add: mem_vertices)

    show "\<exists>e\<in>edges. snd e = ((c, cis), p)"
    proof(cases cis)
      case Nil
      with \<open>valid_in_port ((c, cis), p)\<close>
      have [simp]: "p = plain_ant c" by simp

      have "[] \<in> it_paths (it' c)" by simp
      with \<open>c \<in> set conclusions\<close>
      have "edge_at c [] \<in> edges" by (rule regular_edge)
      moreover
      have "snd (edge_at c []) = ((c, []), plain_ant c)"
        by (simp add: edge_to_def)
      ultimately
      show ?thesis by (auto simp add: Nil simp del: snd_edge_at)
    next
      case (Cons c' "is")
      with \<open>valid_in_port ((c, cis), p)\<close>
      have [simp]: "c' = 0" and "is \<in> it_paths (it' c)"
        and "p |\<in>| inPorts (iNodeOf (tree_at (it' c) is))" by auto

      from this(3) obtain i where
        "i < length (inPorts' (iNodeOf (tree_at (it' c) is)))" and
        "p = inPorts' (iNodeOf (tree_at (it' c) is)) ! i"
          by (auto simp add: inPorts_fset_of in_set_conv_nth)

      show ?thesis
      proof (cases "tree_at (it' c) is")
        case [simp]: (RNode r ants)
        show ?thesis
        proof(cases r)
          case I
          hence "\<not> isHNode (tree_at (it' c) is)" by simp
          from iwf_length_inPorts_not_HNode[OF iwf_it[OF \<open>c \<in> set conclusions\<close>]  \<open>is \<in> it_paths (it' c)\<close> this]
               \<open>i < length (inPorts' (iNodeOf (tree_at (it' c) is)))\<close>
          have "i < length (children (tree_at (it' c) is))" by simp
          with \<open>is \<in> it_paths (it' c)\<close>
          have "is@[i] \<in> it_paths (it' c)" by (rule it_path_SnocI)
          from \<open>c \<in> set conclusions\<close> this
          have "edge_at c (is@[i]) \<in> edges" by (rule regular_edge)
          moreover
          have "snd (edge_at c (is@[i])) = ((c, 0 # is),  inPorts' (iNodeOf (tree_at (it' c) is)) ! i)"
            by (simp add: edge_to_def)
          ultimately
          show ?thesis by (auto simp add: Cons \<open>p = _\<close> simp del: snd_edge_at)
        next
          case (H n s)
          hence "tree_at (it' c) is = HNode n s ants" by simp
          from \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close>  this
          have "hyp_edge_at c is n s \<in> edges"..
          moreover
          from H \<open>p |\<in>| inPorts (iNodeOf (tree_at (it' c) is))\<close>
          have [simp]: "p = plain_ant anyP" by simp

          have "snd (hyp_edge_at c is n s) = ((c, 0 # is), p)"
            by (simp add: hyp_edge_to_def)
          ultimately
          show ?thesis by (auto simp add: Cons simp del: snd_hyp_edge_at)
        qed
      qed
     qed
   qed
qed

sublocale Pruned_Port_Graph nodes inPorts outPorts vertices nodeOf edges
proof
  fix v
  assume "v |\<in>| vertices"
  thus "\<exists>pth v'. path v v' pth \<and> terminal_vertex v'"
  proof(induct rule: vertices_induct)
    case (None c)
    hence "terminal_vertex (c,[])" by simp
    with path.intros(1)
    show ?case by blast
  next
    case (Some c "is")
    hence "path (c, 0 # is) (c, []) (terminal_path_from c is)"
      by (rule path_terminal_path_from)
    moreover
    have "terminal_vertex (c,[])" using Some(1) by simp
    ultimately
    show ?case by blast
  qed
qed

sublocale Well_Shaped_Graph  nodes inPorts outPorts vertices nodeOf edges hyps..

sublocale sol:Solution inPorts outPorts nodeOf hyps nodes vertices  labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst edges
proof
  fix v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2
  assume "((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) \<in> edges"
  thus "labelAtOut v\<^sub>1 p\<^sub>1 = labelAtIn v\<^sub>2 p\<^sub>2"
  proof(cases rule:edges.cases)
    case (regular_edge c "is")

    from \<open>((v\<^sub>1, p\<^sub>1), v\<^sub>2, p\<^sub>2) = edge_at c is\<close>
    have "(v\<^sub>1,p\<^sub>1) = edge_from c is" using fst_edge_at by (metis fst_conv)
    hence [simp]: "v\<^sub>1 = (c, 0 # is)" by (simp add: edge_from_def)

    show ?thesis
    proof(cases "is" rule:rev_cases)
      case Nil
      let "?t'" = "it' c"
      have "labelAtOut v\<^sub>1 p\<^sub>1 = subst (iSubst ?t') (freshen (vidx v\<^sub>1) (iOutPort ?t'))"
        using regular_edge Nil by (simp add: labelAtOut_def edge_at_def edge_from_def)
      also have "vidx v\<^sub>1 = iAnnot ?t'" by (simp add:  Nil)
      also have "subst (iSubst ?t') (freshen (iAnnot ?t') (iOutPort ?t')) = snd (fst (root (ts c)))"
        unfolding iwf_subst_freshen_outPort[OF iwf_it[OF \<open>c \<in> set conclusions\<close>]]..
      also have "\<dots> = c" using \<open>c \<in> set conclusions\<close> by (simp add: ts_conc)
      also have "\<dots> = labelAtIn v\<^sub>2 p\<^sub>2"
        using  \<open>c \<in> set conclusions\<close>  regular_edge Nil
        by (simp add: labelAtIn_def edge_at_def freshen_closed conclusions_closed closed_no_lconsts)
      finally show ?thesis.
    next
      case (snoc is' i)
      let "?t1" = "tree_at (it' c) (is'@[i])"
      let "?t2" = "tree_at (it' c) is'"
      have "labelAtOut v\<^sub>1 p\<^sub>1 = subst (iSubst ?t1) (freshen (vidx v\<^sub>1) (iOutPort ?t1))"
        using regular_edge snoc by (simp add: labelAtOut_def edge_at_def edge_from_def)
      also have "vidx v\<^sub>1 = iAnnot ?t1" using snoc regular_edge(3) by simp
      also have "subst (iSubst ?t1) (freshen (iAnnot ?t1) (iOutPort ?t1))
          = subst (iSubst ?t2) (freshen (iAnnot ?t2) (a_conc (inPorts' (iNodeOf ?t2) ! i)))"
        by (rule iwf_edge_match[OF iwf_it[OF \<open>c \<in> set conclusions\<close>] \<open>is \<in> it_paths (it' c)\<close>[unfolded snoc]])
      also have "iAnnot ?t2 = vidx (c, 0 # is')" by simp
      also have "subst (iSubst ?t2) (freshen (vidx (c, 0 # is')) (a_conc (inPorts' (iNodeOf ?t2) ! i))) = labelAtIn v\<^sub>2 p\<^sub>2"
        using regular_edge snoc by (simp add: labelAtIn_def edge_at_def)
      finally show ?thesis.
  qed
  next
    case (hyp_edge c "is" n s ants)
    let ?f = "subst s (freshen n anyP)"
    let ?h = "hyp_port_h_for (it' c) is ?f"
    let ?his = "hyp_port_path_for (it' c) is ?f"
    let "?t1" = "tree_at (it' c) ?his"
    let "?t2" = "tree_at (it' c) is"

    from \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close> \<open>tree_at (it' c) is = HNode n s ants\<close>
    have "?f \<in> hyps_along (it' c) is"
      by (rule hyps_exist')

    from \<open>((v\<^sub>1, p\<^sub>1), v\<^sub>2, p\<^sub>2) = hyp_edge_at c is n s\<close>
    have "(v\<^sub>1,p\<^sub>1) = hyp_edge_from c is n s" using fst_hyp_edge_at by (metis fst_conv)
    hence [simp]: "v\<^sub>1 = (c, 0 # ?his)" by (simp add: hyp_edge_from_def)

    have "labelAtOut v\<^sub>1 p\<^sub>1 = subst (iSubst ?t1) (freshen (vidx v\<^sub>1) (labelsOut (iNodeOf ?t1) ?h))"
      using hyp_edge by (simp add: hyp_edge_at_def hyp_edge_from_def labelAtOut_def)
    also have "vidx v\<^sub>1 = iAnnot ?t1" by simp
    also have "subst (iSubst ?t1) (freshen (iAnnot ?t1) (labelsOut (iNodeOf ?t1) ?h)) = ?f" using \<open>?f \<in> hyps_along (it' c) is\<close> by (rule local.hyp_port_eq[symmetric])
    also have "\<dots> = subst (iSubst ?t2) (freshen (iAnnot ?t2) anyP)"  using hyp_edge by simp
    also have "subst (iSubst ?t2) (freshen (iAnnot ?t2) anyP) = labelAtIn v\<^sub>2 p\<^sub>2"
        using hyp_edge by (simp add: labelAtIn_def  hyp_edge_at_def hyp_edge_to_def)
    finally show ?thesis.
  qed
qed

lemma node_disjoint_fresh_vars:
  assumes "n \<in> sset nodes"
  assumes "i < length (inPorts' n)"
  assumes "i' < length (inPorts' n)"
  shows "a_fresh (inPorts' n ! i) \<inter> a_fresh (inPorts' n ! i') = {} \<or> i = i'"
  using assms no_multiple_local_consts
  by (fastforce simp add: nodes_def stream.set_map)

sublocale Well_Scoped_Instantiation  freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP inPorts outPorts nodeOf hyps  nodes vertices labelsIn labelsOut vidx inst edges local_vars
proof
  fix v p var v'
  assume "valid_in_port (v, p)"
  hence "v |\<in>| vertices" by simp

  obtain c "is" where "v = (c,is)"  by (cases v, auto)

  from \<open>valid_in_port (v, p)\<close> \<open>v= _\<close>
  have "(c,is) |\<in>| vertices"  and "p |\<in>| inPorts (nodeOf (c, is))"  by simp_all
  hence "c \<in> set conclusions" by (simp add: mem_vertices)

  from \<open>p |\<in>| _\<close> obtain i where
    "i < length (inPorts' (nodeOf (c, is)))" and
    "p = inPorts' (nodeOf (c, is)) ! i" by (auto simp add: inPorts_fset_of in_set_conv_nth)
  hence "p = in_port_at (c, is) i" by (cases "is") auto

  assume "v' |\<in>| vertices"
  then obtain c' is' where "v' = (c',is')" by (cases v', auto)

  assume "var \<in> local_vars (nodeOf v) p"
  hence "var \<in> a_fresh p" by simp

  assume "freshenLC (vidx v) var \<in> subst_lconsts (inst v')"
  then obtain is'' where "is' = 0#is''" and "is'' \<in> it_paths (it' c')"
    using \<open>v' |\<in>| vertices\<close>
    by (cases is') (auto simp add: \<open>v'=_\<close>)

  note \<open>freshenLC (vidx v) var \<in> subst_lconsts (inst v')\<close>
  also
  have "subst_lconsts (inst v') = subst_lconsts (iSubst (tree_at (it' c') is''))"
    by (simp add: \<open>v'=_\<close> \<open>is'=_\<close>)
  also
  from \<open>is'' \<in> it_paths (it' c')\<close>
  have "\<dots> \<subseteq> fresh_at_path (it' c') is'' \<union> range (freshenLC v_away)"
    by (rule globalize_local_consts)
  finally
  have "freshenLC (vidx v) var \<in> fresh_at_path (it' c') is''"
    using \<open>v |\<in>| vertices\<close> by auto
  then obtain is''' where "prefix is''' is''"  and "freshenLC (vidx v) var \<in> fresh_at (it' c') is'''"
    unfolding fresh_at_path_def by auto
  then obtain i' is'''' where "prefix (is''''@[i']) is''"
      and "freshenLC (vidx v) var \<in> fresh_at (it' c') (is''''@[i'])"
    using append_butlast_last_id[where xs = is''', symmetric]
    apply (cases "is''' = []")
    apply (auto simp del: fresh_at_snoc append_butlast_last_id)
    apply metis
    done

  from  \<open>is'' \<in> it_paths (it' c')\<close> \<open>prefix (is''''@[i']) is''\<close>
  have "(is''''@[i']) \<in> it_paths (it' c')" by (rule it_paths_prefix)
  hence "is'''' \<in> it_paths (it' c')" using append_prefixD it_paths_prefix by blast

  from this \<open>freshenLC (vidx v) var \<in> fresh_at (it' c') (is''''@[i'])\<close>
  have "c = c' \<and> is = 0 # is'''' \<and> var \<in> a_fresh (inPorts' (iNodeOf (tree_at (it' c') is'''')) ! i')"
    unfolding fresh_at_def' using \<open>v |\<in>| vertices\<close>  \<open>v' |\<in>| vertices\<close>
    apply (cases "is")
    apply (auto split: if_splits simp add:  iAnnot_globalize it_paths_butlast \<open>v=_\<close> \<open>v'=_\<close> \<open>is'=_\<close> simp del: iAnnot.simps)
    done
  hence "c' = c" and "is = 0 # is''''" and "var \<in> a_fresh (inPorts' (iNodeOf (tree_at (it' c') is'''')) ! i')" by simp_all

  from \<open>(is''''@[i']) \<in> it_paths (it' c')\<close>
  have "i' < length (inPorts' (nodeOf (c, is)))"
    using iwf_length_inPorts[OF iwf_it[OF \<open>c \<in> set conclusions\<close>]]
    by (auto elim!: it_paths_SnocE simp add: \<open>is=_\<close> \<open>c' = _\<close> order.strict_trans2)

  have "nodeOf (c, is) \<in> sset nodes"
    unfolding \<open>is = _\<close> \<open>c' = _\<close> nodeOf.simps
    by (rule iNodeOf_tree_at[OF iwf_it[OF \<open>c \<in> set conclusions\<close>]  \<open>is'''' \<in> it_paths (it' c')\<close>[unfolded \<open>c' = _\<close>]])

  from \<open>var \<in> a_fresh (inPorts' (iNodeOf (tree_at (it' c') is'''')) ! i')\<close>
       \<open>var \<in> a_fresh p\<close> \<open>p = inPorts' (nodeOf (c, is)) ! i\<close>
       node_disjoint_fresh_vars[OF
          \<open>nodeOf (c, is) \<in> sset nodes\<close>
          \<open>i < length (inPorts' (nodeOf (c, is)))\<close> \<open>i' < length (inPorts' (nodeOf (c, is)))\<close>]
  have "i' = i" by (auto simp add: \<open>is=_\<close> \<open>c'=c\<close>)

  from  \<open>prefix (is''''@[i']) is''\<close>
  have "prefix (is @ [i']) is'" by (simp add: \<open>is'=_\<close> \<open>is=_\<close>)

  from \<open>c \<in> set conclusions\<close>  \<open>is'' \<in> it_paths (it' c')\<close> \<open>prefix (is @ [i']) is'\<close>
      \<open>p = in_port_at (c, is) i\<close>
  have "scope' v p v'"
  unfolding \<open>v=_\<close> \<open>v'=_\<close> \<open>c' = _\<close> \<open>is' = _\<close>  \<open>i'=_\<close> by (auto intro: scope'.intros)
  thus "v' \<in> scope (v, p)" using \<open>valid_in_port (v, p)\<close> by (simp add: in_scope)
qed

sublocale Scoped_Proof_Graph freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP  inPorts outPorts nodeOf hyps nodes vertices labelsIn labelsOut vidx inst edges local_vars..

(* interpretation of @{term Tasked_Proof_Graph} has to be named to avoid name clashes in @{term Abstract_Task}. *)
sublocale tpg:Tasked_Proof_Graph freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP antecedent consequent rules assumptions conclusions
  vertices nodeOf edges vidx inst
proof
  show "set (map Conclusion conclusions) \<subseteq> nodeOf ` fset vertices"
  proof-
  {
    fix c
    assume "c \<in> set conclusions"
    hence "(c, []) |\<in>| vertices" by simp
    hence "nodeOf (c, []) \<in> nodeOf ` fset vertices"
      unfolding fmember.rep_eq by (rule imageI)
    hence "Conclusion c \<in> nodeOf ` fset vertices"  by simp
  } thus ?thesis by auto
  qed
qed

end

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Cong_Subst_Pres
  imports Weak_Late_Cong_Subst Weak_Late_Cong_Pres
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "\<tau>.(P) \<simeq>\<^sup>s \<tau>.(Q)"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.tauPres)

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PeqQ: "P \<simeq>\<^sup>s Q"

  shows "a<x>.P \<simeq>\<^sup>s a<x>.Q"
proof(auto simp add: substClosed_def)
  fix \<sigma> :: "(name \<times> name) list"
  {
    fix P Q a x \<sigma>
    assume "P \<simeq>\<^sup>s Q"
    then have "P[<\<sigma>>] \<simeq>\<^sup>s Q[<\<sigma>>]" by(rule partUnfold)
    then have "\<forall>y. (P[<\<sigma>>])[x::=y] \<simeq> (Q[<\<sigma>>])[x::=y]"
      apply(auto simp add: substClosed_def)
      by(erule_tac x="[(x, y)]" in allE) auto
    moreover assume "x \<sharp> \<sigma>"
    ultimately have "(a<x>.P)[<\<sigma>>] \<simeq> (a<x>.Q)[<\<sigma>>]" using weakBisimEqvt
      by(force intro: Weak_Late_Cong_Pres.inputPres)
  }
  note Goal = this

  obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<sigma>"
    by(generate_fresh "name") auto
  from `P \<simeq>\<^sup>s Q` have "([(x, y)] \<bullet> P) \<simeq>\<^sup>s ([(x, y)] \<bullet> Q)" by(rule eqvtI)
  hence "(a<y>.([(x, y)] \<bullet> P))[<\<sigma>>] \<simeq> (a<y>.([(x, y)] \<bullet> Q))[<\<sigma>>]" using `y \<sharp> \<sigma>` by(rule Goal)
  moreover from `y \<sharp> P` `y \<sharp> Q` have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" and "a<x>.Q = a<y>.([(x, y)] \<bullet> Q)"
    by(simp add: pi.alphaInput)+

  ultimately show "(a<x>.P)[<\<sigma>>] \<simeq> (a<x>.Q)[<\<sigma>>]" by simp
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "a{b}.P \<simeq>\<^sup>s a{b}.Q"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.outputPres)

  assumes "P \<simeq>\<^sup>s Q"

  shows "[a\<frown>b]P \<simeq>\<^sup>s [a\<frown>b]Q"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.matchPres)

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<oplus> R \<simeq>\<^sup>s Q \<oplus> R"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.sumPres)

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<parallel> R \<simeq>\<^sup>s Q \<parallel> R"
using assms
by(force simp add: substClosed_def Weak_Late_Cong_Pres.parPres)

  assumes PeqQ: "P \<simeq>\<^sup>s Q"

  shows "<\<nu>x>P \<simeq>\<^sup>s <\<nu>x>Q"
proof(auto simp add: substClosed_def)
  fix s::"(name \<times> name) list"

  have Goal: "\<And>P Q x s. \<lbrakk>P[<s>] \<leadsto><weakBisim> Q[<s>]; x \<sharp> s\<rbrakk> \<Longrightarrow> (<\<nu>x>P)[<s>] \<leadsto><weakBisim> (<\<nu>x>Q)[<s>]"
    by(force intro: Weak_Late_Step_Sim_Pres.resPres Weak_Late_Bisim_Pres.resPres Weak_Late_Bisim.eqvt)

  have "\<exists>c::name. c \<sharp> (P, Q, s)"  by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ: "c \<sharp> Q" and cFreshs: "c \<sharp> s"
    by(force simp add: fresh_prod)

  from PeqQ have "P[<([(x, c)] \<bullet> s)>] \<leadsto><weakBisim> Q[<([(x, c)] \<bullet> s)>]" and
                 "Q[<([(x, c)] \<bullet> s)>] \<leadsto><weakBisim> P[<([(x, c)] \<bullet> s)>]"
    by(force simp add: congruenceSubstDef)+

  hence "([(x, c)] \<bullet> (P[<([(x, c)] \<bullet> s)>])) \<leadsto><weakBisim> ([(x, c)] \<bullet> (Q[<([(x, c)] \<bullet> s)>]))" and
        "([(x, c)] \<bullet> (Q[<([(x, c)] \<bullet> s)>])) \<leadsto><weakBisim> ([(x, c)] \<bullet> (P[<([(x, c)] \<bullet> s)>]))"
    by(blast intro: Weak_Late_Step_Sim.eqvtI Weak_Late_Bisim.eqvt)+

  hence "([(x, c)] \<bullet> P)[<s>] \<leadsto><weakBisim> ([(x, c)] \<bullet> Q)[<s>]" and
        "([(x, c)] \<bullet> Q)[<s>] \<leadsto><weakBisim> ([(x, c)] \<bullet> P)[<s>]" by simp+

  with cFreshs have "(<\<nu>c>([(x, c)] \<bullet> P))[<s>] \<leadsto><weakBisim> (<\<nu>c>([(x, c)] \<bullet> Q))[<s>]" and
                    "(<\<nu>c>([(x, c)] \<bullet> Q))[<s>] \<leadsto><weakBisim> (<\<nu>c>([(x, c)] \<bullet> P))[<s>]"
    by(blast intro: Goal)+

  moreover from cFreshP cFreshQ have "<\<nu>x>P = <\<nu>c>([(x, c)] \<bullet> P)" and "<\<nu>x>Q = <\<nu>c>([(x, c)] \<bullet> Q)"
    by(simp add: alphaRes)+

  ultimately show "(<\<nu>x>P)[<s>] \<simeq> (<\<nu>x>Q)[<s>]"
    by(simp add: congruence_def)
qed

lemma congruenceBang:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "!P \<simeq>\<^sup>s !Q"
using assms
by(force simp add: substClosed_def intro: Weak_Late_Cong_Pres.congruenceBang)

end


           (*-------------------------------------------*
            |                2 Buffers                  |
            |                                           |
            |                June 2009                  |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory TwoBuff
imports CSP_F
begin

(*=============================================================*
 |                                                             |
 |                           Process                           |
 |                                                             |
 *=============================================================*)

(*********************************************************
               process names and events
 *********************************************************)

datatype Event = inC | outC | midC
datatype PN = Buff1 | Buff1' | Buff2 | Buff2' | Buff2''

(*********************************************************
                  Recursivey Process
 *********************************************************)

primrec
  PNdef :: "PN => (PN, Event) proc"
where
 "PNdef   (Buff1) = inC -> $Buff1'"
|"PNdef  (Buff1') = outC -> $Buff1"

|"PNdef   (Buff2) = inC -> $Buff2'"
|"PNdef  (Buff2') = inC -> $Buff2'' [+] outC -> $Buff2"
|"PNdef (Buff2'') = outC -> $Buff2'"

(*
defs (overloaded) Set_PNfun_def [simp]: "PNfun == PNdef"
*)

overloading Set_PNdef ==
  "PNfun :: (PN, Event) pnfun"
begin
  definition "PNfun == PNdef"
end

declare Set_PNdef_def [simp]

(* ------------------ *
      guardedness
 * ------------------ *)

lemma guardedfun_PN[simp]:
      "guardedfun PNdef"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)
(*
defs FPmode_def [simp]: "FPmode == CMSmode"
*)

overloading FPmode ==
  "FPmode :: fpmode"
begin
  definition "FPmode == CMSmode"
end

declare FPmode_def [simp]

(*********************************************************
                     Composition
 *********************************************************)

abbreviation
 Link :: "(PN, Event) proc => (PN, Event) proc => (PN, Event) proc"
        ("(1_ /<---> _)" [76,77] 76)
where "P <---> Q == (P[[outC<-->midC]] |[{midC}]|
                     Q[[inC<-->midC]]) -- {midC}"

abbreviation
 LinkBuff2 :: "(PN, Event) proc"
where "LinkBuff2 == $Buff1 <---> $Buff1"

(*********************************************************
                  for automatising
 *********************************************************)

declare simp_event_set [simp]

lemma Link_cong: "Q =F R ==> P <---> Q =F P <---> R"
by (simp)

(*********************************************************
                    verification
 *********************************************************)

primrec
  Buff2_to_LinkBuff2 :: "PN => (PN, Event) proc"
where
  "Buff2_to_LinkBuff2 (Buff1) = $Buff1"
 |"Buff2_to_LinkBuff2 (Buff1') = $Buff1'"
 |"Buff2_to_LinkBuff2 (Buff2) = LinkBuff2"
 |"Buff2_to_LinkBuff2 (Buff2') = $Buff1' <---> $Buff1"
 |"Buff2_to_LinkBuff2 (Buff2'') = $Buff1' <---> $Buff1'"

theorem Buff2_eq_LinkBuff2:
   "$Buff2 =F LinkBuff2"

(* by finxed point induction *)
apply (rule cspF_fp_induct_left[of _ "Buff2_to_LinkBuff2"])
apply (simp+, induct_tac p, auto, cspF_unwind+)

(* by sequentialising *)
apply (cspF_auto | auto)+
done

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Close_Subst
  imports Agent
begin

context substPsi
begin

definition closeSubst :: "('b::fs_name \<times> ('a::fs_name, 'b, 'c::fs_name) psi \<times> ('a, 'b, 'c) psi) set \<Rightarrow> ('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
where "closeSubst Rel \<equiv> {(\<Psi>, P, Q) | \<Psi> P Q. (\<forall>\<sigma>. wellFormedSubst \<sigma> \<longrightarrow> (\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel)}"

lemma closeSubstI:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<And>\<sigma>. wellFormedSubst \<sigma> \<Longrightarrow> (\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel"

  shows "(\<Psi>, P, Q) \<in> closeSubst Rel"
using assms
by(unfold closeSubst_def) auto

lemma closeSubstE:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<sigma> :: "(name list \<times> 'a list) list"

  assumes "(\<Psi>, P, Q) \<in> closeSubst Rel"
  and     "wellFormedSubst \<sigma>"

  shows "(\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel"
using assms
by(unfold closeSubst_def) auto

lemma closeSubstClosed:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   p :: "name prm"

  assumes "eqvt Rel"
  and     "(\<Psi>, P, Q) \<in> closeSubst Rel"

  shows "(p \<bullet> \<Psi>, p \<bullet> P, p \<bullet> Q) \<in> closeSubst Rel"
proof(rule closeSubstI)
  fix \<sigma>
  assume "wellFormedSubst(\<sigma>::(name list \<times> 'a list) list)"
  with `(\<Psi>, P, Q) \<in> closeSubst Rel` `wellFormedSubst \<sigma>`
  have "(\<Psi>, P[<(rev p \<bullet> \<sigma>)>], Q[<(rev p \<bullet> \<sigma>)>]) \<in> Rel"
    by(rule_tac closeSubstE) auto
  hence "(p \<bullet> \<Psi>, p \<bullet> (P[<(rev p \<bullet> \<sigma>)>]), p \<bullet> (Q[<(rev p \<bullet> \<sigma>)>])) \<in> Rel"
    by(drule_tac p=p in eqvtI[OF `eqvt Rel`]) (simp add: eqvts)
  thus "(p \<bullet> \<Psi>, (p \<bullet> P)[<\<sigma>>], (p \<bullet> Q)[<\<sigma>>]) \<in> Rel"
    by(simp del: seqSubs_def add: eqvts)
qed

lemma closeSubstEqvt:
  assumes "eqvt Rel"

  shows "eqvt(closeSubst Rel)"
proof(auto simp add: eqvt_def)
  fix \<Psi> P Q p
  assume "(\<Psi>, P, Q) \<in> closeSubst Rel"
  thus "((p::name prm) \<bullet> \<Psi>, p \<bullet> P, p \<bullet> Q) \<in> closeSubst Rel"
    by(drule_tac p=p in closeSubstClosed[OF `eqvt Rel`]) (simp add: eqvts)
qed

lemma closeSubstUnfold:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<sigma> :: "(name list \<times> 'a list) list"

  assumes "(\<Psi>, P, Q) \<in> closeSubst Rel"
  and     "wellFormedSubst \<sigma>"

  shows "(\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> closeSubst Rel"
proof(rule closeSubstI)
  fix \<sigma>'::"(name list \<times> 'a list) list"
  assume "wellFormedSubst \<sigma>'"
  with `wellFormedSubst \<sigma>` have "wellFormedSubst(\<sigma>@\<sigma>')" by simp
  with `(\<Psi>, P, Q) \<in> closeSubst Rel` have "(\<Psi>, P[<(\<sigma>@\<sigma>')>], Q[<(\<sigma>@\<sigma>')>]) \<in> Rel"
    by(rule closeSubstE)
  thus "(\<Psi>, P[<\<sigma>>][<\<sigma>'>], Q[<\<sigma>>][<\<sigma>'>]) \<in> Rel"
    by simp
qed

end

end


(*
 * Copyright Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Ancient comprehensive Word Library\<close>

theory Word_Lib_Sumo
imports
  "HOL-Library.Word"
  Aligned
  Bit_Comprehension
  Bit_Comprehension_Int
  Bit_Shifts_Infix_Syntax
  Bits_Int
  Bitwise_Signed
  Bitwise
  Enumeration_Word
  Generic_set_bit
  Hex_Words
  Least_significant_bit
  More_Arithmetic
  More_Divides
  More_Sublist
  Even_More_List
  More_Misc
  Strict_part_mono
  Legacy_Aliases
  Most_significant_bit
  Next_and_Prev
  Norm_Words
  Reversed_Bit_Lists
  Rsplit
  Signed_Words
  Syntax_Bundles
  Typedef_Morphisms
  Type_Syntax
  Word_EqI
  Word_Lemmas
  Word_8
  Word_16
  Word_32
  Word_Syntax
  Signed_Division_Word
  Singleton_Bit_Shifts
  More_Word_Operations
  Many_More
  Word_Lemmas_Internal
  Word_Lemmas_Prefix
begin

unbundle bit_operations_syntax
unbundle bit_projection_infix_syntax

declare word_induct2[induct type]
declare word_nat_cases[cases type]

declare signed_take_bit_Suc [simp]

(* these generate take_bit terms, which we often don't want for concrete lengths *)
lemmas of_int_and_nat = unsigned_of_nat unsigned_of_int signed_of_int signed_of_nat

bundle no_take_bit
begin
declare of_int_and_nat[simp del]
end

lemmas bshiftr1_def = bshiftr1_eq
lemmas is_down_def = is_down_eq
lemmas is_up_def = is_up_eq
lemmas mask_def = mask_eq
lemmas scast_def = scast_eq
lemmas shiftl1_def = shiftl1_eq
lemmas shiftr1_def = shiftr1_eq
lemmas sshiftr1_def = sshiftr1_eq
lemmas sshiftr_def = sshiftr_eq_funpow_sshiftr1
lemmas to_bl_def = to_bl_eq
lemmas ucast_def = ucast_eq
lemmas unat_def = unat_eq_nat_uint
lemmas word_cat_def = word_cat_eq
lemmas word_reverse_def = word_reverse_eq_of_bl_rev_to_bl
lemmas word_roti_def = word_roti_eq_word_rotr_word_rotl
lemmas word_rotl_def = word_rotl_eq
lemmas word_rotr_def = word_rotr_eq
lemmas word_sle_def = word_sle_eq
lemmas word_sless_def = word_sless_eq

lemmas uint_0 = uint_nonnegative
lemmas uint_lt = uint_bounded
lemmas uint_mod_same = uint_idem
lemmas of_nth_def = word_set_bits_def

lemmas of_nat_word_eq_iff = word_of_nat_eq_iff
lemmas of_nat_word_eq_0_iff = word_of_nat_eq_0_iff
lemmas of_int_word_eq_iff = word_of_int_eq_iff
lemmas of_int_word_eq_0_iff = word_of_int_eq_0_iff

lemmas word_next_def = word_next_unfold

lemmas word_prev_def = word_prev_unfold

lemmas is_aligned_def = is_aligned_iff_dvd_nat

lemmas word_and_max_simps =
  word8_and_max_simp
  word16_and_max_simp
  word32_and_max_simp

lemma distinct_lemma: "f x \<noteq> f y \<Longrightarrow> x \<noteq> y" by auto

lemmas and_bang = word_and_nth

lemmas sdiv_int_def = signed_divide_int_def
lemmas smod_int_def = signed_modulo_int_def

(* shortcut for some specific lengths *)
lemma word_fixed_sint_1[simp]:
  "sint (1::8 word) = 1"
  "sint (1::16 word) = 1"
  "sint (1::32 word) = 1"
  "sint (1::64 word) = 1"
  by (auto simp: sint_word_ariths)

declare of_nat_diff [simp]

(* Haskellish names/syntax *)
notation (input)
  bit ("testBit")

lemmas cast_simps = cast_simps ucast_down_bl

(* shadows the slightly weaker Word.nth_ucast *)
lemma nth_ucast:
  "(ucast (w::'a::len word)::'b::len word) !! n =
   (w !! n \<and> n < min LENGTH('a) LENGTH('b))"
  by (auto simp add: bit_simps not_le dest: bit_imp_le_length)

end


(*  Title:       Conflict analysis/Flowgraphs
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
header "Flowgraphs"
theory Flowgraph
imports Main Misc
begin
text_raw {*\label{thy:Flowgraph}*}

text {*
  We use a flowgraph-based program model that extends the one we used previously \cite{LM07}.
  A program is represented as an edge annotated graph and a set of procedures. The nodes of the graph are partitioned by the procedures, i.e. every node belongs to exactly one procedure. There are no edges
  between nodes of different procedures. Every procedure has a distinguished entry and return node and a set of monitors it synchronizes on. Additionally, the program has a distinguished {\em main} procedure.
  The edges are annotated with statements. A statement is either a base statement, a procedure call or a thread creation (spawn). Procedure calls and thread creations refer to the called procedure or to the initial procedure
  of the spawned thread, respectively.

  We require that the main procedure and any initial procedure of a spawned thread does not to synchronize on any monitors. This avoids that spawning of a procedure together with entering a monitor is available in our
  model as an atomic step, which would be an unrealistic assumption for practical problems. Technically, our model would become strictly more powerful without this assumption.

  If we allowed this, our model would become strictly more powerful,
*}

subsection "Definitions"

datatype ('p,'ba) edgeAnnot = Base 'ba | Call 'p | Spawn 'p
type_synonym ('n,'p,'ba) edge = "('n \<times> ('p,'ba) edgeAnnot \<times> 'n)"

record ('n,'p,'ba,'m) flowgraph_rec =
  edges :: "('n,'p,'ba) edge set" -- "Set of annotated edges"
  main :: "'p" -- "Main procedure"
  entry :: "'p \<Rightarrow> 'n" -- "Maps a procedure to its entry point"
  return :: "'p \<Rightarrow> 'n" -- "Maps a procedure to its return point"
  mon :: "'p \<Rightarrow> 'm set" -- "Maps procedures to the set of monitors they allocate"
  proc_of :: "'n \<Rightarrow> 'p" -- "Maps a node to the procedure it is contained in"

definition
  "initialproc fg p == p=main fg \<or> (\<exists>u v. (u,Spawn p,v)\<in>edges fg)"

lemma main_is_initial[simp]: "initialproc fg (main fg)"
  by (unfold initialproc_def) simp

locale flowgraph =
  fixes fg :: "('n,'p,'ba,'m,'more) flowgraph_rec_scheme" (structure)
  (* Type annotation unnecessary, but perhaps makes it more readable
     for the unaware reader ;) *)
  -- "Edges are inside procedures only"
  assumes edges_part: "(u,a,v)\<in>edges fg \<Longrightarrow> proc_of fg u = proc_of fg v"
  -- "The entry point of a procedure must be in that procedure"
  assumes entry_valid[simp]: "proc_of fg (entry fg p) = p"
  -- "The return point of a procedure must be in that procedure"
  assumes return_valid[simp]: "proc_of fg (return fg p) = p"
  -- "Initial procedures do not synchronize on any monitors"
  assumes initial_no_mon[simp]: "initialproc fg p \<Longrightarrow> mon fg p = {}"

subsection "Basic properties"
lemma (in flowgraph) spawn_no_mon[simp]:
  "(u, Spawn p, v) \<in> edges fg \<Longrightarrow> mon fg p = {}"
  using initial_no_mon by (unfold initialproc_def, blast)
lemma (in flowgraph) main_no_mon[simp]: "mon fg (main fg) = {}"
  using initial_no_mon by (unfold initialproc_def, blast)

lemma (in flowgraph) entry_entry_same_proc[simp]:
  "entry fg p = entry fg p' \<Longrightarrow> p=p'"
  apply (subgoal_tac "proc_of fg (entry fg p) = proc_of fg (entry fg p')")
  apply (simp (no_asm_use))
  by simp

lemma (in flowgraph) return_return_same_proc[simp]:
  "return fg p = return fg p' \<Longrightarrow> p=p'"
  apply (subgoal_tac "proc_of fg (return fg p) = proc_of fg (entry fg p')")
  apply (simp (no_asm_use))
  by simp

subsection "Extra assumptions for flowgraphs"
text_raw {*\label{sec:Flowgraph:extra_asm}*}
text {*
  In order to simplify the definition of our restricted schedules (cf. Section~\ref{thy:Normalization}), we make some extra constraints on flowgraphs.
  Note that these are no real restrictions, as we can always rewrite flowgraphs to match these constraints, preserving the set of conflicts. We leave it to future work to consider such a rewriting formally.

  The background of this restrictions is that we want to start an execution of a thread with a procedure call that never returns. This will allow easier technical treatment in Section~\ref{thy:Normalization}. Here we enforce this
  semantic restrictions by syntactic properties of the flowgraph.
*}

text {* The return node of a procedure is called {\em isolated}, if it has no incoming edges and is different from the entry node. A procedure with an isolated return node will never return.
  See Section~\ref{sec:Normalization:eflowgraph} for a proof of this. *}
definition
  "isolated_ret fg p ==
    (\<forall>u l. \<not>(u,l,return fg p)\<in>edges fg) \<and> entry fg p \<noteq> return fg p"

text {* The following syntactic restrictions guarantee that each thread's execution starts with a non-returning call. See Section~\ref{sec:Normalization:eflowgraph} for a proof of this. *}
locale eflowgraph = flowgraph +
  -- "Initial procedure's entry node isn't equal to its return node"
  assumes initial_no_ret: "initialproc fg p \<Longrightarrow> entry fg p \<noteq> return fg p"
  -- "The only outgoing edges of initial procedures' entry nodes are call edges to procedures with isolated return node"
  assumes initial_call_no_ret: "\<lbrakk>initialproc fg p; (entry fg p,l,v)\<in>edges fg\<rbrakk>
    \<Longrightarrow> \<exists>p'. l=Call p' \<and> isolated_ret fg p'"

subsection {* Example Flowgraph*}
text_raw {* \label{sec:Flowgraph:ex_flowgraph} *}
text {* This section contains a check that there exists a (non-trivial) flowgraph, i.e. that the assumptions made in the @{text flowgraph} and @{text eflowgraph}
  locales are consistent and have at least one non-trivial model. *}
definition
  "example_fg == \<lparr>
    edges = {((0::nat,0::nat),Call 1,(0,1)), ((1,0),Spawn 0,(1,0)),
             ((1,0),Call 0, (1,0))},
    main = 0,
    entry = \<lambda>p. (p,0),
    return = \<lambda>p. (p,1),
    mon = \<lambda>p. if p=1 then {0} else {},
    proc_of= \<lambda> (p,x). p \<rparr>"

lemma exists_eflowgraph: "eflowgraph example_fg"
  apply (unfold_locales)
  apply (unfold example_fg_def)
  apply simp
  apply fast
  apply simp
  apply simp
  apply (simp add: initialproc_def)
  apply (simp add: initialproc_def)
  apply (simp add: initialproc_def isolated_ret_def)
  done

end


(*  Title:      HOL/Auth/WooLam.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Woo-Lam Protocol\<close>

theory WooLam imports Public begin

text\<open>Simplified version from page 11 of
  Abadi and Needham (1996).
  Prudent Engineering Practice for Cryptographic Protocols.
  IEEE Trans. S.E. 22(1), pages 6-15.

Note: this differs from the Woo-Lam protocol discussed by Lowe (1996):
  Some New Attacks upon Security Protocols.
  Computer Security Foundations Workshop
\<close>

inductive_set woolam :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> woolam"

         (** These rules allow agents to send messages to themselves **)

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "[| evsf \<in> woolam;  X \<in> synth (analz (spies evsf)) |]
          ==> Says Spy B X  # evsf \<in> woolam"

         (*Alice initiates a protocol run*)
 | WL1:  "evs1 \<in> woolam ==> Says A B (Agent A) # evs1 \<in> woolam"

         (*Bob responds to Alice's message with a challenge.*)
 | WL2:  "[| evs2 \<in> woolam;  Says A' B (Agent A) \<in> set evs2 |]
          ==> Says B A (Nonce NB) # evs2 \<in> woolam"

         (*Alice responds to Bob's challenge by encrypting NB with her key.
           B is *not* properly determined -- Alice essentially broadcasts
           her reply.*)
 | WL3:  "[| evs3 \<in> woolam;
             Says A  B (Agent A)  \<in> set evs3;
             Says B' A (Nonce NB) \<in> set evs3 |]
          ==> Says A B (Crypt (shrK A) (Nonce NB)) # evs3 \<in> woolam"

         (*Bob forwards Alice's response to the Server.  NOTE: usually
           the messages are shown in chronological order, for clarity.
           But here, exchanging the two events would cause the lemma
           WL4_analz_spies to pick up the wrong assumption!*)
 | WL4:  "[| evs4 \<in> woolam;
             Says A'  B X         \<in> set evs4;
             Says A'' B (Agent A) \<in> set evs4 |]
          ==> Says B Server \<lbrace>Agent A, Agent B, X\<rbrace> # evs4 \<in> woolam"

         (*Server decrypts Alice's response for Bob.*)
 | WL5:  "[| evs5 \<in> woolam;
             Says B' Server \<lbrace>Agent A, Agent B, Crypt (shrK A) (Nonce NB)\<rbrace>
               \<in> set evs5 |]
          ==> Says Server B (Crypt (shrK B) \<lbrace>Agent A, Nonce NB\<rbrace>)
                 # evs5 \<in> woolam"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

(*A "possibility property": there are traces that reach the end*)
lemma "\<exists>NB. \<exists>evs \<in> woolam.
             Says Server B (Crypt (shrK B) \<lbrace>Agent A, Nonce NB\<rbrace>) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] woolam.Nil
                    [THEN woolam.WL1, THEN woolam.WL2, THEN woolam.WL3,
                     THEN woolam.WL4, THEN woolam.WL5], possibility)
done

(*Could prove forwarding lemmas for WL4, but we do not need them!*)

(**** Inductive proofs about woolam ****)

(** Theorems of the form X \<notin> parts (spies evs) imply that NOBODY
    sends messages containing X! **)

(*Spy never sees a good agent's shared key!*)
lemma Spy_see_shrK [simp]:
     "evs \<in> woolam ==> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (erule woolam.induct, force, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> woolam ==> (Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> woolam|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

(**** Autheticity properties for Woo-Lam ****)

(*** WL4 ***)

(*If the encrypted message appears then it originated with Alice*)
lemma NB_Crypt_imp_Alice_msg:
     "[| Crypt (shrK A) (Nonce NB) \<in> parts (spies evs);
         A \<notin> bad;  evs \<in> woolam |]
      ==> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*Guarantee for Server: if it gets a message containing a certificate from
  Alice, then she originated that certificate.  But we DO NOT know that B
  ever saw it: the Spy may have rerouted the message to the Server.*)
lemma Server_trusts_WL4 [dest]:
     "[| Says B' Server \<lbrace>Agent A, Agent B, Crypt (shrK A) (Nonce NB)\<rbrace>
           \<in> set evs;
         A \<notin> bad;  evs \<in> woolam |]
      ==> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (blast intro!: NB_Crypt_imp_Alice_msg)

(*** WL5 ***)

(*Server sent WL5 only if it received the right sort of message*)
lemma Server_sent_WL5 [dest]:
     "[| Says Server B (Crypt (shrK B) \<lbrace>Agent A, NB\<rbrace>) \<in> set evs;
         evs \<in> woolam |]
      ==> \<exists>B'. Says B' Server \<lbrace>Agent A, Agent B, Crypt (shrK A) NB\<rbrace>
             \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*If the encrypted message appears then it originated with the Server!*)
lemma NB_Crypt_imp_Server_msg [rule_format]:
     "[| Crypt (shrK B) \<lbrace>Agent A, NB\<rbrace> \<in> parts (spies evs);
         B \<notin> bad;  evs \<in> woolam |]
      ==> Says Server B (Crypt (shrK B) \<lbrace>Agent A, NB\<rbrace>) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*Guarantee for B.  If B gets the Server's certificate then A has encrypted
  the nonce using her key.  This event can be no older than the nonce itself.
  But A may have sent the nonce to some other agent and it could have reached
  the Server via the Spy.*)
lemma B_trusts_WL5:
     "[| Says S B (Crypt (shrK B) \<lbrace>Agent A, Nonce NB\<rbrace>) \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> woolam  |]
      ==> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (blast dest!: NB_Crypt_imp_Server_msg)

(*B only issues challenges in response to WL1.  Not used.*)
lemma B_said_WL2:
     "[| Says B A (Nonce NB) \<in> set evs;  B \<noteq> Spy;  evs \<in> woolam |]
      ==> \<exists>A'. Says A' B (Agent A) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(**CANNOT be proved because A doesn't know where challenges come from...*)
lemma "[| A \<notin> bad;  B \<noteq> Spy;  evs \<in> woolam |]
  ==> Crypt (shrK A) (Nonce NB) \<in> parts (spies evs) \<and>
      Says B A (Nonce NB) \<in> set evs
      \<longrightarrow> Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
apply (erule rev_mp, erule woolam.induct, force, simp_all, blast, auto)
oops

end


theory a3
imports
  "AutoCorres.AutoCorres"
  "AutoCorres.TypHeapSimple"
begin

(* To run this file you need the AutoCorres tool used
   in the lecture.

  1. Download AutoCorres from
       \url{http://www.cse.unsw.edu.au/~cs4161/autocorres-1.6.1.tar}

  2. Unpack the .tar.gz file, which will create the directory autocorres-1.6.1
       tar -xzf autocorres-1.6.1.tar.gz

  3. Build the AutoCorres heap
     L4V_ARCH=X64 isabelle build -v -b -d autocorres-1.6.1 AutoCorres

  4. Load this file using the AutoCorres heap
     L4V_ARCH=X64 isabelle jedit -d autocorres-1.6.1 -l AutoCorres a3.thy

*)

section "Question: Reverse "

(* Hints:
    - use find_theorems to find Isabelle library theorems about existing concepts.
    - you are allowed to use sledgehammer and other automation
    - if you can't prove one of the lemmas below, you can still assume it in the rest of the proof
    - the function @{const int} converts an Isabelle nat to an int
    - the function @{const nat} converts an Isabelle int to a nat
    - If you want to use apply style, you could the tactic @{text insert assms}
      to insert assumptions into your proof.
*)

(* Parse the input file. *)
install_C_file "reverse.c"

(* Abstract the input file. *)
autocorres[unsigned_word_abs=reverse] "reverse.c"

section \<open>utility lemmas\<close>

(* This makes an intro rule which can be used with rule_tac, as opposed to
    using whileLoop_add_inv and subst. *)
lemma whileLoop_add_invI:
  assumes "\<lbrace> P \<rbrace> whileLoop_inv c b init I (measure M) \<lbrace> Q \<rbrace>!"
  shows "\<lbrace> P \<rbrace> whileLoop c b init \<lbrace> Q \<rbrace>!"
  by (metis assms whileLoop_inv_def)

lemma pointer_add_ldistrib_add:
  "p +\<^sub>p (a + b) = (p +\<^sub>p a) +\<^sub>p b"
  unfolding ptr_add_def
  by (simp add: algebra_simps)

lemma heap_w32_update_comp:
  "heap_w32_update (f \<circ> g) s = heap_w32_update f (heap_w32_update g s)"
  by simp

text \<open> This assumes that pointers are wellbehaved \<close>
definition wellbehaved_pointers :: "('a :: c_type) ptr \<Rightarrow> nat \<Rightarrow> bool" where
  "wellbehaved_pointers p n \<equiv>
    \<forall>i j :: int. i < n \<longrightarrow> j < n \<longrightarrow> ((p +\<^sub>p i :: 'a ptr) = p +\<^sub>p j) \<longleftrightarrow> (i = j)"

lemma wellbehaved_pointers_D:
  fixes n :: nat
  and i j :: int
  assumes
    "wellbehaved_pointers p n"
    "i < n"
    "j < n"
  shows
    "(p +\<^sub>p i = p +\<^sub>p j) \<longleftrightarrow> (i = j)"
  using assms
  by (simp add: wellbehaved_pointers_def)

lemma int_geq_0_less_Suc_eq_0_disj:
  fixes a b :: int
  assumes
    "0 \<le> a"
    "0 \<le> b"
  shows
    "a < 1 + b \<longleftrightarrow> a = 0 \<or> (\<exists>a'. a = 1 + a' \<and> 0 \<le> a' \<and> a' < b)"
  using assms
  by presburger

lemma geq_step_Suc:
  "(\<forall>x\<ge>m. P x) = (P m \<and> (\<forall>x\<ge>Suc m. P x))"
  by (metis Suc_leD dual_order.antisym not_less_eq_eq)

lemma gr_is_geq_Suc:
  "(\<forall>x>m. P x) = ((\<forall>x\<ge>Suc m. P x))"
  by (simp add: Suc_le_eq)

lemma leq_minus_split:
    "i \<le> n - m \<longleftrightarrow> i \<le> n - Suc m \<or> i = n - m"
  by linarith

lemma gr_minus_Suc:
  assumes
    "m > n"
  shows
    "(\<forall>x>m - Suc n. P x) \<longleftrightarrow> P (m - n) \<and> (\<forall>x>m - n. P x)"
  using assms
  apply (simp add: gr_is_geq_Suc Suc_diff_Suc)
  apply (subst (1) le_less)
  apply (simp add: Suc_le_eq split_all_conj)
  apply fast
  done

(*******************************************************************************)

primrec
  arr_is_valid :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
    "arr_is_valid s p 0 = True"
  | "arr_is_valid s p (Suc n) = (is_valid_w32 s p \<and> arr_is_valid s (p +\<^sub>p 1) n)"

lemma arr_is_valid_update_heap:
  "arr_is_valid (heap_w32_update f s) p n \<longleftrightarrow> arr_is_valid s p n"
  by (induct n arbitrary: p) simp+

lemma arr_is_valid_conv_all_nth:
  "arr_is_valid s p n \<longleftrightarrow> (\<forall>i<n. is_valid_w32 s (p +\<^sub>p int i))"
  by (induct n arbitrary: p)
    (simp add: All_less_Suc2 pointer_add_ldistrib_add)+

lemma arr_is_validD:
  "arr_is_valid s p n \<Longrightarrow> i < n \<Longrightarrow> is_valid_w32 s (p +\<^sub>p int i)"
  using arr_is_valid_conv_all_nth
  by blast

lemma arr_is_valid_intD:
  "arr_is_valid s p n \<Longrightarrow> 0 \<le> i \<Longrightarrow> nat i < n \<Longrightarrow> is_valid_w32 s (p +\<^sub>p i)"
  using arr_is_valid_conv_all_nth
  by auto

lemma arr_is_valid_smaller:
  "arr_is_valid s p n \<Longrightarrow> m \<le> n \<Longrightarrow> arr_is_valid s p m"
  by (simp add: arr_is_valid_conv_all_nth)

subsection \<open> arr_is_valid \<close>

primrec
  arr_list :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> word32 list"
where
    "arr_list s p 0 = []"
  | "arr_list s p (Suc n) = (heap_w32 s p) # arr_list s (p +\<^sub>p 1) n"

lemma heap_to_arr_list_lookup:
  fixes i :: int
  assumes
    "0 \<le> i"
    "i < n"
  shows "heap_w32 s (p +\<^sub>p i) = arr_list s p n ! nat i"
  using assms
  apply (induct n arbitrary: p i)
   apply simp
  apply (clarsimp simp add: nth_Cons int_geq_0_less_Suc_eq_0_disj split: nat.splits)
  apply (force simp add: pointer_add_ldistrib_add dest: Suc_nat_eq_nat_zadd1)
  done

lemma arr_list_to_heap_lookup:
  assumes "i < n"
  shows "arr_list s p n ! i = heap_w32 s (p +\<^sub>p int i)"
  using assms
  by (induct n arbitrary: p i) (force simp: less_Suc_eq_0_disj pointer_add_ldistrib_add)+

lemma arr_list_length: "length (arr_list s p n) = n"
  by (induct n arbitrary: p) force+

lemma arr_list_empty_iff: "arr_list s p n = [] \<longleftrightarrow> n = 0"
  by (metis arr_list.simps(1) arr_list_length)

lemma arr_list_heap_update:
  assumes
    "wellbehaved_pointers p n"
    "0 \<le> i"
    "nat i < n"
    "arr_is_valid s p n"
  shows
    "arr_list (heap_w32_update (\<lambda>h. h(p +\<^sub>p i := v)) s) p n = (arr_list s p n)[nat i := v]"
  using assms
  by (force simp add:
      list_eq_iff_nth_eq arr_list_to_heap_lookup fun_upd_def
      arr_list_length wellbehaved_pointers_def)

lemma arr_list_heap_update_comp:
  assumes
    "wellbehaved_pointers p n"
    "0 \<le> i"
    "nat i < n"
    "arr_is_valid s p n"
  shows
    "arr_list (heap_w32_update ((\<lambda>a. a(p +\<^sub>p i := v)) \<circ> f) s) p n = (arr_list (heap_w32_update f s) p n)[nat i := v]"
  using assms
  apply -
  apply (subst heap_w32_update_comp)
  apply (subst arr_list_heap_update)
      apply blast
     apply blast
    apply blast
    apply (simp add: arr_is_valid_update_heap)
  apply blast
  done

lemmas arr_list_heap_update_simps = arr_list_heap_update arr_list_heap_update_comp

(*******************************************************************************)

context reverse begin

section \<open> Reverse \<close>

(* The monadic definition that autocorres produces for the C code: *)
thm reverse'_def

subsection \<open> Reverse invariant \<close>

(* Hint: The invariant for the reverse function is split into three parts.
         In the following three definitions xs is the input list,
         xs' is the modified list, and i, j are list indices. *)

(*  Replace True with the correct invariant in each of the following three definitions. *)

definition left_invariant :: "word32 list \<Rightarrow> word32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "left_invariant xs xs' i j \<equiv> \<forall>k. k < i \<longrightarrow> xs' ! k = xs ! (length xs - k - 1)"

definition middle_invariant :: "word32 list \<Rightarrow> word32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "middle_invariant xs xs' i j \<equiv> \<forall>k. i \<le> k \<longrightarrow> k \<le> j \<longrightarrow> xs' ! k = xs ! k"

definition right_invariant :: "word32 list \<Rightarrow> word32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "right_invariant xs xs' i j \<equiv> \<forall>k. j < k \<longrightarrow> k < length xs \<longrightarrow> xs'!k = xs!(length xs - k - 1)"

definition reverse_inv :: "word32 list \<Rightarrow> word32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "reverse_inv xs xs' i j \<equiv>
    left_invariant xs xs' i j \<and> \<comment> \<open> everything less than i is ...  \<close>
    middle_invariant xs xs' i j \<and> \<comment> \<open> everything between i and j is ... \<close>
    right_invariant xs xs' i j" \<comment> \<open> everything larger than j is ...  \<close>

lemmas reverse_invariant_def = left_invariant_def middle_invariant_def right_invariant_def reverse_inv_def

(* Replace SOMETHING in the following lemmas by something that would allow you
    to prove reverse_correct. *)

lemma left_invariant_step:
  assumes
    "length xs' = length xs"
    "i < length xs - Suc i"
    "middle_invariant xs xs' i (length xs - Suc i)"
    "left_invariant xs xs' i (length xs - Suc i)"
  shows
    "left_invariant xs
    (xs'[i := xs' ! (length xs - Suc i),length xs - Suc i:= xs'! i])
    (Suc i) (length xs - Suc (Suc i))"
  using assms
  unfolding left_invariant_def middle_invariant_def
  apply clarsimp
  by (metis (no_types, hide_lams) less_imp_diff_less linorder_neqE_nat not_less_eq nth_list_update_eq nth_list_update_neq)

lemma right_invariant_step:
  assumes
    "length xs' = length xs"
    "i < length xs - Suc i"
    "middle_invariant xs xs' i (length xs - Suc i)"
    "right_invariant xs xs' i (length xs - Suc i)"
  shows
    "right_invariant xs
    (xs'[i := xs' ! (length xs - Suc i),length xs - Suc i:= xs'! i])
    (Suc i) (length xs - Suc (Suc i))"
  using assms
  unfolding middle_invariant_def right_invariant_def
  apply clarsimp
  proof -
    fix k :: nat
    assume a1: "length xs - Suc (Suc i) < k"
    assume a2: "\<forall>k>length xs - Suc i. k < length xs \<longrightarrow> xs' ! k = xs ! (length xs - Suc k)"
    assume a3: "k < length xs"
    have f4: "length xs - Suc i = k \<or> \<not> k < length xs - Suc i"
      using a1 by (metis (no_types) leq_minus_split less_Suc_eq_le nat_less_le not_less_eq)
    have "\<not> length xs - Suc i \<le> i"
      by (meson assms(2) less_Suc_eq_le not_less_eq)
    then have f5: "i \<le> length xs"
      by (meson i_hate_words_helper nat_le_linear)
    have f6: "\<not> length xs < i"
      by (meson assms(2) less_Suc_eq less_imp_diff_less not_less_eq)
    have "\<forall>n. n - Suc n = 0"
      by simp
    then show "xs'[i := xs ! (length xs - Suc i), length xs - Suc i := xs ! i] ! k = xs ! (length xs - Suc k)"
      using f6 f5 f4 a3 a2 by (metis (no_types) Suc_diff_Suc assms(1) assms(2) diff_diff_cancel length_list_update linorder_neqE_nat not_less_zero nth_list_update_eq nth_list_update_neq)
  qed

lemma middle_invariant_step:
  assumes
    "length xs' = length xs"
    "i < length xs - Suc i"
    "middle_invariant xs xs' i (length xs - Suc i)"
  shows
    "middle_invariant xs
    (xs'[i := xs' ! (length xs - Suc i),length xs - Suc i:= xs'! i])
     (Suc i) (length xs - Suc (Suc i))"
  using assms unfolding middle_invariant_def by clarsimp

text \<open> Show the precondition implies the invariant \<close>
lemma pre_impl_inv:
  assumes
    "n < UINT_MAX"
    "arr_is_valid s p n"
    "xs = arr_list s p n"
    "0 < n"
  shows
    "xs \<noteq> []"
    "reverse_inv (arr_list s p n) (arr_list s p n) 0 (n - Suc 0)"
  using assms
  unfolding reverse_inv_def left_invariant_def middle_invariant_def right_invariant_def
  by (auto simp add: arr_list_empty_iff arr_list_length)

text \<open> Show the invariant implies the postcondition \<close>

lemma left_all_is_rev:
  "left_invariant xs (rev(xs)) (length xs - 1) 0"
  unfolding left_invariant_def
  by (simp add: nth_rev)

lemma
  "i < length xs \<longrightarrow> left_invariant xs (rev(xs)) i (length xs -i -1)"
  unfolding left_invariant_def
  by (simp add: nth_rev)

lemma for_k_impl_rev:
  "length xs = length ys \<Longrightarrow>  \<forall>k. k < length xs \<longrightarrow> ys! k  = xs ! (length xs - k - 1) \<Longrightarrow> ys = rev xs"
  apply clarsimp
  apply (induct xs  arbitrary:ys )
  apply simp
  by (metis length_rev nth_equalityI nth_rev_alt rev_rev_ident)

lemma inv_impl_post:
  assumes
    "reverse_inv xs (arr_list s p (length xs)) r (length xs - Suc r)"
    "arr_is_valid s p (length xs)"
    "length xs - Suc r \<le> r"
  shows "arr_list s p (length xs) = rev xs"
  using assms
  unfolding reverse_inv_def left_invariant_def middle_invariant_def right_invariant_def
  apply clarsimp
  using for_k_impl_rev
  by (smt arr_list_length diff_diff_cancel length_rev less_imp_diff_less linorder_neqE_nat
      nat_less_le nth_equalityI rev_nth)

text \<open> Show the invariant is preserved by the loop \<close>
lemma invariant_preservation:
  assumes
    "i < length xs - Suc i"
    "arr_is_valid s p (length xs)"
    "reverse_inv xs (arr_list s p (length xs)) i (length xs - Suc i)"
  shows
    "reverse_inv xs
    ((arr_list s p (length xs))[i := xs ! (length xs - Suc i),length xs - Suc i:= xs! i])
     (Suc i) (length xs - Suc (Suc i))"
  using assms
  unfolding reverse_inv_def left_invariant_def middle_invariant_def right_invariant_def
  apply safe
    apply clarsimp
    apply (metis (no_types, hide_lams) arr_list_length less_antisym less_imp_diff_less not_less_eq nth_list_update_eq nth_list_update_neq)
   apply simp
  apply clarsimp
  proof -
    fix k :: nat
    assume a1: "\<forall>k>length xs - Suc i. k < length xs \<longrightarrow> arr_list s p (length xs) ! k = xs ! (length xs - Suc k)"
    assume a2: "k < length xs"
    assume a3: "length xs - Suc (Suc i) < k"
    have f4: "\<forall>n na. \<not> (n::nat) \<le> na \<or> \<not> na < n"
      using less_Suc_eq_le not_less_eq by presburger
    then have f5: "length xs - Suc i = k \<or> \<not> k \<le> length xs - Suc i"
      using a3 by (metis (no_types) leq_minus_split)
    have f6: "i \<le> length xs"
      using assms(1) by linarith
    have f7: "Suc i \<le> length xs"
      by (meson assms(1) less_Suc_eq_le less_imp_diff_less not_less_eq)
    have "\<not> k \<le> i"
      using f5 f4 by (meson assms(1) le_trans nat_less_le)
      moreover
      { assume "length xs - k \<noteq> i \<and> k \<noteq> i"
        then have "(arr_list s p (length xs)) [i := xs ! (length xs - Suc i), length xs - Suc i := xs ! i] ! k = xs ! (length xs - Suc k) \<or> length xs - Suc i \<noteq> k \<and> k \<noteq> i"
          using f6 f4 a2 by (metis (no_types) arr_list_length diff_diff_cancel length_list_update leq_minus_split nat_less_le not_less_eq_eq nth_list_update_eq) }
      ultimately show "(arr_list s p (length xs)) [i := xs ! (length xs - Suc i), length xs - Suc i := xs ! i] ! k = xs ! (length xs - Suc k)"
        using f7 f5 a2 a1 by (metis (no_types) diff_diff_cancel nat_le_linear nat_less_le not_less_eq_eq nth_list_update_neq)
    qed

text \<open> Show reverse is correct \<close>

lemma inv_impl_mid: "reverse_inv xs xs' i j  \<Longrightarrow> middle_invariant xs xs' i j"
  unfolding reverse_inv_def by blast

lemma mid_impl_access_origin:
  "\<lbrakk>middle_invariant xs xs' i j ; ine \<ge> i ;  ine \<le> j\<rbrakk> \<Longrightarrow> xs ! ine = xs'! ine"
  unfolding middle_invariant_def by simp

lemma state_access_is_arr_access:
  "xs = arr_list s p n \<Longrightarrow> x < n \<and> x \<ge> 0 \<Longrightarrow> xs ! x = heap_w32 s (p +\<^sub>p int (x))"
  by (simp add: arr_list_to_heap_lookup)

lemma mid_impl_access_state_origin:
  "\<lbrakk>i < j; i \<ge> 0; j < n;length xs = n;xs' = arr_list s p n;
   middle_invariant xs xs' i j ; ine \<ge> i ;  ine \<le> j\<rbrakk>
   \<Longrightarrow> heap_w32 s (p +\<^sub>p int (ine)) =  xs ! ine "
  unfolding middle_invariant_def
  by (simp add: arr_list_to_heap_lookup)

lemma mid_impl_access_heap : "\<lbrakk>
  i < j; i \<ge> 0; j < n;length xs = n;xs' = arr_list s p n;n < UINT_MAX;
   middle_invariant xs xs' i j ; ine \<ge> i ;  ine \<le> j; k \<ge>0 ; k < n \<rbrakk>
  \<Longrightarrow> xs [k := heap_w32 s (p +\<^sub>p int (ine)) ] = xs [k := xs ! ine]"
  unfolding middle_invariant_def
  apply clarsimp
  by (simp add: arr_list_to_heap_lookup)

lemma pointer_add_simp:
  fixes r :: nat
    and s :: lifted_globals
  assumes a1: "r < length xs - Suc r"
  assumes a2: "n = length xs"
  assumes a3: "arr_is_valid s p (length xs)"
  shows "is_valid_w32 s (p +\<^sub>p (int (length xs) - (1 + int r)))"
  proof -
    have f4: "r < n - Suc r"
      using a2 a1 by meson
    then have "Suc r < n"
      by linarith
    then have f5: "\<not> n < Suc r"
      by linarith
    have "n - Suc r < n"
      using f4 by linarith
    then show "is_valid_w32 s (p +\<^sub>p (int (length xs) - (1 + int r)))"
      using f5 a3 a2 by (metis (no_types) add_diff_cancel_left' add_diff_inverse_nat arr_is_validD of_nat_Suc of_nat_add)
  qed

lemma reverse_correct:
  "\<lbrace> \<lambda>s. wellbehaved_pointers p n \<and>
         length xs < UINT_MAX \<and>
         arr_is_valid s p (length xs) \<and>
         arr_list s p n = xs \<and>
         n = length xs \<and>
         n > 0
   \<rbrace>
       reverse' p n
   \<lbrace> \<lambda>r s. arr_is_valid s p (length xs) \<and>
           arr_list s p n = rev xs \<rbrace>!"
  unfolding reverse'_def
  apply (wp | clarsimp)+
    apply (rule_tac
      I= "\<lambda> i s.
        wellbehaved_pointers p n \<and>
        n = length xs \<and>
        n < UINT_MAX \<and>
        n > 0 \<and>
        i < n \<and>
        n - i - 1 < n \<and>
        arr_is_valid s p (length xs) \<and>
        reverse_inv xs (arr_list s p n) i (length xs - i - 1)
      "
      and M = "\<lambda> (i,_) . length xs - i"
      in whileLoop_add_invI)
    apply (wp | clarsimp )+
      apply (auto simp add: arr_list_heap_update_simps)[2]
  using arr_is_valid_update_heap apply blast
       apply (frule invariant_preservation)
         apply simp+
       apply (frule inv_impl_mid, subst heap_to_arr_list_lookup[where ?n = "length xs"], fastforce+) +
       apply (simp add: nat_minus_as_int reverse_invariant_def(2))
     apply (simp add: pointer_add_simp)
  using arr_is_validD apply auto[1]
  using reverse.inv_impl_post apply auto[1]
   apply (wp| clarsimp)
  using reverse.pre_impl_inv(2) by fastforce

end


section \<open>Map Interface\<close>
theory IICF_Map
imports "../../Sepref"
begin

subsection \<open>Parametricity for Maps\<close>
definition [to_relAPP]: "map_rel K V \<equiv> (K \<rightarrow> \<langle>V\<rangle>option_rel)
  \<inter> { (mi,m). dom mi \<subseteq> Domain K \<and> dom m \<subseteq> Range K }"
(*
definition [to_relAPP]: "map_rel K V \<equiv> (K \<rightarrow> \<langle>V\<rangle>option_rel)
  \<inter> { (mi,m). dom mi \<subseteq> Domain K \<and> dom m \<subseteq> Range K
      \<and> ran mi \<subseteq> Domain V \<and> ran m \<subseteq> Range V }"
*)

lemma bi_total_map_rel_eq:
  "\<lbrakk>IS_RIGHT_TOTAL K; IS_LEFT_TOTAL K\<rbrakk> \<Longrightarrow> \<langle>K,V\<rangle>map_rel = K \<rightarrow> \<langle>V\<rangle>option_rel"
  unfolding map_rel_def IS_RIGHT_TOTAL_def IS_LEFT_TOTAL_def
  by (auto dest: fun_relD)

lemma map_rel_empty1_simp[simp]:
  "(Map.empty,m)\<in>\<langle>K,V\<rangle>map_rel \<longleftrightarrow> m=Map.empty"
  apply (auto simp: map_rel_def)
  by (meson RangeE domIff option_rel_simp(1) subsetCE tagged_fun_relD_none)

lemma map_rel_empty2_simp[simp]:
  "(m,Map.empty)\<in>\<langle>K,V\<rangle>map_rel \<longleftrightarrow> m=Map.empty"
  apply (auto simp: map_rel_def)
  by (meson Domain.cases domIff fun_relD2 option_rel_simp(2) subset_eq)

lemma map_rel_obtain1:
  assumes 1: "(m,n)\<in>\<langle>K,V\<rangle>map_rel"
  assumes 2: "n l = Some w"
  obtains k v where "m k = Some v" "(k,l)\<in>K" "(v,w)\<in>V"
  using 1 unfolding map_rel_def
proof clarsimp
  assume R: "(m, n) \<in> K \<rightarrow> \<langle>V\<rangle>option_rel"
  assume "dom n \<subseteq> Range K"
  with 2 obtain k where "(k,l)\<in>K" by auto
  moreover from fun_relD[OF R this] have "(m k, n l) \<in> \<langle>V\<rangle>option_rel" .
  with 2 obtain v where "m k = Some v" "(v,w)\<in>V" by (cases "m k"; auto)
  ultimately show thesis by - (rule that)
qed

lemma map_rel_obtain2:
  assumes 1: "(m,n)\<in>\<langle>K,V\<rangle>map_rel"
  assumes 2: "m k = Some v"
  obtains l w where "n l = Some w" "(k,l)\<in>K" "(v,w)\<in>V"
  using 1 unfolding map_rel_def
proof clarsimp
  assume R: "(m, n) \<in> K \<rightarrow> \<langle>V\<rangle>option_rel"
  assume "dom m \<subseteq> Domain K"
  with 2 obtain l where "(k,l)\<in>K" by auto
  moreover from fun_relD[OF R this] have "(m k, n l) \<in> \<langle>V\<rangle>option_rel" .
  with 2 obtain w where "n l = Some w" "(v,w)\<in>V" by (cases "n l"; auto)
  ultimately show thesis by - (rule that)
qed

subsection \<open>Interface Type\<close>

sepref_decl_intf ('k,'v) i_map is "'k \<rightharpoonup> 'v"

subsection \<open>Operations\<close>

context
  fixes t ::  "unit \<Rightarrow> nat"
begin
  definition "mop_map_empty  = SPECT [ Map.empty \<mapsto> t ()]"

  lemma  mop_map_empty: "tt \<le> lst (SPECT [ Map.empty \<mapsto> t () ]) Q
        \<Longrightarrow> tt \<le> lst (mop_map_empty ) Q" unfolding mop_map_empty_def by simp

  sepref_register "mop_map_empty"
end

context
  fixes t ::  "(( 'a \<Rightarrow> 'b option) * 'a) * 'b \<Rightarrow> nat"
begin
  definition "mop_map_update m k v = SPECT [ m(k \<mapsto> v) \<mapsto> t ((m,k),v)]"

  lemma  mop_map_update: "tt \<le> lst (SPECT [ m(k \<mapsto> v) \<mapsto> t ((m,k),v)])  Q
        \<Longrightarrow> tt \<le> lst (mop_map_update m k v) Q" unfolding mop_map_update_def by simp

  sepref_register "mop_map_update"
end

context
  fixes t ::  "('a \<Rightarrow> 'b option) * 'a \<Rightarrow> nat"
begin
  definition "mop_map_dom_member m x = SPECT (emb (\<lambda>b. b \<longleftrightarrow> x\<in>dom m) (t (m,x)))"

  lemma  mop_map_dom_member: "tt \<le> lst (SPECT (emb (\<lambda>b. b \<longleftrightarrow> x\<in>dom m) (t (m,x))))  Q
        \<Longrightarrow> tt \<le> lst (mop_map_dom_member m x) Q" unfolding mop_map_dom_member_def by simp

  sepref_register "mop_map_dom_member"
end

context
  fixes t ::  "('a \<Rightarrow> 'b option) * 'a \<Rightarrow> nat"
begin
  definition "mop_map_lookup m x = do {
        ASSERT (x\<in>dom m);
        SPECT [  (the (m x)) \<mapsto> t (m,x)]
      }"

  lemma  mop_map_lookup: "tt \<le> lst (SPECT [  (the (m x)) \<mapsto> t (m,x)]) Q
        \<Longrightarrow> x : dom m
        \<Longrightarrow> tt \<le> lst (mop_map_lookup m x) Q" unfolding mop_map_lookup_def by simp

  lemma progress_mop_map_lookup[progress_rules]: "t (m,x) > 0 \<Longrightarrow> progress (mop_map_lookup m x)"
      unfolding mop_map_lookup_def by (auto intro!: progress_rules simp add:   zero_enat_def)

  sepref_register "mop_map_lookup"
end

end


(*  Title:       Conflict analysis/Flowgraphs
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "Flowgraphs"
theory Flowgraph
imports Main Misc
begin
text_raw \<open>\label{thy:Flowgraph}\<close>

text \<open>
  We use a flowgraph-based program model that extends the one we used previously \cite{LM07}.
  A program is represented as an edge annotated graph and a set of procedures. The nodes of the graph are partitioned by the procedures, i.e. every node belongs to exactly one procedure. There are no edges
  between nodes of different procedures. Every procedure has a distinguished entry and return node and a set of monitors it synchronizes on. Additionally, the program has a distinguished {\em main} procedure.
  The edges are annotated with statements. A statement is either a base statement, a procedure call or a thread creation (spawn). Procedure calls and thread creations refer to the called procedure or to the initial procedure
  of the spawned thread, respectively.

  We require that the main procedure and any initial procedure of a spawned thread does not to synchronize on any monitors. This avoids that spawning of a procedure together with entering a monitor is available in our
  model as an atomic step, which would be an unrealistic assumption for practical problems. Technically, our model would become strictly more powerful without this assumption.

  If we allowed this, our model would become strictly more powerful,
\<close>

subsection "Definitions"

datatype ('p,'ba) edgeAnnot = Base 'ba | Call 'p | Spawn 'p
type_synonym ('n,'p,'ba) edge = "('n \<times> ('p,'ba) edgeAnnot \<times> 'n)"

record ('n,'p,'ba,'m) flowgraph_rec =
  edges :: "('n,'p,'ba) edge set" \<comment> \<open>Set of annotated edges\<close>
  main :: "'p" \<comment> \<open>Main procedure\<close>
  entry :: "'p \<Rightarrow> 'n" \<comment> \<open>Maps a procedure to its entry point\<close>
  return :: "'p \<Rightarrow> 'n" \<comment> \<open>Maps a procedure to its return point\<close>
  mon :: "'p \<Rightarrow> 'm set" \<comment> \<open>Maps procedures to the set of monitors they allocate\<close>
  proc_of :: "'n \<Rightarrow> 'p" \<comment> \<open>Maps a node to the procedure it is contained in\<close>

definition
  "initialproc fg p == p=main fg \<or> (\<exists>u v. (u,Spawn p,v)\<in>edges fg)"

lemma main_is_initial[simp]: "initialproc fg (main fg)"
  by (unfold initialproc_def) simp

locale flowgraph =
  fixes fg :: "('n,'p,'ba,'m,'more) flowgraph_rec_scheme" (structure)
  (* Type annotation unnecessary, but perhaps makes it more readable
     for the unaware reader ;) *)
  \<comment> \<open>Edges are inside procedures only\<close>
  assumes edges_part: "(u,a,v)\<in>edges fg \<Longrightarrow> proc_of fg u = proc_of fg v"
  \<comment> \<open>The entry point of a procedure must be in that procedure\<close>
  assumes entry_valid[simp]: "proc_of fg (entry fg p) = p"
  \<comment> \<open>The return point of a procedure must be in that procedure\<close>
  assumes return_valid[simp]: "proc_of fg (return fg p) = p"
  \<comment> \<open>Initial procedures do not synchronize on any monitors\<close>
  assumes initial_no_mon[simp]: "initialproc fg p \<Longrightarrow> mon fg p = {}"

subsection "Basic properties"
lemma (in flowgraph) spawn_no_mon[simp]:
  "(u, Spawn p, v) \<in> edges fg \<Longrightarrow> mon fg p = {}"
  using initial_no_mon by (unfold initialproc_def, blast)
lemma (in flowgraph) main_no_mon[simp]: "mon fg (main fg) = {}"
  using initial_no_mon by (unfold initialproc_def, blast)

lemma (in flowgraph) entry_entry_same_proc[simp]:
  "entry fg p = entry fg p' \<Longrightarrow> p=p'"
  apply (subgoal_tac "proc_of fg (entry fg p) = proc_of fg (entry fg p')")
  apply (simp (no_asm_use))
  by simp

lemma (in flowgraph) return_return_same_proc[simp]:
  "return fg p = return fg p' \<Longrightarrow> p=p'"
  apply (subgoal_tac "proc_of fg (return fg p) = proc_of fg (entry fg p')")
  apply (simp (no_asm_use))
  by simp

subsection "Extra assumptions for flowgraphs"
text_raw \<open>\label{sec:Flowgraph:extra_asm}\<close>
text \<open>
  In order to simplify the definition of our restricted schedules (cf. Section~\ref{thy:Normalization}), we make some extra constraints on flowgraphs.
  Note that these are no real restrictions, as we can always rewrite flowgraphs to match these constraints, preserving the set of conflicts. We leave it to future work to consider such a rewriting formally.

  The background of this restrictions is that we want to start an execution of a thread with a procedure call that never returns. This will allow easier technical treatment in Section~\ref{thy:Normalization}. Here we enforce this
  semantic restrictions by syntactic properties of the flowgraph.
\<close>

text \<open>The return node of a procedure is called {\em isolated}, if it has no incoming edges and is different from the entry node. A procedure with an isolated return node will never return.
  See Section~\ref{sec:Normalization:eflowgraph} for a proof of this.\<close>
definition
  "isolated_ret fg p ==
    (\<forall>u l. \<not>(u,l,return fg p)\<in>edges fg) \<and> entry fg p \<noteq> return fg p"

text \<open>The following syntactic restrictions guarantee that each thread's execution starts with a non-returning call. See Section~\ref{sec:Normalization:eflowgraph} for a proof of this.\<close>
locale eflowgraph = flowgraph +
  \<comment> \<open>Initial procedure's entry node isn't equal to its return node\<close>
  assumes initial_no_ret: "initialproc fg p \<Longrightarrow> entry fg p \<noteq> return fg p"
  \<comment> \<open>The only outgoing edges of initial procedures' entry nodes are call edges to procedures with isolated return node\<close>
  assumes initial_call_no_ret: "\<lbrakk>initialproc fg p; (entry fg p,l,v)\<in>edges fg\<rbrakk>
    \<Longrightarrow> \<exists>p'. l=Call p' \<and> isolated_ret fg p'"

subsection \<open>Example Flowgraph\<close>
text_raw \<open>\label{sec:Flowgraph:ex_flowgraph}\<close>
text \<open>This section contains a check that there exists a (non-trivial) flowgraph, i.e. that the assumptions made in the \<open>flowgraph\<close> and \<open>eflowgraph\<close>
  locales are consistent and have at least one non-trivial model.\<close>
definition
  "example_fg == \<lparr>
    edges = {((0::nat,0::nat),Call 1,(0,1)), ((1,0),Spawn 0,(1,0)),
             ((1,0),Call 0, (1,0))},
    main = 0,
    entry = \<lambda>p. (p,0),
    return = \<lambda>p. (p,1),
    mon = \<lambda>p. if p=1 then {0} else {},
    proc_of= \<lambda> (p,x). p \<rparr>"

lemma exists_eflowgraph: "eflowgraph example_fg"
  apply (unfold_locales)
  apply (unfold example_fg_def)
  apply simp
  apply fast
  apply simp
  apply simp
  apply (simp add: initialproc_def)
  apply (simp add: initialproc_def)
  apply (simp add: initialproc_def isolated_ret_def)
  done

end


theory LaunchburyMoreFree
imports Terms Heap Launchbury
begin

text {*
This variant of the original semantics allocates an additional free variable in the application case.
This is a prelimary step towards the equivalence of the original and the stacked semantics.
*}

inductive
  reds :: "heap \<Rightarrow> exp \<Rightarrow> var list \<Rightarrow> heap \<Rightarrow> exp \<Rightarrow> bool"
  ("_ : _ \<Down>*\<^bsub>_\<^esub> _ : _" [50,50,50,50] 50)
where
  Lambda:
    "\<Gamma> : (Lam [x]. e) \<Down>*\<^bsub>L\<^esub> \<Gamma> : (Lam [x]. e)"
 | Application: "\<lbrakk>
    atom y \<sharp> (\<Gamma>,e,x,L,\<Delta>,\<Theta>,z) ;
    atom (n::var) \<sharp> (\<Gamma>,e,x,L,\<Delta>,\<Theta>,z) ;
    n \<noteq> y;
    \<Gamma> : e \<Down>*\<^bsub>n#x#L\<^esub> \<Delta> : (Lam [y]. e');
    \<Delta> : e'[y ::= x] \<Down>*\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : App e x \<Down>*\<^bsub>L\<^esub> \<Theta> : z"
 | Variable: "\<lbrakk>
    (x,e) \<in> set \<Gamma>; delete x \<Gamma> : e \<Down>*\<^bsub>x#L\<^esub> \<Delta> : z \<rbrakk> \<Longrightarrow> \<Gamma> : Var x \<Down>*\<^bsub>L\<^esub> (x, z) # \<Delta> : z"
 | Let: "\<lbrakk>
    set (bn as) \<sharp>* (\<Gamma>, L);
    asToHeap as @ \<Gamma> : body \<Down>*\<^bsub>L\<^esub> \<Delta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Let as body \<Down>*\<^bsub>L\<^esub> \<Delta> : z"

equivariance reds

nominal_inductive reds
  avoids Application: "y" and "n"
    by(auto simp add: fresh_star_def fresh_Pair)

lemma reds_less_free:
  "\<Gamma> : e \<Down>*\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
proof(induct rule: LaunchburyMoreFree.reds.induct)
case (Application y \<Gamma> e x L \<Delta> \<Theta> z n e')
  show ?case
  proof(rule Launchbury.reds.Application)
    show "atom y \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z)"
      by fact
    show  "\<Gamma> : e \<Down>\<^bsub>x # L\<^esub> \<Delta> : Lam [y]. e'"
      apply (rule reds_smaller_L[OF Application.hyps(5)])
      by auto
    show "\<Delta> : e'[y::=x] \<Down>\<^bsub>L\<^esub> \<Theta> : z"
      by fact
  qed
qed (auto intro: reds_smaller_L Launchbury.reds.intros simp add: fresh_star_Pair)

lemma reds_with_n_doesnt_forget:
  "\<Gamma> : e \<Down>*\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> heapVars \<Gamma> \<subseteq> heapVars \<Delta>"
by (metis reds_less_free reds_doesnt_forget)

lemma reds_with_n_fresh:" \<lbrakk> \<Gamma> : e \<Down>*\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e)
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z) \<or> x \<in> (heapVars \<Delta> - set L)"
  by (metis reds_less_free reds_fresh)

lemma reds_with_n_add_var_L: "\<lbrakk> \<Gamma> : e \<Down>*\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e, \<Delta>, z);
   set L' = insert x (set L)
  \<rbrakk> \<Longrightarrow> \<Gamma> : e \<Down>*\<^bsub>L'\<^esub> \<Delta> : z"
proof(nominal_induct avoiding : L' rule: reds.strong_induct)
case (Lambda \<Gamma> x e L L')
  show ?case
    by (rule reds.Lambda)
next
case (Application y \<Gamma> e xa L \<Delta> \<Theta> z n e' L')
  show ?case
  proof(rule reds.Application)
    show "atom y \<sharp> (\<Gamma>, e, xa, L', \<Delta>, \<Theta>, z)"
      using Application
      by (auto simp add: fresh_Pair)

    show "atom n \<sharp> (\<Gamma>, e, xa, L', \<Delta>, \<Theta>, z)"
      using Application
      by (auto simp add: fresh_Pair)

    show "n \<noteq> y" by fact

    have "x \<notin> heapVars \<Theta>"
      using `atom x \<sharp> (\<Gamma>, App e xa, \<Theta>, z)`
      apply (simp add: fresh_Pair)
      by (metis heapVars_not_fresh)
    hence "x \<notin> heapVars \<Delta>"
      by (metis set_mp reds_with_n_doesnt_forget[OF Application.hyps(20)])

    have "atom x \<sharp> (\<Gamma>, e)"
      using `atom x \<sharp> (\<Gamma>, App e xa, \<Theta>, z)`
      by (simp add: fresh_Pair)
    from reds_with_n_fresh[OF Application.hyps(18) this] `x \<notin> heapVars \<Delta>`
    have "atom x \<sharp> (\<Delta>, Lam [y]. e')"
      by auto
    hence "atom x \<sharp> (\<Gamma>, e, \<Delta>, Lam [y]. e')"
      using `atom x \<sharp> (\<Gamma>, App e xa, \<Theta>, z)`
      by (simp add: fresh_Pair)
    moreover
    have "set (n # xa # L') = insert x (set (n # xa # L))"
      using `set L' = _` by auto
    ultimately
    show "\<Gamma> : e \<Down>*\<^bsub>n # xa # L'\<^esub> \<Delta> : Lam [y]. e'"
      by (rule Application.hyps(19))

    have "atom x \<sharp> (\<Delta>, e'[y::=xa])"
      using `atom x \<sharp> (\<Delta>, Lam [y]. e')` `atom x \<sharp> (\<Gamma>, App e xa, \<Theta>, z)` `atom y \<sharp> xa`
      by (auto simp add: fresh_Pair  subst_pres_fresh)
    from reds_with_n_fresh[OF Application.hyps(20) this] `x \<notin> heapVars \<Theta>`
    have "atom x \<sharp> (\<Theta>, z)" by auto
    hence "atom x \<sharp> (\<Delta>, e'[y::=xa], \<Theta>, z)"
      using `atom x \<sharp> (\<Delta>, e'[y::=xa])`
      by (simp add: fresh_Pair)
    then
    show "\<Delta> : e'[y::=xa] \<Down>*\<^bsub>L'\<^esub> \<Theta> : z "
      by (rule Application.hyps(21)[OF _ `set L' = _`])
  qed
next
case (Variable xa e \<Gamma> L \<Delta> z L')
  have "atom x \<sharp> (delete xa \<Gamma>, e, \<Delta>, z)"
    using Variable.prems(1)
    by (auto simp add: fresh_Pair fresh_Cons intro: fresh_delete fresh_heap_expr[OF _ Variable(1)])
  moreover
  have "set (xa # L') = insert x (set (xa # L))"
    using Variable.prems(2) by auto
  ultimately
  show ?case
    by (rule reds.Variable[OF Variable(1) Variable.hyps(3)])
next
case (Let as \<Gamma> L body \<Delta> z L')
  have "x \<notin> heapVars \<Delta>"
    using Let.prems(1)
    apply (auto simp add: fresh_Pair)
    by (metis heapVars_not_fresh)+
  hence "x \<notin> heapVars (asToHeap as @ \<Gamma>)"
      by (metis set_mp reds_with_n_doesnt_forget[OF Let.hyps(3)])
  hence "atom x \<notin> set (bn as)"
    by (auto simp add: set_bn_to_atom_heapVars)
  hence "set (bn as) \<sharp>* x"
    by (auto simp add: fresh_star_def fresh_at_base)

  hence "set (bn as) \<sharp>* set L'"
    using Let(2) Let.prems(2)
    by (auto simp add: fresh_star_def fresh_finite_insert fresh_set)
  hence "set (bn as) \<sharp>* (\<Gamma>, L')"
    using Let(1-4)
    by (simp add: fresh_star_Pair fresh_star_set )
  moreover
  have "atom x \<sharp> (asToHeap as @ \<Gamma>, body, \<Delta>, z)"
    using Let.prems(1) `atom x \<notin> set (bn as)`
    by (auto simp add: fresh_Pair fresh_append fresh_fun_eqvt_app[OF asToHeap_eqvt])
  ultimately
  show ?case
    by (rule reds.Let[OF _ Let.hyps(4)[OF _ Let.prems(2)]])
qed

lemma reds_more_free:
  "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> \<Gamma> : e \<Down>*\<^bsub>L\<^esub> \<Delta> : z"
proof(nominal_induct rule: Launchbury.reds.strong_induct)
case (Application y \<Gamma> e x L \<Delta> \<Theta> z e')
  obtain n :: var where
    fresh: "atom n \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z, y, Lam [y]. e')"
    by (rule obtain_fresh)

  show ?case
  proof (rule reds.Application)
    show "atom y \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z)"
      using Application
      by (auto simp add: fresh_Pair)
    show "atom n \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z)"
      using fresh
      by (auto simp add: fresh_Pair)
   show "n \<noteq> y"
      using fresh
      by (auto simp add: fresh_Pair fresh_at_base)

    note `\<Gamma> : e \<Down>*\<^bsub>x # L\<^esub> \<Delta> : Lam [y]. e'`
    moreover
    have "atom n \<sharp> (\<Gamma>, e, \<Delta>, Lam [y]. e')"
      using fresh by (auto simp add: fresh_Pair)
    ultimately
    show "\<Gamma> : e \<Down>*\<^bsub>n # x # L\<^esub> \<Delta> : Lam [y]. e'"
      by (rule reds_with_n_add_var_L, simp)

    show "\<Delta> : e'[y::=x] \<Down>*\<^bsub>L\<^esub> \<Theta> : z"
      by fact
  qed
qed (auto intro: reds.intros simp add: fresh_star_Pair)

lemma reds_more_free_eq:
  "(\<Gamma> : e \<Down>*\<^bsub>L\<^esub> \<Delta> : z) \<longleftrightarrow> (\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z)"
  by (metis reds_less_free reds_more_free)

lemmas reds_with_n_strong_induct = LaunchburyMoreFree.reds.strong_induct[unfolded reds_more_free_eq, consumes 1, case_names Lambda Application Variable Let]
lemmas reds_with_n_induct = LaunchburyMoreFree.reds.induct[unfolded reds_more_free_eq, consumes 1, case_names Lambda Application Variable Let]

(* This can be shown for reds directly, but we needed it here, and after we got the equality we can transfer it easily. *)
lemmas reds_add_var_L = reds_with_n_add_var_L[unfolded reds_more_free_eq]

end