(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2021 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open> Quasigroups \<close>

theory Quasigroup_ZF imports func1

begin

text\<open> A quasigroup is an algebraic structure that that one gets after adding (sort of)
   divsibility to magma. Quasigroups differ from groups in that they are not necessarily
   associative and they do not have to have the neutral element. \<close>

subsection\<open> Definitions and notation \<close>

text\<open> According to Wikipedia there are at least two approaches to defining a quasigroup.
  One defines a quasigroup as a set with a binary operation, and the other,
  from universal algebra, defines a quasigroup as having three primitive operations. We will use
  the first approach.  \<close>

text\<open> A quasigroup operation does not  have to have the neutral element. The left division is defined
  as the only solution to the equation $a\cdot x=b$ (using multiplicative notation).
  The next definition specifies
  what does it mean that an operation $A$ has a left division on a set $G$. \<close>

definition
  "HasLeftDiv(G,A) \<equiv> \<forall>a\<in>G.\<forall>b\<in>G.\<exists>!x. (x\<in>G \<and> A`\<langle>a,x\<rangle> = b)"

text\<open> An operation $A$ has the right inverse if for all elements $a,b \in G$ the equation $x\cdot a=b$
  has a unique solution. \<close>

definition
  "HasRightDiv(G,A) \<equiv> \<forall>a\<in>G.\<forall>b\<in>G.\<exists>!x. (x\<in>G \<and> A`\<langle>x,a\<rangle> = b)"

text\<open>An operation that has both left and right division is said to have the Latin square property. \<close>

definition
  HasLatinSquareProp (infix "{has Latin square property on}" 65) where
    "A {has Latin square property on} G \<equiv> HasLeftDiv(G,A) \<and> HasRightDiv(G,A)"

text\<open> A quasigroup is a set with a binary operation that has the Latin square property. \<close>

definition
  "IsAquasigroup(G,A) \<equiv> A:G\<times>G\<rightarrow>G \<and> A {has Latin square property on} G"

text\<open> The uniqueness of the left inverse allows us to define the left division as a function.
  The union expression as the value of the function extracts the only element
  of the set of solutions of the equation $x\cdot z = y$ for given
  $\langle x,y \rangle = p \in G\times G$ using the identity $\bigcup \{x\} =x$. \<close>

definition
  "LeftDiv(G,A) \<equiv> {\<langle>p,\<Union>{z\<in>G. A`\<langle>fst(p),z\<rangle> = snd(p)}\<rangle>.p\<in>G\<times>G}"

text\<open>Similarly the right division is defined as a function on $G\times G$.  \<close>

definition
  "RightDiv(G,A) \<equiv> {\<langle>p,\<Union>{z\<in>G. A`\<langle>z,fst(p)\<rangle> = snd(p)}\<rangle>.p\<in>G\<times>G}"

text\<open>Left and right divisions are binary operations on $G$. \<close>

lemma lrdiv_binop: assumes "IsAquasigroup(G,A)" shows
  "LeftDiv(G,A):G\<times>G\<rightarrow>G" and  "RightDiv(G,A):G\<times>G\<rightarrow>G"
proof -
  { fix p assume "p\<in>G\<times>G"
    with assms have
      "\<Union>{x\<in>G. A`\<langle>fst(p),x\<rangle> = snd(p)} \<in> G" and  "\<Union>{x\<in>G. A`\<langle>x,fst(p)\<rangle> = snd(p)} \<in> G"
      unfolding IsAquasigroup_def HasLatinSquareProp_def HasLeftDiv_def HasRightDiv_def
      using ZF1_1_L9(2) by auto
  } then show  "LeftDiv(G,A):G\<times>G\<rightarrow>G" and "RightDiv(G,A):G\<times>G\<rightarrow>G"
    unfolding LeftDiv_def RightDiv_def using ZF_fun_from_total by auto
qed

text\<open> We will use multiplicative notation for the quasigroup operation. The right and left division will
  be denoted $a/b$ and $a\backslash b$, resp.\<close>

locale quasigroup0 =
  fixes G A
  assumes qgroupassum: "IsAquasigroup(G,A)"

  fixes qgroper (infixl "\<cdot>" 70)
  defines qgroper_def[simp]: "x\<cdot>y \<equiv> A`\<langle>x,y\<rangle>"

  fixes leftdiv (infixl "\<ld>" 70)
  defines leftdiv_def[simp]: "x\<ld>y \<equiv>LeftDiv(G,A)`\<langle>x,y\<rangle>"

  fixes rightdiv (infixl "\<rd>" 70)
  defines rightdiv_def[simp]:"x\<rd>y \<equiv>RightDiv(G,A)`\<langle>y,x\<rangle>"

text\<open> The quasigroup operation is closed on $G$. \<close>

lemma (in quasigroup0) qg_op_closed: assumes "x\<in>G" "y\<in>G"
  shows "x\<cdot>y \<in> G"
  using qgroupassum assms IsAquasigroup_def apply_funtype by auto

text\<open> A couple of properties of right and left division: \<close>

lemma (in quasigroup0) lrdiv_props: assumes "x\<in>G" "y\<in>G"
  shows
  "\<exists>!z. z\<in>G \<and> z\<cdot>x = y" "y\<rd>x \<in> G" "(y\<rd>x)\<cdot>x = y" and
  "\<exists>!z. z\<in>G \<and> x\<cdot>z = y" "x\<ld>y \<in> G" "x\<cdot>(x\<ld>y) = y"
proof -
  let ?z\<^sub>r = "\<Union>{z\<in>G. z\<cdot>x = y}"
  from qgroupassum have I: "RightDiv(G,A):G\<times>G\<rightarrow>G" using lrdiv_binop(2) by simp
  with assms have "RightDiv(G,A)`\<langle>x,y\<rangle> = ?z\<^sub>r"
    unfolding RightDiv_def using ZF_fun_from_tot_val by auto
  moreover
  from qgroupassum assms show "\<exists>!z. z\<in>G \<and> z\<cdot>x = y"
    unfolding IsAquasigroup_def HasLatinSquareProp_def HasRightDiv_def by simp
  then have "?z\<^sub>r\<cdot>x = y" by (rule ZF1_1_L9)
  ultimately show "(y\<rd>x)\<cdot>x = y" by simp
  let ?z\<^sub>l = "\<Union>{z\<in>G. x\<cdot>z = y}"
  from qgroupassum have II: "LeftDiv(G,A):G\<times>G\<rightarrow>G" using lrdiv_binop(1) by simp
  with assms have "LeftDiv(G,A)`\<langle>x,y\<rangle> = ?z\<^sub>l"
    unfolding LeftDiv_def using ZF_fun_from_tot_val by auto
  moreover
  from qgroupassum assms show "\<exists>!z. z\<in>G \<and> x\<cdot>z = y"
    unfolding IsAquasigroup_def HasLatinSquareProp_def HasLeftDiv_def by simp
  then have "x\<cdot>?z\<^sub>l = y" by (rule ZF1_1_L9)
  ultimately show "x\<cdot>(x\<ld>y) = y" by simp
  from assms I II show "y\<rd>x \<in> G" and "x\<ld>y \<in> G" using apply_funtype by auto
qed

text\<open> We can cancel the left element on both sides of an equation. \<close>

lemma (in quasigroup0) qg_cancel_left:
  assumes "x\<in>G" "y\<in>G" "z\<in>G" and "x\<cdot>y = x\<cdot>z"
  shows "y=z"
  using qgroupassum assms qg_op_closed lrdiv_props(4) by blast

text\<open> We can cancel the right element on both sides of an equation. \<close>

lemma (in quasigroup0) qg_cancel_right:
  assumes "x\<in>G" "y\<in>G" "z\<in>G" and "y\<cdot>x = z\<cdot>x"
  shows "y=z"
  using qgroupassum assms qg_op_closed lrdiv_props(1) by blast

text\<open> Two additional identities for right and left division: \<close>

lemma (in quasigroup0) lrdiv_ident: assumes "x\<in>G" "y\<in>G"
  shows "(y\<cdot>x)\<rd>x = y" and "x\<ld>(x\<cdot>y) = y"
proof -
  from assms have "(y\<cdot>x)\<rd>x \<in> G" and "((y\<cdot>x)\<rd>x)\<cdot>x = y\<cdot>x"
    using qg_op_closed lrdiv_props(2,3) by auto
  with assms show "(y\<cdot>x)\<rd>x = y" using qg_cancel_right by simp
  from assms have "x\<ld>(x\<cdot>y) \<in> G" and "x\<cdot>(x\<ld>(x\<cdot>y)) = x\<cdot>y"
    using qg_op_closed lrdiv_props(5,6) by auto
  with assms show "x\<ld>(x\<cdot>y) = y" using qg_cancel_left by simp
qed

end


section \<open>Helper Algorithms\<close>

text \<open>This theory contains several algorithms used to calculate components of a test suite.\<close>

theory Helper_Algorithms
imports State_Separator State_Preamble
begin

subsection \<open>Calculating r-distinguishable State Pairs with Separators\<close>

definition r_distinguishable_state_pairs_with_separators ::
  "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> (('a \<times> 'a) \<times> (('a \<times> 'a) + 'a,'b,'c) fsm) set"
  where
  "r_distinguishable_state_pairs_with_separators M =
    {((q1,q2),Sep) | q1 q2 Sep . q1 \<in> states M
                      \<and> q2 \<in> states M
                      \<and> ((q1 < q2 \<and> state_separator_from_s_states M q1 q2 = Some Sep)
                        \<or> (q2 < q1 \<and> state_separator_from_s_states M q2 q1 = Some Sep)) }"

lemma r_distinguishable_state_pairs_with_separators_alt_def :
  "r_distinguishable_state_pairs_with_separators M =
    \<Union> (image (\<lambda> ((q1,q2),A) . {((q1,q2),the A),((q2,q1),the A)})
              (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                          (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                 (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))))"
  (is "?P1 = ?P2")
proof -
  have "\<And> x . x \<in> ?P1 \<Longrightarrow> x \<in> ?P2"
  proof -
    fix x assume "x \<in> ?P1"
    then obtain q1 q2 A where "x = ((q1,q2),A)"
      by (metis eq_snd_iff)
    then have "((q1,q2),A) \<in> ?P1" using \<open>x \<in> ?P1\<close> by auto
    then have "q1 \<in> states M"
         and  "q2 \<in> states M"
         and  "((q1 < q2 \<and> state_separator_from_s_states M q1 q2 = Some A)
                  \<or> (q2 < q1 \<and> state_separator_from_s_states M q2 q1 = Some A))"
      unfolding r_distinguishable_state_pairs_with_separators_def by blast+

    then consider (a) "q1 < q2 \<and> state_separator_from_s_states M q1 q2 = Some A" |
                  (b) "q2 < q1 \<and> state_separator_from_s_states M q2 q1 = Some A"
      by blast
    then show "x \<in> ?P2"
      using \<open>q1 \<in> states M\<close> \<open>q2 \<in> states M\<close> unfolding \<open>x = ((q1,q2),A)\<close> by (cases; force)
  qed
  moreover have "\<And> x . x \<in> ?P2 \<Longrightarrow> x \<in> ?P1"
  proof -
    fix x assume "x \<in> ?P2"
    then obtain q1 q2 A where "x = ((q1,q2),A)"
      by (metis eq_snd_iff)
    then have "((q1,q2),A) \<in> ?P2" using \<open>x \<in> ?P2\<close> by auto
    then obtain q1' q2' A' where "((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}"
                           and   "A' \<noteq> None"
                           and   "((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                            (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))"
      by force

    then have "A' = Some A"
      by (metis (no_types, lifting) empty_iff insert_iff old.prod.inject option.collapse)

    moreover have "A' = state_separator_from_s_states M q1' q2'"
             and  "q1' < q2'"
             and  "q1' \<in> states M"
             and  "q2' \<in> states M"
      using \<open>((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                      (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))\<close>
      by force+
    ultimately have "state_separator_from_s_states M q1' q2' = Some A" by simp

    consider "((q1',q2'),the A') = ((q1,q2),A)" | "((q1',q2'),the A') = ((q2,q1),A)"
      using \<open>((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}\<close>
      by force
    then show "x \<in> ?P1"
    proof cases
      case 1
      then have *: "q1' = q1" and **: "q2' = q2" by auto

      show ?thesis
        using \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> \<open>q1' < q2'\<close> \<open>state_separator_from_s_states M q1' q2' = Some A\<close>
        unfolding r_distinguishable_state_pairs_with_separators_def
        unfolding * ** \<open>x = ((q1,q2),A)\<close> by blast
    next
      case 2
      then have *: "q1' = q2" and **: "q2' = q1" by auto

      show ?thesis
        using \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> \<open>q1' < q2'\<close> \<open>state_separator_from_s_states M q1' q2' = Some A\<close>
        unfolding r_distinguishable_state_pairs_with_separators_def
        unfolding * ** \<open>x = ((q1,q2),A)\<close> by blast
    qed
  qed
  ultimately show ?thesis by blast
qed

lemma r_distinguishable_state_pairs_with_separators_code[code] :
  "r_distinguishable_state_pairs_with_separators M =
    set (concat (map
                  (\<lambda> ((q1,q2),A) . [((q1,q2),the A),((q2,q1),the A)])
                  (filter (\<lambda> (qq,A) . A \<noteq> None)
                          (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                               (filter (\<lambda> (q1,q2) . q1 < q2)
                                       (List.product(states_as_list M) (states_as_list M)))))))"
  (is "r_distinguishable_state_pairs_with_separators M = ?C2")
proof -
  let ?C1 = "\<Union> (image (\<lambda> ((q1,q2),A) . {((q1,q2),the A),((q2,q1),the A)})
                       (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                                   (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                          (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))))"

  have "r_distinguishable_state_pairs_with_separators M = ?C1"
    using r_distinguishable_state_pairs_with_separators_alt_def by assumption
  also have "\<dots> = ?C2"
  proof
    show "?C1 \<subseteq> ?C2"
    proof
      fix x assume "x \<in> ?C1"
      then obtain q1 q2 A where "x = ((q1,q2),A)"
        by (metis eq_snd_iff)
      then have "((q1,q2),A) \<in> ?C1" using \<open>x \<in> ?C1\<close> by auto
      then obtain q1' q2' A' where "((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}"
                             and   "A' \<noteq> None"
                             and   "((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                             (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))"
        by force

      then have "A' = Some A"
        by (metis (no_types, lifting) empty_iff insert_iff old.prod.inject option.collapse)

      moreover have "A' = state_separator_from_s_states M q1' q2'"
               and  "q1' < q2'"
               and  "q1' \<in> states M"
               and  "q2' \<in> states M"
        using \<open>((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                        (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))\<close>
        by force+
      ultimately have "state_separator_from_s_states M q1' q2' = Some A"
                 and  "(q1',q2') \<in> set (filter (\<lambda> (q1,q2) . q1 < q2) (List.product(states_as_list M) (states_as_list M)))"
        unfolding states_as_list_set[symmetric] by auto

      then have "((q1',q2'),A') \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None)
                                              (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                   (filter (\<lambda> (q1,q2) . q1 < q2)
                                                           (List.product(states_as_list M) (states_as_list M)))))"
        using \<open>A' = state_separator_from_s_states M q1' q2'\<close> \<open>A' = Some A\<close> by force

      have scheme1: "\<And> f xs x . x \<in> set xs \<Longrightarrow> f x \<in> set (map f xs)" by auto
      have scheme2: "\<And> x xs xss . xs \<in> set xss \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set (concat xss)" by auto
      have *:"[((q1',q2'),the A'),((q2',q1'),the A')] \<in>
                set (map (\<lambda> ((q1,q2),A) . [((q1,q2),the A),((q2,q1),the A)])
                         (filter (\<lambda> (qq,A) . A \<noteq> None)
                                 (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                      (filter (\<lambda> (q1,q2) . q1 < q2)
                                              (List.product(states_as_list M) (states_as_list M))))))"
        using scheme1[OF \<open>((q1',q2'),A') \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None) (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2)) (filter (\<lambda> (q1,q2) . q1 < q2) (List.product(states_as_list M) (states_as_list M)))))\<close>, of "\<lambda> ((q1', q2'), A') . [((q1',q2'),the A'),((q2',q1'),the A')]"]
        by force
      have **: "((q1,q2),A) \<in> set [((q1',q2'),the A'),((q2',q1'),the A')]"
        using \<open>((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}\<close> by auto

      show "x \<in> ?C2"
        unfolding \<open>x = ((q1,q2),A)\<close> using scheme2[OF * **] by assumption
    qed

    show "?C2 \<subseteq> ?C1"
    proof
      fix x assume "x \<in> ?C2"
      obtain q1q2A where "x \<in>  set ((\<lambda> ((q1', q2'), A') . [((q1',q2'),the A'),((q2',q1'),the A')]) q1q2A)"
                   and   "q1q2A \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None)
                                              (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                   (filter (\<lambda> (q1,q2) . q1 < q2)
                                                           (List.product(states_as_list M) (states_as_list M)))))"
        using concat_map_elem[OF \<open>x \<in> ?C2\<close>] by blast

      moreover obtain q1 q2 A where "q1q2A = ((q1,q2),A)"
        by (metis prod.collapse)

      ultimately have "x \<in> set [((q1,q2),the A),((q2,q1),the A)]"
                 and  "((q1,q2),A) \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None)
                                                 (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                      (filter (\<lambda> (q1,q2) . q1 < q2)
                                                              (List.product(states_as_list M) (states_as_list M)))))"
        by force+

      then have "A = state_separator_from_s_states M q1 q2"
           and  "A \<noteq> None"
           and  "(q1,q2) \<in> set (filter (\<lambda> (q1,q2) . q1 < q2) (List.product(states_as_list M) (states_as_list M)))"
        by auto

      then have "q1 < q2" and "q1 \<in> states M" and "q2 \<in> states M"
        unfolding states_as_list_set[symmetric] by auto
      then have "(q1,q2) \<in> Set.filter (\<lambda>(q1, q2). q1 < q2) (FSM.states M \<times> FSM.states M)"
        by auto
      then have "((q1,q2),A) \<in> (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                                           (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                  (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M))))"
        using \<open>A \<noteq> None\<close> unfolding \<open>A = state_separator_from_s_states M q1 q2\<close> by auto
      then have "{((q1,q2),the A),((q2,q1),the A)} \<in>
                      (image (\<lambda> ((q1,q2),A) . {((q1,q2),the A),((q2,q1),the A)})
                             (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                                         (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                (Set.filter (\<lambda> (q1,q2) . q1 < q2) (states M \<times> states M)))))"
        by (metis (no_types, lifting) \<open>q1q2A = ((q1, q2), A)\<close> case_prod_conv image_iff)
      then show "x \<in> ?C1"
        using \<open>x \<in> set [((q1,q2),the A),((q2,q1),the A)]\<close>
        by (metis (no_types, lifting) UnionI list.simps(15) set_empty2)
    qed
  qed

  finally show ?thesis .
qed

lemma r_distinguishable_state_pairs_with_separators_same_pair_same_separator :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "((q1,q2),A') \<in> r_distinguishable_state_pairs_with_separators M"
shows "A = A'"
  using assms unfolding r_distinguishable_state_pairs_with_separators_def
  by force

lemma r_distinguishable_state_pairs_with_separators_sym_pair_same_separator :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "((q2,q1),A') \<in> r_distinguishable_state_pairs_with_separators M"
shows "A = A'"
  using assms unfolding r_distinguishable_state_pairs_with_separators_def
  by force

lemma r_distinguishable_state_pairs_with_separators_elem_is_separator:
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "observable M"
  and     "completely_specified M"
shows "is_separator M q1 q2 A (Inr q1) (Inr q2)"
proof -
  have *:"q1 \<in> states M"
  and **:"q2 \<in> states M"
  and ***:"q1 \<noteq> q2"
  and ****: "q2\<noteq>q1"
  and *****: "state_separator_from_s_states M q1 q2 = Some A \<or> state_separator_from_s_states M q2 q1 = Some A"
    using assms(1) unfolding r_distinguishable_state_pairs_with_separators_def by auto

  from ***** have "is_state_separator_from_canonical_separator (canonical_separator M q1 q2) q1 q2 A
                    \<or> is_state_separator_from_canonical_separator (canonical_separator M q2 q1) q2 q1 A"
    using state_separator_from_s_states_soundness[of M q1 q2 A, OF _ * ** assms(3)]
    using state_separator_from_s_states_soundness[of M q2 q1 A, OF _ ** * assms(3)] by auto
  then show ?thesis
    using state_separator_from_canonical_separator_is_separator[of M q1 q2 A, OF _ \<open>observable M\<close> * ** ***]
    using state_separator_from_canonical_separator_is_separator[of M q2 q1 A, OF _ \<open>observable M\<close> ** * ****]
    using is_separator_sym[of M q2 q1 A "Inr q2" "Inr q1"] by auto
qed

subsection \<open>Calculating Pairwise r-distinguishable Sets of States\<close>

definition pairwise_r_distinguishable_state_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set set" where
  "pairwise_r_distinguishable_state_sets_from_separators M
    = { S . S \<subseteq> states M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M))}"

definition pairwise_r_distinguishable_state_sets_from_separators_list :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set list" where
  "pairwise_r_distinguishable_state_sets_from_separators_list M =
    (let RDS = image fst (r_distinguishable_state_pairs_with_separators M)
      in filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> RDS)
             (map set (pow_list (states_as_list M))))"

(* uses a list-based calculation to avoid storing the entire powerset *)
lemma pairwise_r_distinguishable_state_sets_from_separators_code[code] :
  "pairwise_r_distinguishable_state_sets_from_separators M = set (pairwise_r_distinguishable_state_sets_from_separators_list M)"
  using pow_list_set[of "states_as_list M"]
  unfolding states_as_list_set[of M]
            pairwise_r_distinguishable_state_sets_from_separators_def
            pairwise_r_distinguishable_state_sets_from_separators_list_def
  by auto

lemma pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> states M"
  shows "\<exists> S \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . q \<in> S"
  unfolding pairwise_r_distinguishable_state_sets_from_separators_def using assms by blast

definition maximal_pairwise_r_distinguishable_state_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set set" where
  "maximal_pairwise_r_distinguishable_state_sets_from_separators M
    = { S . S \<in> (pairwise_r_distinguishable_state_sets_from_separators M)
            \<and> (\<nexists> S' . S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) \<and> S \<subset> S')}"

definition maximal_pairwise_r_distinguishable_state_sets_from_separators_list :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set list" where
  "maximal_pairwise_r_distinguishable_state_sets_from_separators_list M =
    remove_subsets (pairwise_r_distinguishable_state_sets_from_separators_list M)"

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_code[code] :
  "maximal_pairwise_r_distinguishable_state_sets_from_separators M
    = set (maximal_pairwise_r_distinguishable_state_sets_from_separators_list M)"
  unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_list_def
            Let_def remove_subsets_set pairwise_r_distinguishable_state_sets_from_separators_code[symmetric]
            maximal_pairwise_r_distinguishable_state_sets_from_separators_def
  by blast

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> states M"
  shows "\<exists> S \<in> (maximal_pairwise_r_distinguishable_state_sets_from_separators M ). q \<in> S"
proof -

  have *: "{q} \<in> (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def using assms by blast
  have **: "finite (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def by (simp add: fsm_states_finite)

  have "(maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S \<in> (pairwise_r_distinguishable_state_sets_from_separators M).
            \<not>(\<exists> S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . S \<subset> S')}"
    unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_def
              pairwise_r_distinguishable_state_sets_from_separators_def
    by metis
  then have "(maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S \<in> (pairwise_r_distinguishable_state_sets_from_separators M) .
              (\<forall> S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . \<not> S \<subset> S')}"
    by blast
  moreover have "\<exists> S \<in> {S \<in> (pairwise_r_distinguishable_state_sets_from_separators M) .
                      (\<forall> S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . \<not> S \<subset> S')} . q \<in> S"
    using maximal_set_cover[OF ** *]
    by blast
  ultimately show ?thesis
    by blast
qed

subsection \<open>Calculating d-reachable States with Preambles\<close>

(* calculate d-reachable states and a fixed assignment of preambles *)
definition d_reachable_states_with_preambles :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a \<times> ('a,'b,'c) fsm) set" where
  "d_reachable_states_with_preambles M =
    image (\<lambda> qp . (fst qp, the (snd qp)))
          (Set.filter (\<lambda> qp . snd qp \<noteq> None)
                      (image (\<lambda> q . (q, calculate_state_preamble_from_input_choices M q))
                             (states M)))"

lemma d_reachable_states_with_preambles_exhaustiveness :
  assumes "\<exists> P . is_preamble P M q"
  and     "q \<in> states M"
shows "\<exists> P . (q,P) \<in> (d_reachable_states_with_preambles M)"
  using calculate_state_preamble_from_input_choices_exhaustiveness[OF assms(1)] assms(2)
  unfolding d_reachable_states_with_preambles_def by force

lemma d_reachable_states_with_preambles_soundness :
  assumes "(q,P) \<in> (d_reachable_states_with_preambles M)"
  and     "observable M"
  shows "is_preamble P M q"
    and "q \<in> states M"
  using assms(1) calculate_state_preamble_from_input_choices_soundness[of M q P]
  unfolding d_reachable_states_with_preambles_def
  using imageE by auto

subsection \<open>Calculating Repetition Sets\<close>

text \<open>Repetition sets are sets of tuples each containing a maximal set of pairwise r-distinguishable
      states and the subset of those states that have a preamble.\<close>

definition maximal_repetition_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a set \<times> 'a set) set" where
  "maximal_repetition_sets_from_separators M
    = {(S, S \<inter> (image fst (d_reachable_states_with_preambles M))) | S .
            S \<in> (maximal_pairwise_r_distinguishable_state_sets_from_separators M)}"

definition maximal_repetition_sets_from_separators_list_naive :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a set \<times> 'a set) list" where
  "maximal_repetition_sets_from_separators_list_naive M
    = (let DR = (image fst (d_reachable_states_with_preambles M))
        in map (\<lambda> S . (S, S \<inter> DR)) (maximal_pairwise_r_distinguishable_state_sets_from_separators_list M))"

lemma maximal_repetition_sets_from_separators_code[code]:
  "maximal_repetition_sets_from_separators M = (let DR = (image fst (d_reachable_states_with_preambles M))
    in  image (\<lambda> S . (S, S \<inter> DR)) (maximal_pairwise_r_distinguishable_state_sets_from_separators M))"
  unfolding maximal_repetition_sets_from_separators_def Let_def by force

lemma maximal_repetition_sets_from_separators_code_alt:
  "maximal_repetition_sets_from_separators M = set (maximal_repetition_sets_from_separators_list_naive M)"
  unfolding maximal_repetition_sets_from_separators_def
            maximal_repetition_sets_from_separators_list_naive_def
            maximal_pairwise_r_distinguishable_state_sets_from_separators_code
  by force

subsubsection \<open>Calculating Sub-Optimal Repetition Sets\<close>

text \<open>Finding maximal pairwise r-distinguishable subsets of the state set of some FSM is likely too expensive
      for FSMs containing a large number of r-distinguishable pairs of states.
      The following functions calculate only subset of all repetition sets while maintaining the
      property that every state is contained in some repetition set.\<close>

fun extend_until_conflict :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "extend_until_conflict non_confl_set candidates xs 0 = xs" |
  "extend_until_conflict non_confl_set candidates xs (Suc k) = (case dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates of
    [] \<Rightarrow> xs |
    (c#cs) \<Rightarrow> extend_until_conflict non_confl_set cs (c#xs) k)"

lemma extend_until_conflict_retainment :
  assumes "x \<in> set xs"
  shows "x \<in> set (extend_until_conflict non_confl_set candidates xs k)"
using assms proof (induction k arbitrary: candidates xs)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case proof (cases "dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates")
    case Nil
    then show ?thesis
      by (metis Suc.prems extend_until_conflict.simps(2) list.simps(4))
  next
    case (Cons c cs)
    then show ?thesis
      by (simp add: Suc.IH Suc.prems)
  qed
qed

lemma extend_until_conflict_elem :
  assumes "x \<in> set (extend_until_conflict non_confl_set candidates xs k)"
  shows "x \<in> set xs \<or> x \<in> set candidates"
using assms proof (induction k arbitrary: candidates xs)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case proof (cases "dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates")
    case Nil
    then show ?thesis
      by (metis Suc.prems extend_until_conflict.simps(2) list.simps(4))
  next
    case (Cons c cs)
    then have "extend_until_conflict non_confl_set candidates xs (Suc k) = extend_until_conflict non_confl_set cs (c#xs) k"
      by auto
    then have "x \<in> set (c # xs) \<or> x \<in> set cs"
      using Suc.IH[of cs "(c#xs)"] Suc.prems by auto
    moreover have "set (c#cs) \<subseteq> set candidates"
      using Cons by (metis set_dropWhileD subsetI)
    ultimately show ?thesis
      using set_ConsD by auto
  qed
qed

lemma extend_until_conflict_no_conflicts :
  assumes "x \<in> set (extend_until_conflict non_confl_set candidates xs k)"
  and     "y \<in> set (extend_until_conflict non_confl_set candidates xs k)"
  and     "x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> (x,y) \<in> non_confl_set \<or> (y,x) \<in> non_confl_set"
  and     "x \<noteq> y"
shows "(x,y) \<in> non_confl_set \<or> (y,x) \<in> non_confl_set"
using assms proof (induction k arbitrary: candidates xs)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case proof (cases "dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates")
    case Nil
    then have "extend_until_conflict non_confl_set candidates xs (Suc k) = xs"
      by (metis extend_until_conflict.simps(2) list.simps(4))
    then show ?thesis
      using Suc.prems by auto
  next
    case (Cons c cs)
    then have "extend_until_conflict non_confl_set candidates xs (Suc k) = extend_until_conflict non_confl_set cs (c#xs) k"
      by auto
    then have xk: "x \<in> set (extend_until_conflict non_confl_set cs (c#xs) k)"
         and  yk: "y \<in> set (extend_until_conflict non_confl_set cs (c#xs) k)"
      using Suc.prems by auto

    have **: "x \<in> set (c#xs) \<Longrightarrow> y \<in> set (c#xs) \<Longrightarrow> (x,y) \<in> non_confl_set \<or> (y,x) \<in> non_confl_set"
    proof -
      have scheme: "\<And> P xs x xs' . dropWhile P xs = (x#xs') \<Longrightarrow> \<not> P x"
        by (simp add: dropWhile_eq_Cons_conv)
      have "find (\<lambda> y . (c,y) \<notin> non_confl_set) xs = None"
        using scheme[OF Cons] by simp
      then have *: "\<And> y . y \<in> set xs \<Longrightarrow> (c,y) \<in> non_confl_set"
        unfolding find_None_iff by blast

      assume "x \<in> set (c#xs)" and "y \<in> set (c#xs)"
      then consider (a1) "x = c \<and> y \<in> set xs" |
                    (a2) "y = c \<and> x \<in> set xs" |
                    (a3) "x \<in> set xs \<and> y \<in> set xs"
        using \<open>x \<noteq> y\<close> by auto
      then show ?thesis
        using * Suc.prems(3) by (cases; auto)
    qed

    show ?thesis using Suc.IH[OF xk yk ** Suc.prems(4)] by blast
  qed
qed

definition greedy_pairwise_r_distinguishable_state_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set list" where
  "greedy_pairwise_r_distinguishable_state_sets_from_separators M =
    (let pwrds = image fst (r_distinguishable_state_pairs_with_separators M);
         k     = size M;
         nL    = states_as_list M
     in map (\<lambda>q . set (extend_until_conflict pwrds (remove1 q nL) [q] k)) nL)"

definition maximal_repetition_sets_from_separators_list_greedy :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a set \<times> 'a set) list" where
  "maximal_repetition_sets_from_separators_list_greedy M = (let DR = (image fst (d_reachable_states_with_preambles M))
    in remdups (map (\<lambda> S . (S, S \<inter> DR)) (greedy_pairwise_r_distinguishable_state_sets_from_separators M)))"

lemma greedy_pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> states M"
shows "\<exists> S \<in> set (greedy_pairwise_r_distinguishable_state_sets_from_separators M). q \<in> S"
  using assms extend_until_conflict_retainment[of q "[q]"]
  unfolding states_as_list_set[symmetric] greedy_pairwise_r_distinguishable_state_sets_from_separators_def Let_def
  by auto

lemma r_distinguishable_state_pairs_with_separators_sym :
  assumes "(q1,q2) \<in> fst ` r_distinguishable_state_pairs_with_separators M"
  shows "(q2,q1) \<in> fst ` r_distinguishable_state_pairs_with_separators M"
  using assms
  unfolding r_distinguishable_state_pairs_with_separators_def
  by force

lemma greedy_pairwise_r_distinguishable_state_sets_from_separators_soundness :
  "set (greedy_pairwise_r_distinguishable_state_sets_from_separators M) \<subseteq> (pairwise_r_distinguishable_state_sets_from_separators M)"
proof
  fix S assume "S \<in> set (greedy_pairwise_r_distinguishable_state_sets_from_separators M)"
  then obtain q' where "q' \<in> states M"
                 and   *: "S = set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M))
                                                          (remove1 q' (states_as_list M))
                                                          [q']
                                                          (size M))"
    unfolding greedy_pairwise_r_distinguishable_state_sets_from_separators_def Let_def states_as_list_set[symmetric]
    by auto

  have "S \<subseteq> states M"
  proof
    fix q assume "q \<in> S"
    then have "q \<in> set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M)) (remove1 q' (states_as_list M)) [q'] (size M))"
      using * by auto
    then show "q \<in> states M"
      using extend_until_conflict_elem[of q "image fst (r_distinguishable_state_pairs_with_separators M)" "(remove1 q' (states_as_list M))" "[q']" "size M"]
      using states_as_list_set \<open>q' \<in> states M\<close> by auto
  qed

  moreover have "\<And> q1 q2 . q1 \<in> S \<Longrightarrow> q2 \<in> S \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
  proof -
    fix q1 q2 assume "q1 \<in> S" and "q2 \<in> S" and "q1 \<noteq> q2"
    then have e1: "q1 \<in> set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M)) (remove1 q' (states_as_list M)) [q'] (size M))"
         and  e2: "q2 \<in> set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M)) (remove1 q' (states_as_list M)) [q'] (size M))"
      unfolding * by simp+
    have e3: "(q1 \<in> set [q'] \<Longrightarrow> q2 \<in> set [q']
              \<Longrightarrow> (q1, q2) \<in> fst ` r_distinguishable_state_pairs_with_separators M
                  \<or> (q2, q1) \<in> fst ` r_distinguishable_state_pairs_with_separators M)"
      using \<open>q1 \<noteq> q2\<close> by auto

    show "(q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
      using extend_until_conflict_no_conflicts[OF e1 e2 e3 \<open>q1 \<noteq> q2\<close>]
            r_distinguishable_state_pairs_with_separators_sym[of q2 q1 M] by blast
  qed

  ultimately show "S \<in> (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def by blast
qed

end


theory TTree
imports Main ConstOn "List-Interleavings"
begin

subsubsection \<open>Prefix-closed sets of lists\<close>

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 \<open>xs \<in> xss\<close> 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 \<open>xs \<in> xss\<close> 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 \<open>downset xss\<close>  by (auto intro: snoc.IH)
  qed
qed

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

subsubsection \<open>The type of infinite labeled trees\<close>

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

setup_lifting type_definition_ttree

subsubsection \<open>Deconstructors\<close>

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 \<open>Trees as set of paths\<close>

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 \<open>P t t'\<close>
      show "possible t x \<longleftrightarrow> possible t' x" by (rule assms(2))
    next
      assume "possible t x" and "possible t' x"
      with \<open>P t t'\<close>
      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 \<open>The carrier of a tree\<close>

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 \<open>Repeatable trees\<close>

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 \<open>Simple trees\<close>

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 \<open>Intersection of two trees\<close>

lift_definition intersect :: "'a ttree \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree" (infixl "\<inter>\<inter>" 80)
  is "(\<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 \<open>Disjoint union of trees\<close>

lift_definition either :: "'a ttree \<Rightarrow> 'a ttree \<Rightarrow> 'a ttree" (infixl "\<oplus>\<oplus>" 80)
  is "(\<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 \<open>Merging of trees\<close>

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 \<open>x#xs \<in> paths (t \<otimes>\<otimes> t')\<close>
  obtain ys zs where "ys \<in> paths t" and "zs \<in> paths t'" and "x#xs \<in> ys \<otimes> zs"
    by transfer auto

  from \<open>x#xs \<in> ys \<otimes> zs\<close>
  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  \<open>ys \<in> paths t\<close>   \<open>zs \<in> paths t'\<close>
    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: subsetD[OF both_contains_arg1]  subsetD[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 \<open>ys \<in> _\<close> \<open>zs \<in> _\<close> \<open>x \<in> set xs\<close>
  have "x \<in> carrier t \<union> carrier t'"  by transfer auto
  }
  moreover
  note subsetD[OF carrier_mono[OF both_contains_arg1[where t=t and t' = t']]]
       subsetD[OF carrier_mono[OF both_contains_arg2[where t=t and t' = t']]]
  ultimately
  show ?thesis by auto
qed

subsubsection \<open>Removing elements from a tree\<close>

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 \<open>Multiple variables, each called at most once\<close>

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 \<open>xs \<in> paths t\<close>
  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 \<open>Substituting trees for every node\<close>

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: subsetD dest!: subsetD[OF f_nxt_mono1[OF Cons.prems(2)]] subsetD[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 \<open>x # xs \<in> paths (substitute f T' t)\<close>
    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 subsetD[OF substitute_mono1, rotated])
         (auto simp add: f_nxt_def subsetD[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 \<open>x # xs \<in> paths t\<close>
    have "possible t x" by transfer auto
    moreover
    from \<open>x # xs \<in> paths t\<close> 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 subsetD[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 \<open>x \<in> A\<close> by (rule Cons.prems(2))

  from Cons.prems(1,2) Cons.prems(4)[symmetric]
  show ?case
    by (auto elim!: Cons.IH
          dest!: subsetD[OF carrier_f_nxt] subsetD[OF carrier_nxt_subset] subsetD[OF Cons.prems(3)] subsetD[OF \<open>carrier (f x) \<subseteq> A\<close>]
          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 \<open>x' # xs \<in> paths (substitute f T t)\<close>
    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 \<open>x \<in> set (x' # xs)\<close>
    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 \<open>x = x'\<close>.
    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 \<open>xs \<in> _ \<close> 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 \<open>possible t x'\<close>
    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 \<open>xs \<in> _\<close> 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 \<open>possible t x\<close>
    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: subsetD[OF ttree_restr_nxt_subset2]  subsetD[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 subsetD[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 \<open>An alternative characterization of substitution\<close>

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 \<open>x # xs \<in> paths (substitute f T t)\<close>
    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) \<open>substitute'' (f_nxt f T x) T xs' xs\<close>
    have "substitute'' f T (x # ys') (x # xs)"..
    moreover
    from \<open>ys' \<in> paths (nxt t x)\<close> \<open>possible t x\<close>
    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 \<open>possible t x\<close> Cons.prems(3) * True
        by (auto simp add: ttree_restr_both ttree_restr_noop[OF Cons.prems(2)] intro: ttree_restr_possible
                    dest: subsetD[OF substitute_mono2[OF both_mono1[OF ttree_restr_nxt_subset]]])
    next
      case False
      with \<open>const_on f (- S) TTree.empty\<close> 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:  subsetD[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 \<open>substitute'' f T [x'\<leftarrow>xs . x' \<in> S] ys\<close>

    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 \<open>zs \<in> paths (f x)\<close>  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 \<open>set zs \<subseteq> S\<close> filter_False insert_absorb insert_subset)

        from \<open>xs'' \<in> interleave [x'\<leftarrow>xs' . x' \<in> S] zs\<close>
        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 \<open>xs''' \<in> interleave xs' zs\<close>
        have l: "\<And> P. length (filter P xs''') = length (filter P xs') + length (filter P zs)"
          by (induction) auto

        from \<open>substitute'' (f_nxt f T x) T xs'' ys'\<close> \<open>xs'' = _\<close>
        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: \<open>ys = _ \<close> \<open>xs =_\<close> \<open>x \<in> S\<close> \<open>xs'' = _\<close>[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 \<open>x \<in> S\<close> \<open>ys = _\<close> by simp
        moreover
        from \<open>zs \<in> paths (f x)\<close> \<open>xs''' \<in> interleave xs' zs\<close> \<open>substitute'' (f_nxt f T x) T xs''' ys''\<close>
        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:  \<open>xs =_\<close> \<open>x \<notin>  S\<close>)
        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 \<open>x \<notin> S\<close> \<open>ys = _\<close> by simp
        moreover
        have [simp]: "f x = empty" using \<open>x \<notin> S\<close> less.prems(3) by force
        hence "f_nxt f T x = f" by (auto simp add: f_nxt_def)
        with \<open>substitute'' f T xs' ys'\<close>
        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) \<open>xs' \<in> paths t\<close>
  have "xs'' \<in> paths (substitute f T t)" by (auto simp add: substitute_substitute'')
  with \<open>xs = _\<close>
  show "xs \<in> paths (ttree_restr S (substitute f T t))"
    by (auto simp add:  filter_paths_conv_free_restr[symmetric])
qed

end