section \<open>Simulations for Buechi Properties\<close>
theory Simulation_Graphs2
  imports TA.Simulation_Graphs
begin

text \<open>
This theory essentially formalizes the paper concepts from Guangyuan Li's FORMATS 2009 paper
``Checking Timed Büchi Automata Emptiness Using LU-Abstractions'' @{cite "Li:FORMATS:2009"}.
However, instead of formalizing this directly for the notions of timed Büchi automata,
time-abstract simulations, and zone graphs with abstractions,
we use general notions of simulation graphs with certain properties.
\<close>

subsection \<open>Misc\<close>
lemma map_eq_append_conv:
  "(map f xs = ys @ zs) = (\<exists>as bs. xs = as @ bs \<and> map f as = ys \<and> map f bs = zs)"
  by (induction ys arbitrary: xs; simp add: map_eq_Cons_conv; metis append_Cons)

lemma Cons_subseq_iff:
  "subseq (x # xs) ys \<longleftrightarrow> (\<exists>as bs. ys = as @ x # bs \<and> subseq xs bs)"
  using list_emb_ConsD list_emb_append2 by fastforce

lemma append_subseq_iff:
  "subseq (as @ bs) xs \<longleftrightarrow> (\<exists>ys zs. xs = ys @ zs \<and> subseq as ys \<and> subseq bs zs)"
  by (meson list_emb_appendD list_emb_append_mono)

context Graph_Defs
begin

lemma steps_append_singleE:
  assumes "steps (xs @ [x])"
  obtains "xs = []" | ys y where "xs = ys @ [y]" "steps xs" "y \<rightarrow> x"
  using assms by (metis append_butlast_last_id list.distinct(1) list.sel(1) steps_decomp)

lemma steps_alt_induct2[consumes 1, case_names Single Snoc]:
  assumes
    "steps (a # xs @ [b])" "(\<And>b. E a b \<Longrightarrow> P a [] b)"
    "\<And>y x xs. E y x \<Longrightarrow> steps (a # xs @ [y]) \<Longrightarrow> P a xs y \<Longrightarrow> P a (xs @ [y]) x"
  shows "P a xs b"
  using assms(1)
  apply (induction "a # xs @ [b]" arbitrary: xs b rule: steps_alt_induct)
  subgoal
    apply auto
    done
  subgoal for y x xs ys b
    apply (cases "ys = []")
     apply (force intro: assms(2); fail)
    apply (simp, metis append.simps(2) append1_eq_conv append_butlast_last_id assms(3))
    done
  done

lemma steps_singleI:
  "steps [a,b]" if "a \<rightarrow> b"
  using that steps.intros by blast

end

subsection \<open>Backward Simulations\<close>
locale Backward_Simulation = Simulation where A = E and B = E and sim = sim
  for E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and sim (infix "\<preceq>" 60) +
  fixes G :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
  assumes simulation: "b \<in> B \<Longrightarrow> G A B \<Longrightarrow> \<exists>a \<in> A. \<exists>b'. a \<rightarrow> b' \<and> b \<preceq> b'"
      and refl[intro, simp]: "a \<preceq> a" and trans: "transp (\<preceq>)"
begin

lemmas A_simulation_steps = simulation_steps

sublocale Graph_Defs G .

lemmas sim_transD[intro] = transpD[OF trans]

lemma backward_simulation_reaches:
  "\<exists>a \<in> A. \<exists>b'. E\<^sup>*\<^sup>* a b' \<and> b \<preceq> b'" if "G\<^sup>*\<^sup>* A B" "b \<in> B"
  using that
proof (induction arbitrary: b rule: rtranclp_induct)
  case base
  then show ?case
    by auto
next
  case (step Y Z)
  from simulation[OF \<open>b \<in> Z\<close> \<open>G Y Z\<close>] obtain a b' where "a \<in> Y" "a \<rightarrow> b'" "b \<preceq> b'"
    by safe
  from step.IH[OF \<open>a \<in> Y\<close>] obtain a0 a' where "a0 \<in> A" "a0 \<rightarrow>* a'" "a \<preceq> a'"
    by safe
  moreover from A_B_step[OF \<open>a \<rightarrow> b'\<close> \<open>a \<preceq> a'\<close>] obtain b'' where "a' \<rightarrow> b''" "b' \<preceq> b''"
    by safe
  with \<open>a0 \<in> A\<close> \<open>a0 \<rightarrow>* a'\<close> \<open>b \<preceq> b'\<close> show ?case
    by (auto intro: rtranclp.intros(2))
qed

lemma backward_simulation_steps:
  "\<exists>a \<in> A. \<exists>as b'. A.steps (a # as @ [b']) \<and> b \<preceq> b'" if "steps (A # As @ [B])" "b \<in> B"
  using that
proof (induction A As B arbitrary: b rule: steps_alt_induct2)
  case (Single x)
  from simulation[OF this(2,1)] show ?case
    by (safe, intro bexI exI[where x = "[]"]) auto
next
  case (Snoc B C As c)
  from simulation[OF \<open>c \<in> C\<close> \<open>G B C\<close>] obtain b c' where "b \<in> B" "b \<rightarrow> c'" "c \<preceq> c'"
    by safe
  with Snoc.IH obtain a as b' where "a \<in> A" "A.steps (a # as @ [b'])" "b \<preceq> b'"
    by blast
  moreover from \<open>b \<preceq> b'\<close> \<open>b \<rightarrow> c'\<close> obtain c'' where "b' \<rightarrow> c''" "c' \<preceq> c''"
    by (auto dest: A_B_step)
  ultimately have "a \<in> A" "c \<preceq> c''" "A.steps (a # (as @ [b']) @ [c''])"
    using \<open>c \<preceq> c'\<close> by auto (metis A.steps_appendI append_Cons)
  then show ?case
    by blast
qed

lemma backward_simulation_reaches1:
  "\<exists>a \<in> A. \<exists>b'. E\<^sup>+\<^sup>+ a b' \<and> b \<preceq> b'" if "G\<^sup>+\<^sup>+ A B" "b \<in> B"
  using that unfolding A.reaches1_steps_iff reaches1_steps_iff
  by (auto dest!: backward_simulation_steps)

text \<open>Corresponds to lemma 8 of @{cite "Li:FORMATS:2009"}.\<close>
lemma steps_repeat:
  assumes "steps (A # As @ [A])" "a \<in> A" "\<forall>a \<in> A. P a" "\<forall>x y. x \<preceq> y \<and> x \<in> A \<and> P x \<longrightarrow> P y"
  obtains x y as xs where
    "subseq as xs" "list_all P as" "A.steps (x # xs @ [y])" "length as = n" "a \<preceq> y" "x \<in> A"
  using \<open>a \<in> A\<close>
proof (atomize_elim, induction n arbitrary: a)
  case 0
  from backward_simulation_steps[OF \<open>steps (A # As @ [A])\<close> \<open>a \<in> A\<close>] obtain a' as b where
    "a' \<in> A" "A.steps (a' # as @ [b])" "a \<preceq> b"
    by auto
  then show ?case
    by (auto 4 4 intro: exI[where x = "[]"])
next
  case (Suc n b)
  from backward_simulation_steps[OF assms(1) \<open>b \<in> A\<close>] obtain a as b' where
    "a \<in> A" "A.steps (a # as @ [b'])" "b \<preceq> b'"
    by auto
  from Suc.IH[OF \<open>a \<in> A\<close> \<open>a \<in> A\<close>] obtain as' xs x y where
    "subseq as' xs" "list_all P as'" "A.steps (x # xs @ [y])" "n = length as'" "a \<preceq> y" "x \<in> A"
    by auto
  moreover from A_simulation_steps[OF \<open>A.steps (a # _)\<close> \<open>a \<preceq> y\<close>] \<open>b \<preceq> b'\<close> obtain b'' bs where
    "A.steps (y # bs @ [b''])" "list_all2 (\<preceq>) as bs" "b \<preceq> b''"
    unfolding list_all2_append1 list_all2_Cons1 by auto
  ultimately show ?case
    using assms(3,4) \<open>a \<in> A\<close>
    by (inst_existentials "as' @ [y]" "xs @ [y] @ bs" x b'')
       (auto simp: list_emb_append_mono, metis A.steps_append2 append_Cons)
qed

end

subsection \<open>Self Simulation for a Finite Simulation Relation\<close>
text \<open>
This section makes the following abstractions:
  \<^item> The timed automata semantics correspond to the transition system \<open>\<rightarrow>\<close> (\<open>E\<close>).
  \<^item> The finite time-abstract bisimulation \<open>\<equiv>\<^sub>M\<close> from the classic region construction
    corresponds to the simulation \<open>\<preceq>\<close>.
\<close>

locale Self_Simulation =
  Simulation_Invariant where A = E and B = E and sim = sim and PA = P and PB = P
  for E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and sim (infix "\<preceq>" 60) and P +
  assumes refl: "reflp (\<preceq>)" and trans: "transp (\<preceq>)"
begin

lemma sim_reflI[intro, simp]:
  "x \<preceq> x"
  using refl unfolding reflp_def by auto

lemmas sim_transD[intro] = transpD[OF trans]

text \<open>Corresponds to lemma 3 of @{cite "Li:FORMATS:2009"}.\<close>
lemma pre_cycle_infinite_cycle:
  assumes "A.steps (x # xs @ [y])" "x \<preceq> y" "P x" "P y"
  obtains w where
    "A.run (x ## w)" "stream_all2 (\<preceq>) (cycle (x # xs)) (x ## w)"
proof -
  let ?R = "\<lambda>a b. a \<preceq> b \<and> P a \<and> P b"
  define nxt where
    "nxt \<equiv> \<lambda>(xs, y). SOME (ys, z). A.steps (y # ys @ [z]) \<and> list_all2 ?R xs ys \<and> y \<preceq> z"
  have *: "A.steps (y # ys @ [z]) \<and> list_all2 ?R xs ys \<and> y \<preceq> z"
    if "nxt (xs, y) = (ys, z)" "A.steps(x # xs @ [y])" "x \<preceq> y" "P x" "P y" for x y xs ys z
  proof -
    from simulation_steps[OF that(2) \<open>x \<preceq> y\<close>] \<open>P x\<close> \<open>P y\<close> obtain ws y' where
      "A.steps (y # ws @ [y'])" "list_all2 ?R xs ws" "y \<preceq> y'"
      by (smt list_all2_Cons1 list_all2_Nil list_all2_append1)
    then show ?thesis
      using \<open>nxt _ = _\<close> unfolding nxt_def by (auto dest!: verit_sko_ex_indirect[OF sym])
  qed
  let ?w = "flat (smap (\<lambda>(xs, y). xs @ [y]) (siterate nxt (xs, y)))"
  from assms have "A.run ?w"
  proof (coinduction arbitrary: x xs y rule: A.run_flat_coinduct)
    case (run_shift as bs xss x xs y)
    obtain ys z where "nxt (xs, y) = (ys, z)"
      by (cases "nxt (xs, y)")
    with run_shift have "as = xs @ [y]" "bs = ys @ [z]"
      "bs ## xss = smap (\<lambda>(xs, y). xs @ [y]) (siterate nxt (ys, z))"
      by auto
    with *[OF \<open>nxt _ = _\<close> \<open>A.steps (x # _)\<close> \<open>x \<preceq> y\<close>] run_shift(2-) show ?case
      by (inst_existentials ys z)
         (auto 4 3 dest: A.steps_ConsD PA_invariant.invariant_steps elim: A.steps.cases)
  qed
  with assms(1) have "A.run (x ## ?w)"
    apply -
    apply (cases "smap (\<lambda>(xs, y). xs @ [y]) (siterate nxt (xs, y))")
    apply (simp only:)
    apply clarsimp
    by (smt A.run.cases A.run.intros A.steps.cases shift_simps(1) stream.sel(1)
          append_Nil append_is_Nil_conv hd_append2 list.distinct(1) list.sel)
  obtain x' xs' where eqs: "xs = xs'" "x = x'"
    by auto
  with assms have "A.steps (x' # xs' @ [y])" "list_all2 (\<preceq>) xs xs'" "x \<preceq> x'" "x' \<preceq> y" "P x'" "P y"
    by (auto simp: zip_same list_all2_iff)
  then have "stream_all2 (\<preceq>) (cycle (xs @ [x])) ?w"
  proof (rewrite in \<open>(xs, y)\<close> eqs, coinduction arbitrary: x' xs' y rule: stream_rel_coinduct_shift)
    case stream_rel
    obtain ys z where "nxt (xs', y) = (ys, z)"
      by (cases "nxt (xs', y)")
    with stream_rel show ?case
      apply -
      apply (frule (4) *)
      apply (inst_existentials "xs @ [x]" "cycle (xs @ [x])" "xs' @ [y]"
              "flat (smap (\<lambda>(xs, y). xs @ [y]) (siterate nxt (ys, z)))")
      subgoal
        by simp
           (metis cycle_Cons cycle_decomp cycle_rotated list.distinct(1) list.sel(1) list.sel(3))
      subgoal
        by (cases "smap (\<lambda>(xs, y). xs @ [y]) (siterate nxt (xs', y))") (simp only:, auto)
      apply (auto simp: list_all2_iff; fail)+
      apply (auto 4 5 elim: list_all2_trans[rotated] dest: PA_invariant.invariant_steps)
      done
  qed
  then have "stream_all2 (\<preceq>) (cycle (x # xs)) (x ## ?w)"
    by (simp add: cycle_Cons)
  with \<open>A.run (x ## ?w)\<close> show ?thesis
    by (auto intro: that)
qed

end

locale Self_Simulation_Finite =
  Simulation_Invariant where A = E and B = E and sim = sim and PA = P and PB = P
  for E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and sim (infix "\<preceq>" 60) and P +
  assumes equiv_sim: "equivp (\<preceq>)" and finite_quotient: "finite (UNIV // {(x, y). x \<preceq> y})"
begin

sublocale Self_Simulation
  apply standard
  using equiv_sim apply (simp add: equivp_reflp_symp_transp)+
  done

text \<open>Roughly corresponds to lemmas 9, 10, and 11 of @{cite "Li:FORMATS:2009"}.\<close>
lemma steps_cycle_run:
  assumes "A.steps (x # xs)" "subseq as xs" "P x" "length as > card (UNIV // {(x, y). x \<preceq> y})"
    "\<forall>x \<in> set as. \<phi> x" "\<forall>x \<in> set as. \<forall>y. x \<preceq> y \<and> \<phi> x \<longrightarrow> \<phi> y"
  obtains w where "A.run (x ## w)" "infs \<phi> w"
proof -
  from assms(3) obtain a b as' ys cs' where *: "xs = as' @ a # ys @ b # cs'" "a \<preceq> b" "a \<in> set as"
  proof -
    let ?f = "\<lambda>x. {y. x \<preceq> y}"
    let ?as = "map ?f as"
    have "card (set ?as) \<le> card (UNIV // {(x, y). x \<preceq> y})"
      using quotientI[of _ _ "{(x, y). x \<preceq> y}"]
      by (auto intro: finite_quotient surj_card_le[where f = id])
    also have "\<dots> < length as"
      by (rule assms)
    finally have "card (set ?as) < length ?as"
      by simp
    then have "\<not> distinct ?as"
      using distinct_card[of ?as] by auto
    then obtain a b as' ys cs' where "as = as' @ a # ys @ b # cs'" "a \<preceq> b"
      using that
      by (clarsimp simp: map_eq_append_conv map_eq_Cons_conv dest!: not_distinct_decomp) blast
    then show ?thesis
      using that[where a = a and b = b] \<open>subseq as xs\<close>
      by (simp add: append_subseq_iff Cons_subseq_iff) (metis append.assoc)
  qed
  have "A.steps (x # as' @ [a])" "A.steps (a # ys @ [b])"
  proof -
    from assms(1) * show "A.steps (x # as' @ [a])"
      using A.steps_appendD1 by auto
    from * have "as' @ (a # ys) @ b # cs' = xs"
        by simp
    have "b # cs' \<noteq> [] \<and> a # ys \<noteq> [] \<or> (a # ys) @ b # cs' \<noteq> [] \<and> \<not> A.steps ((a # ys) @ b # cs')
        \<or> A.steps ((a # ys) @ [b])"
      by blast
    with \<open>_ = xs\<close> assms(1) have "A.steps ((a # ys) @ [b])"
      by (metis (no_types) A.Single A.steps_ConsD A.steps_append_single A.steps_decomp
          Nil_is_append_conv list.sel(1) self_append_conv2)
    then show "A.steps (a # ys @ [b])"
      by simp
  qed
  with \<open>P x\<close> have "P a" "P b"
    by (auto 4 3 dest: PA_invariant.invariant_steps)
  from pre_cycle_infinite_cycle[OF \<open>A.steps (a # ys @ [b])\<close> \<open>a \<preceq> b\<close> this] obtain w where
    "A.run (a ## w)" "stream_all2 (\<preceq>) (cycle (a # ys)) (a ## w)" .
  from this(2) have "infs ((\<preceq>) a) (a ## w)"
    by (smt alw_ev_lockstep infs_cycle list.distinct(1) list.set_intros(1) sim_reflI sim_transD)
  then have "infs \<phi> (as' @- a ## w)"
    using assms(5) \<open>a \<in> set as\<close> unfolding \<open>xs = as' @ _\<close> apply simp
    using assms(6) by (elim infs_mono[rotated]) blast
  moreover from \<open>A.run _\<close> \<open>A.steps (x # as' @ [a])\<close> have "A.run (x ## as' @- a ## w)"
    by (metis A.extend_run A.steps_decomp append_Cons list.distinct(1) list.sel(1,3)
          shift_simps stream.exhaust stream.sel)
  ultimately show ?thesis
    by (rule that[rotated])
qed

end

subsection \<open>Combining Finite Simulation with Backward Simulation\<close>
text \<open>Here, \<open>\<preceq>\<close> is any time-abstract simulation \<open>\<preceq>\<close>, and \<open>\<preceq>'\<close> corresponds to \<open>\<equiv>\<^sub>M\<close>.\<close>

locale Backward_Double_Simulation = Backward_Simulation where E = E and sim = sim +
  finite: Self_Simulation_Finite where E = E and sim = sim'
  for E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and sim (infix "\<preceq>" 60) and sim' (infix "\<preceq>''" 60)
begin

text \<open>Corresponds to lemma 12 of @{cite "Li:FORMATS:2009"}.\<close>
lemma cycle_Buechi_run:
  assumes "steps (A # As @ [A])" "a \<in> A" "\<forall>a \<in> A. P a" "\<forall>a \<in> A. \<phi> a"
    "\<forall>x y. x \<preceq> y \<and> x \<in> A \<and> \<phi> x \<longrightarrow> \<phi> y" "\<forall>x y. x \<preceq>' y \<and> \<phi> x \<longrightarrow> \<phi> y"
  obtains x xs where "A.run (x ## xs)" "infs \<phi> xs" "x \<in> A"
proof -
  let ?n = "card (UNIV // {(x, y). x \<preceq>' y}) + 1"
  from steps_repeat[OF assms(1,2,4-5), where n = ?n] obtain x y as ys where *:
    "subseq as ys" "list_all \<phi> as" "A.steps (x # ys @ [y])"
    "length as = ?n" "a \<preceq> y" "x \<in> A" .
  with assms(4) have "\<forall>x \<in> set as. \<phi> x"
    by (auto simp: list_all_iff)
  with * assms(3,6) obtain w where "A.run (x ## w)" "infs \<phi> w"
    by - (erule finite.steps_cycle_run[where \<phi> = \<phi>], auto)
  then show ?thesis
    using \<open>x \<in> A\<close> by (elim that) simp
qed

end

lemma (in Simulation_Invariant) simulation_run':
  assumes "A.run (x ## xs)" "x \<sim> y" "PA x" "PB y"
  shows "\<exists>ys. B.run (y ## ys) \<and> stream_all2 (\<lambda>a b. a \<sim> b \<and> PA a \<and> PB b) xs ys"
  using simulation_run assms unfolding equiv'_def by blast

(* XXX Move to graph library *)
context Graph_Invariant_Start
begin

lemma reachable_reaches_equiv: "G'.reaches x y \<longleftrightarrow> x \<rightarrow>* y" if "reachable x" for x y
  using invariant_reaches invariant_reaches_iff reachable_def that by auto

lemma reachable_reaches1_equiv: "G'.reaches1 x y \<longleftrightarrow> x \<rightarrow>\<^sup>+ y" if "reachable x" for x y
  using invariant_reaches invariant_reaches1_iff reachable_def that by auto

lemma reachable_steps_equiv:
  "G'.steps (x # xs) \<longleftrightarrow> steps (x # xs)" if "reachable x"
  using invariant_reaches invariant_steps_iff reachable_def that by auto

lemma reachable_run_equiv:
  "G'.run (x ## xs) \<longleftrightarrow> run (x ## xs)" if "reachable x"
  \<comment> \<open>This proof is bit clumsy due to the name clash for \<open>invariant_run\<close>\<close>
  by (metis reaches_steps_iff Graph_Invariant.invariant_run Graph_Invariant_axioms
        invariant_reaches reachable_steps subgraph_run_iff that)

lemmas invariant_subgraph_equivs =
  reachable_reaches_equiv reachable_reaches1_equiv reachable_steps_equiv reachable_run_equiv

end

text \<open>Adding the assumption that the abstracted zone graph is finite and complete.\<close>
locale Backward_Double_Simulation_Complete =
  A: Graph_Defs E + G: Graph_Defs G + G_inv: Graph_Defs "\<lambda>x y. G x y \<and> Q x \<and> Q y" +
  backward: Backward_Double_Simulation where E = E and G = "\<lambda>x y. G x y \<and> Q x \<and> Q y" +
  complete: Simulation_Invariant where A = E and B = G and PA = P and PB = Q and sim = "(\<in>)" +
  Finite_Graph where E = G and x\<^sub>0 = a\<^sub>0 +
  Graph_Invariant where E = G and P = Q
  for E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and G :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" and a\<^sub>0 and Q +
  assumes Q_P: "Q a \<Longrightarrow> \<forall>x \<in> a. P x" and a\<^sub>0_invariant: "Q a\<^sub>0"
begin

sublocale G: Graph_Invariant_Start where E = G and P = Q and s\<^sub>0 = a\<^sub>0
  by (standard) (rule a\<^sub>0_invariant)

lemmas G_invariant_subgraph_equivs =
  G.invariant_subgraph_equivs[unfolded complete.PB_invariant.E'_def]

text \<open>Corresponds to theorem 1 of @{cite "Li:FORMATS:2009"}.\<close>
theorem Buechi_run_lasso_iff:
  assumes
    "\<forall>x y. x \<preceq>' y \<and> \<phi> x \<longrightarrow> \<phi> y"
    "\<forall>x y. x \<preceq> y  \<and> \<phi> x \<longrightarrow> \<phi> y"
    "\<forall>x y A. G.reaches a\<^sub>0 A \<and> x \<in> A \<and> y \<in> A \<and> \<phi> x \<longrightarrow> \<phi> y"
  shows
    "(\<exists>x\<^sub>0 xs. x\<^sub>0 \<in> a\<^sub>0 \<and> A.run (x\<^sub>0 ## xs) \<and> infs \<phi> (x\<^sub>0 ## xs))
    \<longleftrightarrow> (\<exists>as a bs. G.steps (a\<^sub>0 # as @ a # bs @ [a]) \<and> (\<forall>x \<in> a. \<phi> x) \<and> a \<noteq> {})"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain x\<^sub>0 xs where "x\<^sub>0 \<in> a\<^sub>0" "A.run (x\<^sub>0 ## xs)" "infs \<phi> xs"
    by auto
  have backward_reaches_A: "G.reaches a\<^sub>0 A" if "G_inv.reaches a\<^sub>0 A" for A
    using that by (simp add: G_invariant_subgraph_equivs[symmetric])
  from complete.simulation_run'[OF \<open>A.run _\<close> \<open>x\<^sub>0 \<in> _\<close>] a\<^sub>0_invariant \<open>x\<^sub>0 \<in> a\<^sub>0\<close> obtain as where
    "G.run (a\<^sub>0 ## as)" "stream_all2 (\<lambda>a b. a \<in> b \<and> P a \<and> Q b) xs as"
    by (auto dest: Q_P)
  from \<open>G.run (a\<^sub>0 ## as)\<close> have "G_inv.run (a\<^sub>0 ## as)"
    by (simp add: G_invariant_subgraph_equivs)
  from \<open>infs \<phi> _\<close> \<open>stream_all2 _ _ _\<close> have "infs (\<lambda>a. \<exists>x \<in> a. \<phi> x) as"
    by (rule alw_ev_lockstep) fast
  then have "infs (\<lambda>a. (\<forall>x \<in> a. \<phi> x) \<and> a \<noteq> {}) as"
    using assms(3) \<open>G_inv.run (a\<^sub>0 ## as)\<close>
    by (auto 4 5 simp: stream.pred_set dest!: G_inv.run_reachable backward_reaches_A
          elim!: infs_mono[rotated])
  with \<open>G.run _\<close> show ?rhs
    apply -
    apply (erule buechi_run_lasso)
     apply (simp; fail)
    by (metis (lifting)
          G.reaches1_steps_append G.reaches1_steps_iff G.reaches_stepsE G.steps_reaches1 list.sel(1))
next
  assume ?rhs
  then obtain as a x bs where "G.steps (a\<^sub>0 # as @ a # bs @ [a])" "\<forall>x \<in> a. \<phi> x" "x \<in> a"
    by auto
  then have "G.reaches a\<^sub>0 a" "G.reaches1 a\<^sub>0 a"
    apply -
    subgoal A
      by (smt G.steps_reaches append_Cons last_appendR last_snoc list.sel(1))
    subgoal
      by (metis A G.steps_ConsD G.steps_appendD2 G.steps_reaches1
            append_is_Nil_conv list.distinct(1) rtranclpD)
    done
  moreover from \<open>G.steps (a\<^sub>0 # as @ a # bs @ [a])\<close> have "G.steps (a # bs @ [a])"
    by (metis append_is_Nil_conv list.distinct(1) G.steps_ConsD G.steps_appendD2)
  ultimately have "G_inv.reaches1 a\<^sub>0 a" "G_inv.steps (a # bs @ [a])"
    by (simp add: G_invariant_subgraph_equivs G.reachable_def)+
  from \<open>G.reaches a\<^sub>0 a\<close> a\<^sub>0_invariant have "Q a"
    by (rule complete.PB_invariant.invariant_reaches)
  with assms(1,2) \<open>G.reaches _ _\<close> \<open>\<forall>x \<in> a. \<phi> x\<close> obtain x xs where
    "A.run (x ## xs)" "infs \<phi> xs" "x \<in> a"
    by - (rule backward.cycle_Buechi_run[OF \<open>G_inv.steps (a # bs @ [a])\<close> \<open>x \<in> a\<close>, where \<phi> = \<phi>],
          (blast dest: Q_P)+)
  from backward.backward_simulation_reaches1[OF \<open>G_inv.reaches1 a\<^sub>0 a\<close> \<open>x \<in> a\<close>] obtain x\<^sub>0 x' where
    "x\<^sub>0 \<in> a\<^sub>0" "x \<preceq> x'" "x\<^sub>0 \<rightarrow>\<^sup>+ x'"
    by auto
  then obtain ys where "A.steps (x\<^sub>0 # ys @ [x'])"
    using A.reaches1_steps_iff by auto
  from backward.simulation_run[OF \<open>A.run _\<close> \<open>x \<preceq> x'\<close>] obtain xs' where
    "A.run (x' ## xs')" "stream_all2 (\<preceq>) xs xs'"
    by (elim conjE exE)
  with \<open>A.steps _\<close> have "A.run (x\<^sub>0 ## ys @- x' ## xs')"
    by (metis A.extend_run A.steps_decomp
          append_Cons list.distinct(1) list.sel(1,3) shift_simps(1,2) stream.collapse)
  moreover from \<open>infs _ _\<close> \<open>stream_all2 _ _ _\<close> assms(2) have "infs \<phi> xs'"
    by (auto elim!: alw_ev_lockstep)
  ultimately show ?lhs
    using \<open>x\<^sub>0 \<in> a\<^sub>0\<close> by auto
qed

end

end (* Theory *)


theory Hnr_Fallback
  imports Hnr_Base
begin

lemma hnr_fallback:
  assumes
    "\<And>h. h \<Turnstile> \<Gamma> \<Longrightarrow> c = ci"
  shows
    "hnr \<Gamma> (return ci) (\<lambda>r ri. \<Gamma> * id_assn r ri) (Some c)"
  apply(rule hnrI)
  apply(rule hoare_triple_preI)
  using assms
  by(sep_auto simp: id_rel_def)

method extract_pre uses rule =
  (determ\<open>elim mod_starE rule[elim_format]\<close>)?

lemma models_id_assn:"h \<Turnstile> id_assn x xi \<Longrightarrow> x = xi"
  by(simp add: id_rel_def)

(* TODO: This just works for non-refined fallbacks *)
method hnr_fallback =
  rule hnr_fallback,
  extract_pre rule: models_id_assn,
  ((hypsubst, rule refl) | (simp(no_asm_simp) only: ; fail))

end


text_raw \<open>\section[Particular Structures]{Particular Structures\isalabel{sec:particular-structures}}\<close>

theory ParticularStructure
  imports "../Particulars/Particulars"
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  In this chapter, we present a category of UFO particular structures, whose
  objects are Isabelle/HOL records that encode a model of the UFO theory of
  particulars presented in \autoref{cha:simplified-ufo-theory}.

  The record that encodes a particular structure is defined as follows:
\<close>

record ('p,'q) particular_struct =
  ps_quality_spaces :: \<open>'q set set\<close>
  ps_worlds :: \<open>'p set set\<close>
  ps_inheres_in :: \<open>'p \<Rightarrow> 'p \<Rightarrow> bool\<close>
  ps_assoc_quale :: \<open>'p \<Rightarrow> 'q \<Rightarrow> bool\<close>
  ps_towards :: \<open>'p \<Rightarrow> 'p \<Rightarrow> bool\<close>

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The six fields of the particular structure record represent the formal elements of the
  UFO particular theory:
  \begin{itemize}
  \item \texttt{ps\_worlds}: The set of possible worlds (\<open>\<W>\<close>)
  \item \texttt{ps\_inheres\_in}: The inherence relationship (\<open>\<triangleleft>\<close>)
  \item \texttt{ps\_quality\_spaces}: The set of quality spaces (\<open>\<Q>\<S>\<close>)
  \item \texttt{ps\_assoc\_quale}: The relationship of quale association (\<open>\<leadsto>\<close>)
  \item \texttt{ps\_towards}: The towardness relation (\<open>\<longlongrightarrow>\<close>)
  \end{itemize}
\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> particular_struct_eqI[intro!]:
  fixes M\<^sub>1 M\<^sub>2 :: \<open>('p,'q) particular_struct\<close>
  assumes
    \<open>ps_quality_spaces M\<^sub>1 = ps_quality_spaces M\<^sub>2\<close>
    \<open>ps_worlds M\<^sub>1 = ps_worlds M\<^sub>2\<close>
    \<open>ps_inheres_in M\<^sub>1 = ps_inheres_in M\<^sub>2\<close>
    \<open>ps_assoc_quale M\<^sub>1 = ps_assoc_quale M\<^sub>2\<close>
    \<open>ps_towards M\<^sub>1 = ps_towards M\<^sub>2\<close>
  shows \<open>M\<^sub>1 = M\<^sub>2\<close>
  using assms by auto

locale particular_struct_sig =
  fixes
    \<Gamma> :: \<open>('p,'q) particular_struct\<close> and
    Typ\<^sub>p :: \<open>'p itself\<close> and
    Typ\<^sub>q :: \<open>'q itself\<close>

context particular_struct_sig
begin

abbreviation \<^marker>\<open>tag aponly\<close> \<open>\<W> \<equiv> ps_worlds \<Gamma>\<close>

abbreviation \<^marker>\<open>tag aponly\<close> inheresIn (infix \<open>\<triangleleft>\<close> 75) where
  \<open>inheresIn \<equiv> ps_inheres_in \<Gamma>\<close>

abbreviation \<^marker>\<open>tag aponly\<close> assoc_quale (infix \<open>\<leadsto>\<close> 75) where
  \<open>assoc_quale \<equiv> ps_assoc_quale \<Gamma>\<close>

abbreviation \<^marker>\<open>tag aponly\<close> towards (infix \<open>\<longlongrightarrow>\<close> 75) where
  \<open>(\<longlongrightarrow>) \<equiv> ps_towards \<Gamma>\<close>

abbreviation \<^marker>\<open>tag aponly\<close> \<open>\<Q>\<S> \<equiv> ps_quality_spaces \<Gamma>\<close>

end

definition \<^marker>\<open>tag aponly\<close> (in ufo_particular_theory_sig) \<Gamma>
  :: \<open>('p,'q) particular_struct\<close> where
  \<open>\<Gamma> \<equiv> \<lparr>
      ps_quality_spaces = \<Q>\<S>,
      ps_worlds = \<W>,
      ps_inheres_in = inheresIn,
      ps_assoc_quale = assoc_quale,
      ps_towards = towards
   \<rparr>\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> (in ufo_particular_theory_sig)
    \<Gamma>_simps[simp]:
  \<open>ps_quality_spaces \<Gamma> = \<Q>\<S>\<close>
  \<open>ps_worlds \<Gamma> = \<W>\<close>
  \<open>ps_inheres_in \<Gamma> = inheresIn\<close>
  \<open>ps_assoc_quale \<Gamma> = assoc_quale\<close>
  \<open>ps_towards \<Gamma> = towards\<close>
  using \<Gamma>_def by auto

locale particular_struct_defs =
    particular_struct_sig
      where Typ\<^sub>p = \<open>Typ\<^sub>p\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close> +
    ufo_particular_theory_sig where
      \<Q>\<S> = \<open>\<Q>\<S>\<close> and
      \<W> = \<open>\<W>\<close> and
      inheresIn = \<open>inheresIn\<close> and
      assoc_quale = \<open>assoc_quale\<close> and
      towards = \<open>towards\<close> and
      Typ\<^sub>p = \<open>Typ\<^sub>p\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close>
  for
    Typ\<^sub>p :: \<open>'p itself\<close> and
    Typ\<^sub>q :: \<open>'q itself\<close>

locale particular_struct =
    particular_struct_defs where
      Typ\<^sub>p = \<open>Typ\<^sub>p\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close>  +
    ufo_particular_theory where
      \<Q>\<S> = \<open>\<Q>\<S>\<close> and
      \<W> = \<open>\<W>\<close> and
      inheresIn = \<open>inheresIn\<close> and
      assoc_quale = \<open>assoc_quale\<close> and
      towards = \<open>towards\<close> and
      Typ\<^sub>p = \<open>Typ\<^sub>p\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close>
  for
    Typ\<^sub>p :: \<open>'p itself\<close> and
    Typ\<^sub>q :: \<open>'q itself\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> ufo_theory_and_particular_struct_eq[simp]:
  fixes
    \<W> \<Q>\<S> assoc_quale
    universal_qualia_set inheresIn
    charSet towards
  shows
    \<open>particular_struct (
        ufo_particular_theory_sig.\<Gamma>
          \<W> inheresIn \<Q>\<S> assoc_quale towards) \<longleftrightarrow>
     ufo_particular_theory
          \<W> inheresIn \<Q>\<S> assoc_quale towards
     \<close>
    (is \<open>?B \<longleftrightarrow> ?A\<close>)
proof -
  note S = ufo_particular_theory_sig.\<Gamma>_simps
  show \<open>?thesis\<close>
  proof
    assume \<open>?A\<close>
    then interpret
        ufo_particular_theory \<open>\<W>\<close> \<open>inheresIn\<close>
           \<open>\<Q>\<S>\<close> \<open>assoc_quale\<close> \<open>towards\<close> by simp
    show \<open>?B\<close>
      apply (intro_locales ; simp only: S)
      subgoal
        by (simp add: possible_worlds_axioms)
      subgoal
        by (simp add: inherence_base.axioms(2)
                  inherence_base_axioms)
      subgoal
        by (simp add: noetherian_inherence_axioms_def)
      subgoal
        by (simp add: inherence_axioms_def)
      subgoal
        by (simp add: quality_space_axioms)
      subgoal
        by (simp add: qualified_particulars.axioms(3)
                qualified_particulars_axioms)
      subgoal
        using towardness_axioms towardness_def
        by blast
      using just_ufo_particular_theory_axioms
            ufo_particular_theory_axioms_def
      by blast
  next
    assume \<open>?B\<close>
    then interpret particular_struct
      \<open>ufo_particular_theory_sig.\<Gamma>
        \<W> inheresIn \<Q>\<S> assoc_quale towards\<close>
      by simp
    show \<open>?A\<close>
      using ufo_particular_theory_axioms
      by (simp only: S)
  qed
qed

context ufo_particular_theory
begin

lemma \<^marker>\<open>tag (proof) aponly\<close> particular_struct_valid[intro!,simp]: \<open>particular_struct \<Gamma>\<close>
  using ufo_theory_and_particular_struct_eq
        ufo_particular_theory_axioms
  by simp

end

abbreviation \<^marker>\<open>tag aponly\<close> \<open>particulars \<Gamma> \<equiv>
  possible_worlds_sig.\<P> (ps_worlds \<Gamma>)\<close>

end


(*<*)
theory SyntaxL
  imports Syntax IVSubst
begin
  (*>*)

chapter \<open>Syntax Lemmas\<close>

section \<open>Support, lookup and contexts\<close>

lemma supp_v_tau [simp]:
  assumes "atom z \<sharp> v"
  shows "supp (\<lbrace> z : b | CE_val (V_var z)  ==  CE_val v  \<rbrace>) = supp v \<union> supp b"
  using assms \<tau>.supp c.supp ce.supp
  by (simp add: fresh_def supp_at_base)

lemma supp_v_var_tau [simp]:
  assumes "z \<noteq> x"
  shows  "supp (\<lbrace> z : b | CE_val (V_var z)  ==  CE_val (V_var x)  \<rbrace>) = { atom x } \<union> supp b"
  using supp_v_tau assms
  using supp_at_base by fastforce

text \<open> Sometimes we need to work with a version of a binder where the variable is fresh
in something else, such as  a bigger context. I think these could be generated automatically \<close>

lemma obtain_fresh_fun_def:
  fixes t::"'b::fs"
  shows  "\<exists>y::x. atom y \<sharp> (s,c,\<tau>,t) \<and> (AF_fundef f (AF_fun_typ_none (AF_fun_typ x b c \<tau> s))  = AF_fundef f (AF_fun_typ_none (AF_fun_typ y b ((y \<leftrightarrow> x) \<bullet> c ) ((y \<leftrightarrow> x) \<bullet> \<tau>) ((y \<leftrightarrow> x) \<bullet> s))))"
proof -
  obtain y::x where y: "atom y \<sharp> (s,c,\<tau>,t)" using obtain_fresh by blast
  moreover have "AF_fundef f (AF_fun_typ_none (AF_fun_typ y b ((y \<leftrightarrow> x) \<bullet> c ) ((y \<leftrightarrow> x) \<bullet> \<tau>) ((y \<leftrightarrow> x) \<bullet> s))) =  (AF_fundef f (AF_fun_typ_none (AF_fun_typ  x b c \<tau> s)))"
  proof(cases "x=y")
    case True
    then show ?thesis  using fun_def.eq_iff Abs1_eq_iff(3)  flip_commute flip_fresh_fresh fresh_PairD by auto
  next
    case False

    have  "(AF_fun_typ y b ((y \<leftrightarrow> x) \<bullet> c) ((y \<leftrightarrow> x) \<bullet> \<tau>) ((y \<leftrightarrow> x) \<bullet> s)) =(AF_fun_typ x b c \<tau> s)" proof(subst fun_typ.eq_iff, subst Abs1_eq_iff(3))
      show  \<open>(y = x \<and> (((y \<leftrightarrow> x) \<bullet> c, (y \<leftrightarrow> x) \<bullet> \<tau>), (y \<leftrightarrow> x) \<bullet> s) = ((c, \<tau>), s) \<or>
         y \<noteq> x \<and> (((y \<leftrightarrow> x) \<bullet> c, (y \<leftrightarrow> x) \<bullet> \<tau>), (y \<leftrightarrow> x) \<bullet> s) = (y \<leftrightarrow> x) \<bullet> ((c, \<tau>), s) \<and> atom y \<sharp> ((c, \<tau>), s)) \<and>
         b = b\<close> using False flip_commute flip_fresh_fresh fresh_PairD y by auto
    qed
    thus ?thesis by metis
  qed
  ultimately show  ?thesis using y fresh_Pair by metis
qed

lemma lookup_fun_member:
  assumes "Some (AF_fundef f ft) = lookup_fun \<Phi> f"
  shows "AF_fundef f ft \<in> set \<Phi>"
  using assms proof (induct \<Phi>)
  case Nil
  then show ?case by auto
next
  case (Cons a \<Phi>)
  then show ?case using lookup_fun.simps
    by (metis fun_def.exhaust insert_iff list.simps(15) option.inject)
qed

lemma rig_dom_eq:
  "dom (G[x \<longmapsto> c]) = dom G"
proof(induct G rule: \<Gamma>.induct)
  case GNil
  then show ?case using replace_in_g.simps by presburger
next
  case (GCons xbc \<Gamma>')
  obtain x' and b' and c' where xbc: "xbc=(x',b',c')" using prod_cases3 by blast
  then show ?case using replace_in_g.simps GCons by simp
qed

lemma lookup_in_rig_eq:
  assumes "Some (b,c) = lookup \<Gamma> x"
  shows "Some (b,c') = lookup (\<Gamma>[x\<longmapsto>c']) x"
  using assms proof(induct \<Gamma> rule: \<Gamma>_induct)
  case GNil
  then show ?case by auto
next
  case (GCons x b c \<Gamma>')
  then show ?case using replace_in_g.simps lookup.simps by auto
qed

lemma lookup_in_rig_neq:
  assumes "Some (b,c) = lookup \<Gamma> y" and "x\<noteq>y"
  shows "Some (b,c) = lookup (\<Gamma>[x\<longmapsto>c']) y"
  using assms proof(induct \<Gamma> rule: \<Gamma>_induct)
  case GNil
  then show ?case by auto
next
  case (GCons x' b' c' \<Gamma>')
  then show ?case using replace_in_g.simps lookup.simps by auto
qed

lemma lookup_in_rig:
  assumes "Some (b,c) = lookup \<Gamma> y"
  shows "\<exists>c''. Some (b,c'') = lookup (\<Gamma>[x\<longmapsto>c']) y"
proof(cases "x=y")
  case True
  then show ?thesis using lookup_in_rig_eq using assms by blast
next
  case False
  then show ?thesis using lookup_in_rig_neq using assms by blast
qed

lemma lookup_inside[simp]:
  assumes "x \<notin> fst ` toSet \<Gamma>'"
  shows "Some (b1,c1) = lookup (\<Gamma>'@(x,b1,c1)#\<^sub>\<Gamma>\<Gamma>) x"
  using assms by(induct \<Gamma>',auto)

lemma lookup_inside2:
  assumes "Some (b1,c1) = lookup (\<Gamma>'@((x,b0,c0)#\<^sub>\<Gamma>\<Gamma>)) y" and "x\<noteq>y"
  shows "Some (b1,c1) = lookup (\<Gamma>'@((x,b0,c0')#\<^sub>\<Gamma>\<Gamma>)) y"
  using assms by(induct \<Gamma>' rule: \<Gamma>.induct,auto+)

fun tail:: "'a list \<Rightarrow> 'a list" where
  "tail [] = []"
| "tail (x#xs) = xs"

lemma lookup_options:
  assumes "Some (b,c) = lookup (xt#\<^sub>\<Gamma>G) x"
  shows  "((x,b,c) = xt) \<or> (Some (b,c) = lookup G x)"
  by (metis assms lookup.simps(2) option.inject surj_pair)

lemma lookup_x:
  assumes "Some (b,c) = lookup G x"
  shows "x \<in> fst ` toSet G"
  using assms
  by(induct "G" rule: \<Gamma>.induct ,auto+)

lemma GCons_eq_appendI:
  fixes xs1::\<Gamma>
  shows "[| x #\<^sub>\<Gamma> xs1 = ys; xs = xs1 @ zs |] ==> x #\<^sub>\<Gamma> xs = ys @ zs"
  by (drule sym) simp

lemma split_G: "x : toSet xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x #\<^sub>\<Gamma> zs"
proof (induct xs)
  case GNil thus ?case by simp
next
  case GCons thus ?case using  GCons_eq_appendI
    by (metis Un_iff append_g.simps(1) singletonD toSet.simps(2))
qed

lemma lookup_not_empty:
  assumes "Some \<tau> = lookup G x"
  shows "G \<noteq> GNil"
  using assms by auto

lemma lookup_in_g:
  assumes "Some (b,c) = lookup \<Gamma> x"
  shows "(x,b,c) \<in> toSet \<Gamma>"
  using assms apply(induct \<Gamma>, simp)
  using lookup_options by fastforce

lemma lookup_split:
  fixes \<Gamma>::\<Gamma>
  assumes "Some (b,c) = lookup \<Gamma> x"
  shows "\<exists>G G' . \<Gamma> =  G'@(x,b,c)#\<^sub>\<Gamma>G"
  by (meson assms(1) lookup_in_g split_G)

lemma toSet_splitU[simp]:
  "(x',b',c') \<in> toSet (\<Gamma>' @ (x, b, c) #\<^sub>\<Gamma> \<Gamma>) \<longleftrightarrow> (x',b',c') \<in> (toSet \<Gamma>' \<union> {(x, b, c)} \<union> toSet \<Gamma>)"
  using append_g_toSetU toSet.simps by auto

lemma toSet_splitP[simp]:
  "(\<forall>(x', b', c')\<in>toSet (\<Gamma>' @ (x, b, c) #\<^sub>\<Gamma> \<Gamma>). P x' b' c') \<longleftrightarrow> (\<forall> (x', b', c')\<in>toSet \<Gamma>'. P x' b' c') \<and> P x b c \<and> (\<forall> (x', b', c')\<in>toSet \<Gamma>. P x' b' c')"  (is "?A \<longleftrightarrow> ?B")
  using toSet_splitU by force

lemma lookup_restrict:
  assumes "Some (b',c') = lookup (\<Gamma>'@(x,b,c)#\<^sub>\<Gamma>\<Gamma>) y" and "x \<noteq> y"
  shows "Some (b',c') = lookup (\<Gamma>'@\<Gamma>) y"
  using assms  proof(induct \<Gamma>' rule:\<Gamma>_induct)
  case GNil
  then show ?case by auto
next
  case (GCons x1 b1 c1 \<Gamma>')
  then show ?case by auto
qed

lemma supp_list_member:
  fixes x::"'a::fs" and l::"'a list"
  assumes "x \<in> set l"
  shows "supp x \<subseteq> supp l"
  using assms apply(induct l, auto)
  using supp_Cons by auto

lemma GNil_append:
  assumes "GNil = G1@G2"
  shows "G1 = GNil \<and> G2 = GNil"
proof(rule ccontr)
  assume "\<not> (G1 = GNil \<and> G2 = GNil)"
  hence "G1@G2 \<noteq> GNil" using append_g.simps   by (metis \<Gamma>.distinct(1) \<Gamma>.exhaust)
  thus False using assms by auto
qed

lemma GCons_eq_append_conv:
  fixes xs::\<Gamma>
  shows "x#\<^sub>\<Gamma>xs = ys@zs = (ys = GNil \<and> x#\<^sub>\<Gamma>xs = zs \<or> (\<exists>ys'. x#\<^sub>\<Gamma>ys' = ys \<and> xs = ys'@zs))"
  by(cases ys) auto

lemma dclist_distinct_unique:
  assumes  "(dc, const) \<in> set dclist2" and  "(cons, const1) \<in> set dclist2" and "dc=cons" and  "distinct (List.map fst dclist2)"
  shows "(const) = const1"
proof -
  have  "(cons, const) = (dc, const1)"
    using assms     by (metis (no_types, lifting) assms(3) assms(4) distinct.simps(1) distinct.simps(2) empty_iff insert_iff list.set(1) list.simps(15) list.simps(8) list.simps(9) map_of_eq_Some_iff)
  thus ?thesis by auto
qed

lemma fresh_d_fst_d:
  assumes "atom u \<sharp> \<delta>"
  shows  "u \<notin> fst ` set \<delta>"
  using assms proof(induct \<delta>)
  case Nil
  then show ?case by auto
next
  case (Cons ut \<delta>')
  obtain u' and t' where *:"ut = (u',t') " by fastforce
  hence "atom u \<sharp> ut \<and> atom u \<sharp> \<delta>'" using fresh_Cons Cons by auto
  moreover hence "atom u \<sharp> fst ut" using * fresh_Pair[of "atom u" u' t'] Cons by auto
  ultimately show ?case using Cons by auto
qed

lemma bv_not_in_bset_supp:
  fixes bv::bv
  assumes "bv |\<notin>| B"
  shows "atom bv \<notin> supp B"
proof -
  have *:"supp B = fset (fimage atom B)"
    by (metis fimage.rep_eq finite_fset supp_finite_set_at_base supp_fset)
  thus ?thesis using assms
    using notin_fset by fastforce
qed

lemma u_fresh_d:
  assumes "atom u \<sharp> D"
  shows "u \<notin> fst ` setD D"
  using assms proof(induct D rule: \<Delta>_induct)
  case DNil
  then show ?case by auto
next
  case (DCons u' t' \<Delta>')
  then show ?case unfolding setD.simps
    using fresh_DCons fresh_Pair  by (simp add: fresh_Pair fresh_at_base(2))
qed

section \<open>Type Definitions\<close>

lemma exist_fresh_bv:
  fixes tm::"'a::fs"
  shows  "\<exists>bva2 dclist2. AF_typedef_poly tyid bva dclist = AF_typedef_poly tyid bva2 dclist2 \<and>
             atom bva2 \<sharp> tm"
proof -
  obtain bva2::bv where *:"atom bva2 \<sharp> (bva, dclist,tyid,tm)" using obtain_fresh by metis
  moreover hence "bva2 \<noteq> bva" using fresh_at_base by auto
  moreover have " dclist = (bva \<leftrightarrow> bva2) \<bullet> (bva2 \<leftrightarrow> bva) \<bullet> dclist" by simp
  moreover have "atom bva \<sharp> (bva2 \<leftrightarrow> bva) \<bullet> dclist" proof -
    have "atom bva2 \<sharp> dclist" using * fresh_prodN by auto
    hence "atom ((bva2 \<leftrightarrow> bva) \<bullet> bva2) \<sharp> (bva2 \<leftrightarrow> bva) \<bullet> dclist" using fresh_eqvt True_eqvt
    proof -
      have "(bva2 \<leftrightarrow> bva) \<bullet> atom bva2 \<sharp> (bva2 \<leftrightarrow> bva) \<bullet> dclist"
        by (metis True_eqvt \<open>atom bva2 \<sharp> dclist\<close> fresh_eqvt) (* 62 ms *)
      then show ?thesis
        by simp (* 125 ms *)
    qed
    thus ?thesis by auto
  qed
  ultimately have "AF_typedef_poly tyid bva dclist = AF_typedef_poly tyid bva2 ((bva2 \<leftrightarrow> bva ) \<bullet> dclist)"
    unfolding type_def.eq_iff   Abs1_eq_iff by metis
  thus ?thesis using * fresh_prodN by metis
qed

lemma obtain_fresh_bv:
  fixes tm::"'a::fs"
  obtains bva2::bv and  dclist2 where "AF_typedef_poly tyid bva dclist = AF_typedef_poly tyid bva2 dclist2 \<and>
             atom bva2 \<sharp> tm"
  using exist_fresh_bv by metis

section \<open>Function Definitions\<close>

lemma fun_typ_flip:
  fixes bv1::bv and c::bv
  shows   "(bv1 \<leftrightarrow> c) \<bullet> AF_fun_typ x1 b1 c1 \<tau>1 s1 = AF_fun_typ x1 ((bv1 \<leftrightarrow> c) \<bullet> b1) ((bv1 \<leftrightarrow> c) \<bullet> c1) ((bv1 \<leftrightarrow> c) \<bullet> \<tau>1) ((bv1 \<leftrightarrow> c) \<bullet> s1)"
  using fun_typ.perm_simps flip_fresh_fresh supp_at_base  fresh_def
    flip_fresh_fresh fresh_def supp_at_base
  by (simp add: flip_fresh_fresh)

lemma fun_def_eq:
  assumes  "AF_fundef fa (AF_fun_typ_none (AF_fun_typ xa ba ca \<tau>a sa)) = AF_fundef f (AF_fun_typ_none (AF_fun_typ x b c \<tau> s))"
  shows "f = fa" and "b = ba" and "[[atom xa]]lst. sa = [[atom x]]lst. s" and "[[atom xa]]lst. \<tau>a = [[atom x]]lst. \<tau>" and
    " [[atom xa]]lst. ca = [[atom x]]lst. c"
  using fun_def.eq_iff fun_typ_q.eq_iff fun_typ.eq_iff lst_snd lst_fst  using assms apply metis
  using fun_def.eq_iff fun_typ_q.eq_iff fun_typ.eq_iff lst_snd lst_fst  using assms apply metis
proof -
  have "([[atom xa]]lst. ((ca, \<tau>a), sa) = [[atom x]]lst. ((c, \<tau>), s))" using assms  fun_def.eq_iff fun_typ_q.eq_iff  fun_typ.eq_iff by auto
  thus "[[atom xa]]lst. sa = [[atom x]]lst. s" and "[[atom xa]]lst. \<tau>a = [[atom x]]lst. \<tau>" and
    " [[atom xa]]lst. ca = [[atom x]]lst. c" using lst_snd lst_fst by metis+
qed

lemma fun_arg_unique_aux:
  assumes "AF_fun_typ x1 b1 c1 \<tau>1' s1' = AF_fun_typ x2 b2 c2 \<tau>2' s2'"
  shows "\<lbrace> x1 : b1 | c1 \<rbrace> = \<lbrace> x2 : b2 | c2\<rbrace>"
proof -
  have " ([[atom x1]]lst. c1 = [[atom x2]]lst. c2)" using fun_def_eq assms by metis
  moreover have "b1 = b2" using fun_typ.eq_iff assms  by metis
  ultimately show ?thesis using \<tau>.eq_iff by fast
qed

lemma fresh_x_neq:
  fixes x::x and y::x
  shows "atom x \<sharp> y = (x \<noteq> y)"
  using fresh_at_base  fresh_def by auto

lemma obtain_fresh_z3:
  fixes tm::"'b::fs"
  obtains z::x where "\<lbrace> x : b  | c \<rbrace> =  \<lbrace> z : b  | c[x::=V_var z]\<^sub>c\<^sub>v \<rbrace> \<and>  atom z \<sharp> tm \<and> atom z \<sharp> (x,c)"
proof -
  obtain z::x and c'::c where z:"\<lbrace> x : b  | c \<rbrace> =  \<lbrace> z : b | c' \<rbrace> \<and>  atom z \<sharp> (tm,x,c)" using obtain_fresh_z2 b_of.simps by metis
  hence "c' = c[x::=V_var z]\<^sub>c\<^sub>v" proof -
    have "([[atom z]]lst. c' = [[atom x]]lst. c)" using z \<tau>.eq_iff by metis
    hence "c' = (z \<leftrightarrow> x) \<bullet> c" using Abs1_eq_iff[of z c' x c]  fresh_x_neq  fresh_prodN by fastforce
    also have "... = c[x::=V_var z]\<^sub>c\<^sub>v"
      using subst_v_c_def  flip_subst_v[of z c x] z fresh_prod3 by metis
    finally show ?thesis by auto
  qed
  thus ?thesis using z fresh_prodN that by metis
qed

lemma u_fresh_v:
  fixes u::u and t::v
  shows "atom u \<sharp> t"
  by(nominal_induct t rule:v.strong_induct,auto)

lemma u_fresh_ce:
  fixes u::u and t::ce
  shows "atom u \<sharp> t"
  apply(nominal_induct t rule:ce.strong_induct)
  using  u_fresh_v pure_fresh
       apply (auto simp add:  opp.fresh ce.fresh opp.fresh opp.exhaust)
  unfolding ce.fresh opp.fresh opp.exhaust  by (simp add: fresh_opp_all)

lemma u_fresh_c:
  fixes u::u and t::c
  shows "atom u \<sharp> t"
  by(nominal_induct t rule:c.strong_induct,auto simp add: c.fresh u_fresh_ce)

lemma u_fresh_g:
  fixes u::u and t::\<Gamma>
  shows "atom u \<sharp> t"
  by(induct t rule:\<Gamma>_induct, auto simp add: u_fresh_b u_fresh_c  fresh_GCons fresh_GNil)

lemma u_fresh_t:
  fixes u::u and t::\<tau>
  shows "atom u \<sharp> t"
  by(nominal_induct t rule:\<tau>.strong_induct,auto simp add: \<tau>.fresh u_fresh_c u_fresh_b)

lemma b_of_c_of_eq:
  assumes "atom z \<sharp> \<tau>"
  shows "\<lbrace> z : b_of \<tau> |  c_of \<tau> z \<rbrace> = \<tau>"
  using assms proof(nominal_induct \<tau> avoiding: z rule: \<tau>.strong_induct)
  case (T_refined_type x1a x2a x3a)

  hence " \<lbrace> z : b_of \<lbrace> x1a : x2a  | x3a \<rbrace>  | c_of \<lbrace> x1a : x2a  | x3a \<rbrace> z \<rbrace> = \<lbrace> z : x2a | x3a[x1a::=V_var z]\<^sub>c\<^sub>v \<rbrace>"
    using b_of.simps c_of.simps c_of_eq by auto
  moreover have "\<lbrace> z : x2a | x3a[x1a::=V_var z]\<^sub>c\<^sub>v \<rbrace> = \<lbrace> x1a : x2a  | x3a \<rbrace>" using T_refined_type \<tau>.fresh by auto
  ultimately show  ?case by auto
qed

lemma fresh_d_not_in:
  assumes "atom u2 \<sharp> \<Delta>'"
  shows   "u2 \<notin> fst ` setD \<Delta>'"
  using assms proof(induct \<Delta>' rule: \<Delta>_induct)
  case DNil
  then show ?case by simp
next
  case (DCons u t \<Delta>')
  hence *: "atom u2 \<sharp> \<Delta>' \<and> atom u2 \<sharp> (u,t)"
    by (simp add: fresh_def supp_DCons)
  hence "u2 \<notin> fst ` setD \<Delta>'" using DCons by auto
  moreover have "u2 \<noteq> u" using * fresh_Pair
    by (metis eq_fst_iff not_self_fresh)
  ultimately  show ?case by simp
qed

end


section \<open>Soundness for graphical diagrams\<close>

theory Ribbons_Graphical_Soundness imports
  Ribbons_Graphical
  More_Finite_Map
begin

text \<open>We prove that the proof rules for graphical ribbon proofs are sound
  with respect to the rules of separation logic.

  We impose an additional assumption to achieve soundness: that the
  Frame rule has no side-condition. This assumption is reasonable because there
  are several separation logics that lack such a side-condition, such as
  ``variables-as-resource''.

  We first describe how to extract proofchains from a diagram. This process is
  similar to the process of extracting commands from a diagram, which was
  described in @{theory Ribbon_Proofs.Ribbons_Graphical}. When we extract a proofchain, we
  don't just include the commands, but the assertions in between them. Our
  main lemma for proving soundness says that each of these proofchains
  corresponds to a valid separation logic proof.
\<close>

subsection \<open>Proofstate chains\<close>

text \<open>When extracting a proofchain from a diagram, we need to keep track
  of which nodes we have processed and which ones we haven't. A
  proofstate, defined below, maps a node to ``Top'' if it hasn't been
  processed and ``Bot'' if it has.\<close>

datatype topbot = Top | Bot

type_synonym proofstate = "node \<rightharpoonup>\<^sub>f topbot"

text \<open>A proofstate chain contains all the nodes and edges of a graphical
  diagram, interspersed with proofstates that track which nodes have been
  processed at each point.\<close>

type_synonym ps_chain = "(proofstate, node + edge) chain"

text \<open>The @{term "next_ps \<sigma>"} function processes one node or one edge in a
  diagram, given the current proofstate @{term \<sigma>}. It processes a node
  @{term v} by replacing the mapping from @{term v} to @{term Top} with a
  mapping from @{term v} to @{term Bot}. It processes an edge @{term e}
  (whose source and target nodes are @{term vs} and @{term ws} respectively)
  by removing all the mappings from @{term vs} to @{term Bot}, and adding
  mappings from @{term ws} to @{term Top}.\<close>

fun next_ps :: "proofstate \<Rightarrow> node + edge \<Rightarrow> proofstate"
where
  "next_ps \<sigma> (Inl v) = \<sigma> \<ominus> {|v|} ++\<^sub>f [{|v|} |=> Bot]"
| "next_ps \<sigma> (Inr e) = \<sigma> \<ominus> fst3 e ++\<^sub>f [thd3 e |=> Top]"

text \<open>The function @{term "mk_ps_chain \<Pi> \<pi>"} generates from @{term \<pi>}, which
  is a list of nodes and edges, a proofstate chain, by interspersing the
  elements of @{term \<pi>} with the appropriate proofstates. The first argument
  @{term \<Pi>} is the part of the chain that has already been converted.\<close>

definition
  mk_ps_chain :: "[ps_chain, (node + edge) list] \<Rightarrow> ps_chain"
where
  "mk_ps_chain \<equiv> foldl (\<lambda>\<Pi> x. cSnoc \<Pi> x (next_ps (post \<Pi>) x))"

lemma mk_ps_chain_preserves_length:
  fixes \<pi> \<Pi>
  shows "chainlen (mk_ps_chain \<Pi> \<pi>) = chainlen \<Pi> + length \<pi>"
proof (induct \<pi> arbitrary: \<Pi>)
  case Nil
  show ?case by (unfold mk_ps_chain_def, auto)
next
  case (Cons x \<pi>)
  show ?case
  apply (unfold mk_ps_chain_def list.size foldl.simps)
  apply (fold mk_ps_chain_def)
  apply (auto simp add: Cons len_snoc)
  done
qed

text \<open>Distributing @{term mk_ps_chain} over @{term Cons}.\<close>
lemma mk_ps_chain_cons:
  "mk_ps_chain \<Pi> (x # \<pi>) = mk_ps_chain (cSnoc \<Pi> x (next_ps (post \<Pi>) x)) \<pi>"
by (auto simp add: mk_ps_chain_def)

text \<open>Distributing @{term mk_ps_chain} over @{term snoc}.\<close>
lemma mk_ps_chain_snoc:
  "mk_ps_chain \<Pi> (\<pi> @ [x])
    = cSnoc (mk_ps_chain \<Pi> \<pi>) x (next_ps (post (mk_ps_chain \<Pi> \<pi>)) x)"
by (unfold mk_ps_chain_def, auto)

text \<open>Distributing @{term mk_ps_chain} over @{term cCons}.\<close>
lemma mk_ps_chain_ccons:
  fixes \<pi> \<Pi>
  shows "mk_ps_chain (\<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>) \<pi> = \<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> mk_ps_chain \<Pi> \<pi> "
by (induct \<pi> arbitrary: \<Pi>, auto simp add: mk_ps_chain_cons mk_ps_chain_def)

lemma pre_mk_ps_chain:
  fixes \<Pi> \<pi>
  shows "pre (mk_ps_chain \<Pi> \<pi>) = pre \<Pi>"
apply (induct \<pi> arbitrary: \<Pi>)
apply (auto simp add: mk_ps_chain_def mk_ps_chain_cons pre_snoc)
done

text \<open>A chain which is obtained from the list @{term \<pi>}, has @{term \<pi>}
  as its list of commands. The following lemma states this in a slightly
  more general form, that allows for part of the chain to have already
  been processed.\<close>

lemma comlist_mk_ps_chain:
  "comlist (mk_ps_chain \<Pi> \<pi>) = comlist \<Pi> @ \<pi>"
proof (induct \<pi> arbitrary: \<Pi>)
  case Nil
  thus ?case by (auto simp add: mk_ps_chain_def)
next
  case (Cons x \<pi>')
  show ?case
  apply (unfold mk_ps_chain_def foldl.simps, fold mk_ps_chain_def)
  apply (auto simp add: Cons comlist_snoc)
  done
qed

text \<open>In order to perform induction over our diagrams, we shall wish
  to obtain ``smaller'' diagrams, by removing nodes or edges. However, the
  syntax and well-formedness constraints for diagrams are such that although
  we can always remove an edge from a diagram, we cannot (in general) remove
  a node -- the resultant diagram would not be a well-formed if an edge
  connected to that node.

  Hence, we consider ``partially-processed diagrams'' @{term "(G,S)"}, which
  comprise a diagram @{term G} and a set @{term S} of nodes. @{term S} denotes
  the subset of @{term G}'s initial nodes that have already been processed,
  and can be thought of as having been removed from @{term G}.

  We now give an updated version of the @{term "lins G"} function. This was
  originally defined in @{theory Ribbon_Proofs.Ribbons_Graphical}. We provide an extra
  parameter, @{term S}, which denotes the subset of @{term G}'s initial nodes
  that shouldn't be included in the linear extensions.\<close>

definition lins2 :: "[node fset, diagram] \<Rightarrow> lin set"
where
  "lins2 S G \<equiv> {\<pi> :: lin .
    (distinct \<pi>)
  \<and> (set \<pi> = (fset G^V - fset S) <+> set G^E)
  \<and> (\<forall>i j v e. i < length \<pi> \<and> j < length \<pi>
    \<and> \<pi>!i = Inl v \<and> \<pi>!j = Inr e \<and> v |\<in>| fst3 e \<longrightarrow> i<j)
  \<and> (\<forall>j k w e. j < length \<pi> \<and> k < length \<pi>
    \<and> \<pi>!j = Inr e \<and> \<pi>!k = Inl w \<and> w |\<in>| thd3 e \<longrightarrow> j<k) }"

lemma lins2D:
  assumes "\<pi> \<in> lins2 S G"
  shows "distinct \<pi>"
    and "set \<pi> = (fset G^V - fset S) <+> set G^E"
    and "\<And>i j v e. \<lbrakk> i < length \<pi> ; j < length \<pi> ;
      \<pi>!i = Inl v ; \<pi>!j = Inr e ; v |\<in>| fst3 e \<rbrakk> \<Longrightarrow> i<j"
    and "\<And>i k w e. \<lbrakk> j < length \<pi> ; k < length \<pi> ;
      \<pi>!j = Inr e ; \<pi>!k = Inl w ; w |\<in>| thd3 e \<rbrakk> \<Longrightarrow> j<k"
using assms
apply (unfold lins2_def Collect_iff)
apply (elim conjE, assumption)+
apply blast+
done

lemma lins2I:
  assumes "distinct \<pi>"
    and "set \<pi> = (fset G^V - fset S) <+> set G^E"
    and "\<And>i j v e. \<lbrakk> i < length \<pi> ; j < length \<pi> ;
      \<pi>!i = Inl v ; \<pi>!j = Inr e ; v |\<in>| fst3 e \<rbrakk> \<Longrightarrow> i<j"
    and "\<And>j k w e. \<lbrakk> j < length \<pi> ; k < length \<pi> ;
      \<pi>!j = Inr e ; \<pi>!k = Inl w ; w |\<in>| thd3 e \<rbrakk> \<Longrightarrow> j<k"
  shows "\<pi> \<in> lins2 S G"
using assms
apply (unfold lins2_def Collect_iff, intro conjI)
apply assumption+
apply blast+
done

text \<open>When @{term S} is empty, the two definitions coincide.\<close>
lemma lins_is_lins2_with_empty_S:
  "lins G = lins2 {||} G"
by (unfold lins_def lins2_def, auto)

text \<open>The first proofstate for a diagram @{term G} is obtained by
  mapping each of its initial nodes to @{term Top}.\<close>
definition
  initial_ps :: "diagram \<Rightarrow> proofstate"
where
  "initial_ps G \<equiv> [ initials G |=> Top ]"

text \<open>The first proofstate for the partially-processed diagram @{term G} is
  obtained by mapping each of its initial nodes to @{term Top}, except those
  in @{term S}, which are mapped to @{term Bot}.\<close>
definition
  initial_ps2 :: "[node fset, diagram] \<Rightarrow> proofstate"
where
  "initial_ps2 S G \<equiv> [ initials G - S |=> Top ] ++\<^sub>f [ S |=> Bot ]"

text \<open>When @{term S} is empty, the above two definitions coincide.\<close>
lemma initial_ps_is_initial_ps2_with_empty_S:
  "initial_ps = initial_ps2 {||}"
apply (unfold fun_eq_iff, intro allI)
apply (unfold initial_ps_def initial_ps2_def)
apply simp
done

text \<open>The following function extracts the set of proofstate chains from
   a diagram.\<close>
definition
  ps_chains :: "diagram \<Rightarrow> ps_chain set"
where
  "ps_chains G \<equiv> mk_ps_chain (cNil (initial_ps G)) ` lins G"

text \<open>The following function extracts the set of proofstate chains from
   a partially-processed diagram. Nodes in @{term S} are excluded from
   the resulting chains.\<close>
definition
  ps_chains2 :: "[node fset, diagram] \<Rightarrow> ps_chain set"
where
  "ps_chains2 S G \<equiv> mk_ps_chain (cNil (initial_ps2 S G)) ` lins2 S G"

text \<open>When @{term S} is empty, the above two definitions coincide.\<close>
lemma ps_chains_is_ps_chains2_with_empty_S:
  "ps_chains = ps_chains2 {||}"
apply (unfold fun_eq_iff, intro allI)
apply (unfold ps_chains_def ps_chains2_def)
apply (fold initial_ps_is_initial_ps2_with_empty_S)
apply (fold lins_is_lins2_with_empty_S)
apply auto
done

text \<open>We now wish to describe proofstates chain that are well-formed. First,
  let us say that @{term "f ++\<^sub>fdisjoint g"} is defined, when @{term f} and
  @{term g} have disjoint domains, as @{term "f ++\<^sub>f g"}. Then, a well-formed
  proofstate chain consists of triples of the form @{term "(\<sigma> ++\<^sub>fdisjoint
  [{| v |} |=> Top], Inl v, \<sigma> ++\<^sub>fdisjoint [{| v |} |=> Bot])"}, where @{term v}
  is a node, or of the form @{term "(\<sigma> ++\<^sub>fdisjoint [{| vs |} |=> Bot], Inr e,
  \<sigma> ++\<^sub>fdisjoint [{| ws |} |=> Top])"}, where @{term e} is an edge with source
  and target nodes @{term vs} and @{term ws} respectively.

  The definition below describes a well-formed triple; we then lift this
  to complete chains shortly.\<close>

definition
  wf_ps_triple :: "proofstate \<times> (node + edge) \<times> proofstate \<Rightarrow> bool"
where
  "wf_ps_triple T = (case snd3 T of
    Inl v \<Rightarrow> (\<exists>\<sigma>. v |\<notin>| fmdom \<sigma>
      \<and> fst3 T = [ {|v|} |=> Top ] ++\<^sub>f \<sigma>
      \<and> thd3 T = [ {|v|} |=> Bot ] ++\<^sub>f \<sigma>)
  | Inr e \<Rightarrow> (\<exists>\<sigma>. (fst3 e |\<union>| thd3 e) |\<inter>| fmdom \<sigma> = {||}
      \<and> fst3 T = [ fst3 e |=> Bot ] ++\<^sub>f \<sigma>
      \<and> thd3 T = [ thd3 e |=> Top ] ++\<^sub>f \<sigma>))"

lemma wf_ps_triple_nodeI:
  assumes "\<exists>\<sigma>. v |\<notin>| fmdom \<sigma>  \<and>
    \<sigma>1 = [ {|v|} |=> Top ] ++\<^sub>f \<sigma> \<and>
    \<sigma>2 = [ {|v|} |=> Bot ] ++\<^sub>f \<sigma>"
  shows "wf_ps_triple (\<sigma>1, Inl v, \<sigma>2)"
using assms unfolding wf_ps_triple_def
by (auto simp add: fst3_simp snd3_simp thd3_simp)

lemma wf_ps_triple_edgeI:
  assumes "\<exists>\<sigma>. (fst3 e |\<union>| thd3 e) |\<inter>| fmdom \<sigma> = {||}
      \<and> \<sigma>1 = [ fst3 e |=> Bot ] ++\<^sub>f \<sigma>
      \<and> \<sigma>2 = [ thd3 e |=> Top ] ++\<^sub>f \<sigma>"
  shows "wf_ps_triple (\<sigma>1, Inr e, \<sigma>2)"
using assms unfolding wf_ps_triple_def
by (auto simp add: fst3_simp snd3_simp thd3_simp)

definition
  wf_ps_chain :: "ps_chain \<Rightarrow> bool"
where
  "wf_ps_chain \<equiv> chain_all wf_ps_triple"

lemma next_initial_ps2_vertex:
  "initial_ps2 ({|v|} |\<union>| S) G
  = initial_ps2 S G \<ominus> {|v|} ++\<^sub>f [ {|v|} |=> Bot ]"
apply (unfold initial_ps2_def)
apply transfer
apply (auto simp add: make_map_def map_diff_def map_add_def restrict_map_def)
done

lemma next_initial_ps2_edge:
  assumes "G = Graph V \<Lambda> E" and "G' = Graph V' \<Lambda> E'" and
    "V' = V - fst3 e" and "E' = removeAll e E" and "e \<in> set E" and
    "fst3 e |\<subseteq>| S" and "S |\<subseteq>| initials G" and "wf_dia G"
  shows "initial_ps2 (S - fst3 e) G' =
  initial_ps2 S G \<ominus> fst3 e ++\<^sub>f [ thd3 e |=> Top ]"
proof (insert assms, unfold initial_ps2_def, transfer)
  fix G V \<Lambda> E G' V' E' e S
  assume G_def: "G = Graph V \<Lambda> E" and G'_def: "G' = Graph V' \<Lambda> E'" and
    V'_def: "V' = V - fst3 e" and E'_def: "E' = removeAll e E" and
    e_in_E: "e \<in> set E" and fst_e_in_S: "fst3 e |\<subseteq>| S" and
    S_initials: "S |\<subseteq>| initials G" and wf_G: "wf_dia G"
  have "thd3 e |\<inter>| initials G = {||}"
    by (auto simp add: initials_def G_def e_in_E)
  show "make_map (initials G' - (S - fst3 e)) Top ++ make_map (S - fst3 e) Bot
    = map_diff (make_map (initials G - S) Top ++ make_map S Bot) (fst3 e)
        ++ make_map (thd3 e) Top"
  apply (unfold make_map_def map_diff_def)
  apply (unfold map_add_def restrict_map_def)
  apply (unfold minus_fset)
  apply (unfold fun_eq_iff initials_def)
  apply (unfold G_def G'_def V'_def E'_def)
  apply (unfold edges.simps vertices.simps)
  apply (simp add: less_eq_fset.rep_eq fmember.rep_eq e_in_E)
  apply safe
  apply (insert \<open>thd3 e |\<inter>| initials G = {||}\<close>)[1]
  apply (insert S_initials, fold fset_cong)[2]
  apply (unfold less_eq_fset.rep_eq initials_def filter_fset)
  apply (auto simp add: fmember.rep_eq G_def e_in_E)[1]
  apply (auto simp add: fmember.rep_eq G_def e_in_E)[1]
  apply (auto simp add: fmember.rep_eq G_def e_in_E)[1]
  apply (insert wf_G)[1]
  apply (unfold G_def vertices.simps edges.simps)
  apply (drule wf_dia_inv(3))
  apply (unfold acyclicity_def)
  apply (metis fst_e_in_S inter_fset le_iff_inf subsetD)
  apply (insert wf_G)[1]
  apply (unfold G_def vertices.simps edges.simps)
  apply (drule wf_dia_inv(4))
  apply (drule linearityD2)
  apply (fold fset_cong, unfold inter_fset fset_simps)
  apply (insert e_in_E, blast)[1]
  apply (insert wf_G)[1]
  apply (unfold G_def vertices.simps edges.simps)
  apply (drule wf_dia_inv(3))
  apply (metis (lifting) e_in_E G_def empty_iff fset_simps(1)
    finter_iff linearityD(2) notin_fset wf_G wf_dia_inv(4))
  apply (insert wf_G)[1]
  apply (unfold G_def vertices.simps edges.simps)
  apply (drule wf_dia_inv(4))
  apply (drule linearityD2)
  apply (fold fset_cong, unfold inter_fset fset_simps)
  apply (insert e_in_E, blast)[1]
  apply (insert wf_G)[1]
  apply (unfold G_def vertices.simps edges.simps)
  apply (drule wf_dia_inv(3))
  apply (metis (lifting) e_in_E G_def empty_iff fset_simps(1)
    finter_iff linearityD(2) notin_fset wf_G wf_dia_inv(4))
  apply (insert wf_G)
  apply (unfold G_def vertices.simps edges.simps)
  apply (drule wf_dia_inv(5))
  apply (unfold less_eq_fset.rep_eq union_fset)
  apply auto[1]
  apply (drule wf_dia_inv(5))
  apply (unfold less_eq_fset.rep_eq union_fset)
  apply auto[1]
  apply (drule wf_dia_inv(5))
  apply (unfold less_eq_fset.rep_eq union_fset)
  apply (auto simp add: e_in_E)[1]
  apply (drule wf_dia_inv(5))
  apply (unfold less_eq_fset.rep_eq union_fset)
  apply (auto simp add: e_in_E)[1]
  done
qed

lemma next_lins2_vertex:
  assumes "Inl v # \<pi> \<in> lins2 S G"
  assumes "v |\<notin>| S"
  shows "\<pi> \<in> lins2 ({|v|} |\<union>| S) G"
proof -
  note lins2D = lins2D[OF assms(1)]
  show ?thesis
  proof (intro lins2I)
    show "distinct \<pi>" using lins2D(1) by auto
  next
    have "set \<pi> = set (Inl v # \<pi>) - {Inl v}" using lins2D(1) by auto
    also have "... = (fset G^V - fset ({|v|} |\<union>| S)) <+> set G^E"
      using lins2D(2) by auto
    finally show "set \<pi> = (fset G^V - fset ({|v|} |\<union>| S)) <+> set G^E"
      by auto
  next
    fix i j v e
    assume "i < length \<pi>" "j < length \<pi>" "\<pi> ! i = Inl v"
      "\<pi> ! j = Inr e" "v |\<in>| fst3 e"
    thus "i < j" using lins2D(3)[of "i+1" "j+1"] by auto
  next
    fix j k w e
    assume "j < length \<pi>" "k < length \<pi>" "\<pi> ! j = Inr e"
      "\<pi> ! k = Inl w" "w |\<in>| thd3 e"
    thus "j < k" using lins2D(4)[of "j+1" "k+1"] by auto
  qed
qed

lemma next_lins2_edge:
  assumes "Inr e # \<pi> \<in> lins2 S (Graph V \<Lambda> E)"
      and "vs |\<subseteq>| S"
      and "e = (vs,c,ws)"
  shows "\<pi> \<in> lins2 (S - vs) (Graph (V - vs) \<Lambda> (removeAll e E))"
proof -
  note lins2D = lins2D[OF assms(1)]
  show ?thesis
  proof (intro lins2I, unfold vertices.simps edges.simps)
    show "distinct \<pi>"
    using lins2D(1) by auto
  next
    show "set \<pi> = (fset (V - vs) - fset (S - vs))
      <+> set (removeAll e E)"
    apply (insert lins2D(1) lins2D(2) assms(2))
    apply (unfold assms(3) vertices.simps edges.simps less_eq_fset.rep_eq, simp)
    apply (unfold diff_diff_eq)
    proof -
      have "\<forall>a aa b.
       insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<longrightarrow>
       fset vs \<subseteq> fset S \<longrightarrow>
       Inr (vs, c, ws) \<notin> set \<pi> \<longrightarrow>
       distinct \<pi> \<longrightarrow> (a, aa, b) \<in> set E \<longrightarrow> Inr (a, aa, b) \<notin> set \<pi> \<longrightarrow> b = ws"
     by (metis (lifting) InrI List.set_simps(2)
      prod.inject set_ConsD sum.simps(2))

     moreover have "\<forall>a aa b.
       insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<longrightarrow>
       fset vs \<subseteq> fset S \<longrightarrow>
       Inr (vs, c, ws) \<notin> set \<pi> \<longrightarrow>
       distinct \<pi> \<longrightarrow> (a, aa, b) \<in> set E \<longrightarrow> Inr (a, aa, b) \<notin> set \<pi> \<longrightarrow> aa = c"
     by (metis (lifting) InrI List.set_simps(2)
      prod.inject set_ConsD sum.simps(2))

     moreover have "\<forall>x. insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<longrightarrow>
         fset vs \<subseteq> fset S \<longrightarrow>
         Inr (vs, c, ws) \<notin> set \<pi> \<longrightarrow>
         distinct \<pi> \<longrightarrow> x \<in> set \<pi> \<longrightarrow> x \<in> (fset V - fset S) <+> set E - {(vs, c, ws)}"
      apply (unfold insert_is_Un[of _ "set \<pi>"])
      apply (fold assms(3))
      apply clarify
      apply (subgoal_tac "set \<pi> = ((fset V - fset S) <+> set E) - {Inr e}")
      by auto
    ultimately show "Inr (vs, c, ws) \<notin> set \<pi> \<and> distinct \<pi> \<Longrightarrow>
      insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<Longrightarrow>
      fset vs \<subseteq> fset S \<Longrightarrow> set \<pi> = (fset V - fset S) <+> set E - {(vs, c, ws)}"
    by blast
    qed
  next
    fix i j v e
    assume "i < length \<pi>" "j < length \<pi>" "\<pi> ! i = Inl v"
      "\<pi> ! j = Inr e" "v |\<in>| fst3 e"
    thus "i < j" using lins2D(3)[of "i+1" "j+1"] by auto
  next
    fix j k w e
    assume "j < length \<pi>" "k < length \<pi>" "\<pi> ! j = Inr e"
      "\<pi> ! k = Inl w" "w |\<in>| thd3 e"
    thus "j < k" using lins2D(4)[of "j+1" "k+1"] by auto
  qed
qed

text \<open>We wish to prove that every proofstate chain that can be obtained from
  a linear extension of @{term G} is well-formed and has as its final
  proofstate that state in which every terminal node in @{term G} is mapped
  to @{term Bot}.

  We first prove this for partially-processed diagrams, for
  then the result for ordinary diagrams follows as an easy corollary.

  We use induction on the size of the partially-processed diagram. The size of
  a partially-processed diagram @{term "(G,S)"} is defined as the number of
  nodes in @{term G}, plus the number of edges, minus the number of nodes in
  @{term S}.\<close>

lemmas [simp] = fmember.rep_eq

lemma wf_chains2:
  fixes k
  assumes "S |\<subseteq>| initials G"
      and "wf_dia G"
      and "\<Pi> \<in> ps_chains2 S G"
      and "fcard G^V + length G^E = k + fcard S"
  shows "wf_ps_chain \<Pi> \<and> (post \<Pi> = [ terminals G |=> Bot ])"
using assms
proof (induct k arbitrary: S G \<Pi>)
  case 0
  obtain V \<Lambda> E where G_def: "G = Graph V \<Lambda> E" by (metis diagram.exhaust)
  have "S |\<subseteq>| V"
    using "0.prems"(1) initials_in_vertices[of "G"]
    by (auto simp add: G_def)
  have "fcard V \<le> fcard S"
    using "0.prems"(4)
    by (unfold G_def, auto)
  from fcard_seteq[OF \<open>S |\<subseteq>| V\<close> this] have "S = V" by auto
  hence "E = []" using "0.prems"(4) by (unfold G_def, auto)
  have "initials G = V"
    by (unfold G_def \<open>E=[]\<close>, rule no_edges_imp_all_nodes_initial)
  have "terminals G = V"
    by (unfold G_def \<open>E=[]\<close>, rule no_edges_imp_all_nodes_terminal)
  have "{} <+> {} = {}" by auto
  have "lins2 S G = { [] }"
  apply (unfold G_def \<open>S=V\<close> \<open>E=[]\<close>)
  apply (unfold lins2_def, auto simp add: \<open>{} <+> {} = {}\<close>)
  done
  hence \<Pi>_def: "\<Pi> = \<lbrace> initial_ps2 S G \<rbrace>"
    using "0.prems"(3)
    by (auto simp add: ps_chains2_def mk_ps_chain_def)
  show ?case
  apply (intro conjI)
  apply (unfold \<Pi>_def wf_ps_chain_def, auto)
  apply (unfold post.simps initial_ps2_def \<open>initials G = V\<close> \<open>terminals G = V\<close>)
  apply (unfold \<open>S=V\<close>)
  apply (subgoal_tac "V - V = {||}", simp_all)
  done
next
  case (Suc k)
  obtain V \<Lambda> E where G_def: "G = Graph V \<Lambda> E" by (metis diagram.exhaust)
  from Suc.prems(3) obtain \<pi> where
    \<Pi>_def: "\<Pi> = mk_ps_chain \<lbrace> initial_ps2 S G \<rbrace> \<pi>" and
    \<pi>_in: "\<pi> \<in> lins2 S G"
    by (auto simp add: ps_chains2_def)
  note lins2 = lins2D[OF \<pi>_in]
  have "S |\<subseteq>| V"
    using Suc.prems(1) initials_in_vertices[of "G"]
    by (auto simp add: G_def)
  show ?case
  proof (cases \<pi>)
    case Nil
    from \<pi>_in have "V = S" "E = []"
    apply (-, unfold \<open>\<pi> = []\<close> lins2_def, simp_all)
    apply (unfold empty_eq_Plus_conv)
    apply (unfold G_def vertices.simps edges.simps, auto)
    by (metis \<open>S |\<subseteq>| V\<close> less_eq_fset.rep_eq subset_antisym)

    with Suc.prems(4) have False by (simp add: G_def)
    thus ?thesis by auto
  next
    case (Cons x \<pi>')
    note \<pi>_def = this
    show ?thesis
    proof (cases x)
      case (Inl v)
      note x_def = this

      have "v |\<notin>| S \<and> v |\<in>| V"
      apply (subgoal_tac "v \<in> fset V - fset S")
      apply (simp)
      apply (subgoal_tac "Inl v \<in> (fset V - fset S) <+> set E")
      apply (metis Inl_inject Inr_not_Inl PlusE)
      apply (metis lins2(1) lins2(2) Cons G_def Inl distinct.simps(2)
        distinct_length_2_or_more edges.simps vertices.simps)
      done
      hence v_notin_S: "v |\<notin>| S" and v_in_V: "v |\<in>| V" by auto

      have v_initial_not_S: "v |\<in>| initials G - S"
      apply (simp only: G_def initials_def vertices.simps edges.simps)
      apply (simp only: fminus_iff)
      apply (simp only: conj_commute, intro conjI, rule v_notin_S)
      apply (subgoal_tac
        "v \<in> fset (ffilter (\<lambda>v. \<forall>e\<in>set E. v |\<notin>| thd3 e) V)")
      apply simp
      apply (simp only: filter_fset, simp, simp only: conj_commute)
      apply (intro conjI ballI notI)
      apply (insert v_in_V, simp)
      proof -
        fix e :: edge
        assume "v \<in> fset (thd3 e)"
        then have "v |\<in>| (thd3 e)" by auto
        assume "e \<in> set E"
        hence "Inr e \<in> set \<pi>" using lins2(2) by (auto simp add: G_def)
        then obtain j where
          "j < length \<pi>" "0 < length \<pi>" "\<pi>!j = Inr e" "\<pi>!0 = Inl v"
        by (metis \<pi>_def x_def in_set_conv_nth length_pos_if_in_set nth_Cons_0)
        with lins2(4)[OF this \<open>v |\<in>| (thd3 e)\<close>] show False by auto
      qed

      define S' where "S' = {|v|} |\<union>| S"

      define \<Pi>' where "\<Pi>' = mk_ps_chain \<lbrace> initial_ps2 S' G \<rbrace> \<pi>'"
      hence pre_\<Pi>': "pre \<Pi>' = initial_ps2 S' G"
      by (metis pre.simps(1) pre_mk_ps_chain)

      define \<sigma> where "\<sigma> = [ initials G - ({|v|} |\<union>| S) |=> Top ] ++\<^sub>f [ S |=> Bot ]"

      have "wf_ps_chain \<Pi>' \<and> (post \<Pi>' = [terminals G |=> Bot])"
      proof (intro Suc.hyps[of "S'"])
        show "S' |\<subseteq>| initials G"
        apply (unfold S'_def, auto)
        apply (metis fmember.rep_eq fminus_iff v_initial_not_S)
        by (metis Suc.prems(1) fmember.rep_eq fset_rev_mp)
     next
        show "wf_dia G" by (rule Suc.prems(2))
      next
        show "\<Pi>' \<in> ps_chains2 S' G"
        apply (unfold ps_chains2_def \<Pi>'_def)
        apply (intro imageI)
        apply (unfold S'_def)
        apply (intro next_lins2_vertex)
        apply (fold x_def, fold \<pi>_def)
        apply (rule \<pi>_in)
        by (metis v_notin_S)
      next
        show "fcard G^V + length G^E = k + fcard S'"
         apply (unfold S'_def)
         by (auto simp add: Suc.prems(4) fcard_finsert_disjoint[OF v_notin_S])
      qed
      hence
        wf_\<Pi>': "wf_ps_chain \<Pi>'" and
        post_\<Pi>': "post \<Pi>' = [terminals G |=> Bot]"
      by auto

      show ?thesis
      proof (intro conjI)
        have 1: "fmdom [ {|v|} |=> Bot ]
        |\<inter>| fmdom ([ initials G - ({|v|} |\<union>| S) |=> Top ] ++\<^sub>f
     [ S |=> Bot ]) = {||}"
        by (metis (no_types) fdom_make_fmap fmdom_add
          bot_least funion_iff finter_finsert_left le_iff_inf
          fminus_iff finsert_fsubset sup_ge1 v_initial_not_S)
        show "wf_ps_chain \<Pi>"
        using [[unfold_abs_def = false]]
        apply (simp only: \<Pi>_def \<pi>_def x_def mk_ps_chain_cons)
        apply simp
        apply (unfold mk_ps_chain_ccons)
        apply (fold next_initial_ps2_vertex S'_def)
        apply (fold \<Pi>'_def)
        apply (unfold wf_ps_chain_def chain_all.simps conj_commute)
        apply (intro conjI)
        apply (fold wf_ps_chain_def, rule wf_\<Pi>')
        apply (intro wf_ps_triple_nodeI exI[of _ "\<sigma>"] conjI)
        apply (unfold \<sigma>_def fmdom_add fdom_make_fmap)
        apply (metis finsertI1 fminus_iff funion_iff v_notin_S)
        apply (unfold pre_\<Pi>' initial_ps2_def S'_def)
        apply (unfold fmap_add_commute[OF 1])
        apply (unfold fmadd_assoc)
        apply (fold fmadd_assoc[of _ "[ S |=> Bot ]"])
        apply (unfold make_fmap_union sup.commute[of "{|v|}"])
        apply (unfold fminus_funion)
        using v_initial_not_S apply auto
        by (metis (hide_lams, no_types) finsert_absorb finsert_fminus_single finter_fminus
            inf_commute inf_idem v_initial_not_S)
      next
        show "post \<Pi> = [ terminals G |=> Bot ]"
        apply (unfold \<Pi>_def \<pi>_def x_def mk_ps_chain_cons, simp)
        apply (unfold mk_ps_chain_ccons post.simps)
        apply (fold next_initial_ps2_vertex S'_def)
        apply (fold \<Pi>'_def, rule post_\<Pi>')
        done
      qed
    next
      case (Inr e)
      note x_def = this
      define vs where "vs = fst3 e"
      define ws where "ws = thd3 e"

      obtain c where e_def: "e = (vs, c, ws)"
      by (metis vs_def ws_def fst3_simp thd3_simp prod_cases3)

      have "linearity E" and "acyclicity E" and
        e_in_V: "\<And>e. e \<in> set E \<Longrightarrow> fst3 e |\<union>| thd3 e |\<subseteq>| V"
      by (insert Suc.prems(2) wf_dia_inv, unfold G_def, blast)+
      note lin = linearityD[OF this(1)]

      have acy: "\<And>e. e \<in> set E \<Longrightarrow> fst3 e |\<inter>| thd3 e = {||}"
      apply (fold fset_cong, insert \<open>acyclicity E\<close>)
      apply (unfold acyclicity_def acyclic_def, auto)
      done

      note lins = lins2D[OF \<pi>_in]

      have e_in_E: "e \<in> set E"
      apply (subgoal_tac "set \<pi> = (fset G^V - fset S) <+> set G^E")
      apply (unfold \<pi>_def x_def G_def edges.simps, auto)[1]
      apply (simp add: lins(2))
      done

      have vs_in_S: "vs |\<subseteq>| S"
      apply (insert e_in_V[OF e_in_E])
      apply (unfold less_eq_fset.rep_eq)
      apply (intro subsetI)
      apply (unfold vs_def)
      apply (rule ccontr)
      apply (subgoal_tac "x \<in> fset V")
      prefer 2
      apply (auto)
      proof -
        fix v
        assume a: "v \<in> fset (fst3 e)"
        assume "v \<notin> fset S" and "v \<in> fset V"
        hence "Inl v \<in> set \<pi>"
        by (metis (lifting) DiffI G_def InlI lins(2) vertices.simps)
        then obtain i where
          "i < length \<pi>" "0 < length \<pi>" "\<pi>!i = Inl v"  "\<pi>!0 = Inr e"
        by (metis Cons Inr in_set_conv_nth length_pos_if_in_set nth_Cons_0)
        from lins(3)[OF this] show "False" by (auto simp add: a)
      qed

      have "ws |\<inter>| (initials G) = {||}"
      apply (insert e_in_V[OF e_in_E])
      apply (unfold initials_def less_eq_fset.rep_eq fmember.rep_eq, fold fset_cong)
      apply (unfold ws_def G_def, auto simp add: e_in_E)
      done

      define S' where "S' = S - vs"
      define V' where "V' = V - vs"
      define E' where "E' = removeAll e E"
      define G' where "G' = Graph V' \<Lambda> E'"

      define \<Pi>' where "\<Pi>' = mk_ps_chain \<lbrace> initial_ps2 S' G' \<rbrace> \<pi>'"
      hence pre_\<Pi>': "pre \<Pi>' = initial_ps2 S' G'"
      by (metis pre.simps(1) pre_mk_ps_chain)

      define \<sigma> where "\<sigma> = [ initials G - S |=> Top ] ++\<^sub>f [ S - vs |=> Bot ]"

      have next_initial_ps2: "initial_ps2 S' G'
        = initial_ps2 S G \<ominus> vs ++\<^sub>f [ws |=> Top]"
      using next_initial_ps2_edge[OF G_def _ _ _ e_in_E _ Suc.prems(1)
        Suc.prems(2)] G'_def E'_def vs_def ws_def V'_def vs_in_S S'_def
      by auto

      have "wf_ps_chain \<Pi>' \<and> post \<Pi>' = [ terminals G' |=> Bot ]"
      proof (intro Suc.hyps[of "S'"])
        show "S' |\<subseteq>| initials G'"
        apply (insert Suc.prems(1))
        apply (unfold G'_def G_def initials_def)
        apply (unfold less_eq_fset.rep_eq S'_def E'_def V'_def)
        apply auto
        done
      next
        from Suc.prems(2) have "wf_dia (Graph V \<Lambda> E)"
          by (unfold G_def)
        note wf_G = wf_dia_inv[OF this]
        show "wf_dia G'"
        apply (unfold G'_def V'_def E'_def)
        apply (insert wf_G e_in_E vs_in_S Suc.prems(1))
        apply (unfold vs_def)
        apply (intro wf_dia)
        apply (unfold linearity_def initials_def G_def)
        apply (fold fset_cong, unfold less_eq_fset.rep_eq fmember.rep_eq)
        apply (simp, simp)
        apply (unfold acyclicity_def, rule acyclic_subset)
        apply (auto simp add: distinct_removeAll)
        apply (metis (lifting) IntI empty_iff)
        done
      next
        show "\<Pi>' \<in> ps_chains2 S' G'"
        apply (unfold \<Pi>_def \<Pi>'_def ps_chains2_def)
        apply (intro imageI)
        apply (unfold S'_def G'_def V'_def E'_def)
        apply (intro next_lins2_edge)
        apply (metis \<pi>_def G_def x_def \<pi>_in)
        by (simp only: vs_in_S e_def)+
      next
        have "vs |\<subseteq>| V" by (metis (lifting) \<open>S |\<subseteq>| V\<close> order_trans vs_in_S)
        have "distinct E" using \<open>linearity E\<close> linearity_def by auto
        show "fcard G'^V + length G'^E = k + fcard S'"
        apply (insert Suc.prems(4))
        apply (unfold G_def G'_def vertices.simps edges.simps)
        apply (unfold V'_def E'_def S'_def)
        apply (unfold fcard_funion_fsubset[OF \<open>vs |\<subseteq>| V\<close>])
        apply (unfold fcard_funion_fsubset[OF \<open>vs |\<subseteq>| S\<close>])
        apply (fold distinct_remove1_removeAll[OF \<open>distinct E\<close>])
        apply (unfold length_remove1)
        apply (simp add: e_in_E)
        apply (drule arg_cong[of _ _ "\<lambda>x. x - fcard vs - 1"])
        apply (subst (asm) add_diff_assoc2[symmetric])
        apply (simp add: fcard_mono[OF \<open>vs |\<subseteq>| V\<close>])
        apply (subst add_diff_assoc, insert length_pos_if_in_set[OF e_in_E], arith, auto)
        apply (subst add_diff_assoc, auto simp add: fcard_mono[OF \<open>vs |\<subseteq>| S\<close>])
        done
      qed
      hence
        wf_\<Pi>': "wf_ps_chain \<Pi>'" and
        post_\<Pi>': "post \<Pi>' = [ terminals G' |=> Bot ]"
      by auto

      have terms_same: "terminals G = terminals G'"
      apply (unfold G'_def G_def terminals_def edges.simps vertices.simps)
      apply (unfold E'_def V'_def)
      apply (fold fset_cong, auto simp add: e_in_E vs_def)
      done

      have 1: "fmdom [ fst3 e |=> Bot ] |\<inter>|
        fmdom([ ffilter (\<lambda>v. \<forall>e\<in>set E. v |\<notin>| thd3 e) V - S |=> Top ]
        ++\<^sub>f [ S - fst3 e |=> Bot ]) = {||}"
      apply (unfold fmdom_add fdom_make_fmap)
      apply (fold fset_cong)
      apply auto
      apply (metis in_mono less_eq_fset.rep_eq vs_def vs_in_S)
      done

      show ?thesis
      proof (intro conjI)
        show "wf_ps_chain \<Pi>"
        using [[unfold_abs_def = false]]
        apply (unfold \<Pi>_def \<pi>_def x_def mk_ps_chain_cons)
        apply simp
        apply (unfold mk_ps_chain_ccons)
        apply (fold vs_def ws_def)
        apply (fold next_initial_ps2)
        apply (fold \<Pi>'_def)
        apply (unfold wf_ps_chain_def chain_all.simps conj_commute)
        apply (intro conjI)
        apply (fold wf_ps_chain_def)
        apply (rule wf_\<Pi>')
        apply (intro wf_ps_triple_edgeI exI[of _ "\<sigma>"])
        apply (unfold e_def fst3_simp thd3_simp \<sigma>_def, intro conjI)
        apply (insert Suc.prems(1))
        apply (unfold pre_\<Pi>' initial_ps2_def initials_def)
        apply (insert vs_in_S acy[OF e_in_E])
        apply (fold fset_cong)
        apply (unfold less_eq_fset.rep_eq)[1]
        apply (unfold G_def G'_def vs_def ws_def V'_def E'_def S'_def)
        apply (unfold vertices.simps edges.simps)
        apply (unfold fmap_add_commute[OF 1])
        apply (fold fmadd_assoc)
        apply (unfold make_fmap_union)
        apply (auto simp add: fdom_make_fmap e_in_E)[1]
        apply simp
        apply (unfold fmadd_assoc)
        apply (unfold make_fmap_union)
        apply (metis (lifting) funion_absorb2 vs_def vs_in_S)
        apply (intro arg_cong2[of _ _ "[ S - fst3 e |=> Bot ]"
            "[ S - fst3 e |=> Bot ]" "(++\<^sub>f)"])
        apply (intro arg_cong2[of _ _ "Top" "Top" "make_fmap"])
        defer 1
        apply (simp, simp)
        apply (fold fset_cong)
        apply (unfold less_eq_fset.rep_eq fmember.rep_eq, simp)
        apply (elim conjE)
        apply (intro set_eqI iffI, simp_all)
        apply (elim conjE, intro disjI conjI ballI, simp)
        apply (case_tac "ea=e", simp_all)
        apply (elim disjE conjE, intro conjI ballI impI, simp_all)
        apply (insert e_in_E lin(2))[1]
        apply (subst (asm) (2) fset_cong[symmetric])
        apply (elim conjE)
        apply (subst (asm) inter_fset)
        apply (subst (asm) fset_simps)
        apply (insert disjoint_iff_not_equal)[1]
        apply blast
        apply (metis G_def Suc(3) e_in_E subsetD less_eq_fset.rep_eq wf_dia_inv')
        prefer 2
        apply (metis (lifting) IntI Suc(2) \<open>ws |\<inter>| initials G = {||}\<close>
            empty_iff fset_simps(1) in_mono inter_fset less_eq_fset.rep_eq ws_def)
        apply auto
        done
      next
        show "post \<Pi> = [terminals G |=> Bot]"
        apply (unfold \<Pi>_def \<pi>_def x_def mk_ps_chain_cons)
        apply simp
        apply (unfold mk_ps_chain_ccons post.simps)
        apply (fold vs_def ws_def)
        apply (fold next_initial_ps2)
        apply (fold \<Pi>'_def)
        apply (unfold terms_same)
        apply (rule post_\<Pi>')
        done
      qed
    qed
  qed
qed

corollary wf_chains:
  assumes "wf_dia G"
  assumes "\<Pi> \<in> ps_chains G"
  shows "wf_ps_chain \<Pi> \<and> post \<Pi> = [ terminals G |=> Bot ]"
apply (intro wf_chains2[of "{||}"], insert assms(2))
by (auto simp add: assms(1) ps_chains_is_ps_chains2_with_empty_S fcard_fempty)

subsection \<open>Interface chains\<close>

type_synonym int_chain = "(interface, assertion_gadget + command_gadget) chain"

text \<open>An interface chain is similar to a proofstate chain. However, where a
  proofstate chain talks about nodes and edges, an interface chain talks about
  the assertion-gadgets and command-gadgets that label those nodes and edges
  in a diagram. And where a proofstate chain talks about proofstates, an
  interface chain talks about the interfaces obtained from those proofstates.

  The following functions convert a proofstate chain into an
  interface chain.\<close>

definition
  ps_to_int :: "[diagram, proofstate] \<Rightarrow> interface"
where
  "ps_to_int G \<sigma> \<equiv>
    \<Otimes>v |\<in>| fmdom \<sigma>. case_topbot top_ass bot_ass (lookup \<sigma> v) (G^\<Lambda> v)"

definition
  ps_chain_to_int_chain :: "[diagram, ps_chain] \<Rightarrow> int_chain"
where
  "ps_chain_to_int_chain G \<Pi> \<equiv>
    chainmap (ps_to_int G) ((case_sum (Inl \<circ> G^\<Lambda>) (Inr \<circ> snd3))) \<Pi>"

lemma ps_chain_to_int_chain_simp:
  "ps_chain_to_int_chain (Graph V \<Lambda> E) \<Pi> =
    chainmap (ps_to_int (Graph V \<Lambda> E)) ((case_sum (Inl \<circ> \<Lambda>) (Inr \<circ> snd3))) \<Pi>"
by (simp add: ps_chain_to_int_chain_def)

subsection \<open>Soundness proof\<close>

text \<open>We assume that @{term wr_com} always returns @{term "{}"}. This is
  equivalent to changing our axiomatization of separation logic such that the
  frame rule has no side-condition. One way to obtain a separation logic
  lacking a side-condition on its frame rule is to use variables-as-
  resource.

  We proceed by induction on the proof rules for graphical diagrams. We
  show that: (1) if a diagram @{term G} is provable w.r.t. interfaces
  @{term P} and @{term Q}, then @{term P} and @{term Q} are the top and bottom
  interfaces of @{term G}, and that the Hoare triple @{term "(asn P,
  c, asn Q)"} is provable for each command @{term c} that can be extracted
  from @{term G}; (2) if a command-gadget @{term C} is provable w.r.t.
  interfaces @{term P} and @{term Q}, then the Hoare triple @{term "(asn P,
  c, asn Q)"} is provable for each command @{term c} that can be extracted
  from @{term C}; and (3) if an assertion-gadget @{term A} is provable, and if
  the top and bottom interfaces of @{term A} are @{term P} and @{term Q}
  respectively, then the Hoare triple @{term "(asn P, c, asn Q)"} is provable
  for each command @{term c} that can be extracted from @{term A}.\<close>

lemma soundness_graphical_helper:
  assumes no_var_interference: "\<And>c. wr_com c = {}"
  shows
    "(prov_dia G P Q \<longrightarrow>
      (P = top_dia G \<and> Q = bot_dia G \<and>
      (\<forall>c. coms_dia G c \<longrightarrow> prov_triple (asn P, c, asn Q))))
   \<and> (prov_com C P Q \<longrightarrow>
      (\<forall>c. coms_com C c \<longrightarrow> prov_triple (asn P, c, asn Q)))
   \<and> (prov_ass A \<longrightarrow>
      (\<forall>c. coms_ass A c \<longrightarrow> prov_triple (asn (top_ass A), c, asn (bot_ass A))))"
proof (induct rule: prov_dia_prov_com_prov_ass.induct)
  case (Skip p)
  thus ?case
  apply (intro allI impI, elim conjE coms_skip_inv)
  apply (auto simp add: prov_triple.skip)
  done
next
  case (Exists G P Q x)
  thus ?case
  apply (intro allI impI, elim conjE coms_exists_inv)
  apply (auto simp add: prov_triple.exists)
  done
next
  case (Basic P c Q)
  thus ?case
  by (intro allI impI, elim conjE coms_basic_inv, auto)
next
  case (Choice G P Q H)
  thus ?case
  apply (intro allI impI, elim conjE coms_choice_inv)
  apply (auto simp add: prov_triple.choose)
  done
next
  case (Loop G P)
  thus ?case
  apply (intro allI impI, elim conjE coms_loop_inv)
  apply (auto simp add: prov_triple.loop)
  done
next
  case (Main G)
  thus ?case
  apply (intro conjI)
  apply (simp, simp)
  apply (intro allI impI)
  apply (elim coms_main_inv, simp)
  proof -
    fix c V \<Lambda> E
    fix \<pi>::"lin"
    fix cs::"command list"
    assume wf_G: "wf_dia (Graph V \<Lambda> E)"
    assume "\<And>v. v \<in> fset V \<Longrightarrow> \<forall>c. coms_ass (\<Lambda> v) c \<longrightarrow>
      prov_triple (asn (top_ass (\<Lambda> v)), c, asn (bot_ass (\<Lambda> v)))"
    hence prov_vertex: "\<And>v c P Q F. \<lbrakk> coms_ass (\<Lambda> v) c; v \<in> fset V;
      P = (top_ass (\<Lambda> v) \<otimes> F) ; Q = (bot_ass (\<Lambda> v) \<otimes> F) \<rbrakk>
      \<Longrightarrow> prov_triple (asn P, c, asn Q)"
    by (auto simp add: prov_triple.frame no_var_interference)
    assume "\<And>e. e \<in> set E \<Longrightarrow> \<forall>c. coms_com (snd3 e) c \<longrightarrow> prov_triple
      (asn (\<Otimes>v|\<in>|fst3 e. bot_ass (\<Lambda> v)),c,asn (\<Otimes>v|\<in>|thd3 e. top_ass (\<Lambda> v)))"
    hence prov_edge: "\<And>e c P Q F. \<lbrakk> e \<in> set E ; coms_com (snd3 e) c ;
      P = ((\<Otimes>v|\<in>|fst3 e. bot_ass (\<Lambda> v)) \<otimes> F) ;
      Q = ((\<Otimes>v|\<in>|thd3 e. top_ass (\<Lambda> v)) \<otimes> F) \<rbrakk>
      \<Longrightarrow> prov_triple (asn P, c, asn Q)"
    by (auto simp add: prov_triple.frame no_var_interference)
    assume len_cs: "length cs = length \<pi>"
    assume "\<forall>i<length \<pi>.
      case_sum (coms_ass \<circ> \<Lambda>) (coms_com \<circ> snd3) (\<pi> ! i) (cs ! i)"
    hence \<pi>_cs: "\<And>i. i < length \<pi> \<Longrightarrow>
      case_sum (coms_ass \<circ> \<Lambda>) (coms_com \<circ> snd3) (\<pi> ! i) (cs ! i)" by auto
    assume G_def: "G = Graph V \<Lambda> E"
    assume c_def: "c = foldr (;;) cs Skip"
    assume \<pi>_lin: "\<pi> \<in> lins (Graph V \<Lambda> E)"

    note lins = linsD[OF \<pi>_lin]

    define \<Pi> where "\<Pi> = mk_ps_chain \<lbrace> initial_ps G \<rbrace> \<pi>"

    have "\<Pi> \<in> ps_chains G" by (simp add: \<pi>_lin \<Pi>_def ps_chains_def G_def)
    hence 1: "post \<Pi> = [ terminals G |=> Bot ]"
      and 2: "chain_all wf_ps_triple \<Pi>"
    by (insert wf_chains G_def wf_G, auto simp add: wf_ps_chain_def)

    show "prov_triple (asn (\<Otimes>v|\<in>|initials (Graph V \<Lambda> E). top_ass (\<Lambda> v)),
      foldr (;;) cs Skip, asn (\<Otimes>v|\<in>|terminals (Graph V \<Lambda> E). bot_ass (\<Lambda> v)))"
    using [[unfold_abs_def = false]]
    apply (intro seq_fold[of _ "ps_chain_to_int_chain G \<Pi>"])
    apply (unfold len_cs)
    apply (unfold ps_chain_to_int_chain_def chainmap_preserves_length \<Pi>_def)
    apply (unfold mk_ps_chain_preserves_length, simp)
    apply (unfold pre_chainmap post_chainmap)
    apply (unfold pre_mk_ps_chain pre.simps)
    apply (fold \<Pi>_def, unfold 1)
    apply (unfold initial_ps_def)
    apply (unfold ps_to_int_def)
    apply (unfold fdom_make_fmap)
    apply (unfold G_def labelling.simps, fold G_def)
    apply (subgoal_tac "\<forall>v \<in> fset (initials G). top_ass (\<Lambda> v) =
      case_topbot top_ass bot_ass (lookup [ initials G |=> Top ] v) (\<Lambda> v)")
    apply (unfold iter_hcomp_cong, simp)
    apply (metis lookup_make_fmap topbot.simps(3))
    apply (subgoal_tac "\<forall>v \<in> fset (terminals G). bot_ass (\<Lambda> v) =
      case_topbot top_ass bot_ass (lookup [ terminals G |=> Bot ] v) (\<Lambda> v)")
    apply (unfold iter_hcomp_cong, simp)
    apply (metis lookup_make_fmap topbot.simps(4), simp)
    apply (unfold G_def, fold ps_chain_to_int_chain_simp G_def)
    proof -
      fix i
      assume "i < length \<pi>"
      hence "i < chainlen \<Pi>"
      by (metis \<Pi>_def add_0_left chainlen.simps(1)
        mk_ps_chain_preserves_length)
      hence wf_\<Pi>i: "wf_ps_triple (nthtriple \<Pi> i)"
        by (insert 2, simp add: chain_all_nthtriple)
      show "prov_triple (asn (fst3 (nthtriple (ps_chain_to_int_chain G \<Pi>) i)),
                 cs ! i, asn (thd3 (nthtriple (ps_chain_to_int_chain G \<Pi>) i)))"
      apply (unfold ps_chain_to_int_chain_def)
      apply (unfold nthtriple_chainmap[OF \<open>i < chainlen \<Pi>\<close>])
      apply (unfold fst3_simp thd3_simp)
      proof (cases "\<pi>!i")
        case (Inl v)

        have "snd3 (nthtriple \<Pi> i) = Inl v"
        apply (unfold snds_of_triples_form_comlist[OF \<open>i < chainlen \<Pi>\<close>])
        apply (auto simp add: \<Pi>_def comlist_mk_ps_chain Inl)
        done

        with wf_\<Pi>i wf_ps_triple_def obtain \<sigma> where
          v_notin_\<sigma>: "v |\<notin>| fmdom \<sigma>" and
          fst_\<Pi>i: "fst3 (nthtriple \<Pi> i) = [ {|v|} |=> Top ] ++\<^sub>f \<sigma>" and
          thd_\<Pi>i: "thd3 (nthtriple \<Pi> i) = [ {|v|} |=> Bot ] ++\<^sub>f \<sigma>" by auto

        show "prov_triple (asn (ps_to_int G (fst3 (nthtriple \<Pi> i))),
                   cs ! i, asn (ps_to_int G (thd3 (nthtriple \<Pi> i))))"
        apply (intro prov_vertex[where v=v])
        apply (metis (no_types) Inl \<open>i < length \<pi>\<close> \<pi>_cs o_def sum.simps(5))
        apply (metis (lifting) Inl lins(2) Inl_not_Inr PlusE \<open>i < length \<pi>\<close>
          nth_mem sum.simps(1) vertices.simps)
        apply (unfold fst_\<Pi>i thd_\<Pi>i)
        apply (unfold ps_to_int_def)
        apply (unfold fmdom_add fdom_make_fmap)
        apply (unfold finsert_is_funion[symmetric])
        apply (insert v_notin_\<sigma>)
        apply (unfold iter_hcomp_insert)
        apply (unfold lookup_union2 lookup_make_fmap1)
        apply (unfold G_def labelling.simps)
        apply (subgoal_tac "\<forall>va \<in> fset (fmdom \<sigma>). case_topbot top_ass bot_ass
          (lookup ([ {|v|} |=> Top ] ++\<^sub>f \<sigma>) va) (\<Lambda> va) =
          case_topbot top_ass bot_ass (lookup ([{|v|} |=> Bot] ++\<^sub>f \<sigma>) va)(\<Lambda> va)")
        apply (unfold iter_hcomp_cong, simp)
        apply (metis fmember.rep_eq lookup_union1, simp)
        done
      next
        case (Inr e)
        have "snd3 (nthtriple \<Pi> i) = Inr e"
        apply (unfold snds_of_triples_form_comlist[OF \<open>i < chainlen \<Pi>\<close>])
        apply (auto simp add: \<Pi>_def comlist_mk_ps_chain Inr)
        done

        with wf_\<Pi>i wf_ps_triple_def obtain \<sigma> where
          fst_e_disjoint_\<sigma>: "fst3 e |\<inter>| fmdom \<sigma> = {||}" and
          thd_e_disjoint_\<sigma>: "thd3 e |\<inter>| fmdom \<sigma> = {||}" and
          fst_\<Pi>i: "fst3 (nthtriple \<Pi> i) = [ fst3 e |=> Bot ] ++\<^sub>f \<sigma>" and
          thd_\<Pi>i: "thd3 (nthtriple \<Pi> i) = [ thd3 e |=> Top ] ++\<^sub>f \<sigma>"
        by (auto simp add: inf_sup_distrib2)

        show "prov_triple (asn (ps_to_int G (fst3 (nthtriple \<Pi> i))),
                   cs ! i, asn (ps_to_int G (thd3 (nthtriple \<Pi> i))))"
        apply (intro prov_edge[where e=e])
        apply (subgoal_tac "Inr e \<in> set \<pi>")
        apply (metis Inr_not_Inl PlusE edges.simps lins(2) sum.simps(2))
        apply (metis Inr \<open>i < length \<pi>\<close> nth_mem)
        apply (metis (no_types) Inr \<open>i < length \<pi>\<close> \<pi>_cs o_def sum.simps(6))
        apply (unfold fst_\<Pi>i thd_\<Pi>i)
        apply (unfold ps_to_int_def)
        apply (unfold G_def labelling.simps)
        apply (unfold fmdom_add fdom_make_fmap)
        apply (insert fst_e_disjoint_\<sigma>)
        apply (unfold iter_hcomp_union)
        apply (subgoal_tac "\<forall>v \<in> fset (fst3 e). case_topbot top_ass bot_ass
          (lookup ([ fst3 e |=> Bot ] ++\<^sub>f \<sigma>) v) (\<Lambda> v) = bot_ass (\<Lambda> v)")
        apply (unfold iter_hcomp_cong)
        apply (simp)
        apply (intro ballI)
        apply (subgoal_tac "v |\<notin>| fmdom \<sigma>")
        apply (unfold lookup_union2)
        apply (metis lookup_make_fmap topbot.simps(4))
        apply (metis fempty_iff finterI fmember.rep_eq)
        apply (insert thd_e_disjoint_\<sigma>)
        apply (unfold iter_hcomp_union)
        apply (subgoal_tac "\<forall>v \<in> fset (thd3 e). case_topbot top_ass bot_ass
          (lookup ([ thd3 e |=> Top ] ++\<^sub>f \<sigma>) v) (\<Lambda> v) = top_ass (\<Lambda> v)")
        apply (unfold iter_hcomp_cong)
        apply (subgoal_tac "\<forall>v \<in> fset (fmdom \<sigma>). case_topbot top_ass bot_ass
          (lookup ([ thd3 e |=> Top ] ++\<^sub>f \<sigma>) v) (\<Lambda> v) =
          case_topbot top_ass bot_ass (lookup ([fst3 e |=> Bot] ++\<^sub>f \<sigma>) v) (\<Lambda> v)")
        apply (unfold iter_hcomp_cong)
        apply simp
        apply (intro ballI)
        apply (subgoal_tac "v |\<in>| fmdom \<sigma>")
        apply (unfold lookup_union1, auto)
        apply (subgoal_tac "v |\<notin>| fmdom \<sigma>")
        apply (unfold lookup_union2)
        apply (metis lookup_make_fmap topbot.simps(3))
        by (metis fempty_iff finterI fmember.rep_eq)
      qed
    qed
  qed
qed

text \<open>The soundness theorem states that any diagram provable using the
  proof rules for ribbons can be recreated as a valid proof in separation
  logic.\<close>

corollary soundness_graphical:
  assumes "\<And>c. wr_com c = {}"
  assumes "prov_dia G P Q"
  shows "\<forall>c. coms_dia G c \<longrightarrow> prov_triple (asn P, c, asn Q)"
using soundness_graphical_helper[OF assms(1)] and assms(2) by auto

end