\<^marker>\<open>creator Bernhard Pöttinger\<close>

theory Effectively_Acyclic
imports Flow_Base Approximations Flow_Extensions Pigeonhole Alternating
begin

paragraph \<open>Summary\<close>

text \<open>This theory defines effective acyclicity of flow graphs and provides some lemmas to apply it
more efficiently.\<close>

paragraph \<open>Major Definitions\<close>
text \<open>
- @{term eff_acyclic}: a flow graph is effectively acyclic if the flow along each cycle within the flow
  graph is 0. Enables us to compute flows as we can eliminate the recursive nature of the flow
  equation by unrolling it far enough and all recursive terms will contain cycles (i.e. become
  irrelevant due to effective acyclicity.)
\<close>

section \<open>Effective Acyclicity\<close>

text \<open>@{cite \<open>def. 11\<close> krishna20}\<close>

definition eff_acyclic where
"eff_acyclic N e f \<equiv> \<forall>k \<ge> 1. \<forall>ns \<in> k_lists N k. chain e ns (hd ns) (f (hd ns)) = 0"

text \<open>Convenience definition for @{term eff_acyclic} for flow graphs instead of its components:\<close>

definition eff_acyclic' where
"eff_acyclic' h \<equiv> eff_acyclic (dom_fg h) (edge_fg h) (flow_fg h)"

subsection \<open>Prove that a path has no flow due to effective acyclicity\<close>

text \<open>@{term eff_acyclic_chain_0}: Paths longer than @{term "card N + 1"} definitely contain a cycle,
therefore have flow 0 in effectively acyclic context.\<close>

lemma eff_acyclic_chain_0:
  fixes f :: "'n \<Rightarrow> 'm :: pos_cancel_comm_monoid_add"
  assumes "eff_acyclic N e f" "length ns \<ge> card N + 1" "set ns \<subseteq> N" "finite N"
          "flow_eq (fg N e f) i" "End_closed E" "\<forall>x y. e x y \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "chain e ns n (f (hd ns)) = 0"
proof -
  obtain xs ys zs a where **: "ns = xs @ [a] @ ys @ [a] @ zs"
    using assms pigeonhole_split_list[of N ns] by auto
  then have "set ns = set xs \<union> {a} \<union> set ys \<union> set zs"
    by auto
  then have inn: "set xs \<subseteq> N" "set ys \<subseteq> N" "set zs \<subseteq> N" "a \<in> N"
    using assms ** by blast+
  then have "[a] @ ys \<in> k_lists N (length ys + 1)"
    unfolding k_lists_def by simp
  then have zero: "chain e ([a] @ ys) a (f a) = 0"
    using assms
    unfolding eff_acyclic_def k_lists_def
    by (metis (no_types, lifting) \<open>[a] @ ys \<in> k_lists N (length ys + 1)\<close> assms(1) eff_acyclic_def
        hd_append2 impossible_Cons le_add2 le_numeral_extra(3) list.sel(1) list.size(3))
  then have ***: "chain e ns n = chain e ([a] @ ys @ [a] @ zs) n o chain e xs a"
    using ** chain_append[of "[a] @ ys @ [a] @ zs" e xs n] by simp
  then have "chain e ns n = chain e (a # zs) n o chain e (a # ys) a o chain e xs a"
    using *** chain_append[of "a # zs" e "a # ys" n] by auto
  moreover have B: "chain e xs a (f (hd (xs @ [a]))) \<le> f a"
  proof (cases xs)
    case Nil
    then show ?thesis by simp
  next
    case (Cons aa list)
    have "xs \<in> k_lists N (length xs)"
      using inn unfolding k_lists_def by simp
    then have A: "chain e xs a (f (hd xs)) \<le> (\<Sum>xs\<in>k_lists N (length xs). chain e xs a (f (hd xs)))"
      using sum_insert_pos_monoid[of "k_lists N (length xs)" xs "\<lambda>xs. chain e xs a (f (hd xs))"] inn
        k_lists_finite[of N "length xs"] assms by simp
    have "f a = (\<Sum>ns\<in>k_lists N (length xs). chain e ns a (f (hd ns))) +
                (i a + (\<Sum>ns\<in>l_lists N (length xs). chain e ns a (i (hd ns))))"
      using unroll_flow_eq'[of "length xs" N e f i E a]
        assms inn Cons by (auto simp: algebra_simps)
    then have B: "(\<Sum>ns\<in>k_lists N (length xs). chain e ns a (f (hd ns))) \<le> f a"
      using le_iff_add by auto
    have "chain e xs a (f (hd xs)) \<le> f a" using order_trans[OF A B] .
    then show ?thesis using Cons by simp
  qed
  ultimately have "chain e ns n (f (hd ns)) =
    (chain e (a # zs) n o chain e (a # ys) a o chain e xs a) (f (hd ns))"
    using pos_endo_mono_closed by simp
  also have "... \<le> (chain e (a # zs) n o chain e (a # ys) a) (f a)"
    apply (subst **, subst hd_append, cases xs)
    apply simp_all
    using pos_endo_mono'_closed[OF B, of "chain e (a # zs) n o chain e (a # ys) a", simplified] **
    by (metis B chain_mono assms(6) assms(7) hd_append2 list.sel(1) list.sel(2)
        list.sel(3) not_Cons_self2)
  also have "... = chain e (a # zs) n 0"
    using zero by simp
  also have "... = 0"
    apply (subst endo_f_0_0_closed[of "chain e (a # zs) n"])
    using assms by (auto intro!: endo_chain_closed_nonempty[where E=E])
  finally show ?thesis
    by simp
qed

text \<open>Adapter for @{thm eff_acyclic_chain_0} for flow graphs instead of components.\<close>

lemma eff_acyclic'_chain_eq_0:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "set xs \<subseteq> dom_fg h" "xs \<noteq> []" "End_closed E"
    "\<forall>x y. edge_fg h x y \<in> E" "length xs \<ge> card (dom_fg h) + 1" "h \<noteq> bot" "(\<lambda>_. 0) \<in> E"
  shows "chain (edge_fg h) xs x (flow_fg h (hd xs)) = 0"
proof -
  obtain i where *: "flow_eq h i"
    using \<open>h \<noteq> bot\<close> flow_eq_exists by blast
  have "chain (edge_fg h) xs x (flow_fg h (hd xs)) = 0"
    apply (rule eff_acyclic_chain_0[of "dom_fg h" "edge_fg h" "flow_fg h" xs i E x])
    using assms * unfolding eff_acyclic'_def by simp_all
  then show ?thesis
    using assms by simp
qed

text \<open>Same as @{text contradict_eff_acyclic_flow} but with inflow as initial flow this time
instead of flow.\<close>

text \<open>If a path is not distinct then there is a cycle in there and in an effectively acyclic
context this implies that there is no flow along this path.\<close>

lemma chain_eff_acylic_zero_not_distinct_flow:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "set ns \<subseteq> dom_fg h" "h \<noteq> bot" "id \<in> E" "ns \<noteq> []"
    "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "\<not> distinct ns" "m \<le> flow_fg h (hd ns)" "(\<lambda>_. 0) \<in> E"
  shows "chain (edge_fg h) ns n m = 0"
proof -
  let ?e = "edge_fg h"
  let ?f = "flow_fg h"

  obtain ns1 ns2 ns3 n0 where ns: "ns = ns1 @ n0 # ns2 @ n0 # ns3"
    using assms not_distinct_decomp[of "ns"] by auto

  have "set ns \<subseteq> dom_fg h" using assms by simp
  then have dom: "set ns1 \<subseteq> dom_fg h" "set ns2 \<subseteq> dom_fg h" "set ns3 \<subseteq> dom_fg h" "n0 \<in> dom_fg h"
    using ns by auto

  have "n0 # ns2 \<in> k_lists (dom_fg h) (length (n0 # ns2))"
    unfolding k_lists_def using ns dom by simp
  then have "chain ?e (n0 # ns2) (hd (n0 # ns2)) (?f (hd (n0 # ns2))) = 0"
    using assms unfolding eff_acyclic'_def eff_acyclic_def by force
  then have "chain ?e (n0 # ns3) n (chain ?e (n0 # ns2) (hd ((n0 # ns3) @ [n])) (?f (hd ((n0 # ns3) @ [n])))) = 0"
    apply simp
    apply (rule endo_f_0_0_closed[where f="chain ?e (n0 # ns3) n" and E=E])
    by (rule endo_chain_closed, auto simp: assms)
  then have **: "chain (edge_fg h) (n0 # ns2 @ n0 # ns3) n (flow_fg h (hd (n0 # ns2))) = 0"
    by (subst (asm) chain_append_nonempty[symmetric], simp)

  have *: "chain ?e ns1 n0 (?f (hd (ns1 @ [n0]))) \<le> ?f n0"
    apply (rule chain_flow_fg_le_flow_fg)
    using assms dom by auto

  have "chain ?e ns n m \<le> chain ?e ns n (?f (hd ns))"
    apply (rule order_trans[OF pos_endo_mono'_closed[OF \<open>m \<le> ?f (hd ns)\<close>]])
    by (rule endo_chain_closed[where E=E], auto simp: assms)
  also have "... = chain ?e (n0 # ns2 @ n0 # ns3) n (chain ?e ns1 n0 (?f (hd (ns1 @ [n0]))))"
    apply (simp add: chain_append_nonempty ns)
    by (metis append_self_conv2 hd_append2 list.sel(1))
  also have "... \<le> chain ?e (n0 # ns2 @ n0 # ns3) n (?f n0)"
    apply (rule pos_endo_mono'_closed[OF *, where E=E])
    by (rule endo_chain_closed, auto simp: assms)
  also have "... = 0" using ** by simp

  finally show ?thesis using ns by simp
qed

text \<open>A specialized variant of the previous lemma @{thm chain_eff_acylic_zero_not_distinct_flow}:
initial flow inflow instead of arbitrary flow.\<close>

lemma chain_eff_acylic_zero_not_distinct:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "set ns \<subseteq> dom_fg h" "h \<noteq> bot" "id \<in> E" "(\<lambda>_. 0) \<in> E" "ns \<noteq> []"
    "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "\<not> distinct ns" "m \<le> inf_fg h (hd ns)"
  shows "chain (edge_fg h) ns n m = 0"
proof -
  have *: "m \<le> flow_fg h (hd ns)"
    using inf_fg_le_flow_fg[of h "hd ns"] assms by force
  show ?thesis
    apply (rule chain_eff_acylic_zero_not_distinct_flow)
    using assms * chain_eff_acylic_zero_not_distinct_flow by auto
qed

text \<open>Another special case of @{thm chain_eff_acylic_zero_not_distinct_flow} for convoluted paths.\<close>

lemma chains_eff_acylic_zero_not_distinct:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "\<not> distinct (concat xss)" "eff_acyclic' h" "z \<le> flow_fg h (hd (hd xss))"
    "\<forall>xs \<in> set xss. xs \<noteq> []" "set (concat xss) \<subseteq> dom_fg h" "\<forall>x y. edge_fg h x y \<in> E"
    "End_closed E" "h \<noteq> bot" "xss \<noteq> []" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "chains (edge_fg h) xss y z = 0"
proof -
  have "hd (hd xss) = hd (concat xss)" using assms
    by (metis concat.simps(2) hd_Cons_tl hd_append2 hd_in_set)
  then have "chain (edge_fg h) (concat xss) y z = 0"
    using chain_eff_acylic_zero_not_distinct_flow[of h "concat xss" E z y] assms by simp
  moreover have "chains (edge_fg h) xss y z = chain (edge_fg h) (concat xss) y z"
    using chain_concat_chains assms by metis
  ultimately show ?thesis by simp
qed

lemma eff_acyclic'_chain_eq_0_plus_fg: (* replace/simplify *)
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h1" "h = h1 + h2" "set xs \<subseteq> dom_fg h1" "xs \<noteq> []" "h \<noteq> bot"
  shows "chain (edge_fg h) xs (hd xs) (flow_fg h (hd xs)) = 0"
proof -
  let ?k = "length xs"
  let ?N1 = "dom_fg h1" let ?f1 = "flow_fg h1" let ?e1 = "edge_fg h1"
  let ?N = "dom_fg h" let ?f = "flow_fg h" let ?e = "edge_fg h"

  have "xs \<in> k_lists ?N1 ?k"
    using assms unfolding k_lists_def by simp
  then have "chain ?e1 xs (hd xs) (?f1 (hd xs)) = 0"
    using assms add_leD2 unfolding eff_acyclic'_def eff_acyclic_def
    by (metis One_nat_def Suc_leI assms(1) eff_acyclic'_def eff_acyclic_def length_greater_0_conv)
  then show ?thesis
    apply (subst chain_cong[of xs ?e ?e1])
    using on_eq_superset[OF \<open>set xs \<subseteq> ?N1\<close> edge_fg_plus_fg_on1[of h1 h2]] assms apply simp
    using on_eq_superset[OF \<open>set xs \<subseteq> ?N1\<close> flow_fg_plus_fg_on1[of h1 h2]] assms by simp
qed

subsection \<open>Paths with cycles can not have flow in effective acyclic flow graph\<close>

text \<open>A path that contains its destination node has no flow in an effectively acyclic context.\<close>

lemma contradict_eff_acyclic_flow:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "chain (edge_fg h) ns n (flow_fg h (hd ns)) \<noteq> 0" "set ns \<subseteq> dom_fg h"
    "n \<in> set ns" "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "(\<lambda>_. 0) \<in> E" "id \<in> E"
  shows "False"
proof -
  let ?e = "edge_fg h"
  let ?f = "flow_fg h"
  let ?N = "dom_fg h"
  let ?i = "inf_fg h"

  have "ns \<noteq> []"
    using assms by auto

  obtain ns1 ns2 where *: "ns = ns1 @ n # ns2" "set ns1 \<subseteq> ?N" "set (n # ns2) \<subseteq> ?N"
    using split_list[of n ns] assms(3,4) by auto
  then have **: "n # ns2 \<in> k_lists (dom_fg h) (length (n # ns2))" "length (n # ns2) \<ge> 1"
    unfolding k_lists_def by auto
  then have "chain (edge_fg h) (n # ns2) (hd (n # ns2)) (flow_fg h (hd (n # ns2))) = 0"
    using assms(1) unfolding eff_acyclic_def eff_acyclic'_def by blast
  moreover have "0 \<noteq> chain ?e (n # ns2) n (?f n)"
  proof -
    have ***: "hd (ns @ [n]) = hd (ns1 @ [n])"
      using * by (simp add: hd_append)
    have "0 < chain ?e (n # ns2) n (chain ?e ns1 n (?f (hd ns)))"
      using assms
      apply (subst (asm) \<open>ns = ns1 @ n # ns2\<close>,
             subst (asm) chain_append_nonempty[where xs="ns1" and ys="n # ns2"], simp)
      using not_gr_zero by blast
    also have "... = chain ?e (n # ns2) n (chain ?e ns1 n (?f (hd (ns @ [n]))))"
      using \<open>ns \<noteq> []\<close> by simp
    also have "... \<le> chain ?e (n # ns2) n (?f n)"
      apply (subst ***)
      apply (rule chain_mono[OF chain_flow_fg_le_flow_fg, of h E])
      using assms * by simp_all
    finally show ?thesis
      by simp
  qed
  ultimately show False
    by simp
qed

lemma contradict_eff_acyclic:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "chain (edge_fg h) ns n (inf_fg h (hd ns)) \<noteq> 0" "set ns \<subseteq> dom_fg h"
    "n \<in> set ns" "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "(\<lambda>_. 0) \<in> E" "id \<in> E"
  shows "False"
proof -
  have "0 < chain (edge_fg h) ns n (inf_fg h (hd ns))"
    using assms gr_zeroI by blast
  also have "... \<le> chain (edge_fg h) ns n (flow_fg h (hd ns))"
    apply (auto intro!: pos_endo_mono'_closed[OF inf_fg_le_flow_fg, where E=E] endo_chain_closed simp: assms)
    by (metis assms(3) assms(4) equals0D hd_in_set in_mono set_empty)
  finally have "chain (edge_fg h) ns n (flow_fg h (hd ns)) \<noteq> 0" by simp
  then show False using contradict_eff_acyclic_flow assms by metis
qed

subsection \<open>Upper Bound of Path Length\<close>

text \<open>@{term eff_acyclic_chain_length_le_card}: in an effectively acyclic context paths with
flow have an upper bound of their length.\<close>

lemma eff_acyclic_chain_length_le_card:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "h \<noteq> bot" "chain (edge_fg h) xs y (inf_fg h (hd xs)) \<noteq> 0"
    "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "set xs \<subseteq> dom_fg h" "(\<lambda>_. 0) \<in> E" "id \<in> E"
  shows "length xs \<le> card (dom_fg h)"
proof (rule ccontr)
  assume "\<not> length xs \<le> card (dom_fg h)"
  then have *: "length xs \<ge> card (dom_fg h) + 1" by simp
  then obtain xs1 x xs2 xs3 where **: "xs = xs1 @ x # xs2 @ x # xs3"
    using pigeonhole_split_list[OF *] assms by auto
  then have "chain (edge_fg h) (xs1 @ x # xs2) x (inf_fg h (hd (xs1 @ x # xs2))) \<noteq> 0"
    using chain_append_not_zero(1)[of xs "xs1 @ x # xs2" "x # xs3" _ y _ E] assms
    by (metis (no_types, lifting) Nil_is_append_conv append_Cons
        append_eq_append_conv2 hd_append2 list.sel(1) list.simps(3))
  moreover have "set (xs1 @ x # xs2) \<subseteq> dom_fg h" "x \<in> dom_fg h"
    using assms ** by auto
  ultimately show False
    using contradict_eff_acyclic[of h "xs1 @ x # xs2" x E] assms by simp
qed

text \<open>@{term eff_acyclic_chain_length_le_card'}: Lift the previous result to alternating convoluted paths,
i.e. each path segment is at most as long as the upper bound of its subgraph admits.\<close>

lemma eff_acyclic_chain_length_le_card':
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes alt: "alternating (segment_fg h1) (segment_fg h2) xss"
    and def: "h1 + h2 \<noteq> bot"
    and edge: "End_closed E" "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E"
      "\<forall>x y. edge_fg (h1 + h2) x y \<in> E" "id \<in> E" "(\<lambda>_. 0) \<in> E"
    and ea: "eff_acyclic' h1" "eff_acyclic' h2"
    and null: "chains' (chain (edge_fg (h1 + h2))) xss n (inf_fg h1 (hd (hd xss))) \<noteq> 0"
  shows "alternating (len_segment_fg h1) (len_segment_fg h2) xss"
  using assms
proof (induction xss rule: alternating_induct'_symmetric[where a=h1 and b=h2])
  case empty
  then show ?case by simp
next
  case (base h1 h2 xs)
  have "0 < chain (edge_fg (h1 + h2)) xs n (inf_fg h1 (hd xs))"
    using base gr_zeroI by fastforce
  also have "... = chain (edge_fg h1) xs n (inf_fg h1 (hd xs))"
    apply (subst chain_cong'[OF edge_fg_plus_fg_on1[of h1 h2]])
    using base by simp_all
  finally have *: "chain (edge_fg h1) xs n (inf_fg h1 (hd xs)) \<noteq> 0"
    by simp
  have "length xs \<le> card (dom_fg h1)"
    apply (rule eff_acyclic_chain_length_le_card[where y=n])
    using assms  base * plus_fg_ops_exist unfolding id_def by blast+
  with base show ?case
    by simp
next
  case (step h1 h2 xs ys zss)

  let ?e12 = "edge_fg (h1 + h2)"
  let ?i1 = "inf_fg h1"
  let ?e1 = "edge_fg h1"

  have "chain ?e12 xs (hd ys) (?i1 (hd xs)) \<noteq> 0"
    apply (rule endo_f_n0_n0_closed[OF endo_chains', where E=E])
    using step apply simp_all
    by (clarsimp, rule endo_chain_closed[where E=E], simp_all add: step)
  then have "0 < chain ?e12 xs (hd ys) (inf_fg h1 (hd xs))"
    using gr_zeroI by fastforce
  also have "... = chain ?e1 xs (hd ys) (?i1 (hd xs))"
    apply (subst chain_cong'[OF edge_fg_plus_fg_on1[of h1 h2]])
    using step by simp_all
  finally have *: "chain ?e1 xs (hd ys) (?i1 (hd xs)) \<noteq> 0"
    by simp
  have A: "length xs \<le> card (dom_fg h1)"
    apply (rule eff_acyclic_chain_length_le_card[where y="hd ys" and E=E])
    using assms step * plus_fg_ops_exist unfolding id_def by blast+
  have "0 < chains' (chain ?e12) (ys # zss) n (chain ?e12 xs (hd ys) (?i1 (hd xs)))"
    using step gr_zeroI by fastforce
  also have "... = chains' (chain ?e12) (ys # zss) n (chain ?e1 xs (hd ys) (?i1 (hd (xs @ [hd ys]))))"
    using step by (smt chain_cong' edge_fg_plus_fg_on1' hd_append2)
  also have "... \<le> chains' (chain ?e12) (ys # zss) n (inf_fg h2 (hd ys))"
    apply (rule pos_endo_mono'_closed[OF
            chain_inf_fg_le_inf_fg[where E=E and h="h1 + h2"], where E=E])
    using step apply blast+
    using hd_in_set step.hyps(3) step apply blast
         apply blast
    using step apply blast+
     apply (rule endo_chains'[OF \<open>End_closed E\<close>])
    apply (simp add: endo_chain_closed step)
    using step by blast+
  finally have B: "chains' (chain (edge_fg (h1 + h2))) (ys # zss) n (inf_fg h2 (hd ys)) \<noteq> 0"
    by simp
  from A B step show ?case
    by (simp add: algebra_simps)
qed

end


(*<*)
theory ModeCondition

imports Main FaultModellingTypes Boolean_Expression_Checkers

begin
(*>*)

(*<*)

datatype_new ('a, 'b, 'c) Condition =
  Operations
    (Tautology:"'a \<Rightarrow> bool")
    (Sat: "'a \<Rightarrow> bool")
    (Equiv: "'a \<Rightarrow> 'a \<Rightarrow> bool")
    (Absorb: "'a \<Rightarrow> 'a \<Rightarrow> bool")
    (Eval: "('b \<Rightarrow> 'c) \<Rightarrow>'a \<Rightarrow>  bool")
    (Top: "'a")
    (Bot: "'a")
    (Both: "'a binop")
    (Any: "'a binop")
    (Not: "'a \<Rightarrow> 'a")

notation (output) Tautology ("\<TT>\<index> _" 70)
notation (output) Sat ("\<SS>\<index> _" 70)
notation (output) Equiv (infixr "\<EE>\<index>" 70)
notation (output) Absorb (infixr "\<AA>\<index>" 70)
notation (output) Eval ("_\<Colon>\<lbrakk>_\<rbrakk>\<index>" 70)
notation (output) Top ("\<top>\<index>")
notation (output) Bot ("\<bottom>\<index>")
notation (output) Both (infixr "\<and>\<index>" 50)
notation (output) Any (infixr "\<or>\<index>" 50)
notation (output) Not ("\<not>\<index>_" 50)

datatype_new 'a BoolEx =
  MCConst bool
  | MCVar 'a
  | MCNot "'a BoolEx"
  | MCAnd "'a BoolEx" "'a BoolEx"

type_synonym 'a SeqEx = "'a list set"

notation (output) MCConst  ("_\<^sub>B" 60)
notation (output) MCVar ("_\<^sub>B" 60)
notation (output) MCNot ("\<not>_" 64)
notation (output) MCAnd (infix "\<and>" 65)

abbreviation MCOr :: "'vb BoolEx \<Rightarrow> 'vb BoolEx \<Rightarrow> 'vb BoolEx"
where "MCOr b1 b2 \<equiv> MCNot (MCAnd (MCNot b1) (MCNot b2))"

notation (output) MCOr (infix "\<or>" 70)

abbreviation MCNand :: "'vb BoolEx \<Rightarrow> 'vb BoolEx \<Rightarrow> 'vb BoolEx"
where "MCNand b1 b2 \<equiv> (MCNot (MCAnd b1 b2))"

notation (output) MCNand (infix "\<^sup>\<not>\<and>" 73)

abbreviation MCXor :: "'vb BoolEx \<Rightarrow> 'vb BoolEx \<Rightarrow> 'vb BoolEx"
where "MCXor b1 b2 \<equiv> (MCAnd (MCNand b1 b2) (MCOr b1 b2))"

notation (output) MCXor (infix "\<otimes>" 70)

type_synonym 'vb MCEnv = "'vb \<Rightarrow> bool"

primrec BoolEx_to_bool_expr :: "'vb BoolEx \<Rightarrow> 'vb bool_expr"
where
  "BoolEx_to_bool_expr (MCConst c) = Const_bool_expr c" |
  "BoolEx_to_bool_expr (MCVar v) = Atom_bool_expr v" |
  "BoolEx_to_bool_expr (MCNot b) = Neg_bool_expr (BoolEx_to_bool_expr b)" |
  "BoolEx_to_bool_expr (MCAnd b1 b2) =
    And_bool_expr (BoolEx_to_bool_expr b1) (BoolEx_to_bool_expr b2)"

(*>*)

primrec BoolEx_eval :: "'vb MCEnv \<Rightarrow> 'vb BoolEx \<Rightarrow> bool"
where
  "BoolEx_eval _ (MCConst c) = c" |
  "BoolEx_eval s (MCVar v) = (s v)" |
  "BoolEx_eval s (MCNot b) = (\<not> BoolEx_eval s b)" |
  "BoolEx_eval s (MCAnd b1 b2) =
    ((BoolEx_eval s b1) \<and> (BoolEx_eval s b2))"

definition absorb_rule :: "bool \<Rightarrow> bool \<Rightarrow> bool"
where
  "absorb_rule a b \<equiv> (a \<longrightarrow> b) \<or> (b \<longrightarrow> a)"

definition absorb_test :: "'a bool_expr \<Rightarrow> 'a bool_expr \<Rightarrow> bool"
where
  "absorb_test a b \<equiv> taut_test (Or_bool_expr (Imp_bool_expr a b) (Imp_bool_expr b a))"

definition BoolEx_Absorb :: "'vb BoolEx \<Rightarrow> 'vb BoolEx \<Rightarrow> bool"
where
  "BoolEx_Absorb c1 c2 \<equiv>
    (
        absorb_test (BoolEx_to_bool_expr c1) (BoolEx_to_bool_expr c2)
    )"

definition BoolCondition :: "('vb BoolEx, 'vb, bool) Condition" ("\<^sub>B")
where
  "BoolCondition \<equiv>
  Operations
    (taut_test \<circ> BoolEx_to_bool_expr)
    (sat_test \<circ> BoolEx_to_bool_expr)
    (\<lambda> c1 c2. equiv_test (BoolEx_to_bool_expr c1) (BoolEx_to_bool_expr c2))
    (BoolEx_Absorb)
    (BoolEx_eval)
    (MCConst True)
    (MCConst False)
    (MCAnd)
    (MCOr)
    (MCNot)"

definition SeqCondition:: "('a SeqEx, nat, 'a SeqEx) Condition"
where
  "SeqCondition \<equiv> Operations
    (\<lambda> x . x = {})
    (\<lambda> x . x = {})
    (\<lambda> x y . x = y)
    (\<lambda> x y . x = y)
    (\<lambda> x s . True)
    (UNIV)
    ({})
    (\<lambda> x y . x \<inter> y)
    (\<lambda> x y . x \<union> y)
    (\<lambda> x . UNIV - x)
  "

declare BoolCondition_def [simp]

definition Tautology_Eval_s :: "('a, 'b, 'c) Condition \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> bool"
where "Tautology_Eval_s C s a \<equiv> (Tautology C a = Eval C s a)"

definition ValuePreservation :: "('a, 'b, 'c) Condition \<Rightarrow> bool"
where
  "ValuePreservation C \<equiv> (\<forall> a b.
    (Tautology C a = (\<forall> s. Eval C s a)) \<and>
    (Sat C a = (\<exists> s. Eval C s a)) \<and>
    (Absorb C a b = (\<forall> s. absorb_rule (Eval C s a) (Eval C s b))) \<and>
    (Equiv C a b = (\<forall> s. Eval C s a = Eval C s b))
  )"

definition ValidLattice :: "('a, 'b, 'c) Condition \<Rightarrow> bool"
where
  "ValidLattice C \<equiv>
    (Tautology C (Top C)) \<and>
    (\<not> (Sat C (Bot C))
  )"

definition ValidOps :: "('a, 'b, 'c) Condition \<Rightarrow> bool"
where
  "ValidOps cond \<equiv> (\<forall> a b.
    (Equiv cond (Any cond a (Bot cond)) a) \<and>
    (Equiv cond (Any cond a (Top cond)) (Top cond)) \<and>
    (Equiv cond (Both cond a (Bot cond)) (Bot cond)) \<and>
    (Equiv cond (Both cond a (Top cond)) a) \<and>
    (Equiv cond (Any cond a b) (Any cond b a)) \<and>
    (Equiv cond (Both cond a b) (Both cond b a)) \<and>
    (Equiv cond (Bot cond) (Not cond (Top cond))) \<and>
    (Equiv cond (Top cond) (Not cond (Bot cond)))
  )"

definition ValidCondition :: "('a, 'b, 'c) Condition \<Rightarrow> bool"
where
  "ValidCondition C \<equiv> ValuePreservation C \<and> ValidLattice C \<and> ValidOps C"

lemma "\<lbrakk> ValuePreservation C \<rbrakk> \<Longrightarrow>
  Tautology C a \<Longrightarrow> ((\<forall> s. \<not> Eval C s a)) \<Longrightarrow> False"
apply (simp add: ValuePreservation_def)
done

(*
definition TautologyProperty :: "('a, 'b, 'c) Condition \<Rightarrow> bool"
where
  "TautologyProperty cond \<equiv> \<forall> a. Tautology cond a \<longrightarrow>
    (\<exists> b c. Equiv cond b (Not cond c) \<and> (Equiv cond a (Any cond b c)))"

lemma "\<lbrakk> C = BoolCondition; ValidOps C; ValidLattice C; ValuePreservation C \<rbrakk> \<Longrightarrow>
  TautologyProperty C"
apply (auto)
apply (auto simp add: ValidOps_def TautologyProperty_def ValidLattice_def ValuePreservation_def)
apply (auto simp add: BoolEx_eval_def BoolEx_Absorb_def)
apply (auto simp add: taut_test equiv_test sat_test BoolEx_to_bool_expr_def)
done
*)

lemma ValuePreservation_BoolEx:
  "val_bool_expr (BoolEx_to_bool_expr b) s = BoolEx_eval s b"
apply (induction b)
apply (auto)
done

lemma ValuePreservation_BoolCondition: "ValuePreservation BoolCondition"
apply (auto simp add: ValuePreservation_def)
apply (auto simp add: taut_test ValuePreservation_BoolEx )
apply (auto simp add: sat_test ValuePreservation_BoolEx)
apply (auto simp add: absorb_rule_def BoolEx_Absorb_def absorb_test_def taut_test
  ValuePreservation_BoolEx)
apply (auto simp add: equiv_test ValuePreservation_BoolEx)
done

lemma ValidOps_BoolCondition: "ValidOps BoolCondition"
apply (auto simp add: ValidOps_def equiv_test)
done

lemma ValidLattice_BoolCondition: "ValidLattice BoolCondition"
apply (auto simp add: ValidLattice_def taut_test sat_test)
done

theorem ValidCondition_BoolCondition: "ValidCondition BoolCondition"
apply (auto simp add: ValidCondition_def)
(*apply (auto simp add: ValuePreservation_BoolCondition)*)
apply (auto simp add: ValuePreservation_def)
apply (auto simp add: taut_test ValuePreservation_BoolEx)
apply (auto simp add: sat_test ValuePreservation_BoolEx)
apply (auto simp add: absorb_rule_def absorb_test_def BoolEx_Absorb_def taut_test
  ValuePreservation_BoolEx)
apply (auto simp add: equiv_test ValuePreservation_BoolEx)
apply (auto simp add: ValidOps_def equiv_test)
apply (auto simp add: ValidLattice_def taut_test sat_test)
done

end


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

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "((add3acc (add3acc x1 x2 x3) x4 x5) =
      (add3acc x1 (add3acc x2 x3 x4) x5))"
  oops

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun gt :: "Nat => Nat => bool" where
  "gt y z = lt z y"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter q (nil2) = nil2"
| "filter q (cons2 z xs) =
     (if q z then cons2 z (filter q xs) else filter q xs)"

(*fun did not finish the proof*)
function qsort :: "Nat list => Nat list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: Nat) => le z2 z) xs))
       (x (cons2 z (nil2))
          (qsort (filter (% (x2 :: Nat) => gt x2 z) xs)))"
  by pat_completeness auto

theorem property0 :
  "ordered (qsort xs)"
  oops

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Strong_Bisim_Pres
  imports Strong_Bisim Strong_Sim_Pres
begin

lemma actPres:
  fixes P :: ccs
  and   Q :: ccs
  and   \<alpha> :: act

  assumes "P \<sim> Q"

  shows "\<alpha>.(P) \<sim> \<alpha>.(Q)"
proof -
  let ?X = "{(\<alpha>.(P), \<alpha>.(Q)) | P Q. P \<sim> Q}"
  from assms have "(\<alpha>.(P), \<alpha>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto dest: bisimE intro: actPres)
qed

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

  assumes "P \<sim> Q"

  shows "P \<oplus> R \<sim> Q \<oplus> R"
proof -
  let ?X = "{(P \<oplus> R, Q \<oplus> R) | P Q R. P \<sim> Q}"
  from assms have "(P \<oplus> R, Q \<oplus> R) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: sumPres reflexive dest: bisimE)
qed

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

  assumes "P \<sim> Q"

  shows "P \<parallel> R \<sim> Q \<parallel> R"
proof -
  let ?X = "{(P \<parallel> R, Q \<parallel> R) | P Q R. P \<sim> Q}"
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct, auto) (blast intro: parPres dest: bisimE)+
qed

  assumes "P \<sim> Q"

  shows "\<lparr>\<nu>x\<rparr>P \<sim> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | x P Q. P \<sim> Q}"
  from assms have "(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: resPres dest: bisimE)
qed

  assumes "P \<sim> Q"

  shows "!P \<sim> !Q"
proof -
  from assms have "(!P, !Q) \<in> bangRel bisim"
    by(auto intro: BRBang)
  thus ?thesis
  proof(coinduct rule: bisimWeakCoinduct)
    case(cSim P Q)
    from \<open>(P, Q) \<in> bangRel bisim\<close> show ?case
    proof(induct)
      case(BRBang P Q)
      note \<open>P \<sim> Q\<close> bisimE(1)
      thus "!P \<leadsto>[bangRel bisim] !Q" by(rule bangPres)
    next
      case(BRPar R T P Q)
      from \<open>R \<sim> T\<close> have "R \<leadsto>[bisim] T" by(rule bisimE)
      moreover note \<open>R \<sim> T\<close> \<open>P \<leadsto>[bangRel bisim] Q\<close> \<open>(P, Q) \<in> bangRel bisim\<close> bangRel.BRPar
      ultimately show ?case by(rule Strong_Sim_Pres.parPresAux)
    qed
  next
    case(cSym P Q)
    thus ?case
      by induct (auto dest: bisimE intro: BRPar BRBang)
  qed
qed

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype It = A | B | C

fun removeOne :: "It => (It list) list => (It list) list" where
"removeOne x (nil2) = nil2"
| "removeOne x (cons2 z x2) = cons2 (cons2 x z) (removeOne x x2)"

fun removeOne2 :: "It list => (It list) list" where
"removeOne2 (nil2) = nil2"
| "removeOne2 (cons2 y xs) =
     cons2 xs (removeOne y (removeOne2 xs))"

fun or2 :: "bool list => bool" where
"or2 (nil2) = False"
| "or2 (cons2 y xs) = (y | (or2 xs))"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) y = True"
| "isPrefix (cons2 z x2) (nil2) = False"
| "isPrefix (cons2 z x2) (cons2 x3 x4) =
     ((z = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) y = True"
| "isRelaxedPrefix (cons2 z (nil2)) y = True"
| "isRelaxedPrefix (cons2 z (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

fun spec :: "It list => (It list) list => bool list" where
"spec ys (nil2) = nil2"
| "spec ys (cons2 y z) = cons2 (isPrefix y ys) (spec ys z)"

fun spec2 :: "It list => It list => bool" where
"spec2 x y = or2 (spec y (cons2 x (removeOne2 x)))"

theorem property0 :
  "((isRelaxedPrefix xs ys) = (spec2 xs ys))"
  oops

end


theory TTree
imports Main ConstOn "List-Interleavings"
begin

subsubsection {* Prefix-closed sets of lists *}

definition downset :: "'a list set \<Rightarrow> bool" where
  "downset xss = (\<forall>x n. x \<in> xss \<longrightarrow> take n x \<in> xss)"

lemma downsetE[elim]:
  "downset xss  \<Longrightarrow> xs \<in> xss \<Longrightarrow> butlast xs \<in> xss"
by (auto simp add: downset_def butlast_conv_take)

lemma downset_appendE[elim]:
  "downset xss \<Longrightarrow> xs@ys \<in> xss \<Longrightarrow> xs \<in> xss"
by (auto simp add: downset_def) (metis append_eq_conv_conj)

lemma downset_hdE[elim]:
  "downset xss \<Longrightarrow> xs \<in> xss \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> [hd xs] \<in> xss"
by (auto simp add: downset_def) (metis take_0 take_Suc)

lemma downsetI[intro]:
  assumes "\<And> xs. xs \<in> xss \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> butlast xs \<in> xss"
  shows  "downset xss"
unfolding downset_def
proof(intro impI allI )
  from assms
  have butlast: "\<And> xs. xs \<in> xss \<Longrightarrow> butlast xs \<in> xss"
    by (metis butlast.simps(1))

  fix xs n
  assume "xs \<in> xss"
  show "take n xs \<in> xss"
  proof(cases "n \<le> length xs")
  case True
    from this
    show ?thesis
    proof(induction rule: inc_induct)
    case base with `xs \<in> xss` show ?case by simp
    next
    case (step n')
      from butlast[OF step.IH] step(2)
      show ?case by (simp add: butlast_take)
    qed
  next
  case False with `xs \<in> xss` show ?thesis by simp
  qed
qed

lemma downset_mapI: "downset xss \<Longrightarrow> downset (map f ` xss)"
  by (fastforce simp add: map_butlast[symmetric])

lemma downset_filter:
  assumes "downset xss"
  shows "downset (filter P ` xss)"
proof(rule, elim imageE, clarsimp)
  fix xs
  assume "xs \<in> xss"
  thus "butlast (filter P xs) \<in> filter P ` xss"
  proof (induction xs rule: rev_induct)
    case Nil thus ?case by force
  next
    case snoc
    thus ?case using `downset xss`  by (auto intro: snoc.IH)
  qed
qed

lemma downset_set_subset:
  "downset ({xs. set xs \<subseteq> S})"
by (auto dest: in_set_butlastD)

subsubsection {* The type of infinite labeled trees *}

typedef 'a ttree = "{xss :: 'a list set . [] \<in> xss \<and> downset xss}" by auto

setup_lifting type_definition_ttree

subsubsection {* Deconstructors *}

lift_definition possible ::"'a ttree \<Rightarrow> 'a \<Rightarrow> bool"
  is "\<lambda> xss x. \<exists> xs. x#xs \<in> xss".

lift_definition nxt ::"'a ttree \<Rightarrow> 'a \<Rightarrow> 'a ttree"
  is "\<lambda> xss x. insert [] {xs | xs. x#xs \<in> xss}"
  by (auto simp add: downset_def take_Suc_Cons[symmetric] simp del: take_Suc_Cons)

subsubsection {* Trees as set of paths *}

lift_definition paths :: "'a ttree \<Rightarrow> 'a list set" is "(\<lambda> x. x)".

lemma paths_inj: "paths t = paths t' \<Longrightarrow> t = t'" by transfer auto

lemma paths_injs_simps[simp]: "paths t = paths t' \<longleftrightarrow> t = t'" by transfer auto

lemma paths_Nil[simp]: "[] \<in> paths t" by transfer simp

lemma paths_not_empty[simp]: "(paths t = {}) \<longleftrightarrow> False" by transfer auto

lemma paths_Cons_nxt:
  "possible t x \<Longrightarrow> xs \<in> paths (nxt t x) \<Longrightarrow> (x#xs) \<in> paths t"
  by transfer auto

lemma paths_Cons_nxt_iff:
  "possible t x \<Longrightarrow> xs \<in> paths (nxt t x) \<longleftrightarrow> (x#xs) \<in> paths t"
  by transfer auto

lemma possible_mono:
  "paths t \<subseteq> paths t' \<Longrightarrow> possible t x \<Longrightarrow> possible t' x"
  by transfer auto

lemma nxt_mono:
  "paths t \<subseteq> paths t' \<Longrightarrow> paths (nxt t x) \<subseteq> paths (nxt t' x)"
  by transfer auto

lemma ttree_eqI: "(\<And> x xs. x#xs \<in> paths t \<longleftrightarrow> x#xs \<in> paths t') \<Longrightarrow> t = t'"
  apply (rule paths_inj)
  apply (rule set_eqI)
  apply (case_tac x)
  apply auto
  done

lemma paths_nxt[elim]:
 assumes "xs \<in> paths (nxt t x)"
 obtains "x#xs \<in> paths t"  | "xs = []"
 using assms by transfer auto

lemma Cons_path: "x # xs \<in> paths t \<longleftrightarrow> possible t x \<and> xs \<in> paths (nxt t x)"
 by transfer auto

lemma Cons_pathI[intro]:
  assumes "possible t x \<longleftrightarrow> possible t' x"
  assumes "possible t x \<Longrightarrow> possible t' x \<Longrightarrow> xs \<in> paths (nxt t x) \<longleftrightarrow> xs \<in> paths (nxt t' x)"
  shows  "x # xs \<in> paths t \<longleftrightarrow> x # xs \<in> paths t'"
using assms by (auto simp add: Cons_path)

lemma paths_nxt_eq: "xs \<in> paths (nxt t x) \<longleftrightarrow> xs = [] \<or> x#xs \<in> paths t"
 by transfer auto

lemma ttree_coinduct:
  assumes "P t t'"
  assumes "\<And> t t' x . P t t' \<Longrightarrow> possible t x \<longleftrightarrow> possible t' x"
  assumes "\<And> t t' x . P t t' \<Longrightarrow> possible t x \<Longrightarrow> possible t' x \<Longrightarrow> P (nxt t x) (nxt t' x)"
  shows "t = t'"
proof(rule paths_inj, rule set_eqI)
  fix xs
  from assms(1)
  show "xs \<in> paths t \<longleftrightarrow> xs \<in> paths t'"
  proof (induction xs arbitrary: t t')
  case Nil thus ?case by simp
  next
  case (Cons x xs t t')
    show ?case
    proof (rule Cons_pathI)
      from `P t t'`
      show "possible t x \<longleftrightarrow> possible t' x" by (rule assms(2))
    next
      assume "possible t x" and "possible t' x"
      with `P t t'`
      have "P (nxt t x) (nxt t' x)" by (rule assms(3))
      thus "xs \<in> paths (nxt t x) \<longleftrightarrow> xs \<in> paths (nxt t' x)" by (rule Cons.IH)
    qed
  qed
qed

subsubsection {* The carrier of a tree *}

lift_definition carrier :: "'a ttree \<Rightarrow> 'a set" is "\<lambda> xss. \<Union>(set ` xss)".

lemma carrier_mono: "paths t \<subseteq> paths t' \<Longrightarrow> carrier t \<subseteq> carrier t'" by transfer auto

lemma carrier_possible:
  "possible t x \<Longrightarrow> x \<in> carrier t" by transfer force

lemma carrier_possible_subset:
   "carrier t \<subseteq> A \<Longrightarrow> possible t x \<Longrightarrow> x \<in> A" by transfer force

lemma carrier_nxt_subset:
  "carrier (nxt t x) \<subseteq> carrier t"
  by transfer auto

lemma Union_paths_carrier: "(\<Union>x\<in>paths t. set x) = carrier t"
  by transfer auto

subsubsection {* Repeatable trees *}

definition repeatable where "repeatable t = (\<forall>x . possible t x \<longrightarrow> nxt t x = t)"

lemma nxt_repeatable[simp]: "repeatable t \<Longrightarrow> possible t x \<Longrightarrow> nxt t x = t"
  unfolding repeatable_def by auto

subsubsection {* Simple trees *}

lift_definition empty :: "'a ttree" is "{[]}" by auto

lemma possible_empty[simp]: "possible empty x' \<longleftrightarrow> False"
  by transfer auto

lemma nxt_not_possible[simp]: "\<not> possible t x \<Longrightarrow> nxt t x = empty"
  by transfer auto

lemma paths_empty[simp]: "paths empty = {[]}" by transfer auto

lemma carrier_empty[simp]: "carrier empty = {}" by transfer auto

lemma repeatable_empty[simp]: "repeatable empty" unfolding repeatable_def by transfer auto

lift_definition single :: "'a \<Rightarrow> 'a ttree" is "\<lambda> x. {[], [x]}"
  by auto

lemma possible_single[simp]: "possible (single x) x' \<longleftrightarrow> x = x'"
  by transfer auto

lemma nxt_single[simp]: "nxt (single x) x' =  empty"
  by transfer auto

lemma carrier_single[simp]: "carrier (single y) = {y}"
  by transfer auto

lemma paths_single[simp]: "paths (single x) = {[], [x]}"
  by transfer auto

lift_definition many_calls :: "'a \<Rightarrow> 'a ttree" is "\<lambda> x. range (\<lambda> n. replicate n x)"
  by (auto simp add: downset_def)

lemma possible_many_calls[simp]: "possible (many_calls x) x' \<longleftrightarrow> x = x'"
  by transfer (force simp add: Cons_replicate_eq)

lemma nxt_many_calls[simp]: "nxt (many_calls x) x' = (if x' =  x then many_calls x else empty)"
  by transfer (force simp add: Cons_replicate_eq)

lemma repeatable_many_calls: "repeatable (many_calls x)"
  unfolding repeatable_def by auto

lemma carrier_many_calls[simp]: "carrier (many_calls x) = {x}" by transfer auto

lift_definition anything :: "'a ttree" is "UNIV"
  by auto

lemma possible_anything[simp]: "possible anything x' \<longleftrightarrow> True"
  by transfer auto

lemma nxt_anything[simp]: "nxt anything x = anything"
  by  transfer auto

lemma paths_anything[simp]:
  "paths anything = UNIV" by transfer auto

lemma carrier_anything[simp]:
  "carrier anything = UNIV"
  apply (auto simp add: Union_paths_carrier[symmetric])
  apply (rule_tac x = "[x]" in exI)
  apply simp
  done

lift_definition many_among :: "'a set \<Rightarrow> 'a ttree" is "\<lambda> S. {xs . set xs \<subseteq> S}"
  by (auto intro: downset_set_subset)

lemma carrier_many_among[simp]: "carrier (many_among S) = S"
 by transfer (auto, metis List.set_insert bot.extremum insertCI insert_subset list.set(1))

subsubsection {* Intersection of two trees *}

lift_definition intersect :: "'a ttree \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree" (infixl "\<inter>\<inter>" 80)
  is "op \<inter>"
  by (auto simp add: downset_def)

lemma paths_intersect[simp]: "paths (t \<inter>\<inter> t') = paths t \<inter> paths t'"
  by transfer auto

lemma carrier_intersect: "carrier (t \<inter>\<inter> t') \<subseteq> carrier t \<inter> carrier t'"
  unfolding Union_paths_carrier[symmetric]
  by auto

subsubsection {* Disjoint union of trees *}

lift_definition either :: "'a ttree \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree" (infixl "\<oplus>\<oplus>" 80)
  is "op \<union>"
  by (auto simp add: downset_def)

lemma either_empty1[simp]: "empty \<oplus>\<oplus> t = t"
  by transfer auto
lemma either_empty2[simp]: "t \<oplus>\<oplus> empty = t"
  by transfer auto
lemma either_sym[simp]: "t \<oplus>\<oplus> t2 = t2 \<oplus>\<oplus> t"
  by transfer auto
lemma either_idem[simp]: "t \<oplus>\<oplus> t = t"
  by transfer auto

lemma possible_either[simp]: "possible (t \<oplus>\<oplus> t') x \<longleftrightarrow> possible t x \<or> possible t' x"
  by transfer auto

lemma nxt_either[simp]: "nxt (t \<oplus>\<oplus> t') x = nxt t x \<oplus>\<oplus> nxt t' x"
  by transfer auto

lemma paths_either[simp]: "paths (t \<oplus>\<oplus> t') = paths t \<union> paths t'"
  by transfer simp

lemma carrier_either[simp]:
  "carrier (t \<oplus>\<oplus> t') = carrier t \<union> carrier t'"
  by transfer simp

lemma either_contains_arg1: "paths t \<subseteq> paths (t \<oplus>\<oplus> t')"
  by transfer fastforce

lemma either_contains_arg2: "paths t' \<subseteq> paths (t \<oplus>\<oplus> t')"
  by transfer fastforce

lift_definition Either :: "'a ttree set \<Rightarrow> 'a ttree"  is "\<lambda> S. insert [] (\<Union>S)"
  by (auto simp add: downset_def)

lemma paths_Either: "paths (Either ts) = insert [] (\<Union>(paths ` ts))"
  by transfer auto

subsubsection {* Merging of trees *}

lemma ex_ex_eq_hint: "(\<exists>x. (\<exists>xs ys. x = f xs ys \<and> P xs ys) \<and> Q x) \<longleftrightarrow> (\<exists>xs ys. Q (f xs ys) \<and> P xs ys)"
  by auto

lift_definition both :: "'a ttree \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree" (infixl "\<otimes>\<otimes>" 86)
  is "\<lambda> xss yss . \<Union> {xs \<otimes> ys | xs ys. xs \<in> xss \<and> ys \<in> yss}"
  by (force simp: ex_ex_eq_hint dest: interleave_butlast)

lemma both_assoc[simp]: "t \<otimes>\<otimes> (t' \<otimes>\<otimes> t'') = (t \<otimes>\<otimes> t') \<otimes>\<otimes> t''"
  apply transfer
  apply auto
  apply (metis interleave_assoc2)
  apply (metis interleave_assoc1)
  done

lemma both_comm: "t \<otimes>\<otimes> t' = t' \<otimes>\<otimes> t"
  by transfer (auto, (metis interleave_comm)+)

lemma both_empty1[simp]: "empty \<otimes>\<otimes> t = t"
  by transfer auto

lemma both_empty2[simp]: "t \<otimes>\<otimes> empty = t"
  by transfer auto

lemma paths_both: "xs \<in> paths (t \<otimes>\<otimes> t') \<longleftrightarrow> (\<exists> ys \<in> paths t. \<exists> zs \<in> paths t'. xs \<in> ys \<otimes> zs)"
  by transfer fastforce

lemma both_contains_arg1: "paths t \<subseteq> paths (t \<otimes>\<otimes> t')"
  by transfer fastforce

lemma both_contains_arg2: "paths t' \<subseteq> paths (t \<otimes>\<otimes> t')"
  by transfer fastforce

lemma both_mono1:
  "paths t \<subseteq> paths t' \<Longrightarrow> paths (t \<otimes>\<otimes> t'') \<subseteq> paths (t' \<otimes>\<otimes> t'')"
  by transfer auto

lemma both_mono2:
  "paths t \<subseteq> paths t' \<Longrightarrow> paths (t'' \<otimes>\<otimes> t) \<subseteq> paths (t'' \<otimes>\<otimes> t')"
  by transfer auto

lemma possible_both[simp]: "possible (t \<otimes>\<otimes> t') x \<longleftrightarrow> possible t x \<or> possible t' x"
proof
  assume "possible (t \<otimes>\<otimes> t') x"
  then obtain xs where "x#xs \<in> paths (t \<otimes>\<otimes> t')"
    by transfer auto

  from `x#xs \<in> paths (t \<otimes>\<otimes> t')`
  obtain ys zs where "ys \<in> paths t" and "zs \<in> paths t'" and "x#xs \<in> ys \<otimes> zs"
    by transfer auto

  from `x#xs \<in> ys \<otimes> zs`
  have "ys \<noteq> [] \<and> hd ys = x  \<or> zs \<noteq> [] \<and> hd zs = x"
    by (auto elim: interleave_cases)
  thus "possible t x \<or> possible t' x"
    using  `ys \<in> paths t`   `zs \<in> paths t'`
    by transfer auto
next
  assume "possible t x \<or> possible t' x"
  then obtain xs where "x#xs\<in> paths t \<or> x#xs\<in> paths t'"
    by transfer auto
  from this have "x#xs \<in> paths (t \<otimes>\<otimes> t')" by (auto dest: set_mp[OF both_contains_arg1]  set_mp[OF both_contains_arg2])
  thus "possible (t \<otimes>\<otimes> t') x" by transfer auto
qed

lemma nxt_both:
    "nxt (t' \<otimes>\<otimes> t) x = (if possible t' x \<and> possible t x then nxt t' x \<otimes>\<otimes> t \<oplus>\<oplus> t' \<otimes>\<otimes> nxt t x else
                           if possible t' x then nxt t' x \<otimes>\<otimes> t else
                           if possible t x then t' \<otimes>\<otimes> nxt t x else
                           empty)"
  by (transfer, auto 4 4 intro: interleave_intros)

lemma Cons_both:
    "x # xs \<in> paths (t' \<otimes>\<otimes> t) \<longleftrightarrow> (if possible t' x \<and> possible t x then xs \<in> paths (nxt t' x \<otimes>\<otimes> t) \<or> xs \<in> paths (t' \<otimes>\<otimes> nxt t x) else
                           if possible t' x then xs \<in> paths (nxt t' x \<otimes>\<otimes> t) else
                           if possible t x then xs \<in> paths (t' \<otimes>\<otimes> nxt t x) else
                           False)"
  apply (auto simp add: paths_Cons_nxt_iff[symmetric] nxt_both)
  by (metis paths.rep_eq possible.rep_eq possible_both)

lemma Cons_both_possible_leftE: "possible t x \<Longrightarrow> xs \<in> paths (nxt t x \<otimes>\<otimes> t') \<Longrightarrow> x#xs \<in> paths (t \<otimes>\<otimes> t')"
  by (auto simp add: Cons_both)
lemma Cons_both_possible_rightE: "possible t' x \<Longrightarrow> xs \<in> paths (t \<otimes>\<otimes> nxt t' x) \<Longrightarrow> x#xs \<in> paths (t \<otimes>\<otimes> t')"
  by (auto simp add: Cons_both)

lemma either_both_distr[simp]:
  "t' \<otimes>\<otimes> t \<oplus>\<oplus> t' \<otimes>\<otimes> t'' = t' \<otimes>\<otimes> (t \<oplus>\<oplus> t'')"
  by transfer auto

lemma either_both_distr2[simp]:
  "t' \<otimes>\<otimes> t \<oplus>\<oplus> t'' \<otimes>\<otimes> t = (t' \<oplus>\<oplus> t'') \<otimes>\<otimes> t"
  by transfer auto

lemma nxt_both_repeatable[simp]:
  assumes [simp]: "repeatable t'"
  assumes [simp]: "possible t' x"
  shows "nxt (t' \<otimes>\<otimes> t) x = t' \<otimes>\<otimes> (t \<oplus>\<oplus> nxt t x)"
  by (auto simp add: nxt_both)

lemma nxt_both_many_calls[simp]: "nxt (many_calls x \<otimes>\<otimes> t) x = many_calls x \<otimes>\<otimes> (t  \<oplus>\<oplus> nxt t x)"
  by (simp add: repeatable_many_calls)

lemma repeatable_both_self[simp]:
  assumes [simp]: "repeatable t"
  shows "t \<otimes>\<otimes> t = t"
  apply (intro paths_inj set_eqI)
  apply (induct_tac x)
  apply (auto simp add: Cons_both paths_Cons_nxt_iff[symmetric])
  apply (metis Cons_both both_empty1 possible_empty)+
  done

lemma repeatable_both_both[simp]:
  assumes "repeatable t"
  shows "t \<otimes>\<otimes> t' \<otimes>\<otimes> t = t \<otimes>\<otimes> t'"
  by (metis repeatable_both_self[OF assms]  both_assoc both_comm)

lemma repeatable_both_both2[simp]:
  assumes "repeatable t"
  shows "t' \<otimes>\<otimes> t \<otimes>\<otimes> t = t' \<otimes>\<otimes> t"
  by (metis repeatable_both_self[OF assms]  both_assoc both_comm)

lemma repeatable_both_nxt:
  assumes "repeatable t"
  assumes "possible t' x"
  assumes "t' \<otimes>\<otimes> t = t'"
  shows "nxt t' x \<otimes>\<otimes> t = nxt t' x"
proof(rule classical)
  assume "nxt t' x \<otimes>\<otimes> t \<noteq> nxt t' x"
  hence "(nxt t' x \<oplus>\<oplus> t') \<otimes>\<otimes> t \<noteq> nxt t' x" by (metis (no_types) assms(1) both_assoc repeatable_both_self)
  thus "nxt t' x \<otimes>\<otimes> t = nxt t' x"  by (metis (no_types) assms either_both_distr2 nxt_both nxt_repeatable)
qed

lemma repeatable_both_both_nxt:
  assumes "t' \<otimes>\<otimes> t = t'"
  shows "t' \<otimes>\<otimes> t'' \<otimes>\<otimes> t = t' \<otimes>\<otimes> t''"
  by (metis assms both_assoc both_comm)

lemma carrier_both[simp]:
  "carrier (t \<otimes>\<otimes> t') = carrier t \<union> carrier t'"
proof-
  {
  fix x
  assume "x \<in> carrier (t \<otimes>\<otimes> t')"
  then obtain xs where "xs \<in> paths (t \<otimes>\<otimes> t')" and "x \<in> set xs" by transfer auto
  then obtain ys zs where "ys \<in> paths t" and "zs \<in> paths t'" and "xs \<in> interleave ys zs"
    by (auto simp add: paths_both)
  from this(3) have "set xs = set ys \<union> set zs" by (rule interleave_set)
  with `ys \<in> _` `zs \<in> _` `x \<in> set xs`
  have "x \<in> carrier t \<union> carrier t'"  by transfer auto
  }
  moreover
  note set_mp[OF carrier_mono[OF both_contains_arg1[where t=t and t' = t']]]
       set_mp[OF carrier_mono[OF both_contains_arg2[where t=t and t' = t']]]
  ultimately
  show ?thesis by auto
qed

subsubsection {* Removing elements from a tree *}

lift_definition without :: "'a \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree"
  is "\<lambda> x xss. filter (\<lambda> x'. x' \<noteq> x) ` xss"
  by (auto intro: downset_filter)(metis filter.simps(1) imageI)

lemma carrier_without[simp]: "carrier (without x t) = carrier t - {x}"
  by transfer auto

lift_definition ttree_restr :: "'a set \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree" is "\<lambda> S xss. filter (\<lambda> x'. x' \<in> S) ` xss"
  by (auto intro: downset_filter)(metis filter.simps(1) imageI)

lemma filter_paths_conv_free_restr:
  "filter (\<lambda> x' . x' \<in> S) ` paths t = paths (ttree_restr S t)" by transfer auto

lemma filter_paths_conv_free_restr2:
  "filter (\<lambda> x' . x' \<notin> S) ` paths t = paths (ttree_restr (- S) t)" by transfer auto

lemma filter_paths_conv_free_without:
  "filter (\<lambda> x' . x' \<noteq> y) ` paths t = paths (without y t)" by transfer auto

lemma ttree_restr_is_empty: "carrier t \<inter> S = {} \<Longrightarrow> ttree_restr S t = empty"
  apply transfer
  apply (auto del: iffI )
  apply (metis SUP_bot_conv(2) SUP_inf inf_commute inter_set_filter set_empty)
  apply force
  done

lemma ttree_restr_noop: "carrier t \<subseteq> S \<Longrightarrow> ttree_restr S t = t"
  apply transfer
  apply (auto simp add: image_iff)
  apply (metis SUP_le_iff contra_subsetD filter_True)
  apply (rule_tac x = x in bexI)
  apply (metis SUP_upper contra_subsetD filter_True)
  apply assumption
  done

lemma ttree_restr_tree_restr[simp]:
  "ttree_restr S (ttree_restr S' t) = ttree_restr (S' \<inter> S) t"
  by transfer (simp add: image_comp comp_def)

lemma ttree_restr_both:
  "ttree_restr S (t \<otimes>\<otimes> t') = ttree_restr S t \<otimes>\<otimes> ttree_restr S t'"
  by (force simp add: paths_both filter_paths_conv_free_restr[symmetric] intro: paths_inj filter_interleave  elim: interleave_filter)

lemma ttree_restr_nxt_subset: "x \<in> S \<Longrightarrow> paths (ttree_restr S (nxt t x)) \<subseteq> paths (nxt (ttree_restr S t) x)"
  by transfer (force simp add: image_iff)

lemma ttree_restr_nxt_subset2: "x \<notin> S \<Longrightarrow> paths (ttree_restr S (nxt t x)) \<subseteq> paths (ttree_restr S t)"
  apply transfer
  apply auto
  apply force
  by (metis filter.simps(2) imageI)

lemma ttree_restr_possible: "x \<in> S \<Longrightarrow> possible t x \<Longrightarrow> possible (ttree_restr S t) x"
  by transfer force

lemma ttree_restr_possible2: "possible (ttree_restr S t') x \<Longrightarrow> x \<in> S"
  by transfer (auto, metis filter_eq_Cons_iff)

lemma carrier_ttree_restr[simp]:
  "carrier (ttree_restr S t) = S \<inter> carrier t"
  by transfer auto

(*
lemma intersect_many_among: "t \<inter>\<inter> many_among S = ttree_restr S t"
  apply transfer
  apply auto
*)

subsubsection {* Multiple variables, each called at most once *}

lift_definition singles :: "'a set \<Rightarrow> 'a ttree" is "\<lambda> S. {xs. \<forall> x \<in> S. length (filter (\<lambda> x'. x' = x) xs) \<le> 1}"
  apply auto
  apply (rule downsetI)
  apply auto
  apply (subst (asm) append_butlast_last_id[symmetric]) back
  apply simp
  apply (subst (asm) filter_append)
  apply auto
  done

lemma possible_singles[simp]: "possible (singles S) x"
  apply transfer'
  apply (rule_tac x = "[]" in exI)
  apply auto
  done

lemma length_filter_mono[intro]:
  assumes "(\<And> x. P x \<Longrightarrow> Q x)"
  shows "length (filter P xs) \<le> length (filter Q xs)"
by (induction xs) (auto dest: assms)

lemma nxt_singles[simp]: "nxt (singles S) x' =  (if x' \<in> S then without x' (singles S) else singles S)"
  apply transfer'
  apply auto
  apply (rule rev_image_eqI[where x = "[]"], auto)[1]
  apply (rule_tac x = x in rev_image_eqI)
  apply (simp, rule ballI, erule_tac x = xa in ballE, auto)[1]
  apply (rule sym)
  apply (simp add: filter_id_conv filter_empty_conv)[1]
  apply (erule_tac x = xb in ballE)
  apply (erule order_trans[rotated])
  apply (rule length_filter_mono)
  apply auto
  done

lemma carrier_singles[simp]:
  "carrier (singles S) = UNIV"
  apply transfer
  apply auto
  apply (rule_tac x = "[x]" in exI)
  apply auto
  done

lemma singles_mono:
  "S \<subseteq> S' \<Longrightarrow> paths (singles S') \<subseteq> paths (singles S)"
by transfer auto

lemma paths_many_calls_subset:
  "paths t \<subseteq> paths (many_calls x \<otimes>\<otimes> without x t)"
proof
  fix xs
  assume "xs \<in> paths t"

  have "filter (\<lambda>x'. x' = x) xs = replicate (length (filter (\<lambda>x'. x' = x) xs)) x"
    by (induction xs) auto
  hence "filter (\<lambda>x'. x' = x) xs \<in> paths (many_calls x)" by transfer auto
  moreover
  from `xs \<in> paths t`
  have "filter (\<lambda>x'. x' \<noteq> x) xs \<in> paths (without x t)" by transfer auto
  moreover
  have "xs \<in> interleave (filter (\<lambda>x'. x' = x) xs)  (filter (\<lambda>x'. x' \<noteq> x) xs)" by (rule interleave_filtered)
  ultimately show "xs \<in> paths (many_calls x \<otimes>\<otimes> without x t)" by transfer auto
qed

subsubsection {* Substituting trees for every node *}

definition f_nxt :: "('a \<Rightarrow> 'a ttree) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a ttree)"
  where "f_nxt f T x = (if x \<in> T then f(x:=empty) else f)"

fun substitute' :: "('a \<Rightarrow> 'a ttree) \<Rightarrow> 'a set \<Rightarrow> 'a ttree \<Rightarrow> 'a list \<Rightarrow> bool" where
    substitute'_Nil: "substitute' f T t [] \<longleftrightarrow> True"
  | substitute'_Cons: "substitute' f T t (x#xs) \<longleftrightarrow>
        possible t x \<and> substitute' (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x) xs"

lemma f_nxt_mono1: "(\<And> x. paths (f x) \<subseteq> paths (f' x)) \<Longrightarrow> paths (f_nxt f T x x') \<subseteq> paths (f_nxt f' T x x')"
  unfolding f_nxt_def by auto

lemma f_nxt_empty_set[simp]: "f_nxt f {} x = f" by (simp add: f_nxt_def)

lemma downset_substitute: "downset (Collect (substitute' f T t))"
apply (rule) unfolding mem_Collect_eq
proof-
  fix x
  assume "substitute' f T t x"
  thus "substitute' f T t (butlast x)" by(induction t x rule: substitute'.induct) (auto)
qed

lift_definition substitute :: "('a \<Rightarrow> 'a ttree) \<Rightarrow> 'a set \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree"
  is "\<lambda> f T t. Collect (substitute' f T t)"
  by (simp add: downset_substitute)

lemma elim_substitute'[pred_set_conv]: "substitute' f T t xs \<longleftrightarrow> xs \<in> paths (substitute f T t)" by transfer auto

lemmas substitute_induct[case_names Nil Cons] = substitute'.induct
lemmas substitute_simps[simp] = substitute'.simps[unfolded elim_substitute']

lemma substitute_mono2:
  assumes "paths t \<subseteq> paths t'"
  shows "paths (substitute f T t) \<subseteq> paths (substitute f T t')"
proof
  fix xs
  assume "xs \<in> paths (substitute f T t)"
  thus "xs \<in> paths (substitute f T t')"
  using assms
  proof(induction xs arbitrary:f t t')
  case Nil
    thus ?case by simp
  next
  case (Cons x xs)
    from Cons.prems
    show ?case
    by (auto dest: possible_mono elim: Cons.IH intro!:  both_mono1 nxt_mono)
  qed
qed

lemma substitute_mono1:
  assumes "\<And>x. paths (f x) \<subseteq> paths (f' x)"
  shows "paths (substitute f T t) \<subseteq> paths (substitute f' T t)"
proof
  fix xs
  assume "xs \<in> paths (substitute f T t)"
  from this assms
  show "xs \<in> paths (substitute f' T t)"
  proof (induction xs arbitrary: f f' t)
    case Nil
    thus ?case by simp
  next
  case (Cons x xs)
    from Cons.prems
    show ?case
    by (auto elim!: Cons.IH dest: set_mp dest!: set_mp[OF f_nxt_mono1[OF Cons.prems(2)]] set_mp[OF substitute_mono2[OF  both_mono2[OF Cons.prems(2)]]])
  qed
qed

lemma substitute_monoT:
  assumes "T \<subseteq> T'"
  shows "paths (substitute f T' t) \<subseteq> paths (substitute f T t)"
proof
  fix xs
  assume "xs \<in> paths (substitute f T' t)"
  thus "xs \<in> paths (substitute f T t)"
  using assms
  proof(induction f T' t xs arbitrary: T rule: substitute_induct)
  case Nil
    thus ?case by simp
  next
  case (Cons f T' t x xs T)
    from `x # xs \<in> paths (substitute f T' t)`
    have [simp]: "possible t x" and "xs \<in> paths (substitute (f_nxt f T' x) T' (nxt t x \<otimes>\<otimes> f x))" by auto
    from Cons.IH[OF this(2) Cons.prems(2)]
    have "xs \<in> paths (substitute (f_nxt f T' x) T (nxt t x \<otimes>\<otimes> f x))".
    hence "xs \<in> paths (substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x))"
      by (rule set_mp[OF substitute_mono1, rotated])
         (auto simp add: f_nxt_def set_mp[OF Cons.prems(2)])
    thus ?case by auto
  qed
qed

lemma substitute_contains_arg: "paths t \<subseteq> paths (substitute f T t)"
proof
  fix xs
  show "xs \<in> paths t \<Longrightarrow> xs \<in> paths (substitute f T t)"
  proof (induction xs arbitrary: f t)
    case Nil
    show ?case by simp
  next
    case (Cons x xs)
    from `x # xs \<in> paths t`
    have "possible t x" by transfer auto
    moreover
    from `x # xs \<in> paths t` have "xs \<in> paths (nxt t x)"
      by (auto simp add: paths_nxt_eq)
    hence "xs \<in> paths (nxt t x \<otimes>\<otimes> f x)" by (rule set_mp[OF both_contains_arg1])
    note Cons.IH[OF this]
    ultimately
    show ?case by simp
  qed
qed

lemma possible_substitute[simp]: "possible (substitute f T t) x \<longleftrightarrow> possible t x"
  by (metis Cons_both both_empty2 paths_Nil substitute_simps(2))

lemma nxt_substitute[simp]: "possible t x \<Longrightarrow> nxt (substitute f T t) x = substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x)"
  by (rule ttree_eqI) (simp add: paths_nxt_eq)

lemma substitute_either: "substitute f T (t \<oplus>\<oplus> t') = substitute f T t \<oplus>\<oplus> substitute f T t'"
proof-
  have [simp]: "\<And> t t' x . (nxt t x \<oplus>\<oplus> nxt t' x) \<otimes>\<otimes> f x = nxt t x \<otimes>\<otimes> f x \<oplus>\<oplus> nxt t' x \<otimes>\<otimes> f x" by (metis both_comm either_both_distr)
  {
  fix xs
  have "xs \<in> paths (substitute f T (t \<oplus>\<oplus> t'))  \<longleftrightarrow> xs \<in> paths (substitute f T t) \<or> xs \<in> paths (substitute f T t')"
  proof (induction xs arbitrary: f t t')
    case Nil thus ?case by simp
  next
    case (Cons x xs)
    note IH = Cons.IH[where f = "f_nxt f T x" and t = "nxt t' x \<otimes>\<otimes> f x" and t' = "nxt t x \<otimes>\<otimes> f x"]
    show ?case
    apply (auto simp del: either_both_distr2 simp add: either_both_distr2[symmetric] IH)
    apply (metis IH both_comm either_both_distr either_empty2 nxt_not_possible)
    apply (metis IH both_comm both_empty1 either_both_distr either_empty1 nxt_not_possible)
    done
  qed
  }
  thus ?thesis by (auto intro: paths_inj)
qed

(*
lemma substitute_both: "substitute f (t \<otimes>\<otimes> t') = substitute f t \<otimes>\<otimes> substitute f t'"
proof (intro paths_inj set_eqI)
  fix xs
  show "(xs \<in> paths (substitute f (t \<otimes>\<otimes> t'))) = (xs \<in> paths (substitute f t \<otimes>\<otimes> substitute f t'))"
  proof (induction xs arbitrary: t t')
  case Nil thus ?case by simp
  next
  case (Cons x xs)
    have [simp]: "nxt t x \<otimes>\<otimes> t' \<otimes>\<otimes> f x = nxt t x \<otimes>\<otimes> f x \<otimes>\<otimes> t'"
      by (metis both_assoc both_comm)
    have [simp]: "t \<otimes>\<otimes> nxt t' x \<otimes>\<otimes> f x = t \<otimes>\<otimes> (nxt t' x \<otimes>\<otimes> f x)"
      by (metis both_assoc both_comm)
    note Cons[where t = "nxt t x \<otimes>\<otimes> f x" and t' = t', simp]
    note Cons[where t = t and t' = "nxt t' x \<otimes>\<otimes> f x", simp]
    show ?case
      by (auto simp add: Cons_both nxt_both either_both_distr2[symmetric] substitute_either
                  simp del: both_assoc )
  qed
qed
*)

lemma f_nxt_T_delete:
  assumes "f x = empty"
  shows "f_nxt f (T - {x}) x' = f_nxt f T x'"
using assms
by (auto simp add: f_nxt_def)

lemma f_nxt_empty[simp]:
  assumes "f x = empty"
  shows "f_nxt f T x' x = empty"
using assms
by (auto simp add: f_nxt_def)

lemma f_nxt_empty'[simp]:
  assumes "f x = empty"
  shows "f_nxt f T x = f"
using assms
by (auto simp add: f_nxt_def)

lemma substitute_T_delete:
  assumes "f x = empty"
  shows "substitute f (T - {x}) t = substitute f T t"
proof (intro paths_inj  set_eqI)
  fix xs
  from assms
  show "xs \<in> paths (substitute f (T - {x}) t) \<longleftrightarrow> xs \<in> paths (substitute f T t)"
  by (induction xs arbitrary: f t) (auto simp add: f_nxt_T_delete )
qed

lemma substitute_only_empty:
  assumes "const_on f (carrier t) empty"
  shows "substitute f T t = t"
proof (intro paths_inj  set_eqI)
  fix xs
  from assms
  show "xs \<in> paths (substitute f T t) \<longleftrightarrow> xs \<in> paths t"
  proof (induction xs arbitrary: f t)
  case Nil thus ?case by simp
  case (Cons x xs f t)

    note const_onD[OF Cons.prems carrier_possible, where y = x, simp]

    have [simp]: "possible t x \<Longrightarrow> f_nxt f T x = f"
      by (rule f_nxt_empty', rule const_onD[OF Cons.prems carrier_possible, where y = x])

    from Cons.prems carrier_nxt_subset
    have "const_on f (carrier (nxt t x)) empty"
      by (rule const_on_subset)
    hence "const_on (f_nxt f T x) (carrier (nxt t x)) empty"
      by (auto simp add: const_on_def f_nxt_def)
    note Cons.IH[OF this]
    hence [simp]: "possible t x \<Longrightarrow> (xs \<in> paths (substitute f T (nxt t x))) = (xs \<in> paths (nxt t x))"
      by simp

    show ?case by (auto simp add: Cons_path)
  qed
qed

lemma substitute_only_empty_both: "const_on f (carrier t') empty \<Longrightarrow> substitute f T (t \<otimes>\<otimes> t') = substitute f T t \<otimes>\<otimes> t'"
proof (intro paths_inj set_eqI)
  fix xs
  assume "const_on f (carrier t') TTree.empty"
  thus "(xs \<in> paths (substitute f T (t \<otimes>\<otimes> t'))) = (xs \<in> paths (substitute f T t \<otimes>\<otimes> t'))"
  proof (induction xs arbitrary: f t t')
  case Nil thus ?case by simp
  next
  case (Cons x xs)
    show ?case
    proof(cases "possible t' x")
      case True
      hence "x \<in> carrier t'" by (metis carrier_possible)
      with Cons.prems have [simp]: "f x = empty" by auto
      hence [simp]: "f_nxt f T x = f" by (auto simp add: f_nxt_def)

      note Cons.IH[OF Cons.prems, where t = "nxt t x", simp]

      from Cons.prems
      have "const_on f (carrier (nxt t' x)) empty" by (metis carrier_nxt_subset const_on_subset)
      note Cons.IH[OF this, where t = t, simp]

      show ?thesis using True
        by (auto simp add: Cons_both nxt_both  substitute_either)
    next
      case False

      have [simp]: "nxt t x \<otimes>\<otimes> t' \<otimes>\<otimes> f x = nxt t x \<otimes>\<otimes> f x \<otimes>\<otimes> t'"
        by (metis both_assoc both_comm)

      from Cons.prems
      have "const_on (f_nxt f T x) (carrier t') empty"
        by (force simp add: f_nxt_def)
      note Cons.IH[OF this, where t = "nxt t x \<otimes>\<otimes> f x", simp]

      show ?thesis using False
        by (auto simp add: Cons_both nxt_both  substitute_either)
    qed
  qed
qed

lemma f_nxt_upd_empty[simp]:
  "f_nxt (f(x' := empty)) T x = (f_nxt f T x)(x' := empty)"
  by (auto simp add: f_nxt_def)

lemma repeatable_f_nxt_upd[simp]:
  "repeatable (f x) \<Longrightarrow> repeatable (f_nxt f T x' x)"
  by (auto simp add: f_nxt_def)

lemma substitute_remove_anyways_aux:
  assumes "repeatable (f x)"
  assumes "xs \<in> paths (substitute f T t)"
  assumes "t \<otimes>\<otimes> f x = t"
  shows "xs \<in> paths (substitute (f(x := empty)) T t)"
  using assms(2,3) assms(1)
proof (induction f T t xs  rule: substitute_induct)
  case Nil thus ?case by simp
next
  case (Cons f T t x' xs)
  show ?case
  proof(cases "x' = x")
    case False
    hence [simp]: "(f(x := TTree.empty)) x' = f x'" by simp
    have [simp]: "f_nxt f T x' x = f x" using False by (auto simp add: f_nxt_def)
    show ?thesis using Cons by (auto  simp add: repeatable_both_nxt repeatable_both_both_nxt   simp del: fun_upd_apply)
  next
    case True
    hence [simp]: "(f(x := TTree.empty)) x = empty" by simp
    (*  have [simp]: "f_nxt f T x' x = f x" using False by (auto simp add: f_nxt_def) *)

    have *: "(f_nxt f T x) x = f x \<or> (f_nxt f T x) x = empty" by (simp add: f_nxt_def)
    thus ?thesis
      using Cons True
      by (auto  simp add: repeatable_both_nxt repeatable_both_both_nxt   simp del: fun_upd_apply)
  qed
qed

lemma substitute_remove_anyways:
  assumes "repeatable t"
  assumes "f x = t"
  shows "substitute f T (t \<otimes>\<otimes> t') = substitute (f(x := empty)) T (t \<otimes>\<otimes> t')"
proof (rule paths_inj, rule, rule subsetI)
  fix xs
  have "repeatable (f x)" using assms by simp
  moreover
  assume "xs \<in> paths (substitute f T (t \<otimes>\<otimes> t'))"
  moreover
  have "t \<otimes>\<otimes> t' \<otimes>\<otimes> f x = t \<otimes>\<otimes> t'"
    by (metis assms both_assoc both_comm repeatable_both_self)
  ultimately
  show "xs \<in> paths (substitute (f(x := empty)) T (t \<otimes>\<otimes> t'))"
      by (rule substitute_remove_anyways_aux)
next
  show "paths (substitute (f(x := empty)) T (t \<otimes>\<otimes> t')) \<subseteq> paths (substitute f T (t \<otimes>\<otimes> t'))"
    by (rule substitute_mono1) auto
qed

lemma carrier_f_nxt: "carrier (f_nxt f T x x') \<subseteq> carrier (f x')"
  by (simp add: f_nxt_def)

lemma f_nxt_cong: "f x' = f' x' \<Longrightarrow> f_nxt f T x x' = f_nxt f' T x x'"
  by (simp add: f_nxt_def)

lemma substitute_cong':
  assumes "xs \<in> paths (substitute f T t)"
  assumes "\<And> x n. x \<in> A \<Longrightarrow> carrier (f x) \<subseteq> A"
  assumes "carrier t \<subseteq> A"
  assumes "\<And> x. x \<in> A \<Longrightarrow> f x = f' x"
  shows "xs \<in> paths (substitute f' T t)"
  using assms
proof (induction f T t xs arbitrary: f' rule: substitute_induct )
  case Nil thus ?case by simp
next
  case (Cons f T t x xs)
  hence "possible t x" by auto
  hence "x \<in> carrier t" by (metis carrier_possible)
  hence "x \<in> A" using Cons.prems(3) by auto
  with Cons.prems have [simp]: "f' x = f x" by auto
  have "carrier (f x) \<subseteq> A" using `x \<in> A` by (rule Cons.prems(2))

  from Cons.prems(1,2) Cons.prems(4)[symmetric]
  show ?case
    by (auto elim!: Cons.IH
          dest!: set_mp[OF carrier_f_nxt] set_mp[OF carrier_nxt_subset] set_mp[OF Cons.prems(3)] set_mp[OF `carrier (f x) \<subseteq> A`]
          intro: f_nxt_cong
          )
qed

lemma substitute_cong_induct:
  assumes "\<And> x. x \<in> A \<Longrightarrow> carrier (f x) \<subseteq> A"
  assumes "carrier t \<subseteq> A"
  assumes "\<And> x. x \<in> A \<Longrightarrow> f x = f' x"
  shows "substitute f T t = substitute f' T t"
  apply (rule paths_inj)
  apply (rule set_eqI)
  apply (rule iffI)
  apply (erule (2) substitute_cong'[OF _ assms])
  apply (erule substitute_cong'[OF _ _ assms(2)])
  apply (metis assms(1,3))
  apply (metis assms(3))
  done

lemma carrier_substitute_aux:
  assumes "xs \<in> paths (substitute f T t)"
  assumes "carrier t \<subseteq> A"
  assumes "\<And> x. x \<in> A \<Longrightarrow> carrier (f x) \<subseteq> A"
  shows   "set xs \<subseteq> A"
  using assms
  apply(induction  f T t xs rule: substitute_induct)
  apply auto
  apply (metis carrier_possible_subset)
  apply (metis carrier_f_nxt carrier_nxt_subset carrier_possible_subset contra_subsetD order_trans)
  done

lemma carrier_substitute_below:
  assumes "\<And> x. x \<in> A \<Longrightarrow> carrier (f x) \<subseteq> A"
  assumes "carrier t \<subseteq> A"
  shows "carrier (substitute f T t) \<subseteq> A"
proof-
  have "\<And> xs. xs \<in> paths (substitute f T t) \<Longrightarrow> set xs \<subseteq> A" by (rule carrier_substitute_aux[OF _ assms(2,1)])
  thus ?thesis by (auto simp add:  Union_paths_carrier[symmetric])
qed

lemma f_nxt_eq_empty_iff:
  "f_nxt f T x x' = empty \<longleftrightarrow> f x' = empty \<or> (x' = x \<and> x \<in> T)"
  by (auto simp add: f_nxt_def)

lemma substitute_T_cong':
  assumes "xs \<in> paths (substitute f T t)"
  assumes "\<And> x.  (x \<in> T \<longleftrightarrow> x \<in> T') \<or> f x = empty"
  shows "xs \<in> paths (substitute f T' t)"
  using assms
proof (induction f T t xs  rule: substitute_induct )
  case Nil thus ?case by simp
next
  case (Cons f T t x xs)
  from Cons.prems(2)[where x = x]
  have [simp]: "f_nxt f T x = f_nxt f T' x"
    by (auto simp add: f_nxt_def)

  from Cons.prems(2)
  have "(\<And>x'. (x' \<in> T) = (x' \<in> T') \<or> f_nxt f T x x' = TTree.empty)"
    by (auto simp add: f_nxt_eq_empty_iff)
  from Cons.prems(1) Cons.IH[OF _ this]
  show ?case
    by auto
qed

lemma substitute_cong_T:
  assumes "\<And> x.  (x \<in> T \<longleftrightarrow> x \<in> T') \<or> f x = empty"
  shows "substitute f T = substitute f T'"
  apply rule
  apply (rule paths_inj)
  apply (rule set_eqI)
  apply (rule iffI)
  apply (erule substitute_T_cong'[OF _ assms])
  apply (erule substitute_T_cong')
  apply (metis assms)
  done

lemma carrier_substitute1: "carrier t \<subseteq> carrier (substitute f T t)"
    by (rule carrier_mono) (rule substitute_contains_arg)

lemma substitute_cong:
  assumes "\<And> x. x \<in> carrier (substitute f T t) \<Longrightarrow> f x = f' x"
  shows "substitute f T t = substitute f' T t"
proof(rule substitute_cong_induct[OF _ _ assms])
  show "carrier t \<subseteq> carrier (substitute f T t)"
    by (rule carrier_substitute1)
next
  fix x
  assume "x \<in> carrier (substitute f T t)"
  then obtain xs where "xs \<in> paths (substitute f T t)"  and "x \<in> set xs"  by transfer auto
  thus "carrier (f x) \<subseteq> carrier (substitute f T t)"
  proof (induction xs arbitrary: f t)
  case Nil thus ?case by simp
  next
  case (Cons x' xs f t)
    from `x' # xs \<in> paths (substitute f T t)`
    have "possible t x'" and "xs \<in> paths (substitute (f_nxt f T x') T (nxt t x' \<otimes>\<otimes> f x'))" by auto

    from `x \<in> set (x' # xs)`
    have "x = x' \<or> (x \<noteq> x' \<and> x \<in> set xs)" by auto
    hence "carrier (f x) \<subseteq> carrier (substitute (f_nxt f T x') T (nxt t x' \<otimes>\<otimes> f x'))"
    proof(elim conjE disjE)
      assume "x = x'"
      have "carrier (f x) \<subseteq> carrier (nxt t x \<otimes>\<otimes> f x)" by simp
      also have "\<dots> \<subseteq> carrier (substitute (f_nxt f T x') T (nxt t x \<otimes>\<otimes> f x))" by (rule carrier_substitute1)
      finally show ?thesis unfolding `x = x'`.
    next
      assume "x \<noteq> x'"
      hence [simp]: "(f_nxt f T x' x) = f x" by (simp add: f_nxt_def)

      assume "x \<in> set xs"
      from Cons.IH[OF `xs \<in> _ ` this]
      show "carrier (f x) \<subseteq> carrier (substitute (f_nxt f T x') T (nxt t x' \<otimes>\<otimes> f x'))" by simp
    qed
    also
    from `possible t x'`
    have "carrier (substitute (f_nxt f T x') T (nxt t x' \<otimes>\<otimes> f x')) \<subseteq>  carrier (substitute f T t)"
      apply transfer
      apply auto
      apply (rule_tac x = "x'#xa" in exI)
      apply auto
      done
    finally show ?case.
  qed
qed

lemma substitute_substitute:
  assumes "\<And> x. const_on f' (carrier (f x)) empty"
  shows "substitute f T (substitute f' T t) = substitute (\<lambda> x. f x \<otimes>\<otimes> f' x) T t"
proof (rule paths_inj, rule set_eqI)
  fix xs
  have [simp]: "\<And> f f' x'. f_nxt (\<lambda>x. f x \<otimes>\<otimes> f' x) T x' = (\<lambda>x. f_nxt f T x' x \<otimes>\<otimes> f_nxt f' T x' x)"
    by (auto simp add: f_nxt_def)

  from  assms
  show "xs \<in> paths (substitute f T (substitute f' T t)) \<longleftrightarrow> xs \<in> paths (substitute (\<lambda>x. f x \<otimes>\<otimes> f' x) T t)"
  proof (induction xs arbitrary: f f' t )
  case Nil thus ?case by simp
  case (Cons x xs)
    thus ?case
    proof (cases "possible t x")
      case True

      from Cons.prems
      have prem': "\<And> x'. const_on (f_nxt f' T x) (carrier (f x')) empty"
        by (force simp add: f_nxt_def)
      hence "\<And>x'. const_on (f_nxt f' T x) (carrier ((f_nxt f T x) x')) empty"
        by (metis carrier_empty const_onI emptyE f_nxt_def fun_upd_apply)
      note Cons.IH[where f = "f_nxt f T x" and f' = "f_nxt f' T x", OF this, simp]

      have [simp]: "nxt t x \<otimes>\<otimes> f x \<otimes>\<otimes> f' x = nxt t x \<otimes>\<otimes> f' x \<otimes>\<otimes> f x"
        by (metis both_comm both_assoc)

      show ?thesis using True
        by (auto del: iffI simp add: substitute_only_empty_both[OF prem'[where x' = x] , symmetric])
    next
    case False
      thus ?thesis by simp
    qed
  qed
qed

lemma ttree_rest_substitute:
  assumes "\<And> x. carrier (f x) \<inter> S = {}"
  shows "ttree_restr S (substitute f T t) = ttree_restr S t"
proof(rule paths_inj, rule set_eqI, rule iffI)
  fix xs
  assume "xs \<in> paths (ttree_restr S (substitute f T t))"
  then
  obtain xs' where [simp]: "xs = filter (\<lambda> x'. x' \<in> S) xs'" and "xs' \<in> paths (substitute f T t)"
    by (auto simp add: filter_paths_conv_free_restr[symmetric])
  from this(2) assms
  have "filter (\<lambda> x'. x' \<in> S) xs' \<in>  paths (ttree_restr S t)"
  proof (induction xs' arbitrary: f t)
  case Nil thus ?case by simp
  next
  case (Cons x xs f t)
    from Cons.prems
    have "possible t x" and "xs \<in> paths (substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x))" by auto

    from Cons.prems(2)
    have "(\<And>x'. carrier (f_nxt f T x x') \<inter> S = {})" by (auto simp add: f_nxt_def)

    from  Cons.IH[OF `xs \<in> _` this]
    have "[x'\<leftarrow>xs . x' \<in> S] \<in> paths (ttree_restr S (nxt t x) \<otimes>\<otimes> ttree_restr S (f x))" by (simp add: ttree_restr_both)
    hence "[x'\<leftarrow>xs . x' \<in> S] \<in> paths (ttree_restr S (nxt t x))" by (simp add: ttree_restr_is_empty[OF Cons.prems(2)])
    with `possible t x`
    show "[x'\<leftarrow>x#xs . x' \<in> S] \<in> paths (ttree_restr S t)"
      by (cases "x \<in> S") (auto simp add: Cons_path ttree_restr_possible  dest: set_mp[OF ttree_restr_nxt_subset2]  set_mp[OF ttree_restr_nxt_subset])
  qed
  thus "xs \<in> paths (ttree_restr S t)" by simp
next
  fix xs
  assume "xs \<in> paths (ttree_restr S t)"
  then obtain xs' where [simp]:"xs = filter (\<lambda> x'. x' \<in> S) xs'" and "xs' \<in> paths t"
    by (auto simp add: filter_paths_conv_free_restr[symmetric])
  from this(2)
  have "xs' \<in> paths (substitute f T t)" by (rule set_mp[OF substitute_contains_arg])
  thus "xs \<in> paths (ttree_restr S (substitute f T t))"
    by (auto simp add: filter_paths_conv_free_restr[symmetric])
qed

text {* An alternative characterization of substitution *}

inductive substitute'' :: "('a \<Rightarrow> 'a ttree) \<Rightarrow> 'a set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  substitute''_Nil: "substitute'' f T [] []"
  | substitute''_Cons:
    "zs \<in> paths (f x) \<Longrightarrow> xs' \<in> interleave xs zs \<Longrightarrow> substitute'' (f_nxt f T x) T xs' ys
       \<Longrightarrow> substitute'' f T (x#xs) (x#ys)"

inductive_cases substitute''_NilE[elim]: "substitute'' f T xs []"  "substitute'' f T [] xs"
inductive_cases substitute''_ConsE[elim]: "substitute'' f T (x#xs) ys"

lemma substitute_substitute'':
  "xs \<in> paths (substitute f T t) \<longleftrightarrow> (\<exists> xs' \<in> paths t. substitute'' f T xs' xs)"
proof
  assume "xs \<in> paths (substitute f T t)"
  thus "\<exists> xs' \<in> paths t. substitute'' f T xs' xs"
  proof(induction xs arbitrary: f t)
    case Nil
    have "substitute'' f T [] []"..
    thus ?case by auto
  next
    case (Cons x xs f t)
    from `x # xs \<in> paths (substitute f T t)`
    have "possible t x" and "xs \<in> paths (substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x))" by (auto simp add: Cons_path)
    from Cons.IH[OF this(2)]
    obtain xs' where "xs' \<in> paths (nxt t x \<otimes>\<otimes> f x)" and "substitute'' (f_nxt f T x) T xs' xs" by auto
    from this(1)
    obtain ys' zs' where "ys' \<in> paths (nxt t x)" and "zs' \<in> paths (f x)" and "xs' \<in> interleave ys' zs'"
      by (auto simp add: paths_both)

    from this(2,3) `substitute'' (f_nxt f T x) T xs' xs`
    have "substitute'' f T (x # ys') (x # xs)"..
    moreover
    from `ys' \<in> paths (nxt t x)` `possible t x`
    have "x # ys' \<in> paths t"  by (simp add: Cons_path)
    ultimately
    show ?case by auto
  qed
next
  assume "\<exists> xs' \<in> paths t. substitute'' f T xs' xs"
  then obtain xs' where  "substitute'' f T xs' xs" and "xs' \<in> paths t"  by auto
  thus "xs \<in> paths (substitute f T t)"
  proof(induction arbitrary: t rule: substitute''.induct[case_names Nil Cons])
  case Nil thus ?case by simp
  next
  case (Cons zs x xs' xs ys t)
    from Cons.prems Cons.hyps
    show ?case by (force simp add: Cons_path paths_both intro!: Cons.IH)
  qed
qed

lemma paths_substitute_substitute'':
  "paths (substitute f T t) = \<Union>((\<lambda> xs . Collect (substitute'' f T xs)) ` paths t)"
  by (auto simp add: substitute_substitute'')

lemma ttree_rest_substitute2:
  assumes "\<And> x. carrier (f x) \<subseteq> S"
  assumes "const_on f (-S) empty"
  shows "ttree_restr S (substitute f T t) = substitute f T (ttree_restr S t)"
proof(rule paths_inj, rule set_eqI, rule iffI)
  fix xs
  assume "xs \<in> paths (ttree_restr S (substitute f T t))"
  then
  obtain xs' where [simp]: "xs = filter (\<lambda> x'. x' \<in> S) xs'" and "xs' \<in> paths (substitute f T t)"
    by (auto simp add: filter_paths_conv_free_restr[symmetric])
  from this(2) assms
  have "filter (\<lambda> x'. x' \<in> S) xs' \<in> paths (substitute f T (ttree_restr S t))"
  proof (induction f T t xs' rule: substitute_induct)
  case Nil thus ?case by simp
  next
  case (Cons f T t x xs)
    from Cons.prems(1)
    have "possible t x" and "xs \<in> paths (substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x))" by auto
    note this(2)
    moreover
    from  Cons.prems(2)
    have "\<And> x'. carrier (f_nxt f T x x') \<subseteq> S" by (auto simp add: f_nxt_def)
    moreover
    from  Cons.prems(3)
    have "const_on (f_nxt f T x) (-S) empty" by (force simp add: f_nxt_def)
    ultimately
    have "[x'\<leftarrow>xs . x' \<in> S] \<in> paths (substitute (f_nxt f T x) T (ttree_restr S (nxt t x \<otimes>\<otimes> f x)))" by (rule Cons.IH)
    hence *: "[x'\<leftarrow>xs . x' \<in> S] \<in> paths (substitute (f_nxt f T x) T (ttree_restr S (nxt t x \<otimes>\<otimes> f x)))" by (simp add: ttree_restr_both)
    show ?case
    proof (cases "x \<in> S")
      case True
      show ?thesis
        using `possible t x` Cons.prems(3) * True
        by (auto simp add: ttree_restr_both ttree_restr_noop[OF Cons.prems(2)] intro: ttree_restr_possible
                    dest: set_mp[OF substitute_mono2[OF both_mono1[OF ttree_restr_nxt_subset]]])
    next
      case False
      with `const_on f (- S) TTree.empty` have [simp]: "f x = empty" by auto
      hence [simp]: "f_nxt f T x = f" by (auto simp add: f_nxt_def)
      show ?thesis
      using * False
      by (auto dest:  set_mp[OF substitute_mono2[OF ttree_restr_nxt_subset2]])
    qed
  qed
  thus "xs \<in> paths (substitute f T (ttree_restr S t))" by simp
next
  fix xs
  assume "xs \<in> paths (substitute f T (ttree_restr S t))"
  then obtain xs' where "xs' \<in> paths t" and "substitute'' f T (filter (\<lambda> x'. x'\<in>S) xs') xs "
    unfolding substitute_substitute''
    by (auto simp add: filter_paths_conv_free_restr[symmetric])

  from this(2) assms
  have "\<exists> xs''. xs = filter (\<lambda> x'. x'\<in>S) xs'' \<and> substitute'' f T xs' xs''"
  proof(induction "(xs',xs)" arbitrary: f xs' xs rule: measure_induct_rule[where f = "\<lambda> (xs,ys). length (filter (\<lambda> x'. x' \<notin> S) xs) + length ys"])
  case (less xs ys)
    note `substitute'' f T [x'\<leftarrow>xs . x' \<in> S] ys`

    show ?case
    proof(cases xs)
    case Nil with less.prems have "ys = []" by auto
      thus ?thesis using Nil by (auto,  metis filter.simps(1) substitute''_Nil)
    next
    case (Cons x xs')
      show ?thesis
      proof (cases "x \<in> S")
      case True with Cons less.prems
        have "substitute'' f T (x# [x'\<leftarrow>xs' . x' \<in> S]) ys" by simp
        from substitute''_ConsE[OF this]
        obtain zs xs'' ys' where "ys = x # ys'" and "zs \<in> paths (f x)" and "xs'' \<in> interleave [x'\<leftarrow>xs' . x' \<in> S] zs" and "substitute'' (f_nxt f T x) T xs'' ys'".
        from `zs \<in> paths (f x)`  less.prems(2)
        have "set zs \<subseteq> S" by (auto simp add: Union_paths_carrier[symmetric])
        hence [simp]: "[x'\<leftarrow>zs . x' \<in> S] = zs" "[x'\<leftarrow>zs . x' \<notin> S] = []"
            by (metis UnCI Un_subset_iff eq_iff filter_True,
               metis `set zs \<subseteq> S` filter_False insert_absorb insert_subset)

        from `xs'' \<in> interleave [x'\<leftarrow>xs' . x' \<in> S] zs`
        have "xs'' \<in> interleave [x'\<leftarrow>xs' . x' \<in> S] [x'\<leftarrow>zs . x' \<in> S]" by simp
        then obtain xs''' where "xs'' = [x'\<leftarrow>xs''' . x' \<in> S]" and "xs''' \<in> interleave xs' zs" by (rule interleave_filter)

        from `xs''' \<in> interleave xs' zs`
        have l: "\<And> P. length (filter P xs''') = length (filter P xs') + length (filter P zs)"
          by (induction) auto

        from `substitute'' (f_nxt f T x) T xs'' ys'` `xs'' = _`
        have "substitute'' (f_nxt f T x) T [x'\<leftarrow>xs''' . x' \<in> S] ys'" by simp
        moreover
        from less.prems(2)
        have "\<And>xa. carrier (f_nxt f T x xa) \<subseteq> S"
          by (auto simp add: f_nxt_def)
        moreover
        from less.prems(3)
        have "const_on (f_nxt f T x) (- S) TTree.empty" by (force simp add: f_nxt_def)
        ultimately
        have "\<exists>ys''. ys' = [x'\<leftarrow>ys'' . x' \<in> S] \<and> substitute'' (f_nxt f T x) T xs''' ys''"
            by (rule less.hyps[rotated])
               (auto simp add: `ys = _ ` `xs =_` `x \<in> S` `xs'' = _`[symmetric] l)[1]
        then obtain ys'' where "ys' = [x'\<leftarrow>ys'' . x' \<in> S]" and "substitute'' (f_nxt f T x) T xs''' ys''" by blast
        hence "ys = [x'\<leftarrow>x#ys'' . x' \<in> S]" using `x \<in> S` `ys = _` by simp
        moreover
        from `zs \<in> paths (f x)` `xs''' \<in> interleave xs' zs` `substitute'' (f_nxt f T x) T xs''' ys''`
        have "substitute'' f T (x#xs') (x#ys'')"
          by rule
        ultimately
        show ?thesis unfolding Cons by blast
      next
      case False with Cons less.prems
        have "substitute'' f T ([x'\<leftarrow>xs' . x' \<in> S]) ys" by simp
        hence "\<exists>ys'. ys = [x'\<leftarrow>ys' . x' \<in> S] \<and> substitute'' f T xs' ys'"
            by (rule less.hyps[OF _ _ less.prems(2,3), rotated]) (auto simp add:  `xs =_` `x \<notin>  S`)
        then obtain ys' where "ys = [x'\<leftarrow>ys' . x' \<in> S]" and "substitute'' f T xs' ys'" by auto

        from this(1)
        have "ys = [x'\<leftarrow>x#ys' . x' \<in> S]" using `x \<notin> S` `ys = _` by simp
        moreover
        have [simp]: "f x = empty" using `x \<notin> S` less.prems(3) by force
        hence "f_nxt f T x = f" by (auto simp add: f_nxt_def)
        with `substitute'' f T xs' ys'`
        have "substitute'' f T (x#xs') (x#ys')"
          by (auto intro: substitute''.intros)
        ultimately
        show ?thesis unfolding Cons by blast
      qed
    qed
  qed
  then obtain xs'' where "xs = filter (\<lambda> x'. x'\<in>S) xs''" and "substitute'' f T xs' xs''" by auto
  from this(2) `xs' \<in> paths t`
  have "xs'' \<in> paths (substitute f T t)" by (auto simp add: substitute_substitute'')
  with `xs = _`
  show "xs \<in> paths (ttree_restr S (substitute f T t))"
    by (auto simp add:  filter_paths_conv_free_restr[symmetric])
qed

end