Theory LambdaCalculus

(*  Title:       LambdaCalculus
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2022
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "The Lambda Calculus"

  text ‹
    In this second part of the article, we apply the residuated transition system framework
    developed in the first part to the theory of reductions in Church's ‹λ›-calculus.
    The underlying idea is to exhibit ‹λ›-terms as states (identities) of an RTS,
    with reduction steps as non-identity transitions.  We represent both states and transitions
    in a unified, variable-free syntax based on de Bruijn indices.
    A difficulty one faces in regarding the ‹λ›-calculus as an RTS is that
    ``elementary reductions'', in which just one redex is contracted, are not preserved by
    residuation: an elementary reduction can have zero or more residuals along another
    elementary reduction.  However, ``parallel reductions'', which permit the contraction of
    multiple redexes existing in a term to be contracted in a single step, are preserved
    by residuation.  For this reason, in our syntax each term represents a parallel reduction
    of zero or more redexes; a parallel reduction of zero redexes representing an identity.
    We have syntactic constructors for variables, ‹λ›-abstractions, and applications.
    An additional constructor represents a ‹β›-redex that has been marked for contraction.
    This is a slightly different approach that that taken by other authors
    (\emph{e.g.}~\<^cite>‹"barendregt"› or \<^cite>‹"huet-residual-theory"›), in which it is the
    application constructor that is marked to indicate a redex to be contracted,
    but it seems more natural in the present setting in which a single syntax is used to
    represent both terms and reductions.

    Once the syntax has been defined, we define the residuation operation and prove
    that it satisfies the conditions for a weakly extensional RTS.  In this RTS, the source
    of a term is obtained by ``erasing'' the markings on redexes, leaving an identity term.
    The target of a term is the contractum of the parallel reduction it represents.
    As the definition of residuation involves the use of substitution, a necessary prerequisite
    is to develop the theory of substitution using de Bruijn indices.
    In addition, various properties concerning the commutation of residuation and substitution
    have to be proved.  This part of the work has benefited greatly from previous work
    of Huet \<^cite>‹"huet-residual-theory"›, in which the theory of residuation was formalized
    in the proof assistant Coq.  In particular, it was very helpful to have already available
    known-correct statements of various lemmas regarding indices, substitution, and residuation.
    The development of the theory culminates in the proof of L\'{e}vy's ``Cube Lemma''
    \<^cite>‹"levy"›, which is the key axiom in the definition of RTS.

    Once reductions in the ‹λ›-calculus have been cast as transitions of an RTS,
    we are able to take advantage of generic results already proved for RTS's; in particular,
    the construction of the RTS of paths, which represent reduction sequences.
    Very little additional effort is required at this point to prove the Church-Rosser Theorem.
    Then, after proving a series of miscellaneous lemmas about reduction paths,
    we turn to the study of developments.  A development of a term is a reduction path from
    that term in which the only redexes that are contracted are those that are residuals of
    redexes in the original term.  We prove the Finite Developments Theorem: all developments
    are finite.  The proof given here follows that given by de Vrijer \<^cite>‹"deVrijer"›,
    except that here we make the adaptations necessary for a syntax based on de Bruijn
    indices, rather than the classical named-variable syntax used by de Vrijer.
    Using the Finite Developments Theorem, we define a function that takes a term and constructs
    a ``complete development'' of that term, which is a development in which no residuals of
    original redexes remain to be contracted.

    We then turn our attention to ``standard reduction paths'', which are reduction paths in
    which redexes are contracted in a left-to-right order, perhaps with some skips.
    After giving a definition of standard reduction paths, we define a function that takes a
    term and constructs a complete development that is also standard.
    Using this function as a base case, we then define a function that takes an arbitrary
    parallel reduction path and transforms it into a standard reduction path that is congruent
    to the given path.  The algorithm used is roughly analogous to insertion sort.
    We use this function to prove strong form of the Standardization Theorem: every reduction
    path is congruent to a standard reduction path.  As a corollary of the Standardization
    Theorem, we prove the Leftmost Reduction Theorem: leftmost reduction is a normalizing
    reduction strategy.

    It should be noted that, in this article, we consider only the ‹λβ›-calculus.
    In the early stages of this work, I made an exploratory attempt to incorporate ‹η›-reduction
    as well, but after encountering some unanticipated difficulties I decided not to attempt that
    extension until the ‹β›-only case had been well-developed.
  ›

theory LambdaCalculus
imports Main ResiduatedTransitionSystem
begin

  section "Syntax"

  locale lambda_calculus
  begin

    text ‹
      The syntax of terms has constructors ‹Var› for variables, ‹Lam› for ‹λ›-abstraction,
      and ‹App› for application.  In addition, there is a constructor ‹Beta› which is used
      to represent a ‹β›-redex that has been marked for contraction.  The idea is that
      a term ‹Beta t u› represents a marked version of the term ‹App (Lam t) u›.
      Finally, there is a constructor ‹Nil› which is used to represent the null element
      required for the residuation operation.
    ›

    datatype (discs_sels) lambda =
      Nil
    | Var nat
    | Lam lambda
    | App lambda lambda
    | Beta lambda lambda

    text ‹
      The following notation renders ‹Beta t u› as a ``marked'' version of ‹App (Lam t) u›,
      even though the former is a single constructor, whereas the latter contains two
      constructors.
    ›

    notation Nil  ("❙♯")
    notation Var  ("❙«_❙»")
    notation Lam  ("❙λ❙[_❙]")
    notation App  (infixl "❙∘" 55)
    notation Beta ("(❙λ❙[_❙] ❙⦁ _)" [55, 56] 55)

    text ‹
      The following function computes the set of free variables of a term.
      Note that since variables are represented by numeric indices, this is a set of numbers.
    ›

    fun FV
    where "FV ❙♯ = {}"
        | "FV ❙«i❙» = {i}"
        | "FV ❙λ❙[t❙] = (λn. n - 1) ` (FV t - {0})"
        | "FV (t ❙∘ u) = FV t ∪ FV u"
        | "FV (❙λ❙[t❙] ❙⦁ u) = (λn. n - 1) ` (FV t - {0}) ∪ FV u"

    subsection "Some Orderings for Induction"

    text ‹
      We will need to do some simultaneous inductions on pairs and triples of subterms
      of given terms.  We prove the well-foundedness of the associated relations using
      the following size measure.
    ›

    fun size :: "lambda ⇒ nat"
    where "size ❙♯ = 0"
        | "size ❙«_❙» = 1"
        | "size ❙λ❙[t❙] = size t + 1"
        | "size (t ❙∘ u) = size t + size u + 1"
        | "size (❙λ❙[t❙] ❙⦁ u) = (size t + 1) + size u + 1"

    lemma wf_if_img_lt:
    fixes r :: "('a * 'a) set" and f :: "'a ⇒ nat"
    assumes "⋀x y. (x, y) ∈ r ⟹ f x < f y"
    shows "wf r"
      using assms
      by (metis in_measure wf_iff_no_infinite_down_chain wf_measure)

    inductive subterm
    where "⋀t. subterm t ❙λ❙[t❙]"
        | "⋀t u. subterm t (t ❙∘ u)"
        | "⋀t u. subterm u (t ❙∘ u)"
        | "⋀t u. subterm t (❙λ❙[t❙] ❙⦁ u)"
        | "⋀t u. subterm u (❙λ❙[t❙] ❙⦁ u)"
        | "⋀t u v. ⟦subterm t u; subterm u v⟧ ⟹ subterm t v"

    lemma subterm_implies_smaller:
    shows "subterm t u ⟹ size t < size u"
      by (induct rule: subterm.induct) auto

    abbreviation subterm_rel
    where "subterm_rel ≡ {(t, u). subterm t u}"

    lemma wf_subterm_rel:
    shows "wf subterm_rel"
      using subterm_implies_smaller wf_if_img_lt
      by (metis case_prod_conv mem_Collect_eq)

    abbreviation subterm_pair_rel
    where "subterm_pair_rel ≡ {((t1, t2), u1, u2). subterm t1 u1 ∧ subterm t2 u2}"

    lemma wf_subterm_pair_rel:
    shows "wf subterm_pair_rel"
      using subterm_implies_smaller
            wf_if_img_lt [of subterm_pair_rel "λ(t1, t2). max (size t1) (size t2)"]
      by fastforce

    abbreviation subterm_triple_rel
    where "subterm_triple_rel ≡
           {((t1, t2, t3), u1, u2, u3). subterm t1 u1 ∧ subterm t2 u2 ∧ subterm t3 u3}"

    lemma wf_subterm_triple_rel:
    shows "wf subterm_triple_rel"
      using subterm_implies_smaller
            wf_if_img_lt [of subterm_triple_rel
                             "λ(t1, t2, t3). max (max (size t1) (size t2)) (size t3)"]
      by fastforce

    lemma subterm_lemmas:
    shows "subterm t ❙λ❙[t❙]"
    and "subterm t (❙λ❙[t❙] ❙∘ u) ∧ subterm u (❙λ❙[t❙] ❙∘ u)"
    and "subterm t (t ❙∘ u) ∧ subterm u (t ❙∘ u)"
    and "subterm t (❙λ❙[t❙] ❙⦁ u) ∧ subterm u (❙λ❙[t❙] ❙⦁ u)"
      by (metis subterm.simps)+

    subsection "Arrows and Identities"

    text ‹
      Here we define some special classes of terms.
      An ``arrow'' is a term that contains no occurrences of ‹Nil›.
      An ``identity'' is an arrow that contains no occurrences of ‹Beta›.
      It will be important for the commutation of substitution and residuation later on
      that substitution not be used in a way that could create any marked redexes;
      for example, we don't want the substitution of ‹Lam (Var 0)› for ‹Var 0› in an
      application ‹App (Var 0) (Var 0)› to create a new ``marked'' redex.
      The use of the separate constructor ‹Beta› for marked redexes automatically avoids this.
    ›

    fun Arr
    where "Arr ❙♯ = False"
        | "Arr ❙«_❙» = True"
        | "Arr ❙λ❙[t❙] = Arr t"
        | "Arr (t ❙∘ u) = (Arr t ∧ Arr u)"
        | "Arr (❙λ❙[t❙] ❙⦁ u) = (Arr t ∧ Arr u)"

    lemma Arr_not_Nil:
    assumes "Arr t"
    shows "t ≠ ❙♯"
      using assms by auto

    fun Ide
    where "Ide ❙♯ = False"
        | "Ide ❙«_❙» = True"
        | "Ide ❙λ❙[t❙] = Ide t"
        | "Ide (t ❙∘ u) = (Ide t ∧ Ide u)"
        | "Ide (❙λ❙[t❙] ❙⦁ u) = False"

    lemma Ide_implies_Arr:
    shows "Ide t ⟹ Arr t"
      by (induct t) auto

    lemma ArrE [elim]:
    assumes "Arr t"
    and "⋀i. t = ❙«i❙» ⟹ T"
    and "⋀u. t = ❙λ❙[u❙] ⟹ T"
    and "⋀u v. t = u ❙∘ v ⟹ T"
    and "⋀u v. t = ❙λ❙[u❙] ❙⦁ v ⟹ T"
    shows T
      using assms
      by (cases t) auto

    subsection "Raising Indices"

    text ‹
      For substitution, we need to be able to raise the indices of all free variables
      in a subterm by a specified amount.  To do this recursively, we need to keep track
      of the depth of nesting of ‹λ›'s and only raise the indices of variables that are
      already greater than or equal to that depth, as these are the variables that are free
      in the current context.  This leads to defining a function ‹Raise› that has two arguments:
      the depth threshold ‹d› and the increment ‹n› to be added to indices above that threshold.
    ›

    fun Raise
    where "Raise _ _ ❙♯ = ❙♯"
        | "Raise d n ❙«i❙» = (if i ≥ d then ❙«i+n❙» else ❙«i❙»)"
        | "Raise d n ❙λ❙[t❙] = ❙λ❙[Raise (Suc d) n t❙]"
        | "Raise d n (t ❙∘ u) = Raise d n t ❙∘ Raise d n u"
        | "Raise d n (❙λ❙[t❙] ❙⦁ u) = ❙λ❙[Raise (Suc d) n t❙] ❙⦁ Raise d n u"

    text ‹
      Ultimately, the definition of substitution will only directly involve the function
      that raises all indices of variables that are free in the outermost context;
      in a term, so we introduce an abbreviation for this special case.
    ›

    abbreviation raise
    where "raise == Raise 0"

    lemma size_Raise:
    shows "⋀d. size (Raise d n t) = size t"
      by (induct t) auto

    lemma Raise_not_Nil:
    assumes "t ≠ ❙♯"
    shows "Raise d n t ≠ ❙♯"
      using assms
      by (cases t) auto

    lemma FV_Raise:
    shows "FV (Raise d n t) = (λx. if x ≥ d then x + n else x) ` FV t"
      apply (induct t arbitrary: d n)
          apply auto[3]
            apply force
           apply force
          apply force
         apply force
        apply force
    proof -
      fix t u d n
      assume ind1: "⋀d n. FV (Raise d n t) = (λx. if d ≤ x then x + n else x) ` FV t"
      assume ind2: "⋀d n. FV (Raise d n u) = (λx. if d ≤ x then x + n else x) ` FV u"
      have "FV (Raise d n (❙λ❙[t❙] ❙⦁ u)) = 
            (λx. x - Suc 0) ` ((λx. x + n) `
              (FV t ∩ {x. Suc d ≤ x}) ∪ FV t ∩ {x. ¬ Suc d ≤ x} - {0}) ∪
            ((λx. x + n) ` (FV u ∩ {x. d ≤ x}) ∪ FV u ∩ {x. ¬ d ≤ x})"
        using ind1 ind2 by simp
      also have "... = (λx. if d ≤ x then x + n else x) ` FV (❙λ❙[t❙] ❙⦁ u)"
        by auto force+
      finally show "FV (Raise d n (❙λ❙[t❙] ❙⦁ u)) =
                    (λx. if d ≤ x then x + n else x) ` FV (❙λ❙[t❙] ❙⦁ u)"
        by blast
    qed

    lemma Arr_Raise:
    shows "Arr t ⟷ Arr (Raise d n t)"
      using FV_Raise
      by (induct t arbitrary: d n) auto

    lemma Ide_Raise:
    shows "Ide t ⟷ Ide (Raise d n t)"
      by (induct t arbitrary: d n) auto

    lemma Raise_0:
    shows "Raise d 0 t = t"
      by (induct t arbitrary: d) auto

    lemma Raise_Suc:
    shows "Raise d (Suc n) t = Raise d 1 (Raise d n t)"
      by (induct t arbitrary: d n) auto

    lemma Raise_Var:
    shows "Raise d n ❙«i❙» = ❙«if i < d then i else i + n❙»"
      by auto

    text ‹
      The following development of the properties of raising indices, substitution, and
      residuation has benefited greatly from the previous work by Huet \<^cite>‹"huet-residual-theory"›.
      In particular, it was very helpful to have correct statements of various lemmas
      available, rather than having to reconstruct them.
    ›

    lemma Raise_plus:
    shows "Raise d (m + n) t = Raise (d + m) n (Raise d m t)"
      by (induct t arbitrary: d m n) auto

    lemma Raise_plus':
    shows "⟦d' ≤ d + n; d ≤ d'⟧ ⟹ Raise d (m + n) t = Raise d' m (Raise d n t)"
      by (induct t arbitrary: n m d d') auto

    lemma Raise_Raise:
    shows "i ≤ n ⟹ Raise i p (Raise n k t) = Raise (p + n) k (Raise i p t)"
      by (induct t arbitrary: i k n p) auto

    lemma raise_plus:
    shows "d ≤ n ⟹ raise (m + n) t = Raise d m (raise n t)"
      using Raise_plus' by auto

    lemma raise_Raise:
    shows "raise p (Raise n k t) = Raise (p + n) k (raise p t)"
      by (simp add: Raise_Raise)

    lemma Raise_inj:
    shows "Raise d n t = Raise d n u ⟹ t = u"
    proof (induct t arbitrary: d n u)
      show "⋀d n u. Raise d n ❙♯ = Raise d n u ⟹ ❙♯ = u"
        by (metis Raise.simps(1) Raise_not_Nil)
      show "⋀x d n. Raise d n ❙«x❙» = Raise d n u ⟹ ❙«x❙» = u" for u
        using Raise_Var
        apply (cases u, auto)
        by (metis add_lessD1 add_right_imp_eq)
      show "⋀t d n. ⟦⋀d n u'. Raise d n t = Raise d n u' ⟹ t = u';
                      Raise d n ❙λ❙[t❙] = Raise d n u⟧
                        ⟹ ❙λ❙[t❙] = u"
        for u
        apply (cases u, auto)
        by (metis lambda.distinct(9))
      show "⋀t1 t2 d n. ⟦⋀d n u'. Raise d n t1 = Raise d n u' ⟹ t1 = u';
                         ⋀d n u'. Raise d n t2 = Raise d n u' ⟹ t2 = u';
                         Raise d n (t1 ❙∘ t2) = Raise d n u⟧
                           ⟹ t1 ❙∘ t2 = u"
        for u
        apply (cases u, auto)
        by (metis lambda.distinct(11))
      show "⋀t1 t2 d n. ⟦⋀d n u'. Raise d n t1 = Raise d n u' ⟹ t1 = u';
                         ⋀d n u'. Raise d n t2 = Raise d n u' ⟹ t2 = u';
                         Raise d n (❙λ❙[t1❙] ❙⦁ t2) = Raise d n u⟧
                           ⟹ ❙λ❙[t1❙] ❙⦁ t2 = u"
        for u
        apply (cases u, auto)
        by (metis lambda.distinct(13))
    qed

    subsection "Substitution"

    text ‹
      Following \<^cite>‹"huet-residual-theory"›, we now define a generalized substitution operation
      with adjustment of indices.  The ultimate goal is to define the result of contraction
      of a marked redex ‹Beta t u› to be ‹subst u t›.  However, to be able to give a proper
      recursive definition of ‹subst›, we need to introduce a parameter ‹n› to keep track of the
      depth of nesting of ‹Lam›'s as we descend into the the term ‹t›.  So, instead of ‹subst u t›
      simply substituting ‹u› for occurrences of ‹Var 0›, ‹Subst n u t› will be substituting
      for occurrences of ‹Var n›, and the term ‹u› will have the indices of its free variables
      raised by ‹n› before replacing ‹Var n›.  In addition, any variables in ‹t› that have
      indices greater than ‹n› will have these indices lowered by one, to account for the
      outermost ‹Lam› that is being removed by the contraction.  We can then define
      ‹subst u t› to be ‹Subst 0 u t›.
    ›

    fun Subst
    where "Subst _ _ ❙♯ = ❙♯"
        | "Subst n v ❙«i❙» = (if n < i then ❙«i-1❙» else if n = i then raise n v else ❙«i❙»)"
        | "Subst n v ❙λ❙[t❙] = ❙λ❙[Subst (Suc n) v t❙]"
        | "Subst n v (t ❙∘ u) = Subst n v t ❙∘ Subst n v u"
        | "Subst n v (❙λ❙[t❙] ❙⦁ u) = ❙λ❙[Subst (Suc n) v t❙] ❙⦁ Subst n v u"

    abbreviation subst
    where "subst ≡ Subst 0"

    lemma Subst_Nil:
    shows "Subst n v ❙♯ = ❙♯"
      by (cases "v = ❙♯") auto

    lemma Subst_not_Nil:
    assumes "v ≠ ❙♯" and "t ≠ ❙♯"
    shows "t ≠ ❙♯ ⟹ Subst n v t ≠ ❙♯"
      using assms Raise_not_Nil
      by (induct t) auto

    text ‹
      The following expression summarizes how the set of free variables of a term ‹Subst d u t›,
      obtained by substituting ‹u› into ‹t› at depth ‹d›, relates to the sets of free variables
      of ‹t› and ‹u›.  This expression is not used in the subsequent formal development,
      but it has been left here as an aid to understanding.
    ›

    abbreviation FVS
    where "FVS d v t ≡ (FV t ∩ {x. x < d}) ∪
                        (λx. x - 1) ` {x. x > d ∧ x ∈ FV t} ∪
                        (λx. x + d) ` {x. d ∈ FV t ∧ x ∈ FV v}"

    lemma FV_Subst:
    shows "FV (Subst d v t) = FVS d v t"
    proof (induct t arbitrary: d v)
      have "⋀d t v. (λx. x - 1) ` (FVS (Suc d) v t - {0}) = FVS d v ❙λ❙[t❙]"
      proof -
        fix d t v
        have "FVS d v ❙λ❙[t❙] =
              (λx. x - Suc 0) ` (FV t - {0}) ∩ {x. x < d} ∪
              (λx. x - Suc 0) ` {x. d < x ∧ x ∈ (λx. x - Suc 0) ` (FV t - {0})} ∪
              (λx. x + d) ` {x. d ∈ (λx. x - Suc 0) ` (FV t - {0}) ∧ x ∈ FV v}"
          by simp
        also have "... = (λx. x - 1) ` (FVS (Suc d) v t - {0})"
          by auto force+
        finally show "(λx. x - 1) ` (FVS (Suc d) v t - {0}) = FVS d v ❙λ❙[t❙]"
          by metis
      qed
      thus "⋀d t v. (⋀d v. FV (Subst d v t) = FVS d v t)
                              ⟹ FV (Subst d v ❙λ❙[t❙]) = FVS d v ❙λ❙[t❙]"
        by simp
      have "⋀t u v d. (λx. x - 1) ` (FVS (Suc d) v t - {0}) ∪ FVS d v u = FVS d v (❙λ❙[t❙] ❙⦁ u)"
      proof -
        fix t u v d
        have "FVS d v (❙λ❙[t❙] ❙⦁ u) =
              ((λx. x - Suc 0) ` (FV t - {0}) ∪ FV u) ∩ {x. x < d} ∪
              (λx. x - Suc 0) ` {x. d < x ∧ (x ∈ (λx. x - Suc 0) ` (FV t - {0}) ∨ x ∈ FV u)} ∪
              (λx. x + d) ` {x. (d ∈ (λx. x - Suc 0) ` (FV t - {0}) ∨ d ∈ FV u) ∧ x ∈ FV v}"
          by simp
        also have "... = (λx. x - 1) ` (FVS (Suc d) v t - {0}) ∪ FVS d v u"
          by force
        finally show "(λx. x - 1) ` (FVS (Suc d) v t - {0}) ∪ FVS d v u = FVS d v (❙λ❙[t❙] ❙⦁ u)"
          by metis
      qed
      thus "⋀t u v d. ⟦⋀d v. FV (Subst d v t) = FVS d v t;
                       ⋀d v. FV (Subst d v u) = FVS d v u⟧
                            ⟹ FV (Subst d v (❙λ❙[t❙] ❙⦁ u)) = FVS d v (❙λ❙[t❙] ❙⦁ u)"
        by simp
    qed (auto simp add: FV_Raise)

    lemma Arr_Subst:
    assumes "Arr v"
    shows "Arr t ⟹ Arr (Subst n v t)"
      using assms Arr_Raise FV_Subst
      by (induct t arbitrary: n) auto

    lemma vacuous_Subst:
    shows "⟦Arr v; i ∉ FV t⟧ ⟹ Raise i 1 (Subst i v t) = t"
      apply (induct t arbitrary: i v, auto)
      by force+

    lemma Ide_Subst_iff:
    shows "Ide (Subst n v t) ⟷ Ide t ∧ (n ∈ FV t ⟶ Ide v)"
      using Ide_Raise vacuous_Subst
      apply (induct t arbitrary: n)
          apply auto[5]
       apply fastforce
      by (metis Diff_empty Diff_insert0 One_nat_def diff_Suc_1 image_iff insertE
                insert_Diff nat.distinct(1))

    lemma Ide_Subst:
    shows "⟦Ide t; Ide v⟧ ⟹ Ide (Subst n v t)"
      using Ide_Raise
      by (induct t arbitrary: n) auto

    lemma Raise_Subst:
    shows "Raise (p + n) k (Subst p v t) = Subst p (Raise n k v) (Raise (Suc (p + n)) k t)"
      using raise_Raise
      apply (induct t arbitrary: v k n p, auto)
      by (metis add_Suc)+

    lemma Raise_Subst':
    assumes "t ≠ ❙♯"
    shows "⟦v ≠ ❙♯; k ≤ n⟧ ⟹ Raise k p (Subst n v t) = Subst (p + n) v (Raise k p t)"
      using assms raise_plus
      apply (induct t arbitrary: v k n p, auto)
          apply (metis Raise.simps(1) Subst_Nil Suc_le_mono add_Suc_right)
         apply fastforce
        apply fastforce
       apply (metis Raise.simps(1) Subst_Nil Suc_le_mono add_Suc_right)
      by fastforce

    lemma Raise_subst:
    shows "Raise n k (subst v t) = subst (Raise n k v) (Raise (Suc n) k t)"
      using Raise_0
      apply (induct t arbitrary: v k n, auto)
      by (metis One_nat_def Raise_Subst plus_1_eq_Suc)+

    lemma raise_Subst:
    assumes "t ≠ ❙♯"
    shows "v ≠ ❙♯ ⟹ raise p (Subst n v t) = Subst (p + n) v (raise p t)"
      using assms Raise_plus raise_Raise Raise_Subst'
      apply (induct t arbitrary: v n p)
      by (meson zero_le)+

    lemma Subst_Raise:
    shows "⟦v ≠ ❙♯; d ≤ m; m ≤ n + d⟧ ⟹ Subst m v (Raise d (Suc n) t) = Raise d n t"
      by (induct t arbitrary: v m n d) auto

    lemma Subst_raise:
    shows "⟦v ≠ ❙♯; m ≤ n⟧ ⟹ Subst m v (raise (Suc n) t) = raise n t"
      using Subst_Raise
      by (induct t arbitrary: v m n) auto

    lemma Subst_Subst:
    shows "⟦v ≠ ❙♯; w ≠ ❙♯⟧ ⟹
             Subst (m + n) w (Subst m v t) = Subst m (Subst n w v) (Subst (Suc (m + n)) w t)"
      using Raise_0 raise_Subst Subst_not_Nil Subst_raise
      apply (induct t arbitrary: v w m n, auto)
      by (metis add_Suc)+

    text ‹
      The Substitution Lemma, as given by Huet \<^cite>‹"huet-residual-theory"›.
    ›

    lemma substitution_lemma:
    shows "⟦v ≠ ❙♯; w ≠ ❙♯⟧ ⟹ Subst n v (subst w t) = subst (Subst n v w) (Subst (Suc n) v t)"
      by (metis Subst_Subst add_0)

    section "Lambda-Calculus as an RTS"

    subsection "Residuation"

    text ‹
      We now define residuation on terms.
      Residuation is an operation which, when defined for terms ‹t› and ‹u›,
      produces terms ‹t \ u› and ‹u \ t› that represent, respectively, what remains
      of the reductions of ‹t› after performing the reductions in ‹u›,
      and what remains of the reductions of ‹u› after performing the reductions in ‹t›.

      The definition ensures that, if residuation is defined for two terms, then those
      terms in must be arrows that are \emph{coinitial} (\emph{i.e.}~they are the same
      after erasing marks on redexes).  The residual ‹t \ u› then has marked redexes at
      positions corresponding to redexes that were originally marked in ‹t› and that
      were not contracted by any of the reductions of ‹u›.

      This definition has also benefited from the presentation in \<^cite>‹"huet-residual-theory"›.
    ›

    fun resid  (infix "\\" 70)
    where "❙«i❙» \\ ❙«i'❙» = (if i = i' then ❙«i❙» else ❙♯)"
        | "❙λ❙[t❙] \\ ❙λ❙[t'❙] = (if t \\ t' = ❙♯ then ❙♯ else ❙λ❙[t \\ t'❙])"
        | "(t ❙∘ u) \\ (t'❙∘ u') = (if t \\ t' = ❙♯ ∨ u \\ u' = ❙♯ then ❙♯ else (t \\ t') ❙∘ (u \\ u'))"
        | "(❙λ❙[t❙] ❙⦁ u) \\ (❙λ❙[t'❙] ❙⦁ u') = (if t \\ t' = ❙♯ ∨ u \\ u' = ❙♯ then ❙♯ else subst (u \\ u') (t \\ t'))"
        | "(❙λ❙[t❙] ❙∘ u) \\ (❙λ❙[t'❙] ❙⦁ u') = (if t \\ t' = ❙♯ ∨ u \\ u' = ❙♯ then ❙♯ else subst (u \\ u') (t \\ t'))"
        | "(❙λ❙[t❙] ❙⦁ u) \\ (❙λ❙[t'❙] ❙∘ u') = (if t \\ t' = ❙♯ ∨ u \\ u' = ❙♯ then ❙♯ else ❙λ❙[t \\ t'❙] ❙⦁ (u \\ u'))"
        | "resid _  _ = ❙♯"

    text ‹
      Terms t and u are \emph{consistent} if residuation is defined for them.
    ›

    abbreviation Con  (infix "⌢" 50)
    where "Con t u ≡ resid t u ≠ ❙♯"

    lemma ConE [elim]:
    assumes "t ⌢ t'"
    and "⋀i. ⟦t = ❙«i❙»; t' = ❙«i❙»; resid t t' = ❙«i❙»⟧ ⟹ T"
    and "⋀u u'. ⟦t = ❙λ❙[u❙]; t' = ❙λ❙[u'❙]; u ⌢ u'; t \\ t' = ❙λ❙[u \\ u'❙]⟧ ⟹ T"
    and "⋀u v u' v'. ⟦t = u ❙∘ v; t' = u' ❙∘ v'; u ⌢ u'; v ⌢ v';
                      t \\ t' = (u \\ u') ❙∘ (v \\ v')⟧ ⟹ T"
    and "⋀u v u' v'. ⟦t = ❙λ❙[u❙] ❙⦁ v; t' = ❙λ❙[u'❙] ❙⦁ v'; u ⌢ u'; v ⌢ v';
                      t \\ t' = subst (v \\ v') (u \\ u')⟧ ⟹ T"
    and "⋀u v u' v'. ⟦t = ❙λ❙[u❙] ❙∘ v; t' = Beta u' v'; u ⌢ u'; v ⌢ v';
                      t \\ t' = subst (v \\ v') (u \\ u')⟧ ⟹ T"
    and "⋀u v u' v'. ⟦t = ❙λ❙[u❙] ❙⦁ v; t' = ❙λ❙[u'❙] ❙∘ v'; u ⌢ u'; v ⌢ v';
                      t \\ t' = ❙λ❙[u \\ u'❙] ❙⦁ (v \\ v')⟧ ⟹ T"
    shows T
      using assms
      apply (cases t; cases t')
                     apply simp_all
           apply metis
          apply metis
         apply metis
        apply (cases "un_App1 t", simp_all)
        apply metis
       apply (cases "un_App1 t'", simp_all)
       apply metis
      by metis

    text ‹
      A term can only be consistent with another if both terms are ``arrows''.
    ›

    lemma Con_implies_Arr1:
    shows "t ⌢ u ⟹ Arr t"
    proof (induct t arbitrary: u)
      fix u v t'
      assume ind1: "⋀u'. u ⌢ u' ⟹ Arr u"
      assume ind2: "⋀v'. v ⌢ v' ⟹ Arr v"
      show "u ❙∘ v ⌢ t' ⟹ Arr (u ❙∘ v)"
        using ind1 ind2
        apply (cases t', simp_all)
         apply metis
        apply (cases u, simp_all)
        by (metis lambda.distinct(3) resid.simps(2))
      show "❙λ❙[u❙] ❙⦁ v ⌢ t' ⟹ Arr (❙λ❙[u❙] ❙⦁ v)"
        using ind1 ind2
        apply (cases t', simp_all)
         apply (cases "un_App1 t'", simp_all)
        by metis+
    qed auto

    lemma Con_implies_Arr2:
    shows "t ⌢ u ⟹ Arr u"
    proof (induct u arbitrary: t)
      fix u' v' t
      assume ind1: "⋀u. u ⌢ u' ⟹ Arr u'"
      assume ind2: "⋀v. v ⌢ v' ⟹ Arr v'"
      show "t ⌢ u' ❙∘ v' ⟹ Arr (u' ❙∘ v')"
        using ind1 ind2
        apply (cases t, simp_all)
         apply metis
        apply (cases u', simp_all)
        by (metis lambda.distinct(3) resid.simps(2))
      show "t ⌢ (❙λ❙[u'❙] ❙⦁ v') ⟹ Arr (❙λ❙[u'❙] ❙⦁ v')"
        using ind1 ind2
        apply (cases t, simp_all)
        apply (cases "un_App1 t", simp_all)
        by metis+
    qed auto

    lemma ConD:
    shows "t ❙∘ u ⌢ t' ❙∘ u' ⟹ t ⌢ t' ∧ u ⌢ u'"
    and "❙λ❙[v❙] ❙⦁ u ⌢ ❙λ❙[v'❙] ❙⦁ u' ⟹ ❙λ❙[v❙] ⌢ ❙λ❙[v'❙] ∧ u ⌢ u'"
    and "❙λ❙[v❙] ❙⦁ u ⌢ t' ❙∘ u' ⟹ ❙λ❙[v❙] ⌢ t' ∧ u ⌢ u'"
    and "t ❙∘ u ⌢ ❙λ❙[v'❙] ❙⦁ u' ⟹ t ⌢ ❙λ❙[v'❙] ∧ u ⌢ u'"
      by auto

    text ‹
      Residuation on consistent terms preserves arrows.
    ›

    lemma Arr_resid:
    shows "t ⌢ u ⟹ Arr (t \\ u)"
    proof (induct t arbitrary: u)
      fix t1 t2 u
      assume ind1: "⋀u. t1 ⌢ u ⟹ Arr (t1 \\ u)"
      assume ind2: "⋀u. t2 ⌢ u ⟹ Arr (t2 \\ u)"
      show "t1 ❙∘ t2 ⌢ u ⟹ Arr ((t1 ❙∘ t2) \\ u)"
        using ind1 ind2 Arr_Subst
        apply (cases u, auto)
        apply (cases t1, auto)
        by (metis Arr.simps(3) ConD(2) resid.simps(2) resid.simps(4))
      show "❙λ❙[t1❙] ❙⦁ t2 ⌢ u ⟹ Arr ((❙λ❙[t1❙] ❙⦁ t2) \\ u)"
        using ind1 ind2 Arr_Subst
        by (cases u) auto
    qed auto

    subsection "Source and Target"

    text ‹
      Here we give syntactic versions of the \emph{source} and \emph{target} of a term.
      These will later be shown to agree (on arrows) with the versions derived from the residuation.
      The underlying idea here is that a term stands for a reduction sequence in which
      all marked redexes (corresponding to instances of the constructor ‹Beta›) are contracted
      in a bottom-up fashion.  A term without any marked redexes stands for an empty reduction
      sequence; such terms will be shown to be the identities derived from the residuation.
      The source of term is the identity obtained by erasing all markings; that is, by replacing
      all subterms of the form ‹Beta t u› by ‹App (Lam t) u›.  The target of a term is the
      identity that is the result of contracting all the marked redexes.
    ›

    fun Src
    where "Src ❙♯ = ❙♯"
        | "Src ❙«i❙» = ❙«i❙»"
        | "Src ❙λ❙[t❙] = ❙λ❙[Src t❙]"
        | "Src (t ❙∘ u) = Src t ❙∘ Src u"
        | "Src (❙λ❙[t❙] ❙⦁ u) = ❙λ❙[Src t❙] ❙∘ Src u"

    fun Trg
    where "Trg ❙«i❙» = ❙«i❙»"
        | "Trg ❙λ❙[t❙] = ❙λ❙[Trg t❙]"
        | "Trg (t ❙∘ u) = Trg t ❙∘ Trg u"
        | "Trg (❙λ❙[t❙] ❙⦁ u) = subst (Trg u) (Trg t)"
        | "Trg _ = ❙♯"

    lemma Ide_Src:
    shows "Arr t ⟹ Ide (Src t)"
      by (induct t) auto

    lemma Ide_iff_Src_self:
    assumes "Arr t"
    shows "Ide t ⟷ Src t = t"
      using assms Ide_Src
      by (induct t) auto

    lemma Arr_Src [simp]:
    assumes "Arr t"
    shows "Arr (Src t)"
      using assms Ide_Src Ide_implies_Arr by blast

    lemma Con_Src:
    shows "⟦size t + size u ≤ n; t ⌢ u⟧ ⟹ Src t ⌢ Src u"
      by (induct n arbitrary: t u) auto

    lemma Src_eq_iff:
    shows "Src ❙«i❙» = Src ❙«i'❙» ⟷ i = i'"
    and "Src (t ❙∘ u) = Src (t' ❙∘ u') ⟷ Src t = Src t' ∧ Src u = Src u'"
    and "Src (❙λ❙[t❙] ❙⦁ u) = Src (❙λ❙[t'❙] ❙⦁ u') ⟷ Src t = Src t' ∧ Src u = Src u'"
    and "Src (❙λ❙[t❙] ❙∘ u) = Src (❙λ❙[t'❙] ❙⦁ u') ⟷ Src t = Src t' ∧ Src u = Src u'"
      by auto

    lemma Src_Raise:
    shows "Src (Raise d n t) = Raise d n (Src t)"
      by (induct t arbitrary: d) auto

    lemma Src_Subst [simp]:
    shows "⟦Arr t; Arr u⟧ ⟹ Src (Subst d t u) = Subst d (Src t) (Src u)"
      using Src_Raise
      by (induct u arbitrary: d X) auto

    lemma Ide_Trg:
    shows "Arr t ⟹ Ide (Trg t)"
      using Ide_Subst
      by (induct t) auto

    lemma Ide_iff_Trg_self:
    shows "Arr t ⟹ Ide t ⟷ Trg t = t"
      apply (induct t)
          apply auto
      by (metis Ide.simps(5) Ide_Subst Ide_Trg)+

    lemma Arr_Trg [simp]:
    assumes "Arr X"
    shows "Arr (Trg X)"
      using assms Ide_Trg Ide_implies_Arr by blast

    lemma Src_Src [simp]:
    assumes "Arr t"
    shows "Src (Src t) = Src t"
      using assms Ide_Src Ide_iff_Src_self Ide_implies_Arr by blast

    lemma Trg_Src [simp]:
    assumes "Arr t"
    shows "Trg (Src t) = Src t"
      using assms Ide_Src Ide_iff_Trg_self Ide_implies_Arr by blast

    lemma Trg_Trg [simp]:
    assumes "Arr t"
    shows "Trg (Trg t) = Trg t"
      using assms Ide_Trg Ide_iff_Trg_self Ide_implies_Arr by blast

    lemma Src_Trg [simp]:
    assumes "Arr t"
    shows "Src (Trg t) = Trg t"
      using assms Ide_Trg Ide_iff_Src_self Ide_implies_Arr by blast

    text ‹
      Two terms are syntactically \emph{coinitial} if they are arrows with the same source;
      that is, they represent two reductions from the same starting term.
    ›

    abbreviation Coinitial
    where "Coinitial t u ≡ Arr t ∧ Arr u ∧ Src t = Src u"

    text ‹
      We now show that terms are consistent if and only if they are coinitial.
    ›

    lemma Coinitial_cases:
    assumes "Arr t" and "Arr t'" and "Src t = Src t'"
    shows "(t = ❙♯ ∧ t' = ❙♯) ∨
           (∃x. t = ❙«x❙» ∧ t' = ❙«x❙») ∨
           (∃u u'. t = ❙λ❙[u❙] ∧ t' = ❙λ❙[u'❙]) ∨
           (∃u v u' v'. t = u ❙∘ v ∧ t' = u' ❙∘ v') ∨
           (∃u v u' v'. t = ❙λ❙[u❙] ❙⦁ v ∧ t' = ❙λ❙[u'❙] ❙⦁ v') ∨
           (∃u v u' v'. t = ❙λ❙[u❙] ❙∘ v ∧ t' = ❙λ❙[u'❙] ❙⦁ v') ∨
           (∃u v u' v'. t = ❙λ❙[u❙] ❙⦁ v ∧ t' = ❙λ❙[u'❙] ❙∘ v')"
      using assms
      by (cases t; cases t') auto

    lemma Con_implies_Coinitial_ind:
    shows "⟦size t + size u ≤ n; t ⌢ u⟧ ⟹ Coinitial t u"
      using Con_implies_Arr1 Con_implies_Arr2
      by (induct n arbitrary: t u) auto

    lemma Coinitial_implies_Con_ind:
    shows "⟦size (Src t) ≤ n; Coinitial t u⟧ ⟹ t ⌢ u"
    proof (induct n arbitrary: t u)
      show "⋀t u. ⟦size (Src t) ≤ 0; Coinitial t u⟧ ⟹ t ⌢ u"
        by auto
      fix n t u
      assume Coinitial: "Coinitial t u"
      assume n: "size (Src t) ≤ Suc n"
      assume ind: "⋀t u. ⟦size (Src t) ≤ n; Coinitial t u⟧ ⟹ t ⌢ u"
      show "t ⌢ u"
        using n ind Coinitial Coinitial_cases [of t u] Subst_not_Nil by auto
    qed

    lemma Coinitial_iff_Con:
    shows "Coinitial t u ⟷ t ⌢ u"
      using Coinitial_implies_Con_ind Con_implies_Coinitial_ind by blast

    lemma Coinitial_Raise_Raise:
    shows "Coinitial t u ⟹ Coinitial (Raise d n t) (Raise d n u)"
      using Arr_Raise Src_Raise
      apply (induct t arbitrary: d n u, auto)
      by (metis Raise.simps(3-4))

    lemma Con_sym:
    shows "t ⌢ u ⟷ u ⌢ t"
      by (metis Coinitial_iff_Con)

    lemma ConI [intro, simp]:
    assumes "Arr t" and "Arr u" and "Src t = Src u"
    shows "Con t u"
      using assms Coinitial_iff_Con by blast

    lemma Con_Arr_Src [simp]:
    assumes "Arr t"
    shows "t ⌢ Src t" and "Src t ⌢ t"
      using assms
      by (auto simp add: Ide_Src Ide_implies_Arr)

    lemma resid_Arr_self:
    shows "Arr t ⟹ t \\ t = Trg t"
      by (induct t) auto

    text ‹
      The following result is not used in the formal development that follows,
      but it requires some proof and might eventually be useful.
    ›

    lemma finite_branching:
    shows "Ide a ⟹ finite {t. Arr t ∧ Src t = a}"
    proof (induct a)
      show "Ide ❙♯ ⟹ finite {t. Arr t ∧ Src t = ❙♯}"
        by simp
      fix x
      have "⋀t. Src t = ❙«x❙» ⟷ t = ❙«x❙»"
        using Src.elims by blast
      thus "finite {t. Arr t ∧ Src t = ❙«x❙»}"
        by simp
      next
      fix a
      assume a: "Ide ❙λ❙[a❙]"
      assume ind: "Ide a ⟹ finite {t. Arr t ∧ Src t = a}"
      have "{t. Arr t ∧ Src t = ❙λ❙[a❙]} = Lam ` {t. Arr t ∧ Src t = a}"
        using Coinitial_cases by fastforce
      thus "finite {t. Arr t ∧ Src t = ❙λ❙[a❙]}"
        using a ind by simp
      next
      fix a1 a2
      assume ind1: "Ide a1 ⟹ finite {t. Arr t ∧ Src t = a1}"
      assume ind2: "Ide a2 ⟹ finite {t. Arr t ∧ Src t = a2}"
      assume a: "Ide (❙λ❙[a1❙] ❙⦁ a2)"
      show "finite {t. Arr t ∧ Src t = ❙λ❙[a1❙] ❙⦁ a2}"
        using a ind1 ind2 by simp
      next
      fix a1 a2
      assume ind1: "Ide a1 ⟹ finite {t. Arr t ∧ Src t = a1}"
      assume ind2: "Ide a2 ⟹ finite {t. Arr t ∧ Src t = a2}"
      assume a: "Ide (a1 ❙∘ a2)"
      have "{t. Arr t ∧ Src t = a1 ❙∘ a2} =
            ({t. is_App t} ∩ ({t. Arr t ∧ Src (un_App1 t) = a1 ∧ Src (un_App2 t) = a2})) ∪
            ({t. is_Beta t ∧ is_Lam a1} ∩
             ({t. Arr t ∧ is_Lam a1 ∧ Src (un_Beta1 t) = un_Lam a1 ∧ Src (un_Beta2 t) = a2}))"
        by fastforce
      have "{t. Arr t ∧ Src t = a1 ❙∘ a2} =
            (λ(t1, t2). t1 ❙∘ t2) ` ({t1. Arr t1 ∧ Src t1 = a1} × {t2. Arr t2 ∧ Src t2 = a2}) ∪
            (λ(t1, t2). ❙λ❙[t1❙] ❙⦁ t2) `
              ({t1t2. is_Lam a1} ∩
                 {t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})"
      proof
        show "(λ(t1, t2). t1 ❙∘ t2) ` ({t1. Arr t1 ∧ Src t1 = a1} × {t2. Arr t2 ∧ Src t2 = a2}) ∪
              (λ(t1, t2). ❙λ❙[t1❙] ❙⦁ t2) `
                ({t1t2. is_Lam a1} ∩
                   {t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})
                ⊆ {t. Arr t ∧ Src t = a1 ❙∘ a2}"
          by auto
        show "{t. Arr t ∧ Src t = a1 ❙∘ a2}
                ⊆ (λ(t1, t2). t1 ❙∘ t2) `
                    ({t1. Arr t1 ∧ Src t1 = a1} × {t2. Arr t2 ∧ Src t2 = a2}) ∪
                  (λ(t1, t2). ❙λ❙[t1❙] ❙⦁ t2) `
                    ({t1t2. is_Lam a1} ∩
                       {t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})"
        proof
          fix t
          assume t: "t ∈ {t. Arr t ∧ Src t = a1 ❙∘ a2}"
          have "is_App t ∨ is_Beta t"
            using t by auto
          moreover have "is_App t ⟹ t ∈ (λ(t1, t2). t1 ❙∘ t2) `
                                        ({t1. Arr t1 ∧ Src t1 = a1} × {t2. Arr t2 ∧ Src t2 = a2})"
            using t image_iff is_App_def by fastforce
          moreover have "is_Beta t ⟹
                           t ∈ (λ(t1, t2). ❙λ❙[t1❙] ❙⦁ t2) `
                             ({t1t2. is_Lam a1} ∩
                                {t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})"
            using t is_Beta_def by fastforce
          ultimately show "t ∈ (λ(t1, t2). t1 ❙∘ t2) `
                                 ({t1. Arr t1 ∧ Src t1 = a1} × {t2. Arr t2 ∧ Src t2 = a2}) ∪
                               (λ(t1, t2). ❙λ❙[t1❙] ❙⦁ t2) `
                                 ({t1t2. is_Lam a1} ∩
                                    {t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})"
            by blast
        qed
      qed
      moreover have "finite ({t1. Arr t1 ∧ Src t1 = a1} × {t2. Arr t2 ∧ Src t2 = a2})"
        using a ind1 ind2 Ide.simps(4) by blast
      moreover have "is_Lam a1 ⟹
                     finite ({t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})"
      proof -
        assume a1: "is_Lam a1"
        have "Ide (un_Lam a1)"
          using a a1 is_Lam_def by force
        have "Lam ` {t1. Arr t1 ∧ Src t1 = un_Lam a1} = {t. Arr t ∧ Src t = a1}"
        proof
          show "Lam ` {t1. Arr t1 ∧ Src t1 = un_Lam a1} ⊆ {t. Arr t ∧ Src t = a1}"
            using a1 by fastforce
          show "{t. Arr t ∧ Src t = a1} ⊆ Lam ` {t1. Arr t1 ∧ Src t1 = un_Lam a1}"
          proof
            fix t
            assume t: "t ∈ {t. Arr t ∧ Src t = a1}"
            have "is_Lam t"
              using a1 t by auto
            hence "un_Lam t ∈ {t1. Arr t1 ∧ Src t1 = un_Lam a1}"
              using is_Lam_def t by force
            thus "t ∈ Lam ` {t1. Arr t1 ∧ Src t1 = un_Lam a1}"
              by (metis ‹is_Lam t› lambda.collapse(2) rev_image_eqI)
          qed
        qed
        moreover have "inj Lam"
          using inj_on_def by blast
        ultimately have "finite {t1. Arr t1 ∧ Src t1 = un_Lam a1}"
          by (metis (mono_tags, lifting) Ide.simps(4) a finite_imageD ind1 injD inj_onI)
        moreover have "finite {t2. Arr t2 ∧ Src t2 = a2}"
          using Ide.simps(4) a ind2 by blast
        ultimately
        show "finite ({t1. Arr t1 ∧ Src t1 = un_Lam a1} × {t2. Arr t2 ∧ Src t2 = a2})"
          by blast
      qed
      ultimately show "finite {t. Arr t ∧ Src t = a1 ❙∘ a2}"
        using a ind1 ind2 by simp
    qed

    subsection "Residuation and Substitution"

    text ‹
      We now develop a series of lemmas that involve the interaction of residuation
      and substitution.
    ›

    lemma Raise_resid:
    shows "t ⌢ u ⟹ Raise k n (t \\ u) = Raise k n t \\ Raise k n u"
    proof -
      (*
       * Note: This proof uses subterm induction because the hypothesis Con t u yields
       * cases in which App and Beta terms are compared, so that the first argument to App
       * needs to be unfolded.
       *)
      let ?P = "λ(t, u). ∀k n. t ⌢ u ⟶ Raise k n (t \\ u) = Raise k n t \\ Raise k n u"
      have "⋀t u.
               ∀t' u'. ((t', u'), (t, u)) ∈ subterm_pair_rel ⟶
                         (∀k n. t' ⌢ u' ⟶
                                Raise k n (t' \\ u') = Raise k n t' \\ Raise k n u') ⟹
               (⋀k n. t ⌢ u ⟹ Raise k n (t \\ u) = Raise k n t \\ Raise k n u)"
        using subterm_lemmas Coinitial_iff_Con Coinitial_Raise_Raise Raise_subst by auto
      thus "t ⌢ u ⟹ Raise k n (t \\ u) = Raise k n t \\ Raise k n u"
        using wf_subterm_pair_rel wf_induct [of subterm_pair_rel ?P] by blast
    qed

    lemma Con_Raise:
    shows "t ⌢ u ⟹ Raise d n t ⌢ Raise d n u"
      by (metis Raise_not_Nil Raise_resid)

    text ‹
      The following is Huet's Commutation Theorem \<^cite>‹"huet-residual-theory"›:
      ``substitution commutes with residuation''.
    ›

    lemma resid_Subst:
    assumes "t ⌢ t'" and "u ⌢ u'"
    shows "Subst n t u \\ Subst n t' u' = Subst n (t \\ t') (u \\ u')"
    proof -
      let ?P = "λ(u, u'). ∀n t t'. t ⌢ t' ∧ u ⌢ u' ⟶
                                     Subst n t u \\ Subst n t' u' = Subst n (t \\ t') (u \\ u')"
      have "⋀u u'. ∀w w'. ((w, w'), (u, u')) ∈ subterm_pair_rel ⟶
                             (∀n v v'. v ⌢ v' ∧ w ⌢ w' ⟶
                               Subst n v w \\ Subst n v' w' = Subst n (v \\ v') (w \\ w')) ⟹
                   ∀n t t'. t ⌢ t' ∧ u ⌢ u' ⟶
                              Subst n t u \\ Subst n t' u' = Subst n (t \\ t') (u \\ u')"
        using subterm_lemmas Raise_resid Subst_not_Nil Con_Raise Raise_subst substitution_lemma
        by auto
      thus ?thesis
        using assms wf_subterm_pair_rel wf_induct [of subterm_pair_rel ?P] by auto
    qed

    lemma Trg_Subst [simp]:
    shows "⟦Arr t; Arr u⟧ ⟹ Trg (Subst d t u) = Subst d (Trg t) (Trg u)"
      by (metis Arr_Subst Arr_Trg Arr_not_Nil resid_Arr_self resid_Subst)

    lemma Src_resid:
    shows "t ⌢ u ⟹ Src (t \\ u) = Trg u"
    proof (induct u arbitrary: t, auto simp add: Arr_resid)
      fix t t1'
      show "⋀t2'. ⟦⋀t1. t1 ⌢ t1' ⟹ Src (t1 \\ t1') = Trg t1';
                   ⋀t2. t2 ⌢ t2' ⟹ Src (t2 \\ t2') = Trg t2';
                   t ⌢ t1' ❙∘ t2'⟧
                      ⟹ Src (t \\ (t1' ❙∘ t2')) = Trg t1' ❙∘ Trg t2'"
        apply (cases t; cases t1')
                            apply auto
        by (metis Src.simps(3) lambda.distinct(3) lambda.sel(2) resid.simps(2))
    qed

    lemma Coinitial_resid_resid:
    assumes "t ⌢ v" and "u ⌢ v"
    shows "Coinitial (t \\ v) (u \\ v)"
      using assms Src_resid Arr_resid Coinitial_iff_Con by presburger

    lemma Con_implies_is_Lam_iff_is_Lam:
    assumes "t ⌢ u"
    shows "is_Lam t ⟷ is_Lam u"
      using assms by auto

    lemma Con_implies_Coinitial3:
    assumes "t \\ v ⌢ u \\ v"
    shows "Coinitial v u" and "Coinitial v t" and "Coinitial u t"
      using assms
      by (metis Coinitial_iff_Con resid.simps(7))+

    text ‹
      We can now prove L\'{e}vy's ``Cube Lemma'' \<^cite>‹"levy"›, which is the key axiom
      for a residuated transition system.
    ›

    lemma Cube:
    shows "v \\ t ⌢ u \\ t ⟹ (v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
    proof -
      let ?P = "λ(t, u, v). v \\ t ⌢ u \\ t ⟶ (v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
      have "⋀t u v.
               ∀t' u' v'.
                 ((t', u', v'), (t, u, v)) ∈ subterm_triple_rel ⟶ ?P (t', u', v') ⟹
                   v \\ t ⌢ u \\ t ⟶ (v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
      proof -
        fix t u v
        assume ind: "∀t' u' v'. 
                       ((t', u', v'), (t, u, v)) ∈ subterm_triple_rel ⟶ ?P (t', u', v')"
        show "v \\ t ⌢ u \\ t ⟶ (v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
        proof (intro impI)
          assume con: "v \\ t ⌢ u \\ t"
          have "Con v t"
            using con by auto
          moreover have "Con u t"
            using con by auto
          ultimately show "(v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
            using subterm_lemmas ind Coinitial_iff_Con Coinitial_resid_resid resid_Subst
            apply (elim ConE [of v t] ConE [of u t])
                                apply simp_all
                    apply metis
                   apply metis
                  apply (cases "un_App1 t"; cases "un_App1 v", simp_all)
                  apply metis
                 apply metis
                apply metis
               apply metis
              apply metis
             apply (cases "un_App1 u", simp_all)
             apply metis
            by metis
        qed
      qed
      hence "?P (t, u, v)"
        using wf_subterm_triple_rel wf_induct [of subterm_triple_rel ?P] by blast
      thus "v \\ t ⌢ u \\ t ⟹ (v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
        by simp
    qed

    subsection "Residuation Determines an RTS"

    text ‹
      We are now in a position to verify that the residuation operation that we have defined
      satisfies the axioms for a residuated transition system, and that various notions
      which we have defined syntactically above (\emph{e.g.}~arrow, source, target) agree
      with the versions derived abstractly from residuation.
    ›

    sublocale partial_magma resid
      apply unfold_locales
      by (metis Arr.simps(1) Coinitial_iff_Con)

    lemma null_char [simp]:
    shows "null = ❙♯"
      using null_def
      by (metis null_is_zero(2) resid.simps(7))

    sublocale residuation resid
      using null_char Arr_resid Coinitial_iff_Con Cube
      apply (unfold_locales, auto)
      by metis+

    (* TODO: Try to understand when notation is and is not inherited. *)
    notation resid  (infix "\\" 70)

    lemma resid_is_residuation:
    shows "residuation resid"
      ..

    lemma arr_char [iff]:
    shows "arr t ⟷ Arr t"
      using Coinitial_iff_Con arr_def con_def null_char by auto

    lemma ide_char [iff]:
    shows "ide t ⟷ Ide t"
      by (metis Ide_iff_Trg_self Ide_implies_Arr arr_char arr_resid_iff_con ide_def
          resid_Arr_self)

    lemma resid_Arr_Ide:
    shows "⟦Ide a; Coinitial t a⟧ ⟹ t \\ a = t"
      using Ide_iff_Src_self
      by (induct t arbitrary: a, auto)

    lemma resid_Ide_Arr:
    shows "⟦Ide a; Coinitial a t⟧ ⟹ Ide (a \\ t)"
      by (metis Coinitial_resid_resid ConI Ide_iff_Trg_self cube resid_Arr_Ide resid_Arr_self)

    lemma resid_Arr_Src [simp]:
    assumes "Arr t"
    shows "t \\ Src t = t"
      using assms Ide_Src
      by (simp add: Ide_implies_Arr resid_Arr_Ide)

    lemma resid_Src_Arr [simp]:
    assumes "Arr t"
    shows "Src t \\ t = Trg t"
      using assms
      by (metis (full_types) Con_Arr_Src(2) Con_implies_Arr1 Src_Src Src_resid cube
          resid_Arr_Src resid_Arr_self)

    sublocale rts resid
    proof
      show "⋀a t. ⟦ide a; con t a⟧ ⟹ t \\ a = t"
        using ide_char resid_Arr_Ide
        by (metis Coinitial_iff_Con con_def null_char)
      show "⋀t. arr t ⟹ ide (trg t)"
        by (simp add: Ide_Trg resid_Arr_self trg_def)
      show "⋀a t. ⟦ide a; con a t⟧ ⟹ ide (resid a t)"
        using ide_char null_char resid_Ide_Arr Coinitial_iff_Con con_def by force
      show "⋀t u. con t u ⟹ ∃a. ide a ∧ con a t ∧ con a u"
        by (metis Coinitial_iff_Con Ide_Src Ide_iff_Src_self Ide_implies_Arr con_def
            ide_char null_char)
      show "⋀t u v. ⟦ide (resid t u); con u v⟧ ⟹ con (resid t u) (resid v u)"
        by (metis Coinitial_resid_resid ide_char not_arr_null null_char resid_Ide_Arr
                  con_def con_sym ide_implies_arr)
    qed

    lemma is_rts:
    shows "rts resid"
      ..

    lemma sources_char⇩Λ:
    shows "sources t = (if Arr t then {Src t} else {})"
    proof (cases "Arr t")
      show "¬ Arr t ⟹ ?thesis"
        using arr_char arr_iff_has_source by auto
      assume t: "Arr t"
      have 1: "{Src t} ⊆ sources t"
        using t Ide_Src by force
      moreover have "sources t ⊆ {Src t}"
        by (metis Coinitial_iff_Con Ide_iff_Src_self ide_char in_sourcesE null_char
                  con_def singleton_iff subsetI)
      ultimately show ?thesis
        using t by auto
    qed

    lemma sources_simp [simp]:
    assumes "Arr t"
    shows "sources t = {Src t}"
      using assms sources_char⇩Λ by auto

    lemma sources_simps [simp]:
    shows "sources ❙♯ = {}"
    and "sources ❙«x❙» = {❙«x❙»}"
    and "arr t ⟹ sources ❙λ❙[t❙] = {❙λ❙[Src t❙]}"
    and "⟦arr t; arr u⟧ ⟹ sources (t ❙∘ u) = {Src t ❙∘ Src u}"
    and "⟦arr t; arr u⟧ ⟹ sources (❙λ❙[t❙] ❙⦁ u) = {❙λ❙[Src t❙] ❙∘ Src u}"
      using sources_char⇩Λ by auto

    lemma targets_char⇩Λ:
    shows "targets t = (if Arr t then {Trg t} else {})"
    proof (cases "Arr t")
      show "¬ Arr t ⟹ ?thesis"
        by (meson arr_char arr_iff_has_target)
      assume t: "Arr t"
      have 1: "{Trg t} ⊆ targets t"
        using t resid_Arr_self trg_def trg_in_targets by force
      moreover have "targets t ⊆ {Trg t}"
        by (metis 1 Ide_iff_Src_self arr_char ide_char ide_implies_arr
            in_targetsE insert_subset prfx_implies_con resid_Arr_self
            sources_resid sources_simp t)
      ultimately show ?thesis
        using t by auto
    qed

    lemma targets_simp [simp]:
    assumes "Arr t"
    shows "targets t = {Trg t}"
      using assms targets_char⇩Λ by auto

    lemma targets_simps [simp]:
    shows "targets ❙♯ = {}"
    and "targets ❙«x❙» = {❙«x❙»}"
    and "arr t ⟹ targets ❙λ❙[t❙] = {❙λ❙[Trg t❙]}"
    and "⟦arr t; arr u⟧ ⟹ targets (t ❙∘ u) = {Trg t ❙∘ Trg u}"
    and "⟦arr t; arr u⟧ ⟹ targets (❙λ❙[t❙] ❙⦁ u) = {subst (Trg u) (Trg t)}"
      using targets_char⇩Λ by auto

    lemma seq_char:
    shows "seq t u ⟷ Arr t ∧ Arr u ∧ Trg t = Src u"
      using seq_def arr_char sources_char⇩Λ targets_char⇩Λ by force

    lemma seqI⇩Λ [intro, simp]:
    assumes "Arr t" and "Arr u" and "Trg t = Src u"
    shows "seq t u"
      using assms seq_char by simp

    lemma seqE⇩Λ [elim]:
    assumes "seq t u"
    and "⟦Arr t; Arr u; Trg t = Src u⟧ ⟹ T"
    shows T
      using assms seq_char by blast

    text ‹
      The following classifies the ways that transitions can be sequential.  It is useful
      for later proofs by case analysis.
    ›

    lemma seq_cases:
    assumes "seq t u"
    shows "(is_Var t ∧ is_Var u) ∨
           (is_Lam t ∧ is_Lam u) ∨
           (is_App t ∧ is_App u) ∨
           (is_App t ∧ is_Beta u ∧ is_Lam (un_App1 t)) ∨
           (is_App t ∧ is_Beta u ∧ is_Beta (un_App1 t)) ∨
           is_Beta t"
      using assms seq_char
      by (cases t; cases u) auto

    sublocale confluent_rts resid
      by (unfold_locales) fastforce

    lemma is_confluent_rts:
    shows "confluent_rts resid"
      ..

    lemma con_char [iff]:
    shows "con t u ⟷ Con t u"
      by fastforce

    lemma coinitial_char [iff]:
    shows "coinitial t u ⟷ Coinitial t u"
      by fastforce

    lemma sources_Raise:
    assumes "Arr t"
    shows "sources (Raise d n t) = {Raise d n (Src t)}"
      using assms
      by (simp add: Coinitial_Raise_Raise Src_Raise)

    lemma targets_Raise:
    assumes "Arr t"
    shows "targets (Raise d n t) = {Raise d n (Trg t)}"
      using assms
      by (metis Arr_Raise ConI Raise_resid resid_Arr_self targets_char⇩Λ)

    lemma sources_subst [simp]:
    assumes "Arr t" and "Arr u"
    shows "sources (subst t u) = {subst (Src t) (Src u)}"
      using assms sources_char⇩Λ Arr_Subst arr_char by simp

    lemma targets_subst [simp]:
    assumes "Arr t" and "Arr u"
    shows "targets (subst t u) = {subst (Trg t) (Trg u)}"
      using assms targets_char⇩Λ Arr_Subst arr_char by simp

    notation prfx  (infix "≲" 50)
    notation cong  (infix "∼" 50)

    lemma prfx_char [iff]:
    shows "t ≲ u ⟷ Ide (t \\ u)"
      using ide_char by simp

    lemma prfx_Var_iff:
    shows "u ≲ ❙«i❙» ⟷ u = ❙«i❙»"
      by (metis Arr.simps(2) Coinitial_iff_Con Ide.simps(1) Ide_iff_Src_self Src.simps(2)
          ide_char resid_Arr_Ide)

    lemma prfx_Lam_iff:
    shows "u ≲ Lam t ⟷ is_Lam u ∧ un_Lam u ≲ t"
      using ide_char Arr_not_Nil Con_implies_is_Lam_iff_is_Lam Ide_implies_Arr is_Lam_def
      by fastforce

    lemma prfx_App_iff:
    shows "u ≲ t1 ❙∘ t2 ⟷ is_App u ∧ un_App1 u ≲ t1 ∧ un_App2 u ≲ t2"
      using ide_char
      by (cases u; cases t1) auto

    lemma prfx_Beta_iff:
    shows "u ≲ ❙λ❙[t1❙] ❙⦁ t2 ⟷ 
           (is_App u ∧ un_App1 u ≲ ❙λ❙[t1❙] ∧ un_App2 u ⌢ t2 ∧
             (0 ∈ FV (un_Lam (un_App1 u) \\ t1) ⟶ un_App2 u ≲ t2)) ∨
           (is_Beta u ∧ un_Beta1 u ≲ t1 ∧ un_Beta2 u ⌢ t2 ∧
             (0 ∈ FV (un_Beta1 u \\ t1) ⟶ un_Beta2 u ≲ t2))"
      using ide_char Ide_Subst_iff
      by (cases u; cases "un_App1 u") auto

    lemma cong_Ide_are_eq:
    assumes "t ∼ u" and "Ide t" and "Ide u"
    shows "t = u"
      using assms
      by (metis Coinitial_iff_Con Ide_iff_Src_self con_char prfx_implies_con)

    lemma eq_Ide_are_cong:
    assumes "t = u" and "Ide t"
    shows "t ∼ u"
      using assms Ide_implies_Arr resid_Ide_Arr by blast

    sublocale weakly_extensional_rts resid
      apply unfold_locales
      by (metis Coinitial_iff_Con Ide_iff_Src_self Ide_implies_Arr ide_char ide_def)

    lemma is_weakly_extensional_rts:
    shows "weakly_extensional_rts resid"
      ..

    lemma src_char [simp]:
    shows "src t = (if Arr t then Src t else ❙♯)"
      using src_def by force

    lemma trg_char [simp]:
    shows "trg t = (if Arr t then Trg t else ❙♯)"
      by (metis Coinitial_iff_Con resid_Arr_self trg_def)

    text ‹
      We ``almost'' have an extensional RTS.
      The case that fails is ‹❙λ❙[t1❙] ❙⦁ t2 ∼ u ⟹ ❙λ❙[t1❙] ❙⦁ t2 = u›.
      This is because ‹t1› might ignore its argument, so that ‹subst t2 t1 = subst t2' t1›,
      with both sides being identities, even if ‹t2 ≠ t2'›.

      The following gives a concrete example of such a situation.
    ›

    abbreviation non_extensional_ex1
    where "non_extensional_ex1 ≡ ❙λ❙[❙λ❙[❙«0❙»❙] ❙∘ ❙λ❙[❙«0❙»❙]❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙⦁ ❙λ❙[❙«0❙»❙])"

    abbreviation non_extensional_ex2
    where "non_extensional_ex2 ≡ ❙λ❙[❙λ❙[❙«0❙»❙] ❙∘ ❙λ❙[❙«0❙»❙]❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙∘ ❙λ❙[❙«0❙»❙])"

    lemma non_extensional:
    shows "❙λ❙[❙«1❙»❙] ❙⦁ non_extensional_ex1 ∼ ❙λ❙[❙«1❙»❙] ❙⦁ non_extensional_ex2"
    and "❙λ❙[❙«1❙»❙] ❙⦁  non_extensional_ex1 ≠ ❙λ❙[❙«1❙»❙] ❙⦁ non_extensional_ex2"
      by auto

    text ‹
      The following gives an example of two terms that are both coinitial and coterminal,
      but which are not congruent.
    ›

    abbreviation cong_nontrivial_ex1
    where "cong_nontrivial_ex1 ≡
           ❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙] ❙∘ ❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙] ❙∘ (❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙] ❙⦁ ❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙])"

    abbreviation cong_nontrivial_ex2
    where "cong_nontrivial_ex2 ≡
           ❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙] ❙⦁ ❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙] ❙∘ (❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙] ❙∘ ❙λ❙[❙«0❙» ❙∘ ❙«0❙»❙])"

    lemma cong_nontrivial:
    shows "coinitial cong_nontrivial_ex1 cong_nontrivial_ex2"
    and "coterminal cong_nontrivial_ex1 cong_nontrivial_ex2"
    and "¬ cong cong_nontrivial_ex1 cong_nontrivial_ex2"
      by auto

    text ‹
      Every two coinitial transitions have a join, obtained structurally by unioning the sets
      of marked redexes.
    ›

    fun Join  (infix "⊔" 52)
    where "❙«x❙» ⊔ ❙«x'❙» = (if x = x' then ❙«x❙» else ❙♯)"
        | "❙λ❙[t❙] ⊔ ❙λ❙[t'❙] = ❙λ❙[t ⊔ t'❙]"
        | "❙λ❙[t❙] ❙∘ u ⊔ ❙λ❙[t'❙] ❙⦁ u' = ❙λ❙[(t ⊔ t')❙] ❙⦁ (u ⊔ u')"
        | "❙λ❙[t❙] ❙⦁ u ⊔ ❙λ❙[t'❙] ❙∘ u' = ❙λ❙[(t ⊔ t')❙] ❙⦁ (u ⊔ u')"
        | "t ❙∘ u ⊔ t'❙∘ u' = (t ⊔ t') ❙∘ (u ⊔ u')"
        | "❙λ❙[t❙] ❙⦁ u ⊔ ❙λ❙[t'❙] ❙⦁ u' = ❙λ❙[(t ⊔ t')❙] ❙⦁ (u ⊔ u')"
        | "_ ⊔ _ = ❙♯"

    lemma Join_sym:
    shows "t ⊔ u = u ⊔ t"
      using Join.induct [of "λt u. t ⊔ u = u ⊔ t"] by auto

    lemma Src_Join:
    shows "Coinitial t u ⟹ Src (t ⊔ u) = Src t"
    proof (induct t arbitrary: u)
      show "⋀u. Coinitial ❙♯ u ⟹ Src (❙♯ ⊔ u) = Src ❙♯"
        by simp
      show "⋀x u. Coinitial ❙«x❙» u ⟹ Src (❙«x❙» ⊔ u) = Src ❙«x❙»"
        by auto
      fix t u
      assume ind: "⋀u. Coinitial t u ⟹ Src (t ⊔ u) = Src t"
      assume tu: "Coinitial ❙λ❙[t❙] u"
      show "Src (❙λ❙[t❙] ⊔ u) = Src ❙λ❙[t❙]"
        using tu ind
        by (cases u) auto
      next
      fix t1 t2 u
      assume ind1: "⋀u1. Coinitial t1 u1 ⟹ Src (t1 ⊔ u1) = Src t1"
      assume ind2: "⋀u2. Coinitial t2 u2 ⟹ Src (t2 ⊔ u2) = Src t2"
      assume tu: "Coinitial (t1 ❙∘ t2) u"
      show "Src (t1 ❙∘ t2 ⊔ u) = Src (t1 ❙∘ t2)"
        using tu ind1 ind2
        apply (cases u, simp_all)
        apply (cases t1, simp_all)
        by (metis Arr.simps(3) Join.simps(2) Src.simps(3) lambda.sel(2))
      next
      fix t1 t2 u
      assume ind1: "⋀u1. Coinitial t1 u1 ⟹ Src (t1 ⊔ u1) = Src t1"
      assume ind2: "⋀u2. Coinitial t2 u2 ⟹ Src (t2 ⊔ u2) = Src t2"
      assume tu: "Coinitial (❙λ❙[t1❙] ❙⦁ t2) u"
      show "Src ((❙λ❙[t1❙] ❙⦁ t2) ⊔ u) = Src (❙λ❙[t1❙] ❙⦁ t2)"
        using tu ind1 ind2
        apply (cases u, simp_all)
        by (cases "un_App1 u") auto
    qed

    lemma resid_Join:
    shows "Coinitial t u ⟹ (t ⊔ u) \\ u = t \\ u"
    proof (induct t arbitrary: u)
      show "⋀u. Coinitial ❙♯ u ⟹ (❙♯ ⊔ u) \\ u = ❙♯ \\ u"
        by auto
      show "⋀x u. Coinitial ❙«x❙» u ⟹ (❙«x❙» ⊔ u) \\ u = ❙«x❙» \\ u"
        by auto
      fix t u
      assume ind: "⋀u. Coinitial t u ⟹ (t ⊔ u) \\ u = t \\ u"
      assume tu: "Coinitial ❙λ❙[t❙] u"
      show "(❙λ❙[t❙] ⊔ u) \\ u = ❙λ❙[t❙] \\ u"
        using tu ind
        by (cases u) auto
      next
      fix t1 t2 u
      assume ind1: "⋀u1. Coinitial t1 u1 ⟹ (t1 ⊔ u1) \\ u1 = t1 \\ u1"
      assume ind2: "⋀u2. Coinitial t2 u2 ⟹ (t2 ⊔ u2) \\ u2 = t2 \\ u2"
      assume tu: "Coinitial (t1 ❙∘ t2) u"
      show "(t1 ❙∘ t2 ⊔ u) \\ u = (t1 ❙∘ t2) \\ u"
        using tu ind1 ind2 Coinitial_iff_Con
        apply (cases u, simp_all)
      proof -
        fix u1 u2
        assume u: "u = ❙λ❙[u1❙] ❙⦁ u2"
        have t2u2: "t2 ⌢ u2"
          using Arr_not_Nil Arr_resid tu u by simp
        have t1u1: "Coinitial (un_Lam t1 ⊔ u1) u1"
        proof -
          have "Arr (un_Lam t1 ⊔ u1)"
            by (metis Arr.simps(3-5) Coinitial_iff_Con Con_implies_is_Lam_iff_is_Lam
                Join.simps(2) Src.simps(3-5) ind1 lambda.collapse(2) lambda.disc(8)
                lambda.sel(3) tu u)
          thus ?thesis
            using Src_Join
            by (metis Arr.simps(3-5) Coinitial_iff_Con Con_implies_is_Lam_iff_is_Lam
                Src.simps(3-5) lambda.collapse(2) lambda.disc(8) lambda.sel(2-3) tu u)
        qed
        have "un_Lam t1 ⌢ u1"
          using t1u1
          by (metis Coinitial_iff_Con Con_implies_is_Lam_iff_is_Lam ConD(4) lambda.collapse(2)
              lambda.disc(8) resid.simps(2) tu u)
        thus "(t1 ❙∘ t2 ⊔ ❙λ❙[u1❙] ❙⦁ u2) \\ (❙λ❙[u1❙] ❙⦁ u2) = (t1 ❙∘ t2) \\ (❙λ❙[u1❙] ❙⦁ u2)"
          using u tu t1u1 t2u2 ind1 ind2
          apply (cases t1, auto)
        proof -
          fix v
          assume v: "t1 = ❙λ❙[v❙]"
          show "subst (t2 \\ u2) ((v ⊔ u1) \\ u1) = subst (t2 \\ u2) (v \\ u1)"
          proof -
            have "subst (t2 \\ u2) ((v ⊔ u1) \\ u1) = (t1 ❙∘ t2 ⊔ ❙λ❙[u1❙] ❙⦁ u2) \\ (❙λ❙[u1❙] ❙⦁ u2)"
              by (simp add: Coinitial_iff_Con ind2 t2u2 v)
            also have "... = (t1 ❙∘ t2) \\ (❙λ❙[u1❙] ❙⦁ u2)"
            proof -
              have "(t1 ❙∘ t2 ⊔ ❙λ❙[u1❙] ❙⦁ u2) \\ (❙λ❙[u1❙] ❙⦁ u2) =
                    (❙λ❙[(v ⊔ u1)❙] ❙⦁ (t2 ⊔ u2)) \\ (❙λ❙[u1❙] ❙⦁ u2)"
                using v by simp
              also have "... = subst (t2 \\ u2) ((v ⊔ u1) \\ u1)"
                by (simp add: Coinitial_iff_Con ind2 t2u2)
              also have "... = subst (t2 \\ u2) (v \\ u1)"
              proof -
                have "(t1 ⊔ ❙λ❙[u1❙]) \\ ❙λ❙[u1❙] = t1 \\ ❙λ❙[u1❙]"
                  using u tu ind1 by simp
                thus ?thesis
                  using ‹un_Lam t1 \ u1 ≠ ❙♯› t1u1 v by force
              qed
              also have "... = (t1 ❙∘ t2) \\ (❙λ❙[u1❙] ❙⦁ u2)"
                using tu u v by force
              finally show ?thesis by blast
            qed
            also have "... = subst (t2 \\ u2) (v \\ u1)"
              by (simp add: t2u2 v)
            finally show ?thesis by auto
          qed
        qed
      qed
      next
      fix t1 t2 u
      assume ind1: "⋀u1. Coinitial t1 u1 ⟹ (t1 ⊔ u1) \\ u1 = t1 \\ u1"
      assume ind2: "⋀u2. Coinitial t2 u2 ⟹ (t2 ⊔ u2) \\ u2 = t2 \\ u2"
      assume tu: "Coinitial (❙λ❙[t1❙] ❙⦁ t2) u"
      show "((❙λ❙[t1❙] ❙⦁ t2) ⊔ u) \\ u = (❙λ❙[t1❙] ❙⦁ t2) \\ u"
        using tu ind1 ind2 Coinitial_iff_Con
        apply (cases u, simp_all)
      proof -
        fix u1 u2
        assume u: "u = u1 ❙∘ u2"
        show "(❙λ❙[t1❙] ❙⦁ t2 ⊔ u1 ❙∘ u2) \\ (u1 ❙∘ u2) = (❙λ❙[t1❙] ❙⦁ t2) \\ (u1 ❙∘ u2)"
          using ind1 ind2 tu u
          by (cases u1) auto
      qed
    qed

    lemma prfx_Join:
    shows "Coinitial t u ⟹ u ≲ t ⊔ u"
    proof (induct t arbitrary: u)
      show "⋀u. Coinitial ❙♯ u ⟹ u ≲ ❙♯ ⊔ u"
        by simp
      show "⋀x u. Coinitial ❙«x❙» u ⟹ u ≲ ❙«x❙» ⊔ u"
        by auto
      fix t u
      assume ind: "⋀u. Coinitial t u ⟹ u ≲ t ⊔ u"
      assume tu: "Coinitial ❙λ❙[t❙] u"
      show "u ≲ ❙λ❙[t❙] ⊔ u"
        using tu ind
        apply (cases u, auto)
        by force
      next
      fix t1 t2 u
      assume ind1: "⋀u1. Coinitial t1 u1 ⟹ u1 ≲ t1 ⊔ u1"
      assume ind2: "⋀u2. Coinitial t2 u2 ⟹ u2 ≲ t2 ⊔ u2"
      assume tu: "Coinitial (t1 ❙∘ t2) u"
      show "u ≲ t1 ❙∘ t2 ⊔ u"
        using tu ind1 ind2 Coinitial_iff_Con
        apply (cases u, simp_all)
         apply (metis Ide.simps(1))
      proof -
        fix u1 u2
        assume u: "u = ❙λ❙[u1❙] ❙⦁ u2"
        assume 1: "Arr t1 ∧ Arr t2 ∧ Arr u1 ∧ Arr u2 ∧ Src t1 = ❙λ❙[Src u1❙] ∧ Src t2 = Src u2"
        have 2: "u1 ⌢ un_Lam t1 ⊔ u1"
          by (metis "1" Coinitial_iff_Con Con_implies_is_Lam_iff_is_Lam Con_Arr_Src(2)
              lambda.collapse(2) lambda.disc(8) resid.simps(2) resid_Join)
        have 3: "u2 ⌢ t2 ⊔ u2"
          by (metis "1" conE ind2 null_char prfx_implies_con)
        show "Ide ((❙λ❙[u1❙] ❙⦁ u2) \\ (t1 ❙∘ t2 ⊔ ❙λ❙[u1❙] ❙⦁ u2))"
         using u tu 1 2 3 ind1 ind2
         apply (cases t1, simp_all)
         by (metis Arr.simps(3) Ide.simps(3) Ide_Subst Join.simps(2) Src.simps(3) resid.simps(2))
       qed
      next
      fix t1 t2 u
      assume ind1: "⋀u1. Coinitial t1 u1 ⟹ u1 ≲ t1 ⊔ u1"
      assume ind2: "⋀u2. Coinitial t2 u2 ⟹ u2 ≲ t2 ⊔ u2"
      assume tu: "Coinitial (❙λ❙[t1❙] ❙⦁ t2) u"
      show "u ≲ (❙λ❙[t1❙] ❙⦁ t2) ⊔ u"
        using tu ind1 ind2 Coinitial_iff_Con
        apply (cases u, simp_all)
         apply (cases "un_App1 u", simp_all)
        by (metis Ide.simps(1) Ide_Subst)+
    qed

    lemma Ide_resid_Join:
    shows "Coinitial t u ⟹ Ide (u \\ (t ⊔ u))"
      using ide_char prfx_Join by blast

    lemma join_of_Join:
    assumes "Coinitial t u"
    shows "join_of t u (t ⊔ u)"
    proof (unfold join_of_def composite_of_def, intro conjI)
      show "t ≲ t ⊔ u"
        using assms Join_sym prfx_Join [of u t] by simp
      show "u ≲ t ⊔ u"
        using assms Ide_resid_Join ide_char by simp
      show "(t ⊔ u) \\ t ≲ u \\ t"
        by (metis ‹prfx u (Join t u)› arr_char assms cong_subst_right(2) prfx_implies_con
            prfx_reflexive resid_Join con_sym cube)
      show "u \\ t ≲ (t ⊔ u) \\ t"
        by (metis Coinitial_resid_resid ‹prfx t (Join t u)› ‹prfx u (Join t u)› conE ide_char
            null_char prfx_implies_con resid_Ide_Arr cube)
      show "(t ⊔ u) \\ u ≲ t \\ u"
        using ‹(t ⊔ u) \ t ≲ u \ t› cube by auto
      show "t \\ u ≲ (t ⊔ u) \\ u"
        by (metis ‹(t ⊔ u) \ t ≲ u \ t› assms cube resid_Join)
    qed

    sublocale rts_with_joins resid
      using join_of_Join
      apply unfold_locales
      by (metis Coinitial_iff_Con conE joinable_def null_char)

    lemma is_rts_with_joins:
    shows "rts_with_joins resid"
      ..

    subsection "Simulations from Syntactic Constructors"

    text ‹
      Here we show that the syntactic constructors ‹Lam› and ‹App›, as well as the substitution
      operation ‹subst›, determine simulations.  In addition, we show that ‹Beta› determines
      a transformation from ‹App ∘ (Lam × Id)› to ‹subst›.
    ›  

    abbreviation Lam⇩e⇩x⇩t
    where "Lam⇩e⇩x⇩t t ≡ if arr t then ❙λ❙[t❙] else ❙♯"

    lemma Lam_is_simulation:
    shows "simulation resid resid Lam⇩e⇩x⇩t"
      using Arr_resid Coinitial_iff_Con
      by unfold_locales auto

    interpretation Lam: simulation resid resid Lam⇩e⇩x⇩t
      using Lam_is_simulation by simp

    interpretation ΛxΛ: product_of_weakly_extensional_rts resid resid
      ..

    abbreviation App⇩e⇩x⇩t
    where "App⇩e⇩x⇩t t ≡ if ΛxΛ.arr t then fst t ❙∘ snd t else ❙♯"

    lemma App_is_binary_simulation:
    shows "binary_simulation resid resid resid App⇩e⇩x⇩t"
    proof
      show "⋀t. ¬ ΛxΛ.arr t ⟹ App⇩e⇩x⇩t t = null"
        by auto
      show "⋀t u. ΛxΛ.con t u ⟹ con (App⇩e⇩x⇩t t) (App⇩e⇩x⇩t u)"
        using ΛxΛ.con_char Coinitial_iff_Con by auto
      show "⋀t u. ΛxΛ.con t u ⟹ App⇩e⇩x⇩t (ΛxΛ.resid t u) = App⇩e⇩x⇩t t \\ App⇩e⇩x⇩t u"
        using ΛxΛ.arr_char ΛxΛ.resid_def
        apply simp
        by (metis Arr_resid Con_implies_Arr1 Con_implies_Arr2)
    qed

    interpretation App: binary_simulation resid resid resid App⇩e⇩x⇩t
      using App_is_binary_simulation by simp

    abbreviation subst⇩e⇩x⇩t
    where "subst⇩e⇩x⇩t ≡ λt. if ΛxΛ.arr t then subst (snd t) (fst t) else ❙♯"

    lemma subst_is_binary_simulation:
    shows "binary_simulation resid resid resid subst⇩e⇩x⇩t"
    proof
      show "⋀t. ¬ ΛxΛ.arr t ⟹ subst⇩e⇩x⇩t t = null"
        by auto
      show "⋀t u. ΛxΛ.con t u ⟹ con (subst⇩e⇩x⇩t t) (subst⇩e⇩x⇩t u)"
        using ΛxΛ.con_char con_char Subst_not_Nil resid_Subst ΛxΛ.coinitialE
              ΛxΛ.con_imp_coinitial
        apply simp
        by metis
      show "⋀t u. ΛxΛ.con t u ⟹ subst⇩e⇩x⇩t (ΛxΛ.resid t u) = subst⇩e⇩x⇩t t \\ subst⇩e⇩x⇩t u"
        using ΛxΛ.arr_char ΛxΛ.resid_def
        apply simp
        by (metis Arr_resid Con_implies_Arr1 Con_implies_Arr2 resid_Subst)
    qed

    interpretation subst: binary_simulation resid resid resid subst⇩e⇩x⇩t
      using subst_is_binary_simulation by simp

    interpretation Id: identity_simulation resid
      ..
    interpretation Lam_Id: product_simulation resid resid resid resid Lam⇩e⇩x⇩t Id.map
      ..
    interpretation App_o_Lam_Id: composite_simulation ΛxΛ.resid ΛxΛ.resid resid Lam_Id.map App⇩e⇩x⇩t
      ..

    abbreviation Beta⇩e⇩x⇩t
    where "Beta⇩e⇩x⇩t t ≡ if ΛxΛ.arr t then ❙λ❙[fst t❙] ❙⦁ snd t else ❙♯"

    lemma Beta_is_transformation:
    shows "transformation ΛxΛ.resid resid App_o_Lam_Id.map subst⇩e⇩x⇩t Beta⇩e⇩x⇩t"
    proof
      show "⋀f. ¬ ΛxΛ.arr f ⟹ Beta⇩e⇩x⇩t f = null"
        by simp
      show "⋀f. ΛxΛ.ide f ⟹ src (Beta⇩e⇩x⇩t f) = App_o_Lam_Id.map f"
        using ΛxΛ.src_char ΛxΛ.src_ide Lam_Id.map_def by force
      show "⋀f. ΛxΛ.ide f ⟹ trg (Beta⇩e⇩x⇩t f) = subst⇩e⇩x⇩t f"
        using ΛxΛ.trg_char ΛxΛ.trg_ide by force
      show "⋀f. ΛxΛ.arr f ⟹
                  Beta⇩e⇩x⇩t (ΛxΛ.src f) \\ App_o_Lam_Id.map f = Beta⇩e⇩x⇩t (ΛxΛ.trg f)"
          using ΛxΛ.src_char ΛxΛ.trg_char Arr_Trg Arr_not_Nil Lam_Id.map_def by simp
      show "⋀f. ΛxΛ.arr f ⟹ App_o_Lam_Id.map f \\ Beta⇩e⇩x⇩t (ΛxΛ.src f) = subst⇩e⇩x⇩t f"
          using ΛxΛ.src_char ΛxΛ.trg_char Lam_Id.map_def by auto
      show "⋀f. ΛxΛ.arr f ⟹ join_of (Beta⇩e⇩x⇩t (ΛxΛ.src f)) (App_o_Lam_Id.map f) (Beta⇩e⇩x⇩t f)"
      proof -
        fix f
        assume f: "ΛxΛ.arr f"
        show "join_of (Beta⇩e⇩x⇩t (ΛxΛ.src f)) (App_o_Lam_Id.map f) (Beta⇩e⇩x⇩t f)"
        proof (intro join_ofI composite_ofI)
          show "App_o_Lam_Id.map f ≲ Beta⇩e⇩x⇩t f"
            using f Lam_Id.map_def Ide_Subst arr_char prfx_char prfx_reflexive by auto
          show "Beta⇩e⇩x⇩t f \\ Beta⇩e⇩x⇩t (ΛxΛ.src f) ∼ App_o_Lam_Id.map f \\ Beta⇩e⇩x⇩t (ΛxΛ.src f)"
            using f Lam_Id.map_def ΛxΛ.src_char trg_char trg_def
            apply auto
            by (metis Arr_Subst Ide_Trg)
          show 1: "Beta⇩e⇩x⇩t f \\ App_o_Lam_Id.map f ∼ Beta⇩e⇩x⇩t (ΛxΛ.src f) \\ App_o_Lam_Id.map f"
            using f Lam_Id.map_def Ide_Subst ΛxΛ.src_char Ide_Trg Arr_resid Coinitial_iff_Con
                  resid_Arr_self
            apply simp
            by metis
          show "Beta⇩e⇩x⇩t (ΛxΛ.src f) ≲ Beta⇩e⇩x⇩t f"
            using f 1 Lam_Id.map_def Ide_Subst ΛxΛ.src_char resid_Arr_self by auto
        qed
      qed
    qed

    text ‹
      The next two results are used to show that mapping App over lists of transitions
      preserves paths.
    ›

    lemma App_is_simulation1:
    assumes "ide a"
    shows "simulation resid resid (λt. if arr t then t ❙∘ a else ❙♯)"
    proof -
      have "(λt. if ΛxΛ.arr (t, a) then fst (t, a) ❙∘ snd (t, a) else ❙♯) =
            (λt. if arr t then t ❙∘ a else ❙♯)"
        using assms ide_implies_arr by force
      thus ?thesis
        using assms App.fixing_ide_gives_simulation_0 [of a] by auto
    qed

    lemma App_is_simulation2:
    assumes "ide a"
    shows "simulation resid resid (λt. if arr t then a ❙∘ t else ❙♯)"
    proof -
      have "(λt. if ΛxΛ.arr (a, t) then fst (a, t) ❙∘ snd (a, t) else ❙♯) =
            (λt. if arr t then a ❙∘ t else ❙♯)"
        using assms ide_implies_arr by force
      thus ?thesis
        using assms App.fixing_ide_gives_simulation_1 [of a] by auto
    qed

    subsection "Reduction and Conversion"

    text ‹
      Here we define the usual relations of reduction and conversion.
      Reduction is the least transitive relation that relates ‹a› to ‹b› if there exists
      an arrow ‹t› having ‹a› as its source and ‹b› as its target.
      Conversion is the least transitive relation that relates ‹a› to b if there exists
      an arrow ‹t› in either direction between ‹a› and ‹b›.
    ›

    inductive red
    where "Arr t ⟹ red (Src t) (Trg t)"
        | "⟦red a b; red b c⟧ ⟹ red a c"

    inductive cnv
    where "Arr t ⟹ cnv (Src t) (Trg t)"
        | "Arr t ⟹ cnv (Trg t) (Src t)"
        | "⟦cnv a b; cnv b c⟧ ⟹ cnv a c"

    lemma cnv_refl:
    assumes "Ide a"
    shows "cnv a a"
      using assms
      by (metis Ide_iff_Src_self Ide_implies_Arr cnv.simps)

    lemma cnv_sym:
    shows "cnv a b ⟹ cnv b a"
      apply (induct rule: cnv.induct)
      using cnv.intros(1-2)
        apply auto[2]
      using cnv.intros(3) by blast

    lemma red_imp_cnv:
    shows "red a b ⟹ cnv a b"
      using cnv.intros(1,3) red.inducts by blast

  end

  text ‹
    We now define a locale that extends the residuation operation defined above
    to paths, using general results that have already been shown for paths in an RTS.
    In particular, we are taking advantage of the general proof of the Cube Lemma for
    residuation on paths.

    Our immediate goal is to prove the Church-Rosser theorem, so we first prove a lemma
    that connects the reduction relation to paths.  Later, we will prove many more
    facts in this locale, thereby developing a general framework for reasoning about
    reduction paths in the ‹λ›-calculus.
  ›

  locale reduction_paths =
    Λ: lambda_calculus
  begin

    sublocale Λ: rts Λ.resid
      by (simp add: Λ.is_rts_with_joins rts_with_joins.axioms(1))
    sublocale paths_in_weakly_extensional_rts Λ.resid
      ..
    sublocale paths_in_confluent_rts Λ.resid
      using confluent_rts.axioms(1) Λ.is_confluent_rts paths_in_rts_def
            paths_in_confluent_rts.intro
      by blast

    notation Λ.resid  (infix "\\" 70)
    notation Λ.con    (infix "⌢" 50)
    notation Λ.prfx   (infix "≲" 50)
    notation Λ.cong   (infix "∼" 50)

    notation Resid    (infix "⇧*\\⇧*" 70)
    notation Resid1x  (infix "⇧1\\⇧*" 70)
    notation Residx1  (infix "⇧*\\⇧1" 70)
    notation con      (infix "⇧*⌢⇧*" 50)
    notation prfx     (infix "⇧*≲⇧*" 50)
    notation cong     (infix "⇧*∼⇧*" 50)

    lemma red_iff:
    shows "Λ.red a b ⟷ (∃T. Arr T ∧ Src T = a ∧ Trg T = b)"
    proof
      show "Λ.red a b ⟹ ∃T. Arr T ∧ Src T = a ∧ Trg T = b"
      proof (induct rule: Λ.red.induct)
        show "⋀t. Λ.Arr t ⟹ ∃T. Arr T ∧ Src T = Λ.Src t ∧ Trg T = Λ.Trg t"
          by (metis Arr.simps(2) Srcs.simps(2) Srcs_simp⇩P⇩W⇩E Trg.simps(2) Λ.trg_def
              Λ.arr_char Λ.resid_Arr_self Λ.sources_char⇩Λ singleton_insert_inj_eq')
        show "⋀a b c. ⟦∃T. Arr T ∧ Src T = a ∧ Trg T = b;
                       ∃T. Arr T ∧ Src T = b ∧ Trg T = c⟧
                           ⟹ ∃T. Arr T ∧ Src T = a ∧ Trg T = c"
          by (metis Arr.simps(1) Arr_appendI⇩P⇩W⇩E Srcs_append Srcs_simp⇩P⇩W⇩E Trgs_append
              Trgs_simp⇩P⇩W⇩E singleton_insert_inj_eq')
      qed
      show "∃T. Arr T ∧ Src T = a ∧ Trg T = b ⟹ Λ.red a b"
      proof -
        have "Arr T ⟹ Λ.red (Src T) (Trg T)" for T
        proof (induct T)
          show "Arr [] ⟹ Λ.red (Src []) (Trg [])"
            by auto
          fix t T
          assume ind: "Arr T ⟹ Λ.red (Src T) (Trg T)"
          assume Arr: "Arr (t # T)"
          show "Λ.red (Src (t # T)) (Trg (t # T))"
          proof (cases "T = []")
            show "T = [] ⟹ ?thesis"
              using Arr arr_char Λ.red.intros(1) by simp
            assume T: "T ≠ []"
            have "Λ.red (Src (t # T)) (Λ.Trg t)"
              apply simp
              by (meson Arr Arr.simps(2) Con_Arr_self Con_implies_Arr(1) Con_initial_left
                  Λ.arr_char Λ.red.intros(1))
            moreover have "Λ.Trg t = Src T"
              using Arr
              by (metis Arr.elims(2) Srcs_simp⇩P⇩W⇩E T Λ.arr_iff_has_target insert_subset
                  Λ.targets_char⇩Λ list.sel(1) list.sel(3) singleton_iff)
            ultimately show ?thesis
              using ind
              by (metis (no_types, opaque_lifting) Arr Con_Arr_self Con_implies_Arr(2)
                  Resid_cons(2) T Trg.simps(3) Λ.red.intros(2) neq_Nil_conv)
          qed
        qed
        thus "∃T. Arr T ∧ Src T = a ∧ Trg T = b ⟹ Λ.red a b"
          by blast
      qed
    qed

  end

  subsection "The Church-Rosser Theorem"

  context lambda_calculus
  begin

    interpretation Λx: reduction_paths .

    theorem church_rosser:
    shows "cnv a b ⟹ ∃c. red a c ∧ red b c"
    proof (induct rule: cnv.induct)
      show "⋀t. Arr t ⟹ ∃c. red (Src t) c ∧ red (Trg t) c"
        by (metis Ide_Trg Ide_iff_Src_self Ide_iff_Trg_self Ide_implies_Arr red.intros(1))
      thus "⋀t. Arr t ⟹ ∃c. red (Trg t) c ∧ red (Src t) c"
        by auto
      show "⋀a b c. ⟦cnv a b; cnv b c; ∃x. red a x ∧ red b x; ∃y. red b y ∧ red c y⟧
                         ⟹ ∃z. red a z ∧ red c z"
      proof -
        fix a b c
        assume ind1: "∃x. red a x ∧ red b x" and ind2: "∃y. red b y ∧ red c y"
        obtain x where x: "red a x ∧ red b x"
          using ind1 by blast
        obtain y where y: "red b y ∧ red c y"
          using ind2 by blast
        obtain T1 U1 where 1: "Λx.Arr T1 ∧ Λx.Arr U1 ∧ Λx.Src T1 = a ∧ Λx.Src U1 = b ∧
                               Λx.Trgs T1 = Λx.Trgs U1"
          using x Λx.red_iff [of a x] Λx.red_iff [of b x] by fastforce
        obtain T2 U2 where 2: "Λx.Arr T2 ∧ Λx.Arr U2 ∧ Λx.Src T2 = b ∧ Λx.Src U2 = c ∧
                               Λx.Trgs T2 = Λx.Trgs U2"
          using y Λx.red_iff [of b y] Λx.red_iff [of c y] by fastforce
        show "∃e. red a e ∧ red c e"
        proof -
          let ?T = "T1 @ (Λx.Resid T2 U1)" and ?U = "U2 @ (Λx.Resid U1 T2)"
          have 3: "Λx.Arr ?T ∧ Λx.Arr ?U ∧ Λx.Src ?T = a ∧ Λx.Src ?U = c"
            using 1 2
            by (metis Λx.Arr_appendI⇩P⇩W⇩E Λx.Arr_has_Trg Λx.Con_imp_Arr_Resid Λx.Src_append
                Λx.Src_resid Λx.Srcs_simp⇩P⇩W⇩E Λx.Trgs.simps(1) Λx.Trgs_simp⇩P⇩W⇩E Λx.arrI⇩P
                Λx.arr_append_imp_seq Λx.confluence_ind singleton_insert_inj_eq')
          moreover have "Λx.Trgs ?T = Λx.Trgs ?U"
            using 1 2 3 Λx.Srcs_simp⇩P⇩W⇩E Λx.Trgs_Resid_sym Λx.Trgs_append Λx.confluence_ind
            by presburger
          ultimately have "∃T U. Λx.Arr T ∧ Λx.Arr U ∧ Λx.Src T = a ∧ Λx.Src U = c ∧
                                 Λx.Trgs T = Λx.Trgs U"
            by blast
          thus ?thesis
            using Λx.red_iff Λx.Arr_has_Trg by fastforce
        qed
      qed
    qed

    corollary weak_diamond:
    assumes "red a b" and "red a b'"
    obtains c where "red b c" and "red b' c"
    proof -
      have "cnv b b'"
        using assms
        by (metis cnv.intros(1,3) cnv_sym red.induct)
      thus ?thesis
        using that church_rosser by blast
    qed

    text ‹
      As a consequence of the Church-Rosser Theorem, the collection of all reduction
      paths forms a coherent normal sub-RTS of the RTS of reduction paths, and on identities
      the congruence induced by this normal sub-RTS coincides with convertibility.
      The quotient of the ‹λ›-calculus RTS by this congruence is then obviously discrete:
      the only transitions are identities.
    ›

    interpretation Red: normal_sub_rts Λx.Resid ‹Collect Λx.Arr›
    proof
      show "⋀t. t ∈ Collect Λx.Arr ⟹ Λx.arr t"
        by blast
      show "⋀a. Λx.ide a ⟹ a ∈ Collect Λx.Arr"
        using Λx.Ide_char Λx.ide_char by blast
      show "⋀u t. ⟦u ∈ Collect Λx.Arr; Λx.coinitial t u⟧ ⟹ Λx.Resid u t ∈ Collect Λx.Arr"
        by (metis Λx.Con_imp_Arr_Resid Λx.Resid.simps(1) Λx.con_sym Λx.confluence⇩P Λx.ide_def
            ‹⋀a. Λx.ide a ⟹ a ∈ Collect Λx.Arr› mem_Collect_eq Λx.arr_resid_iff_con)
      show "⋀u t. ⟦u ∈ Collect Λx.Arr; Λx.Resid t u ∈ Collect Λx.Arr⟧ ⟹ t ∈ Collect Λx.Arr"
        by (metis Λx.Arr.simps(1) Λx.Con_implies_Arr(1) mem_Collect_eq)
      show "⋀u t. ⟦u ∈ Collect Λx.Arr; Λx.seq u t⟧ ⟹ ∃v. Λx.composite_of u t v"
        by (meson Λx.obtains_composite_of)
      show "⋀u t. ⟦u ∈ Collect Λx.Arr; Λx.seq t u⟧ ⟹ ∃v. Λx.composite_of t u v"
        by (meson Λx.obtains_composite_of)
    qed

    interpretation Red: coherent_normal_sub_rts Λx.Resid ‹Collect Λx.Arr›
      apply unfold_locales
      by (metis Red.Cong_closure_props(4) Red.Cong_imp_arr(2) Λx.Con_imp_Arr_Resid
          Λx.arr_resid_iff_con Λx.con_char Λx.sources_resid mem_Collect_eq)

    lemma cnv_iff_Cong:
    assumes "ide a" and "ide b"
    shows "cnv a b ⟷ Red.Cong [a] [b]"
    proof
      assume 1: "Red.Cong [a] [b]"
      obtain U V
        where UV: "Λx.Arr U ∧ Λx.Arr V ∧ Red.Cong⇩0 (Λx.Resid [a] U) (Λx.Resid [b] V)"
        using 1 Red.Cong_def [of "[a]" "[b]"] by blast
      have "red a (Λx.Trg U) ∧ red b (Λx.Trg V)"
        by (metis UV Λx.Arr.simps(1) Λx.Con_implies_Arr(1) Λx.Resid_single_ide(2) Λx.Src_resid
            Λx.Trg.simps(2) assms(1-2) mem_Collect_eq reduction_paths.red_iff trg_ide)
      moreover have "Λx.Trg U = Λx.Trg V"
        using UV
        by (metis (no_types, lifting) Red.Cong⇩0_imp_con Λx.Arr.simps(1) Λx.Con_Arr_self
            Λx.Con_implies_Arr(1) Λx.Resid_single_ide(2) Λx.Src_resid Λx.cube Λx.ide_def
            Λx.resid_arr_ide assms(1) mem_Collect_eq)
      ultimately show "cnv a b"
        by (metis cnv_sym cnv.intros(3) red_imp_cnv)
      next
      assume 1: "cnv a b"
      obtain c where c: "red a c ∧ red b c"
        using 1 church_rosser by blast
      obtain U where U: "Λx.Arr U ∧ Λx.Src U = a ∧ Λx.Trg U = c"
        using c Λx.red_iff by blast
      obtain V where V: "Λx.Arr V ∧ Λx.Src V = b ∧ Λx.Trg V = c"
        using c Λx.red_iff by blast
      have "Λx.Resid1x a U = c ∧ Λx.Resid1x b V = c"
        by (metis U V Λx.Con_single_ide_ind Λx.Ide.simps(2) Λx.Resid1x_as_Resid
            Λx.Resid_Ide_Arr_ind Λx.Resid_single_ide(2) Λx.Srcs_simp⇩P⇩W⇩E Λx.Trg.simps(2)
            Λx.Trg_resid_sym Λx.ex_un_Src assms(1-2) singletonD trg_ide)
      hence "Red.Cong⇩0 (Λx.Resid [a] U) (Λx.Resid [b] V)"
        by (metis Red.Cong⇩0_reflexive U V Λx.Con_single_ideI(1) Λx.Resid1x_as_Resid
            Λx.Srcs_simp⇩P⇩W⇩E Λx.arr_resid Λx.con_char assms(1-2) empty_set
            list.set_intros(1) list.simps(15))
      thus "Red.Cong [a] [b]"
        using U V Red.Cong_def [of "[a]" "[b]"] by blast
    qed

    interpretation Λq: quotient_by_coherent_normal Λx.Resid ‹Collect Λx.Arr›
      ..

    lemma quotient_by_cnv_is_discrete:
    shows "Λq.arr t ⟷ Λq.ide t"
      by (metis Red.Cong_class_memb_is_arr Λq.arr_char Λq.ide_char' Λx.arr_char
          mem_Collect_eq subsetI)

    subsection "Normalization"

    text ‹
      A \emph{normal form} is an identity that is not the source of any non-identity arrow.
    ›

    definition NF
    where "NF a ≡ Ide a ∧ (∀t. Arr t ∧ Src t = a ⟶ Ide t)"

    lemma (in reduction_paths) path_from_NF_is_Ide:
    assumes "Λ.NF a"
    shows "⟦Arr U; Src U = a⟧ ⟹ Ide U"
    proof (induct U, simp)
      fix u U
      assume ind: "⟦Arr U; Src U = a⟧ ⟹ Ide U"
      assume uU: "Arr (u # U)" and a: "Src (u # U) = a"
      have "Λ.Ide u"
        using assms a Λ.NF_def uU by force
      thus "Ide (u # U)"
        using a uU ind
        by (metis Arr_consE Con_Arr_self Con_imp_eq_Srcs Con_initial_right Ide.simps(2)
                  Ide_consI Srcs.simps(2) Srcs_simp⇩P⇩W⇩E Λ.Ide_iff_Src_self Λ.Ide_implies_Arr
                  Λ.sources_char⇩Λ Λ.trg_ide Λ.ide_char
                  singleton_insert_inj_eq)
    qed

    lemma NF_reduct_is_trivial:
    assumes "NF a" and "red a b"
    shows "a = b"
    proof -
      interpret Λx: reduction_paths .
      have "⋀U. ⟦Λx.Arr U; a ∈ Λx.Srcs U⟧ ⟹ Λx.Ide U"
        using assms Λx.path_from_NF_is_Ide
        by (simp add: Λx.Srcs_simp⇩P⇩W⇩E)
      thus ?thesis
        using assms Λx.red_iff
        by (metis Λx.Con_Arr_self Λx.Resid_Arr_Ide_ind Λx.Src_resid Λx.path_from_NF_is_Ide)
    qed

    lemma NF_unique:
    assumes "red t u" and "red t u'" and "NF u" and "NF u'"
    shows "u = u'"
      using assms weak_diamond NF_reduct_is_trivial by metis

    text ‹
      A term is \emph{normalizable} if it is an identity that is reducible to a normal form.
    ›

    definition normalizable
    where "normalizable a ≡ Ide a ∧ (∃b. red a b ∧ NF b)"

  end

  section "Reduction Paths"

  text ‹
    In this section we develop further facts about reduction paths for the ‹λ›-calculus.
  ›

  context reduction_paths
  begin

    subsection "Sources and Targets"

    lemma Srcs_simp⇩Λ⇩P:
    shows "Arr t ⟹ Srcs t = {Λ.Src (hd t)}"
      by (metis Arr_has_Src Srcs.elims list.sel(1) Λ.sources_char⇩Λ)

    lemma Trgs_simp⇩Λ⇩P:
    shows "Arr t ⟹ Trgs t = {Λ.Trg (last t)}"
      by (metis Arr.simps(1) Arr_has_Trg Trgs.simps(2) Trgs_append
          append_butlast_last_id not_Cons_self2 Λ.targets_char⇩Λ)

    lemma sources_single_Src [simp]:
    assumes "Λ.Arr t"
    shows "sources [Λ.Src t] = sources [t]"
      using assms
      by (metis Λ.Con_Arr_Src(1) Λ.Ide_Src Ide.simps(2) Resid.simps(3) con_char ideE
          ide_char sources_resid Λ.con_char Λ.ide_char list.discI Λ.resid_Arr_Src)

    lemma targets_single_Trg [simp]:
    assumes "Λ.Arr t"
    shows "targets [Λ.Trg t] = targets [t]"
      using assms
      by (metis (full_types) Resid.simps(3) conI⇩P Λ.Arr_Trg Λ.arr_char Λ.resid_Arr_Src
          Λ.resid_Src_Arr Λ.arr_resid_iff_con targets_resid_sym)

    lemma sources_single_Trg [simp]:
    assumes "Λ.Arr t"
    shows "sources [Λ.Trg t] = targets [t]"
      using assms
      by (metis Λ.Ide_Trg Ide.simps(2) ideE ide_char sources_resid Λ.ide_char
          targets_single_Trg)

    lemma targets_single_Src [simp]:
    assumes "Λ.Arr t"
    shows "targets [Λ.Src t] = sources [t]"
      using assms
      by (metis Λ.Arr_Src Λ.Trg_Src sources_single_Src sources_single_Trg)

    lemma single_Src_hd_in_sources:
    assumes "Arr T"
    shows "[Λ.Src (hd T)] ∈ sources T"
      using assms
      by (metis Arr.simps(1) Arr_has_Src Ide.simps(2) Resid_Arr_Src Srcs_simp⇩P
          Λ.source_is_ide conI⇩P empty_set ide_char in_sourcesI Λ.sources_char⇩Λ
          list.set_intros(1) list.simps(15))

    lemma single_Trg_last_in_targets:
    assumes "Arr T"
    shows "[Λ.Trg (last T)] ∈ targets T"
      using assms targets_char⇩P Arr_imp_arr_last Trgs_simp⇩Λ⇩P Λ.Ide_Trg by fastforce

    lemma in_sources_iff:
    assumes "Arr T"
    shows "A ∈ sources T ⟷ A ⇧*∼⇧* [Λ.Src (hd T)]"
      using assms
      by (meson single_Src_hd_in_sources sources_are_cong sources_cong_closed)

    lemma in_targets_iff:
    assumes "Arr T"
    shows "B ∈ targets T ⟷ B ⇧*∼⇧* [Λ.Trg (last T)]"
      using assms
      by (meson single_Trg_last_in_targets targets_are_cong targets_cong_closed)

    lemma seq_imp_cong_Trg_last_Src_hd:
    assumes "seq T U"
    shows "Λ.Trg (last T) ∼ Λ.Src (hd U)"
      using assms Arr_imp_arr_hd Arr_imp_arr_last Srcs_simp⇩P⇩W⇩E Trgs_simp⇩P⇩W⇩E
            Λ.cong_reflexive seq_char
      by (metis Srcs_simp⇩Λ⇩P Trgs_simp⇩Λ⇩P Λ.Arr_Trg Λ.arr_char singleton_inject)

    lemma sources_char⇩Λ⇩P:
    shows "sources T = {A. Arr T ∧ A ⇧*∼⇧* [Λ.Src (hd T)]}"
      using in_sources_iff arr_char sources_char⇩P by auto

    lemma targets_char⇩Λ⇩P:
    shows "targets T = {B. Arr T ∧ B ⇧*∼⇧* [Λ.Trg (last T)]}"
      using in_targets_iff arr_char targets_char by auto

    lemma Src_hd_eqI:
    assumes "T ⇧*∼⇧* U"
    shows "Λ.Src (hd T) = Λ.Src (hd U)"
      using assms
      by (metis Con_imp_eq_Srcs Con_implies_Arr(1) Ide.simps(1) Srcs_simp⇩Λ⇩P ide_char
          singleton_insert_inj_eq')

    lemma Trg_last_eqI:
    assumes "T ⇧*∼⇧* U"
    shows "Λ.Trg (last T) = Λ.Trg (last U)"
    proof -
      have 1: "[Λ.Trg (last T)] ∈ targets T ∧ [Λ.Trg (last U)] ∈ targets U"
        using assms
        by (metis Con_implies_Arr(1) Ide.simps(1) ide_char single_Trg_last_in_targets)
      have "Λ.cong (Λ.Trg (last T)) (Λ.Trg (last U))"
        by (metis "1" Ide.simps(2) Resid.simps(3) assms con_char cong_implies_coterminal
            coterminal_iff ide_char prfx_implies_con targets_are_cong)
      moreover have "Λ.Ide (Λ.Trg (last T)) ∧ Λ.Ide (Λ.Trg (last U))"
        using "1" Ide.simps(2) ide_char by blast
      ultimately show ?thesis
        using Λ.weak_extensionality by blast
    qed

    lemma Trg_last_Src_hd_eqI:
    assumes "seq T U"
    shows "Λ.Trg (last T) = Λ.Src (hd U)"
      using assms Arr_imp_arr_hd Arr_imp_arr_last Λ.Ide_Src Λ.weak_extensionality Λ.Ide_Trg
            seq_char seq_imp_cong_Trg_last_Src_hd
      by force

    lemma seqI⇩Λ⇩P [intro]:
    assumes "Arr T" and "Arr U" and "Λ.Trg (last T) = Λ.Src (hd U)"
    shows "seq T U"
      by (metis assms Arr_imp_arr_last Srcs_simp⇩Λ⇩P Λ.arr_char Λ.targets_char⇩Λ
          Trgs_simp⇩P seq_char)

    lemma conI⇩Λ⇩P [intro]:
    assumes "arr T" and "arr U" and "Λ.Src (hd T) = Λ.Src (hd U)"
    shows "T ⇧*⌢⇧* U"
      using assms
      by (simp add: Srcs_simp⇩Λ⇩P arr_char con_char confluence_ind)

    subsection "Mapping Constructors over Paths"

    lemma Arr_map_Lam:
    assumes "Arr T"
    shows "Arr (map Λ.Lam T)"
    proof -
      interpret Lam: simulation Λ.resid Λ.resid ‹λt. if Λ.arr t then ❙λ❙[t❙] else ❙♯›
        using Λ.Lam_is_simulation by simp
      interpret simulation Resid Resid
                  ‹λT. if Arr T then map (λt. if Λ.arr t then ❙λ❙[t❙] else ❙♯) T else []›
        using assms Lam.lifts_to_paths by blast
      have "map (λt. if Λ.Arr t then ❙λ❙[t❙] else ❙♯) T = map Λ.Lam T"
        using assms set_Arr_subset_arr by fastforce
      thus ?thesis
        using assms preserves_reflects_arr [of T] arr_char
        by (simp add: ‹map (λt. if Λ.Arr t then ❙λ❙[t❙] else ❙♯) T = map Λ.Lam T›)
    qed

    lemma Arr_map_App1:
    assumes "Λ.Ide b" and "Arr T"
    shows "Arr (map (λt. t ❙∘ b) T)"
    proof -
      interpret App1: simulation Λ.resid Λ.resid ‹λt. if Λ.arr t then t ❙∘ b else ❙♯›
        using assms Λ.App_is_simulation1 [of b] by simp
      interpret simulation Resid Resid
                  ‹λT. if Arr T then map (λt. if Λ.arr t then t ❙∘ b else ❙♯) T else []›
        using assms App1.lifts_to_paths by blast
      have "map (λt. if Λ.arr t then t ❙∘ b else ❙♯) T = map (λt. t ❙∘ b) T"
        using assms set_Arr_subset_arr by auto
      thus ?thesis
        using assms preserves_reflects_arr arr_char
        by (metis (mono_tags, lifting))
    qed

    lemma Arr_map_App2:
    assumes "Λ.Ide a" and "Arr T"
    shows "Arr (map (Λ.App a) T)"
    proof -
      interpret App2: simulation Λ.resid Λ.resid ‹λu. if Λ.arr u then a ❙∘ u else ❙♯›
        using assms Λ.App_is_simulation2 by simp
      interpret simulation Resid Resid
                  ‹λT. if Arr T then map (λu. if Λ.arr u then a ❙∘ u else ❙♯) T else []›
        using assms App2.lifts_to_paths by blast
      have "map (λu. if Λ.arr u then a ❙∘ u else ❙♯) T = map (λu. a ❙∘ u) T"
        using assms set_Arr_subset_arr by auto
      thus ?thesis
        using assms preserves_reflects_arr arr_char
        by (metis (mono_tags, lifting))
    qed

    interpretation Λ⇩L⇩a⇩m: sub_rts Λ.resid ‹λt. Λ.Arr t ∧ Λ.is_Lam t›
    proof
     show "⋀t. Λ.Arr t ∧ Λ.is_Lam t ⟹ Λ.arr t"
       by blast
     show "⋀t. Λ.Arr t ∧ Λ.is_Lam t ⟹ Λ.sources t ⊆ {t. Λ.Arr t ∧ Λ.is_Lam t}"
       by auto
     show "⟦Λ.Arr t ∧ Λ.is_Lam t; Λ.Arr u ∧ Λ.is_Lam u; Λ.con t u⟧
                    ⟹ Λ.Arr (t \\ u) ∧ Λ.is_Lam (t \\ u)"
             for t u
       apply (cases t; cases u)
                           apply simp_all
       using Λ.Coinitial_resid_resid
       by presburger
    qed

    interpretation un_Lam: simulation Λ⇩L⇩a⇩m.resid Λ.resid
                             ‹λt. if Λ⇩L⇩a⇩m.arr t then Λ.un_Lam t else ❙♯›
    proof
      let ?un_Lam = "λt. if Λ⇩L⇩a⇩m.arr t then Λ.un_Lam t else ❙♯"
      show "⋀t. ¬ Λ⇩L⇩a⇩m.arr t ⟹ ?un_Lam t = Λ.null"
        by auto
      show "⋀t u. Λ⇩L⇩a⇩m.con t u ⟹ Λ.con (?un_Lam t) (?un_Lam u)"
        by auto
      show "⋀t u. Λ⇩L⇩a⇩m.con t u ⟹ ?un_Lam (Λ⇩L⇩a⇩m.resid t u) = ?un_Lam t \\ ?un_Lam u"
        using Λ⇩L⇩a⇩m.resid_closed Λ⇩L⇩a⇩m.resid_def by auto
    qed

    lemma Arr_map_un_Lam:
    assumes "Arr T" and "set T ⊆ Collect Λ.is_Lam"
    shows "Arr (map Λ.un_Lam T)"
    proof -
      have "map (λt. if Λ⇩L⇩a⇩m.arr t then Λ.un_Lam t else ❙♯) T = map Λ.un_Lam T"
        using assms set_Arr_subset_arr by auto
      thus ?thesis
        using assms
        by (metis (no_types, lifting) Λ⇩L⇩a⇩m.path_reflection Λ.arr_char mem_Collect_eq
            set_Arr_subset_arr subset_code(1) un_Lam.preserves_paths)
    qed

    interpretation Λ⇩A⇩p⇩p: sub_rts Λ.resid ‹λt. Λ.Arr t ∧ Λ.is_App t›
    proof
      show "⋀t. Λ.Arr t ∧ Λ.is_App t ⟹ Λ.arr t"
        by blast
      show "⋀t. Λ.Arr t ∧ Λ.is_App t ⟹ Λ.sources t ⊆ {t. Λ.Arr t ∧ Λ.is_App t}"
        by auto
      show "⟦Λ.Arr t ∧ Λ.is_App t; Λ.Arr u ∧ Λ.is_App u; Λ.con t u⟧
                 ⟹ Λ.Arr (t \\ u) ∧ Λ.is_App (t \\ u)"
            for t u
        using Λ.Arr_resid
        by (cases t; cases u) auto
    qed

    interpretation un_App1: simulation Λ⇩A⇩p⇩p.resid Λ.resid 
                             ‹λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App1 t else ❙♯›
    proof
      let ?un_App1 = "λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App1 t else ❙♯"
      show "⋀t. ¬ Λ⇩A⇩p⇩p.arr t ⟹ ?un_App1 t = Λ.null"
        by auto
      show "⋀t u. Λ⇩A⇩p⇩p.con t u ⟹ Λ.con (?un_App1 t) (?un_App1 u)"
        by auto
      show "Λ⇩A⇩p⇩p.con t u ⟹ ?un_App1 (Λ⇩A⇩p⇩p.resid t u) = ?un_App1 t \\ ?un_App1 u"
              for t u
        using Λ⇩A⇩p⇩p.resid_def Λ.Arr_resid
        by (cases t; cases u) auto
    qed

    interpretation un_App2: simulation Λ⇩A⇩p⇩p.resid Λ.resid 
                             ‹λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App2 t else ❙♯›
    proof
      let ?un_App2 = "λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App2 t else ❙♯"
      show "⋀t. ¬ Λ⇩A⇩p⇩p.arr t ⟹ ?un_App2 t = Λ.null"
        by auto
      show "⋀t u. Λ⇩A⇩p⇩p.con t u ⟹ Λ.con (?un_App2 t) (?un_App2 u)"
        by auto
      show "Λ⇩A⇩p⇩p.con t u ⟹ ?un_App2 (Λ⇩A⇩p⇩p.resid t u) = ?un_App2 t \\ ?un_App2 u"
              for t u
        using Λ⇩A⇩p⇩p.resid_def Λ.Arr_resid
        by (cases t; cases u) auto
    qed

    lemma Arr_map_un_App1:
    assumes "Arr T" and "set T ⊆ Collect Λ.is_App"
    shows "Arr (map Λ.un_App1 T)"
    proof -
      interpret P⇩A⇩p⇩p: paths_in_rts Λ⇩A⇩p⇩p.resid
        ..
      interpret un_App1: simulation P⇩A⇩p⇩p.Resid Resid
                          ‹λT. if P⇩A⇩p⇩p.Arr T then
                                 map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App1 t else ❙♯) T
                               else []›
        using un_App1.lifts_to_paths by simp
      have 1: "map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App1 t else ❙♯) T = map Λ.un_App1 T"
        using assms set_Arr_subset_arr by auto
      have 2: "P⇩A⇩p⇩p.Arr T"
        using assms set_Arr_subset_arr Λ⇩A⇩p⇩p.path_reflection [of T] by blast
      hence "arr (if P⇩A⇩p⇩p.Arr T then map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App1 t else ❙♯) T else [])"
        using un_App1.preserves_reflects_arr [of T] by blast
      hence "Arr (if P⇩A⇩p⇩p.Arr T then map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App1 t else ❙♯) T else [])"
        using arr_char by auto
      hence "Arr (if P⇩A⇩p⇩p.Arr T then map Λ.un_App1 T else [])"
        using 1 by metis
      thus ?thesis
        using 2 by simp
    qed

    lemma Arr_map_un_App2:
    assumes "Arr T" and "set T ⊆ Collect Λ.is_App"
    shows "Arr (map Λ.un_App2 T)"
    proof -
      interpret P⇩A⇩p⇩p: paths_in_rts Λ⇩A⇩p⇩p.resid
        ..
      interpret un_App2: simulation P⇩A⇩p⇩p.Resid Resid
                           ‹λT. if P⇩A⇩p⇩p.Arr T then
                                  map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App2 t else ❙♯) T
                                else []›
        using un_App2.lifts_to_paths by simp
      have 1: "map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App2 t else ❙♯) T = map Λ.un_App2 T"
        using assms set_Arr_subset_arr by auto
      have 2: "P⇩A⇩p⇩p.Arr T"
        using assms set_Arr_subset_arr Λ⇩A⇩p⇩p.path_reflection [of T] by blast
      hence "arr (if P⇩A⇩p⇩p.Arr T then map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App2 t else ❙♯) T else [])"
        using un_App2.preserves_reflects_arr [of T] by blast
      hence "Arr (if P⇩A⇩p⇩p.Arr T then map (λt. if Λ⇩A⇩p⇩p.arr t then Λ.un_App2 t else ❙♯) T else [])"
        using arr_char by blast
      hence "Arr (if P⇩A⇩p⇩p.Arr T then map Λ.un_App2 T else [])"
        using 1 by metis
      thus ?thesis
        using 2 by simp
    qed

    lemma map_App_map_un_App1:
    shows "⟦Arr U; set U ⊆ Collect Λ.is_App; Λ.Ide b; Λ.un_App2 ` set U ⊆ {b}⟧ ⟹
              map (λt. Λ.App t b) (map Λ.un_App1 U) = U"
      by (induct U) auto

    lemma map_App_map_un_App2:
    shows "⟦Arr U; set U ⊆ Collect Λ.is_App; Λ.Ide a; Λ.un_App1 ` set U ⊆ {a}⟧ ⟹
              map (Λ.App a) (map Λ.un_App2 U) = U"
      by (induct U) auto

    lemma map_Lam_Resid:
    assumes "coinitial T U"
    shows "map Λ.Lam (T ⇧*\\⇧* U) = map Λ.Lam T ⇧*\\⇧* map Λ.Lam U"
    proof -
      interpret Lam: simulation Λ.resid Λ.resid ‹λt. if Λ.arr t then ❙λ❙[t❙] else ❙♯›
        using Λ.Lam_is_simulation by simp
      interpret Lamx: simulation Resid Resid
                        ‹λT. if Arr T then
                               map (λt. if Λ.arr t then ❙λ❙[t❙] else ❙♯) T
                         else []›
        using Lam.lifts_to_paths by simp
      have "⋀T. Arr T ⟹ map (λt. if Λ.arr t then ❙λ❙[t❙] else ❙♯) T = map Λ.Lam T"
        using set_Arr_subset_arr by auto
      moreover have "Arr (T ⇧*\\⇧* U)"
        using assms confluence⇩P Con_imp_Arr_Resid con_char by force
      moreover have "T ⇧*⌢⇧* U"
        using assms confluence by simp
      moreover have "Arr T ∧ Arr U"
        using assms arr_char by auto
      ultimately show ?thesis
        using assms Lamx.preserves_resid [of T U] by presburger
    qed

    lemma map_App1_Resid:
    assumes "Λ.Ide x" and "coinitial T U"
    shows "map (Λ.App x) (T ⇧*\\⇧* U) = map (Λ.App x) T ⇧*\\⇧* map (Λ.App x) U"
    proof -
      interpret App: simulation Λ.resid Λ.resid ‹λt. if Λ.arr t then x ❙∘ t else ❙♯›
        using assms Λ.App_is_simulation2 by simp
      interpret Appx: simulation Resid Resid
                        ‹λT. if Arr T then map (λt. if Λ.arr t then x ❙∘ t else ❙♯) T else []›
        using App.lifts_to_paths by simp
      have "⋀T. Arr T ⟹ map (λt. if Λ.arr t then x ❙∘ t else ❙♯) T = map (Λ.App x) T"
        using set_Arr_subset_arr by auto
      moreover have "Arr (T ⇧*\\⇧* U)"
        using assms confluence⇩P Con_imp_Arr_Resid con_char by force
      moreover have "T ⇧*⌢⇧* U"
        using assms confluence by simp
      moreover have "Arr T ∧ Arr U"
        using assms arr_char by auto
      ultimately show ?thesis
        using assms Appx.preserves_resid [of T U] by presburger
    qed

    lemma map_App2_Resid:
    assumes "Λ.Ide x" and "coinitial T U"
    shows "map (λt. t ❙∘ x) (T ⇧*\\⇧* U) = map (λt. t ❙∘ x) T ⇧*\\⇧* map (λt. t ❙∘ x) U"
    proof -
      interpret App: simulation Λ.resid Λ.resid ‹λt. if Λ.arr t then t ❙∘ x else ❙♯›
        using assms Λ.App_is_simulation1 by simp
      interpret Appx: simulation Resid Resid
                        ‹λT. if Arr T then map (λt. if Λ.arr t then t ❙∘ x else ❙♯) T else []›
        using App.lifts_to_paths by simp
      have "⋀T. Arr T ⟹ map (λt. if Λ.arr t then t ❙∘ x else ❙♯) T = map (λt. t ❙∘ x) T"
        using set_Arr_subset_arr by auto
      moreover have "Arr (T ⇧*\\⇧* U)"
        using assms confluence⇩P Con_imp_Arr_Resid con_char by force
      moreover have "T ⇧*⌢⇧* U"
        using assms confluence by simp
      moreover have "Arr T ∧ Arr U"
        using assms arr_char by auto
      ultimately show ?thesis
        using assms Appx.preserves_resid [of T U] by presburger
    qed

    lemma cong_map_Lam:
    shows "T ⇧*∼⇧* U ⟹ map Λ.Lam T ⇧*∼⇧* map Λ.Lam U"
      apply (induct U arbitrary: T)
       apply (simp add: ide_char)
      by (metis map_Lam_Resid cong_implies_coinitial cong_reflexive ideE
          map_is_Nil_conv Con_imp_Arr_Resid arr_char)

    lemma cong_map_App1:
    shows "⟦Λ.Ide x; T ⇧*∼⇧* U⟧ ⟹ map (Λ.App x) T ⇧*∼⇧* map (Λ.App x) U"
      apply (induct U arbitrary: x T)
       apply (simp add: ide_char)
      apply (intro conjI)
      by (metis Nil_is_map_conv arr_resid_iff_con con_char con_imp_coinitial
                cong_reflexive ideE map_App1_Resid)+

    lemma cong_map_App2:
    shows "⟦Λ.Ide x; T ⇧*∼⇧* U⟧ ⟹ map (λX. X ❙∘ x) T ⇧*∼⇧* map (λX. X ❙∘ x) U"
      apply (induct U arbitrary: x T)
       apply (simp add: ide_char)
      apply (intro conjI)
      by (metis Nil_is_map_conv arr_resid_iff_con con_char cong_implies_coinitial
                   cong_reflexive ide_def arr_char ideE map_App2_Resid)+

    subsection "Decomposition of `App Paths'"

    text ‹
      The following series of results is aimed at showing that a reduction path, all of whose
      transitions have ‹App› as their top-level constructor, can be factored up to congruence
      into a reduction path in which only the ``rator'' components are reduced, followed
      by a reduction path in which only the ``rand'' components are reduced.
    ›

    lemma orthogonal_App_single_single:
    assumes "Λ.Arr t" and "Λ.Arr u"
    shows "[Λ.Src t ❙∘ u] ⇧*\\⇧* [t ❙∘ Λ.Src u] = [Λ.Trg t ❙∘ u]"
    and "[t ❙∘ Λ.Src u] ⇧*\\⇧* [Λ.Src t ❙∘ u] = [t ❙∘ Λ.Trg u]"
      using assms arr_char Λ.Arr_not_Nil by auto

    lemma orthogonal_App_single_Arr:
    shows "⟦Arr [t]; Arr U⟧ ⟹
              map (Λ.App (Λ.Src t)) U ⇧*\\⇧* [t ❙∘ Λ.Src (hd U)] = map (Λ.App (Λ.Trg t)) U ∧
              [t ❙∘ Λ.Src (hd U)] ⇧*\\⇧* map (Λ.App (Λ.Src t)) U = [t ❙∘ Λ.Trg (last U)]"
    proof (induct U arbitrary: t)
      show "⋀t. ⟦Arr [t]; Arr []⟧ ⟹
                   map (Λ.App (Λ.Src t)) [] ⇧*\\⇧* [t ❙∘ Λ.Src (hd [])] = map (Λ.App (Λ.Trg t)) [] ∧
                   [t ❙∘ Λ.Src (hd [])] ⇧*\\⇧* map (Λ.App (Λ.Src t)) [] = [t ❙∘ Λ.Trg (last [])]"
        by fastforce
      fix t u U
      assume ind: "⋀t. ⟦Arr [t]; Arr U⟧ ⟹
                         map (Λ.App (Λ.Src t)) U ⇧*\\⇧* [t ❙∘ Λ.Src (hd U)] =
                         map (Λ.App (Λ.Trg t)) U ∧
                         [t ❙∘ Λ.Src (hd U)] ⇧*\\⇧* map (Λ.App (Λ.Src t)) U = [t ❙∘ Λ.Trg (last U)]"
      assume t: "Arr [t]"
      assume uU: "Arr (u # U)"
      show "map (Λ.App (Λ.Src t)) (u # U) ⇧*\\⇧* [t ❙∘ Λ.Src (hd (u # U))] =
            map (Λ.App (Λ.Trg t)) (u # U) ∧
            [t ❙∘ Λ.Src (hd (u # U))] ⇧*\\⇧* map (Λ.App (Λ.Src t)) (u # U) =
            [t ❙∘ Λ.Trg (last (u # U))]"
      proof (cases "U = []")
        show "U = [] ⟹ ?thesis"
          using t uU orthogonal_App_single_single by simp
        assume U: "U ≠ []"
        have 2: "coinitial ([Λ.Src t ❙∘ u] @ map (Λ.App (Λ.Src t)) U) [t ❙∘ Λ.Src u]"
        proof
          show 3: "arr ([Λ.Src t ❙∘ u] @ map (Λ.App (Λ.Src t)) U)"
            using t uU
            by (metis Arr_iff_Con_self Arr_map_App2 Con_rec(1) append_Cons append_Nil arr_char
                Λ.Con_implies_Arr2 Λ.Ide_Src Λ.con_char list.simps(9))
          show "sources ([Λ.Src t ❙∘ u] @ map (Λ.App (Λ.Src t)) U) = sources [t ❙∘ Λ.Src u]"
          proof -
            have "seq [Λ.Src t ❙∘ u] (map (Λ.App (Λ.Src t)) U)"
              using U 3 arr_append_imp_seq by force
            thus ?thesis
              using sources_append [of "[Λ.Src t ❙∘ u]" "map (Λ.App (Λ.Src t)) U"]
                    sources_single_Src [of "Λ.Src t ❙∘ u"]
                    sources_single_Src [of "t ❙∘ Λ.Src u"]
              using arr_char t
              by (simp add: seq_char)
          qed
        qed
        show ?thesis
        proof
          show 4: "map (Λ.App (Λ.Src t)) (u # U) ⇧*\\⇧* [t ❙∘ Λ.Src (hd (u # U))] =
                   map (Λ.App (Λ.Trg t)) (u # U)"
          proof -
            have "map (Λ.App (Λ.Src t)) (u # U) ⇧*\\⇧* [t ❙∘ Λ.Src (hd (u # U))] =
                  ([Λ.Src t ❙∘ u] @ map (Λ.App (Λ.Src t)) U) ⇧*\\⇧* [t ❙∘ Λ.Src u]"
              by simp
            also have "... = [Λ.Src t ❙∘ u] ⇧*\\⇧* [t ❙∘ Λ.Src u] @
                               map (Λ.App (Λ.Src t)) U ⇧*\\⇧* ([t ❙∘ Λ.Src u] ⇧*\\⇧* [Λ.Src t ❙∘ u])"
              by (meson "2" Resid_append(1) con_char confluence not_Cons_self2)
            also have "... = [Λ.Trg t ❙∘ u] @ map (Λ.App (Λ.Src t)) U ⇧*\\⇧* [t ❙∘ Λ.Trg u]"
              using t Λ.Arr_not_Nil
              by (metis Arr_imp_arr_hd Λ.arr_char list.sel(1) orthogonal_App_single_single(1)
                  orthogonal_App_single_single(2) uU)
            also have "... = [Λ.Trg t ❙∘ u] @ map (Λ.App (Λ.Trg t)) U"
            proof -
              have "Λ.Src (hd U) = Λ.Trg u"
                using U uU Arr.elims(2) Srcs_simp⇩Λ⇩P by force
              thus ?thesis
                using t uU ind Arr.elims(2) by fastforce
            qed
            also have "... = map (Λ.App (Λ.Trg t)) (u # U)"
              by auto
            finally show ?thesis by blast
          qed
          show "[t ❙∘ Λ.Src (hd (u # U))] ⇧*\\⇧* map (Λ.App (Λ.Src t)) (u # U) =
                [t ❙∘ Λ.Trg (last (u # U))]"
          proof -
            have "[t ❙∘ Λ.Src (hd (u # U))] ⇧*\\⇧* map (Λ.App (Λ.Src t)) (u # U) =
                  ([t ❙∘ Λ.Src (hd (u # U))] ⇧*\\⇧* [Λ.Src t ❙∘ u]) ⇧*\\⇧* map (Λ.App (Λ.Src t)) U"
              by (metis U 4 Con_sym Resid_cons(2) list.distinct(1) list.simps(9) map_is_Nil_conv)
            also have "... = [t ❙∘ Λ.Trg u] ⇧*\\⇧* map (Λ.App (Λ.Src t)) U"
              by (metis Arr_imp_arr_hd lambda_calculus.arr_char list.sel(1)
                  orthogonal_App_single_single(2) t uU)
            also have "... = [t ❙∘ Λ.Trg (last (u # U))]"
              by (metis 2 t U uU Con_Arr_self Con_cons(1) Con_implies_Arr(1) Trg_last_Src_hd_eqI
                  arr_append_imp_seq coinitialE ind Λ.Src.simps(4) Λ.Trg.simps(3)
                  Λ.lambda.inject(3) last.simps list.distinct(1) list.map_sel(1) map_is_Nil_conv)
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

    lemma orthogonal_App_Arr_Arr:
    shows "⟦Arr T; Arr U⟧ ⟹
              map (Λ.App (Λ.Src (hd T))) U ⇧*\\⇧* map (λX. Λ.App X (Λ.Src (hd U))) T =
              map (Λ.App (Λ.Trg (last T))) U ∧
              map (λX. X ❙∘ Λ.Src (hd U)) T ⇧*\\⇧* map (Λ.App (Λ.Src (hd T))) U =
              map (λX. X ❙∘ Λ.Trg (last U)) T"
    proof (induct T arbitrary: U)
      show "⋀U. ⟦Arr []; Arr U⟧
                  ⟹ map (Λ.App (Λ.Src (hd []))) U ⇧*\\⇧* map (λX. X ❙∘ Λ.Src (hd U)) [] =
                      map (Λ.App (Λ.Trg (last []))) U ∧
                      map (λX. X ❙∘ Λ.Src (hd U)) [] ⇧*\\⇧* map (Λ.App (Λ.Src (hd []))) U =
                      map (λX. X ❙∘ Λ.Trg (last U)) []"
        by simp
      fix t T U
      assume ind: "⋀U. ⟦Arr T; Arr U⟧
                          ⟹ map (Λ.App (Λ.Src (hd T))) U ⇧*\\⇧*
                                map (λX. Λ.App X (Λ.Src (hd U))) T =
                              map (Λ.App (Λ.Trg (last T))) U ∧
                              map (λX. X ❙∘ Λ.Src (hd U)) T ⇧*\\⇧* map (Λ.App (Λ.Src (hd T))) U =
                              map (λX. X ❙∘ Λ.Trg (last U)) T"
      assume tT: "Arr (t # T)"
      assume U: "Arr U"
      show "map (Λ.App (Λ.Src (hd (t # T)))) U ⇧*\\⇧* map (λX. X ❙∘ Λ.Src (hd U)) (t # T) =
            map (Λ.App (Λ.Trg (last (t # T)))) U ∧
            map (λX. X ❙∘ Λ.Src (hd U)) (t # T) ⇧*\\⇧* map (Λ.App (Λ.Src (hd (t # T)))) U =
            map (λX. X ❙∘ Λ.Trg (last U)) (t # T)"
      proof (cases "T = []")
        show "T = [] ⟹ ?thesis"
          using tT U
          by (simp add: orthogonal_App_single_Arr)
        assume T: "T ≠ []"
        have 1: "Arr T"
          using T tT Arr_imp_Arr_tl by fastforce
        have 2: "Λ.Src (hd T) = Λ.Trg t"
          using tT T Arr.elims(2) Srcs_simp⇩Λ⇩P by force
        show ?thesis
        proof
          show 3: "map (Λ.App (Λ.Src (hd (t # T)))) U ⇧*\\⇧*
                     map (λX. X ❙∘ Λ.Src (hd U)) (t # T) =
                   map (Λ.App (Λ.Trg (last (t # T)))) U"
          proof -
            have "map (Λ.App (Λ.Src (hd (t # T)))) U ⇧*\\⇧* map (λX. X ❙∘ Λ.Src (hd U)) (t # T) =
                  map (Λ.App (Λ.Src t)) U ⇧*\\⇧*
                  ([Λ.App t (Λ.Src (hd U))] @ map (λX. X ❙∘ Λ.Src (hd U)) T)"
              using tT U by simp
            also have "... = (map (Λ.App (Λ.Src t)) U ⇧*\\⇧* [t ❙∘ Λ.Src (hd U)]) ⇧*\\⇧*
                             map (λX. X ❙∘ Λ.Src (hd U)) T"
              using tT U Resid_append(2)
              by (metis Con_appendI(2) Resid.simps(1) T map_is_Nil_conv not_Cons_self2)
            also have "... = map (Λ.App (Λ.Trg t)) U ⇧*\\⇧* map (λX. X ❙∘ Λ.Src (hd U)) T"
              using tT U orthogonal_App_single_Arr Arr_imp_arr_hd by fastforce
            also have "... = map (Λ.App (Λ.Trg (last (t # T)))) U"
              using tT U 1 2 ind by auto
            finally show ?thesis by blast
          qed
          show "map (λX. X ❙∘ Λ.Src (hd U)) (t # T) ⇧*\\⇧*
                  map (Λ.App (Λ.Src (hd (t # T)))) U =
                map (λX. X ❙∘ Λ.Trg (last U)) (t # T)"
          proof -
            have "map (λX. X ❙∘ Λ.Src (hd U)) (t # T) ⇧*\\⇧*
                    map (Λ.App (Λ.Src (hd (t # T)))) U =
                  ([t ❙∘ Λ.Src (hd U)] @ map (λX. X ❙∘ Λ.Src (hd U)) T) ⇧*\\⇧*
                    map (Λ.App (Λ.Src t)) U"
              using tT U by simp
            also have "... = ([t ❙∘ Λ.Src (hd U)] ⇧*\\⇧* map (Λ.App (Λ.Src t)) U) @
                             (map (λX. X ❙∘ Λ.Src (hd U)) T ⇧*\\⇧*
                                 (map (Λ.App (Λ.Src t)) U ⇧*\\⇧* [t ❙∘ Λ.Src (hd U)]))"
              using tT U 3 Con_sym
                    Resid_append(1)
                      [of "[t ❙∘ Λ.Src (hd U)]" "map (λX. X ❙∘ Λ.Src (hd U)) T"
                       "map (Λ.App (Λ.Src t)) U"]
              by fastforce
            also have "... = [t ❙∘ Λ.Trg (last U)] @
                               map (λX. X ❙∘ Λ.Src (hd U)) T ⇧*\\⇧* map (Λ.App (Λ.Trg t)) U"
              using tT U Arr_imp_arr_hd orthogonal_App_single_Arr by fastforce
            also have "... = [t ❙∘ Λ.Trg (last U)] @ map (λX. X ❙∘ Λ.Trg (last U)) T"
              using tT U "1" "2" ind by presburger
            also have "... = map (λX. X ❙∘ Λ.Trg (last U)) (t # T)"
              by simp
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

    lemma orthogonal_App_cong:
    assumes "Arr T" and "Arr U"
    shows "map (λX. X ❙∘ Λ.Src (hd U)) T @ map (Λ.App (Λ.Trg (last T))) U ⇧*∼⇧*
           map (Λ.App (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T"
(*
      using assms orthogonal_App_Arr_Arr [of T U] Arr.simps(1) Con_imp_Arr_Resid
            Con_implies_Arr(1) Resid_Arr_self  Resid_append_ind ide_char list.map_disc_iff cube
      by (smt (verit))
*)
    proof
      have 1: "Arr (map (λX. X ❙∘ Λ.Src (hd U)) T)"
        using assms Arr_imp_arr_hd Arr_map_App1 Λ.Ide_Src by force
      have 2: "Arr (map (Λ.App (Λ.Trg (last T))) U)"
        using assms Arr_imp_arr_last Arr_map_App2 Λ.Ide_Trg by force
      have 3: "Arr (map (Λ.App (Λ.Src (hd T))) U)"
        using assms Arr_imp_arr_hd Arr_map_App2 Λ.Ide_Src by force
      have 4: "Arr (map (λX. X ❙∘ Λ.Trg (last U)) T)"
        using assms Arr_imp_arr_last Arr_map_App1 Λ.Ide_Trg by force
      have 5: "Arr (map (λX. X ❙∘ Λ.Src (hd U)) T @ map (Λ.App (Λ.Trg (last T))) U)"
        using assms
        by (metis (no_types, lifting) 1 2 Arr.simps(2) Arr_has_Src Arr_imp_arr_last
            Srcs.simps(1) Srcs_Resid_Arr_single Trgs_simp⇩P arr_append arr_char last_map
            orthogonal_App_single_Arr seq_char)
      have 6: "Arr (map (Λ.App (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T)"
        using assms
        by (metis (no_types, lifting) 3 4 Arr.simps(2) Arr_has_Src Arr_imp_arr_hd
            Srcs.simps(1) Srcs.simps(2) Srcs_Resid Srcs_simp⇩P arr_append arr_char hd_map
            orthogonal_App_single_Arr seq_char)
      have 7: "Con (map (λX. X ❙∘ Λ.Src (hd U)) T @ map ((❙∘) (Λ.Trg (last T))) U)
                   (map ((❙∘) (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T)"
        using assms orthogonal_App_Arr_Arr [of T U]
        by (metis 1 2 5 6 Con_imp_eq_Srcs Resid.simps(1) Srcs_append confluence_ind)
      have 8: "Con (map ((❙∘) (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T)
                   (map (λX. X ❙∘ Λ.Src (hd U)) T @ map ((❙∘) (Λ.Trg (last T))) U)"
        using 7 Con_sym by simp
      show "map (λX. X ❙∘ Λ.Src (hd U)) T @ map ((❙∘) (Λ.Trg (last T))) U ⇧*≲⇧*
            map ((❙∘) (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T"
      proof -
        have "(map (λX. X ❙∘ Λ.Src (hd U)) T @ map ((❙∘) (Λ.Trg (last T))) U) ⇧*\\⇧*
                (map ((❙∘) (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T) =
              map (λX. X ❙∘ Λ.Trg (last U)) T ⇧*\\⇧* map (λX. X ❙∘ Λ.Trg (last U)) T @
                (map ((❙∘) (Λ.Trg (last T))) U ⇧*\\⇧* map ((❙∘) (Λ.Trg (last T))) U) ⇧*\\⇧*
                   (map (λX. X ❙∘ Λ.Trg (last U)) T ⇧*\\⇧* map (λX. X ❙∘ Λ.Trg (last U)) T)"
          using assms 7 orthogonal_App_Arr_Arr
                Resid_append2
                  [of "map (λX. X ❙∘ Λ.Src (hd U)) T" "map (Λ.App (Λ.Trg (last T))) U"
                      "map (Λ.App (Λ.Src (hd T))) U" "map (λX. X ❙∘ Λ.Trg (last U)) T"]
          by fastforce
        moreover have "Ide ..."
          using assms 1 2 3 4 5 6 7 Resid_Arr_self
          by (metis Arr_append_iff⇩P Con_Arr_self Con_imp_Arr_Resid Ide_appendI⇩P
              Resid_Ide_Arr_ind append_Nil2 calculation)
        ultimately show ?thesis
          using ide_char by presburger
      qed
      show "map ((❙∘) (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T ⇧*≲⇧*
            map (λX. X ❙∘ Λ.Src (hd U)) T @ map ((❙∘) (Λ.Trg (last T))) U"
      proof -
        have "map ((❙∘) (Λ.Src (hd T))) U ⇧*\\⇧* map (λX. X ❙∘ Λ.Src (hd U)) T =
              map ((❙∘) (Λ.Trg (last T))) U"
          by (simp add: assms orthogonal_App_Arr_Arr)
        have "(map ((❙∘) (Λ.Src (hd T))) U @ map (λX. X ❙∘ Λ.Trg (last U)) T) ⇧*\\⇧*
                (map (λX. X ❙∘ Λ.Src (hd U)) T @ map ((❙∘) (Λ.Trg (last T))) U) =
              (map ((❙∘) (Λ.Trg (last T))) U) ⇧*\\⇧* map ((❙∘) (Λ.Trg (last T))) U @
                 (map (λX. X ❙∘ Λ.Trg (last U)) T ⇧*\\⇧* map (λX. X ❙∘ Λ.Trg (last U)) T) ⇧*\\⇧*
                    (map ((❙∘) (Λ.Trg (last T))) U ⇧*\\⇧* map ((❙∘) (Λ.Trg (last T))) U)"
          using assms 8 orthogonal_App_Arr_Arr [of T U]
                Resid_append2
                  [of "map (Λ.App (Λ.Src (hd T))) U" "map (λX. X ❙∘ Λ.Trg (last U)) T"
                      "map (λX. X ❙∘ Λ.Src (hd U)) T" "map (Λ.App (Λ.Trg (last T))) U"]
          by fastforce
        moreover have "Ide ..."
          using assms 1 2 3 4 5 6 8 Resid_Arr_self Arr_append_iff⇩P Con_sym
          by (metis Con_Arr_self Con_imp_Arr_Resid Ide_appendI⇩P Resid_Ide_Arr_ind
              append_Nil2 calculation)
        ultimately show ?thesis
          using ide_char by presburger
      qed
    qed

    text ‹
      We arrive at the final objective of this section: factorization, up to congruence,
      of a path whose transitions all have ‹App› as the top-level constructor,
      into the composite of a path that reduces only the ``rators'' and a path
      that reduces only the ``rands''.
    ›

    lemma map_App_decomp:
    shows "⟦Arr U; set U ⊆ Collect Λ.is_App⟧ ⟹
             map (λX. X ❙∘ Λ.Src (Λ.un_App2 (hd U))) (map Λ.un_App1 U) @
               map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U) ⇧*∼⇧*
             U"
    proof (induct U)
      show "Arr [] ⟹ map (λX. X ❙∘ Λ.Src (Λ.un_App2 (hd []))) (map Λ.un_App1 []) @
                         map (Λ.App (Λ.Trg (Λ.un_App1 (last [])))) (map Λ.un_App2 []) ⇧*∼⇧*
                       []"
        by simp
      fix u U
      assume ind: "⟦Arr U; set U ⊆ Collect Λ.is_App⟧ ⟹
                       map (λX. Λ.App X (Λ.Src (Λ.un_App2 (hd U)))) (map Λ.un_App1 U) @
                         map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U) ⇧*∼⇧*
                       U"
      assume uU: "Arr (u # U)"
      assume set: "set (u # U) ⊆ Collect Λ.is_App"
      have u: "Λ.Arr u ∧ Λ.is_App u"
        using set set_Arr_subset_arr uU by fastforce
      show "map (λX. X ❙∘ Λ.Src (Λ.un_App2 (hd (u # U)))) (map Λ.un_App1 (u # U)) @
              map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) (map Λ.un_App2 (u # U)) ⇧*∼⇧*
            u # U"
      proof (cases "U = []")
        assume U: "U = []"
        show ?thesis
          using u U Λ.Con_sym Λ.Ide_iff_Src_self Λ.resid_Arr_self Λ.resid_Src_Arr
                Λ.resid_Arr_Src Λ.Src_resid Λ.Arr_resid ide_char Λ.Arr_not_Nil
          by (cases u, simp_all)
        next
        assume U: "U ≠ []"
        have 1: "Arr (map Λ.un_App1 U)"
          using U set Arr_map_un_App1 uU
          by (metis Arr_imp_Arr_tl list.distinct(1) list.map_disc_iff list.map_sel(2) list.sel(3))
        have 2: "Arr [Λ.un_App2 u]"
          using U uU set
          by (metis Arr.simps(2) Arr_imp_arr_hd Arr_map_un_App2 hd_map list.discI list.sel(1))
        have 3: "Λ.Arr (Λ.un_App1 u) ∧ Λ.Arr (Λ.un_App2 u)"
          using uU set
          by (metis Arr_imp_arr_hd Arr_map_un_App1 Arr_map_un_App2 Λ.arr_char
              list.distinct(1) list.map_sel(1) list.sel(1))
        have 4: "map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                   [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u] ⇧*∼⇧*
                 [Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u] @
                   map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U)"
        proof -
          have "map (λX. X ❙∘ Λ.Src (hd [Λ.un_App2 u])) (map Λ.un_App1 U) =
                map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U)"
            using U uU set by simp
          moreover have "map (Λ.App (Λ.Trg (last (map Λ.un_App1 U)))) [Λ.un_App2 u] =
                         [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]"
            by (simp add: U last_map)
          moreover have "map (Λ.App (Λ.Src (hd (map Λ.un_App1 U)))) [Λ.un_App2 u] =
                         [Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u]"
            by simp
          moreover have "map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U) =
                         map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U)"
            using U uU set by blast
          ultimately show ?thesis
            using U uU set last_map hd_map 1 2 3
                  orthogonal_App_cong [of "map Λ.un_App1 U" "[Λ.un_App2 u]"]
            by presburger
        qed
        have 5: "Λ.Arr (Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u))"
          by (simp add: 3)
        have 6: "Arr (map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U))"
          by (metis 1 Arr_imp_arr_last Arr_map_App2 Arr_map_un_App2 Con_implies_Arr(2)
              Ide.simps(1) Resid_Arr_self Resid_cons(2) U insert_subset
              Λ.Ide_Trg Λ.arr_char last_map list.simps(15) set uU)
        have 7: "Λ.Arr (Λ.Trg (Λ.un_App1 (last U)))"
          by (metis 4 Arr.simps(2) Arr_append_iff⇩P Con_implies_Arr(2) Ide.simps(1)
              U ide_char Λ.Arr.simps(4) Λ.arr_char list.map_disc_iff not_Cons_self2)
        have 8: "Λ.Src (hd (map Λ.un_App1 U)) = Λ.Trg (Λ.un_App1 u)"
        proof -
          have "Λ.Src (hd U) = Λ.Trg u"
            using u uU U by fastforce
          thus ?thesis
            using u uU U set
            apply (cases u; cases "hd U")
                                apply (simp_all add: list.map_sel(1))
            using list.set_sel(1)
            by fastforce
        qed
        have 9: "Λ.Src (Λ.un_App2 (hd U)) = Λ.Trg (Λ.un_App2 u)"
        proof -
          have "Λ.Src (hd U) = Λ.Trg u"
            using u uU U by fastforce
          thus ?thesis
            using u uU U set
            apply (cases u; cases "hd U")
                                apply simp_all
            by (metis lambda_calculus.lambda.disc(15) list.set_sel(1) mem_Collect_eq
                subset_code(1))
        qed
        have "map (λX. X ❙∘ Λ.Src (Λ.un_App2 (hd (u # U)))) (map Λ.un_App1 (u # U)) @
                map ((❙∘) (Λ.Trg (Λ.un_App1 (last (u # U))))) (map Λ.un_App2 (u # U)) =
              [Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                (map (λX. X ❙∘ Λ.Src (Λ.un_App2 u))
                     (map Λ.un_App1 U) @ [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]) @
                  map ((❙∘) (Λ.Trg (Λ.un_App1 (last U)))) (map Λ.un_App2 U)"
          using uU U by simp
        also have 12: "cong ... ([Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                               ([Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u] @
                                  map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U)) @
                                 map ((❙∘) (Λ.Trg (Λ.un_App1 (last U)))) (map Λ.un_App2 U))"
        proof (intro cong_append [of "[Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)]"]
                     cong_append [where U = "map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X)
                                                 (map Λ.un_App2 U)"])
          show "[Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] ⇧*∼⇧* [Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)]"
            using 5 arr_char cong_reflexive Arr.simps(2) Λ.arr_char by presburger
          show "map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U) ⇧*∼⇧*
                map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U)"
            using 6 cong_reflexive by auto
          show "map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                  [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u] ⇧*∼⇧*
                [Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u] @
                  map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U)"
            using 4 by simp
          show 10: "seq [Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)]
                        ((map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                           [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]) @
                             map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U))"
          proof
            show "Arr [Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)]"
              using 5 Arr.simps(2) by blast
            show "Arr ((map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                          [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]) @
                         map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U))"
            proof (intro Arr_appendI⇩P⇩W⇩E)
              show "Arr (map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U))"
                using 1 3 Arr_map_App1 lambda_calculus.Ide_Src by blast
              show "Arr [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]"
                by (simp add: 3 7)
              show "Trg (map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U)) =
                    Src [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]"
                by (metis 4 Arr_appendE⇩P⇩W⇩E Con_implies_Arr(2) Ide.simps(1) U ide_char
                    list.map_disc_iff not_Cons_self2)
              show "Arr (map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U))"
                using 6 by simp
              show "Trg (map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                           [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]) =
                    Src (map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U))"
                using U uU set 1 3 6 7 9 Srcs_simp⇩P⇩W⇩E Arr_imp_arr_hd Arr_imp_arr_last
                apply auto
                by (metis Nil_is_map_conv hd_map Λ.Src.simps(4) Λ.Src_Trg Λ.Trg_Trg
                    last_map list.map_comp)
            qed
            show "Λ.Trg (last [Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)]) =
                  Λ.Src (hd ((map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                                [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u]) @
                               map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U)))"
              using 8 9
              by (simp add: 3 U hd_map)
          qed
          show "seq (map (λX. X ❙∘ Λ.Src (Λ.un_App2 u)) (map Λ.un_App1 U) @
                      [Λ.Trg (Λ.un_App1 (last U)) ❙∘ Λ.un_App2 u])
                    (map (λX. Λ.Trg (Λ.un_App1 (last U)) ❙∘ X) (map Λ.un_App2 U))"
            by (metis Nil_is_map_conv U 10 append_is_Nil_conv arr_append_imp_seq seqE)
        qed
        also have 11: "[Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                         ([Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u] @
                            map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U)) @
                           map ((❙∘) (Λ.Trg (Λ.un_App1 (last U)))) (map Λ.un_App2 U) =
                       ([Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                         [Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u]) @
                         map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U) @
                           map ((❙∘) (Λ.Trg (Λ.un_App1 (last U)))) (map Λ.un_App2 U)"
          by simp
        also have "cong ... ([u] @ U)"
        proof (intro cong_append)
          show "seq ([Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                       [Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u])
                    (map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U) @
                       map ((❙∘) (Λ.Trg (Λ.un_App1 (last U)))) (map Λ.un_App2 U))"
            by (metis 5 11 12 U Arr.simps(1-2) Con_implies_Arr(2) Ide.simps(1) Nil_is_map_conv
                append_is_Nil_conv arr_append_imp_seq arr_char ide_char Λ.arr_char)
          show "[Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                  [Λ.Src (hd (map Λ.un_App1 U)) ❙∘ Λ.un_App2 u] ⇧*∼⇧*
                [u]"
          proof -
            have "[Λ.un_App1 u ❙∘ Λ.Src (Λ.un_App2 u)] @
                    [Λ.Trg (Λ.un_App1 u) ❙∘ Λ.un_App2 u] ⇧*∼⇧*
                  [u]"
              using u uU U Λ.Arr_Trg Λ.Arr_not_Nil Λ.resid_Arr_self
              apply (cases u)
                  apply auto
              by force+
            thus ?thesis using 8 by simp
          qed
          show "map (λX. X ❙∘ Λ.Trg (last [Λ.un_App2 u])) (map Λ.un_App1 U) @
                  map ((❙∘) (Λ.Trg (Λ.un_App1 (last U)))) (map Λ.un_App2 U) ⇧*∼⇧*
                U"
            using ind set 9
            apply simp
            using U uU by blast
        qed
        also have "[u] @ U = u # U"
          by simp
        finally show ?thesis by blast
      qed
    qed

    subsection "Miscellaneous"

    lemma Resid_parallel:
    assumes "cong t t'" and "coinitial t u"
    shows "u ⇧*\\⇧* t = u ⇧*\\⇧* t'"
    proof -
      have "u ⇧*\\⇧* t = (u ⇧*\\⇧* t) ⇧*\\⇧* (t' ⇧*\\⇧* t)"
        using assms
        by (metis con_target conI⇩P con_sym resid_arr_ide)
      also have "... = (u ⇧*\\⇧* t') ⇧*\\⇧* (t ⇧*\\⇧* t')"
        using cube by auto
      also have "... = u ⇧*\\⇧* t'"
        using assms
        by (metis con_target conI⇩P con_sym resid_arr_ide)
      finally show ?thesis by blast
    qed

    lemma set_Ide_subset_single_hd:
    shows "Ide T ⟹ set T ⊆ {hd T}"
      apply (induct T, auto)
      using Λ.coinitial_ide_are_cong
      by (metis Arr_imp_arr_hd Ide_consE Ide_imp_Ide_hd Ide_implies_Arr Srcs_simp⇩P⇩W⇩E Srcs_simp⇩Λ⇩P
          Λ.trg_ide equals0D Λ.Ide_iff_Src_self Λ.arr_char Λ.ide_char set_empty singletonD
          subset_code(1))

    text ‹
      A single parallel reduction with ‹Beta› as the top-level operator factors,
      up to congruence, either as a path in which the top-level redex is
      contracted first, or as a path in which the top-level redex is contracted last.
    ›

    lemma Beta_decomp:
    assumes "Λ.Arr t" and "Λ.Arr u"
    shows "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t] ⇧*∼⇧* [❙λ❙[t❙] ❙⦁ u]"
    and "[❙λ❙[t❙] ❙∘ u] @ [❙λ❙[Λ.Trg t❙] ❙⦁ Λ.Trg u] ⇧*∼⇧* [❙λ❙[t❙] ❙⦁ u]"
      using assms Λ.Arr_not_Nil Λ.Subst_not_Nil ide_char Λ.Ide_Subst Λ.Ide_Trg
            Λ.Arr_Subst Λ.resid_Arr_self
      by auto

    text ‹
      If a reduction path follows an initial reduction whose top-level constructor is ‹Lam›,
      then all the terms in the path have ‹Lam› as their top-level constructor.
    ›

    lemma seq_Lam_Arr_implies:
    shows "⟦seq [t] U; Λ.is_Lam t⟧ ⟹ set U ⊆ Collect Λ.is_Lam"
    proof (induct U arbitrary: t)
      show "⋀t. ⟦seq [t] []; Λ.is_Lam t⟧ ⟹ set [] ⊆ Collect Λ.is_Lam"
        by simp
      fix u U t
      assume ind: "⋀t. ⟦seq [t] U; Λ.is_Lam t⟧ ⟹ set U ⊆ Collect Λ.is_Lam"
      assume uU: "seq [t] (u # U)"
      assume t: "Λ.is_Lam t"
      show "set (u # U) ⊆ Collect Λ.is_Lam"
      proof -
        have "Λ.is_Lam u"
          by (metis Trg_last_Src_hd_eqI Λ.Src.simps(1-2,4-5) Λ.Trg.simps(2) Λ.is_App_def
            Λ.is_Beta_def Λ.is_Lam_def Λ.is_Var_def Λ.lambda.disc(9) Λ.lambda.exhaust_disc
            last_ConsL list.sel(1) t uU)
        moreover have "set U ⊆ Collect Λ.is_Lam"
        proof (cases "U = []")
          show "U = [] ⟹ ?thesis"
            by simp
          assume U: "U ≠ []"
          have "seq [u] U"
            by (metis U append_Cons arr_append_imp_seq not_Cons_self2 self_append_conv2
                seqE uU)
          thus ?thesis
            using ind calculation by simp
        qed
        ultimately show ?thesis by auto
      qed
    qed

    lemma seq_map_un_Lam:
    assumes "seq [❙λ❙[t❙]] U"
    shows "seq [t] (map Λ.un_Lam U)"
    proof -
      have "Arr (❙λ❙[t❙] # U)"
        using assms
        by (simp add: seq_char)
      hence "Arr (map Λ.un_Lam (❙λ❙[t❙] # U)) ∧ Arr U"
        using seq_Lam_Arr_implies
        by (metis Arr_map_un_Lam ‹seq [❙λ❙[t❙]] U› Λ.lambda.discI(2) mem_Collect_eq
            seq_char set_ConsD subset_code(1))
      hence "Arr (Λ.un_Lam ❙λ❙[t❙] # map Λ.un_Lam U) ∧ Arr U"
        by simp
      thus ?thesis
        using seq_char
        by (metis (no_types, lifting) Arr.simps(1) Con_imp_eq_Srcs Con_implies_Arr(2)
            Con_initial_right Resid_rec(1) Resid_rec(3) Srcs_Resid Λ.lambda.sel(2)
            map_is_Nil_conv confluence_ind)
    qed

  end

  section "Developments"

  text ‹
    A \emph{development} is a reduction path from a term in which at each step exactly one
    redex is contracted, and the only redexes that are contracted are those that are residuals
    of redexes present in the original term.  That is, no redexes are contracted that were
    newly created as a result of the previous reductions.  The main theorem about developments
    is the Finite Developments Theorem, which states that all developments are finite.
    A proof of this theorem was published by Hindley \<^cite>‹"hindley"›, who attributes the
    result to Schroer \<^cite>‹"schroer"›.  Other proofs were published subsequently.
    Here we follow the paper by de Vrijer \<^cite>‹"deVrijer"›, which may in some sense be considered
    the definitive work because de Vrijer's proof gives an exact bound on the number of steps
    in a development.  Since de Vrijer used a classical, named-variable representation of
    ‹λ›-terms, for the formalization given in the present article it was necessary to find the
    correct way to adapt de Vrijer's proof to the de Bruijn index representation of terms.
    I found this to be a somewhat delicate matter and to my knowledge it has not been done
    previously.
  ›

  context lambda_calculus
  begin

    text ‹
      We define an \emph{elementary reduction} defined to be a term with exactly one marked redex.
      These correspond to the most basic computational steps.
    ›

    fun elementary_reduction
    where "elementary_reduction ❙♯ ⟷ False"
        | "elementary_reduction (❙«_❙») ⟷ False"
        | "elementary_reduction ❙λ❙[t❙] ⟷ elementary_reduction t"
        | "elementary_reduction (t ❙∘ u) ⟷
            (elementary_reduction t ∧ Ide u) ∨ (Ide t ∧ elementary_reduction u)"
        | "elementary_reduction (❙λ❙[t❙] ❙⦁ u) ⟷ Ide t ∧ Ide u"

    text ‹
      It is tempting to imagine that elementary reductions would be atoms with respect to the
      preorder ‹≲›, but this is not necessarily the case.
      For example, suppose ‹t = ❙λ❙[❙«1❙»❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙∘ ❙«0❙»)› and ‹u = ❙λ❙[❙«1❙»❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙⦁ ❙«0❙»)›.
      Then ‹t› is an elementary reduction, ‹u ≲ t› (in fact ‹u ∼ t›) but ‹u› is not an identity,
      nor is it elementary.
    ›

    lemma elementary_reduction_is_arr:
    shows "elementary_reduction t ⟹ arr t"
      using Ide_implies_Arr arr_char
      by (induct t) auto

    lemma elementary_reduction_not_ide:
    shows "elementary_reduction t ⟹ ¬ ide t"
      using ide_char
      by (induct t) auto

    lemma elementary_reduction_Raise_iff:
    shows "⋀d n. elementary_reduction (Raise d n t) ⟷ elementary_reduction t"
      using Ide_Raise
      by (induct t) auto

    lemma elementary_reduction_Lam_iff:
    shows "is_Lam t ⟹ elementary_reduction t ⟷ elementary_reduction (un_Lam t)"
      by (metis elementary_reduction.simps(3) lambda.collapse(2))

    lemma elementary_reduction_App_iff:
    shows "is_App t ⟹ elementary_reduction t ⟷
                        (elementary_reduction (un_App1 t) ∧ ide (un_App2 t)) ∨
                        (ide (un_App1 t) ∧ elementary_reduction (un_App2 t))"
      using ide_char
      by (metis elementary_reduction.simps(4) lambda.collapse(3))

    lemma elementary_reduction_Beta_iff:
    shows "is_Beta t ⟹ elementary_reduction t ⟷ ide (un_Beta1 t) ∧ ide (un_Beta2 t)"
      using ide_char
      by (metis elementary_reduction.simps(5) lambda.collapse(4))

    lemma cong_elementary_reductions_are_equal:
    shows "⟦elementary_reduction t; elementary_reduction u; t ∼ u⟧ ⟹ t = u"
    proof (induct t arbitrary: u)
      show "⋀u. ⟦elementary_reduction ❙♯; elementary_reduction u; ❙♯ ∼ u⟧ ⟹ ❙♯ = u"
        by simp
      show "⋀x u. ⟦elementary_reduction ❙«x❙»; elementary_reduction u; ❙«x❙» ∼ u⟧ ⟹ ❙«x❙» = u"
        by simp
      show "⋀t u. ⟦⋀u. ⟦elementary_reduction t; elementary_reduction u; t ∼ u⟧ ⟹ t = u;
                    elementary_reduction ❙λ❙[t❙]; elementary_reduction u; ❙λ❙[t❙] ∼ u⟧
                     ⟹ ❙λ❙[t❙] = u"
        by (metis elementary_reduction_Lam_iff lambda.collapse(2) lambda.inject(2) prfx_Lam_iff)
      show "⋀t1 t2. ⟦⋀u. ⟦elementary_reduction t1; elementary_reduction u; t1 ∼ u⟧ ⟹ t1 = u;
                     ⋀u. ⟦elementary_reduction t2; elementary_reduction u; t2 ∼ u⟧ ⟹ t2 = u;
                     elementary_reduction (t1 ❙∘ t2); elementary_reduction u; t1 ❙∘ t2 ∼ u⟧
                       ⟹ t1 ❙∘ t2 = u"
        for u
        using prfx_App_iff
        apply (cases u)
            apply auto[3]
         apply (metis elementary_reduction_App_iff ide_backward_stable lambda.sel(3-4)
                      weak_extensionality)
        by auto
      show "⋀t1 t2. ⟦⋀u. ⟦elementary_reduction t1; elementary_reduction u; t1 ∼ u⟧ ⟹ t1 = u;
                     ⋀u. ⟦elementary_reduction t2; elementary_reduction u; t2 ∼ u⟧ ⟹ t2 = u;
                     elementary_reduction (❙λ❙[t1❙] ❙⦁ t2); elementary_reduction u; ❙λ❙[t1❙] ❙⦁ t2 ∼ u⟧
                       ⟹ ❙λ❙[t1❙] ❙⦁ t2 = u"
        for u
        using prfx_App_iff
        apply (cases u, simp_all)
        by (metis (full_types) Coinitial_iff_Con Ide_iff_Src_self Ide.simps(1))
    qed

    text ‹
      An \emph{elementary reduction path} is a path in which each step is an elementary reduction.
      It will be convenient to regard the empty list as an elementary reduction path, even though
      it is not actually a path according to our previous definition of that notion.
    ›

    definition (in reduction_paths) elementary_reduction_path
    where "elementary_reduction_path T ⟷
           (T = [] ∨ Arr T ∧ set T ⊆ Collect Λ.elementary_reduction)"

    text ‹
      In the formal definition of ``development'' given below, we represent a set of
      redexes simply by a term, in which the occurrences of ‹Beta› correspond to the redexes
      in the set.  To express the idea that an elementary reduction ‹u› is a member of
      the set of redexes represented by term ‹t›, it is not adequate to say ‹u ≲ t›.
      To see this, consider the developments of a term of the form ‹❙λ❙[t1❙] ❙⦁ t2›. 
      Intuitively, such developments should consist of a (possibly empty) initial segment
      containing only transitions of the form ‹t1 ❙∘ t2›, followed by a transition of the form
      ‹❙λ❙[u1'❙] ❙⦁ u2'›, followed by a development of the residual of the original ‹❙λ❙[t1❙] ❙⦁ t2›
      after what has come so far.
      The requirement ‹u ≲ ❙λ❙[t1❙] ❙⦁ t2› is not a strong enough constraint on the
      transitions in the initial segment, because ‹❙λ❙[u1❙] ❙⦁ u2 ≲ ❙λ❙[t1❙] ❙⦁ t2›
      can hold for ‹t2› and ‹u2› coinitial, but otherwise without any particular relationship
      between their sets of marked redexes.  In particular, this can occur when
      ‹u2› and ‹t2› occur as subterms that can be deleted by the contraction of an outer redex.
      So we need to introduce a notion of containment between terms that is stronger
      and more ``syntactic'' than ‹≲›.  The notion ``subsumed by'' defined below serves
      this purpose.  Term ‹u› is subsumed by term ‹t› if both terms are arrows with exactly
      the same form except that ‹t› may contain ‹❙λ❙[t1❙] ❙⦁ t2› (a marked redex) in places
      where ‹u› contains ‹❙λ❙[t1❙] ❙∘ t2›.
    ›

    fun subs  (infix "⊑" 50)
    where "❙«i❙» ⊑ ❙«i'❙» ⟷ i = i'"
        | "❙λ❙[t❙] ⊑ ❙λ❙[t'❙] ⟷ t ⊑ t'"
        | "t ❙∘ u ⊑ t' ❙∘ u' ⟷ t ⊑ t' ∧ u ⊑ u'"
        | "❙λ❙[t❙] ❙∘ u ⊑ ❙λ❙[t'❙] ❙⦁ u' ⟷ t ⊑ t' ∧ u ⊑ u'"
        | "❙λ❙[t❙] ❙⦁ u ⊑ ❙λ❙[t'❙] ❙⦁ u' ⟷ t ⊑ t' ∧ u ⊑ u'"
        | "_ ⊑ _ ⟷ False"

    lemma subs_implies_prfx:
    shows "t ⊑ u ⟹ t ≲ u"
      apply (induct t arbitrary: u)
          apply auto[1]
      using subs.elims(2)
         apply fastforce
    proof -
      show "⋀t. ⟦⋀u. t ⊑ u ⟹ t ≲ u; ❙λ❙[t❙] ⊑ u⟧ ⟹ ❙λ❙[t❙] ≲ u" for u
        by (cases u, auto) fastforce
      show "⋀t2. ⟦⋀u1. t1 ⊑ u1 ⟹ t1 ≲ u1;
                  ⋀u2. t2 ⊑ u2 ⟹ t2 ≲ u2;
                  t1 ❙∘ t2 ⊑ u⟧
                     ⟹ t1 ❙∘ t2 ≲ u" for t1 u
        apply (cases t1; cases u)
                            apply simp_all
            apply fastforce+
          apply (metis Ide_Subst con_char lambda.sel(2) subs.simps(2) prfx_Lam_iff prfx_char
                       prfx_implies_con)
        by fastforce+
      show "⋀t1 t2. ⟦⋀u1. t1 ⊑ u1 ⟹ t1 ≲ u1;
                     ⋀u2. t2 ⊑ u2 ⟹ t2 ≲ u2;
                     ❙λ❙[t1❙] ❙⦁ t2 ⊑ u⟧
                        ⟹ ❙λ❙[t1❙] ❙⦁ t2 ≲ u" for u
        using Ide_Subst
        apply (cases u, simp_all)
        by (metis Ide.simps(1))
    qed

    text ‹
      The following is an example showing that two terms can be related by ‹≲› without being
      related by ‹⊑›.
    ›

    lemma subs_example:
    shows "❙λ❙[❙«1❙»❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙⦁ ❙«0❙») ≲ ❙λ❙[❙«1❙»❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙∘ ❙«0❙») = True"
    and "❙λ❙[❙«1❙»❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙⦁ ❙«0❙») ⊑ ❙λ❙[❙«1❙»❙] ❙⦁ (❙λ❙[❙«0❙»❙] ❙∘ ❙«0❙») = False"
      by auto

    lemma subs_Ide:
    shows "⟦ide u; Src t = Src u⟧ ⟹ u ⊑ t"
      using Ide_Src Ide_implies_Arr Ide_iff_Src_self
      by (induct t arbitrary: u, simp_all) force+

    lemma subs_App:
    shows "u ⊑ t1 ❙∘ t2 ⟷ is_App u ∧ un_App1 u ⊑ t1 ∧ un_App2 u ⊑ t2"
      by (metis lambda.collapse(3) prfx_App_iff subs.simps(3) subs_implies_prfx)

  end

  context reduction_paths
  begin

    text ‹
      We now formally define a \emph{development of ‹t›} to be an elementary reduction path ‹U›
      that is coinitial with ‹[t]›  and is such that each transition ‹u› in ‹U› is subsumed by
      the residual of ‹t› along the prefix of ‹U› coming before ‹u›.  Stated another way,
      each transition in ‹U› corresponds to the contraction of a single redex that is the residual
      of a redex originally marked in ‹t›.
    ›

    fun development
    where "development t [] ⟷ Λ.Arr t"
        | "development t (u # U) ⟷
           Λ.elementary_reduction u ∧ u ⊑ t ∧ development (t \\ u) U"

    lemma development_imp_Arr:
    assumes "development t U"
    shows "Λ.Arr t"
      using assms
      by (metis Λ.Con_implies_Arr2 Λ.Ide.simps(1) Λ.ide_char Λ.subs_implies_prfx
          development.elims(2))

    lemma development_Ide:
    shows "Λ.Ide t ⟹ development t U ⟷ U = []"
      using Λ.Ide_implies_Arr
      apply (induct U arbitrary: t)
       apply auto
      by (meson Λ.elementary_reduction_not_ide Λ.ide_backward_stable Λ.ide_char
          Λ.subs_implies_prfx)

    lemma development_implies:
    shows "development t U ⟹ elementary_reduction_path U ∧ (U ≠ [] ⟶ U ⇧*≲⇧* [t])"
      apply (induct U arbitrary: t)
      using elementary_reduction_path_def
       apply simp
    proof -
      fix t u U
      assume ind: "⋀t. development t U ⟹
                       elementary_reduction_path U ∧ (U ≠ [] ⟶ U ⇧*≲⇧* [t])"
      show "development t (u # U) ⟹
            elementary_reduction_path (u # U) ∧ (u # U ≠ [] ⟶ u # U ⇧*≲⇧* [t])"
      proof (cases "U = []")
        assume uU: "development t (u # U)"
        show "U = [] ⟹ ?thesis"
          using uU Λ.subs_implies_prfx ide_char Λ.elementary_reduction_is_arr
                elementary_reduction_path_def prfx_implies_con
          by force
        assume U: "U ≠ []"
        have "Λ.elementary_reduction u ∧ u ⊑ t ∧ development (t \\ u) U"
          using U uU development.elims(1) by blast
        hence 1: "Λ.elementary_reduction u ∧ elementary_reduction_path U ∧ u ⊑ t ∧
                  (U ≠ [] ⟶ U ⇧*≲⇧* [t \\ u])"
          using U uU ind by auto
        show ?thesis
        proof (unfold elementary_reduction_path_def, intro conjI)
          show "u # U = [] ∨ Arr (u # U) ∧ set (u # U) ⊆ Collect Λ.elementary_reduction"
            using U 1
            by (metis Con_implies_Arr(1) Con_rec(2) con_char prfx_implies_con
                elementary_reduction_path_def insert_subset list.simps(15) mem_Collect_eq
                Λ.prfx_implies_con Λ.subs_implies_prfx)
          show "u # U ≠ [] ⟶ u # U ⇧*≲⇧* [t]"
          proof -
            have "u # U ⇧*≲⇧* [t] ⟷ ide ([u \\ t] @ U ⇧*\\⇧* [t \\ u])"
              using 1 U Con_rec(2) Resid_rec(2) con_char prfx_implies_con
                    Λ.prfx_implies_con Λ.subs_implies_prfx
              by simp
            also have "... ⟷ True"
              using U 1 ide_char Ide_append_iff⇩P⇩W⇩E [of "[u \\ t]" "U ⇧*\\⇧* [t \\ u]"]
              by (metis Ide.simps(2) Ide_appendI⇩P⇩W⇩E Src_resid Trg.simps(2)
                  Λ.apex_sym con_char Λ.subs_implies_prfx prfx_implies_con)
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

    text ‹
      The converse of the previous result does not hold, because there could be a stage ‹i›
      at which ‹u⇩i ≲ t⇩i›, but ‹t⇩i›  deletes the redex contracted in ‹u⇩i›, so there is nothing
      forcing that redex to have been originally marked in ‹t›.  So ‹U› being a development
      of ‹t› is a stronger property than ‹U› just being an elementary reduction path such
      that ‹U ⇧*≲⇧* [t]›.
    ›

    lemma development_append:
    shows "⟦development t U; development (t ⇧1\\⇧* U) V⟧ ⟹ development t (U @ V)"
      using development_imp_Arr null_char
      apply (induct U arbitrary: t V)
       apply auto
      by (metis Resid1x.simps(2-3) append_Nil neq_Nil_conv)

    lemma development_map_Lam:
    shows "development t T ⟹ development ❙λ❙[t❙] (map Λ.Lam T)"
      using Λ.Arr_not_Nil development_imp_Arr
      by (induct T arbitrary: t) auto

    lemma development_map_App_1:
    shows "⟦development t T; Λ.Arr u⟧ ⟹ development (t ❙∘ u) (map (λx. x ❙∘ Λ.Src u) T)"
      apply (induct T arbitrary: t)
       apply (simp add: Λ.Ide_implies_Arr)
    proof -
      fix t T t'
      assume ind: "⋀t. ⟦development t T; Λ.Arr u⟧
                          ⟹ development (t ❙∘ u) (map (λx. x ❙∘ Λ.Src u) T)"
      assume t'T: "development t (t' # T)"
      assume u: "Λ.Arr u"
      show "development (t ❙∘ u) (map (λx. x ❙∘ Λ.Src u) (t' # T))"
        using u t'T ind
        apply simp
        using Λ.Arr_not_Nil Λ.Ide_Src development_imp_Arr Λ.subs_Ide by force
    qed

    lemma development_map_App_2:
    shows "⟦Λ.Arr t; development u U⟧ ⟹ development (t ❙∘ u) (map (λx. Λ.App (Λ.Src t) x) U)"
      apply (induct U arbitrary: u)
       apply (simp add: Λ.Ide_implies_Arr)
    proof -
      fix u U u'
      assume ind: "⋀u. ⟦Λ.Arr t; development u U⟧
                          ⟹ development (t ❙∘ u) (map (Λ.App (Λ.Src t)) U)"
      assume u'U: "development u (u' # U)"
      assume t: "Λ.Arr t"
      show "development (t ❙∘ u) (map (Λ.App (Λ.Src t)) (u' # U)) "
        using t u'U ind
        apply simp
        by (metis Λ.Coinitial_iff_Con Λ.Ide_Src Λ.Ide_iff_Src_self Λ.Ide_implies_Arr
            development_imp_Arr Λ.ide_char Λ.resid_Arr_Ide Λ.subs_Ide)
    qed

    subsection "Finiteness of Developments"

    text ‹
      A term ‹t› has the finite developments property if there exists a finite value
      that bounds the length of all developments of ‹t›.  The goal of this section is
      to prove the Finite Developments Theorem: every term has the finite developments
      property.
    ›

    definition FD
    where "FD t ≡ ∃n. ∀U. development t U ⟶ length U ≤ n"

  end

  text ‹
    In \<^cite>‹"hindley"›, Hindley proceeds by using structural induction to establish
    a bound on the length of a development of a term.
    The only case that poses any difficulty is the case of a ‹β›-redex, which is
    ‹❙λ❙[t❙] ❙⦁ u› in the notation used here.  He notes that there is an easy bound on the
    length of a development of a special form in which all the contractions of residuals of ‹t›
    occur before the contraction of the top-level redex.  The development first
    takes ‹❙λ❙[t❙] ❙⦁ u› to ‹❙λ❙[t'❙] ❙⦁ u'›, then to ‹subst u' t'›, then continues with
    independent developments of ‹u'›.  The number of independent developments of ‹u'›
    is given by the number of free occurrences of ‹Var 0› in ‹t'›.  As there can be
    only finitely many such ‹t'›, we can use the maximum number of free occurrences
    of ‹Var 0› over all such ‹t'› to bound the steps in the independent developments of ‹u'›.

    In the general case, the problem is that reductions of residuals of t can
    increase the number of free occurrences of ‹Var 0›, so we can't readily count
    them at any particular stage.  Hindley shows that developments in which
    there are reductions of residuals of ‹t› that occur after the contraction of the
    top-level redex are equivalent to reductions of the special form, by a
    transformation with a bounded increase in length.  This can be considered as a
    weak form of standardization for developments.

    A later paper by de Vrijer \<^cite>‹"deVrijer"› obtains an explicit function for the
    exact number of steps in a development of maximal length.  His proof is very
    straightforward and amenable to formalization, and it is what we follow here.
    The main issue for us is that de Vrijer uses a classical representation of ‹λ›-terms,
    with variable names and ‹α›-equivalence, whereas here we are using de Bruijn indices.
    This means that we have to discover the correct modification of de Vrijer's definitions
    to apply to the present situation.
  ›

  context lambda_calculus
  begin

    text ‹
      Our first definition is that of the ``multiplicity'' of a free variable in a term.
      This is a count of the maximum number of times a variable could occur free in a term
      reachable in a development.  The main issue in adjusting to de Bruijn indices
      is that the same variable will have different indices depending on the depth at which
      it occurs in the term.  So, we need to keep track of how the indices of variables change
      as we move through the term.  Our modified definitions adjust the parameter to the
      multiplicity function on each recursive call, to account for the contextual depth
      (\emph{i.e.}~the number of binders on a path from the root of the term).
     
      The definition of this function is readily understandable, except perhaps for the
      ‹Beta› case.  The multiplicity ‹mtp x (❙λ❙[t❙] ❙⦁ u)› has to be at least as large as
      ‹mtp x (❙λ❙[t❙] ❙∘ u)›, to account for developments in which the top-level redex is not
      contracted.  However, if the top-level redex ‹❙λ❙[t❙] ❙⦁ u› is contracted, then the contractum
      is ‹subst u t›, so the multiplicity has to be at least as large as ‹mtp x (subst u t)›.
      This leads to the relation:
      \begin{center}
        ‹mtp x (❙λ❙[t❙] ❙⦁ u) = max (mtp x (❙λ❙[t❙] ❙∘ u)) (mtp x (subst u t))›
      \end{center}
      This is not directly suitable for use in a definition of the function ‹mtp›, because
      proving the termination is problematic.  Instead, we have to guess the correct
      expression for ‹mtp x (subst u t)› and use that.
    
      Now, each variable ‹x› in ‹subst u t› other than the variable ‹0› that is substituted for
      still has all the occurrences that it does in ‹❙λ❙[t❙]›.  In addition, the variable being
      substituted for (which has index ‹0› in the outermost context of ‹t›) will in general have
      multiple free occurrences in ‹t›, with a total multiplicity given by ‹mtp 0 t›.
      The substitution operation replaces each free occurrence by ‹u›, which has the effect of
      multiplying the multiplicity of a variable ‹x› in ‹t› by a factor of ‹mtp 0 t›.
      These considerations lead to the following:
      \begin{center}
       ‹mtp x (❙λ❙[t❙] ❙⦁ u) = max (mtp x ❙λ❙[t❙] + mtp x u) (mtp x ❙λ❙[t❙] + mtp x u * mtp 0 t)›
      \end{center}
      However, we can simplify this to:
      \begin{center}
       ‹mtp x (❙λ❙[t❙] ❙⦁ u) = mtp x ❙λ❙[t❙] + mtp x u * max 1 (mtp 0 t)›
      \end{center}
      and replace the ‹mtp x ❙λ❙[t❙]› by ‹mtp (Suc x) t› to simplify the ordering necessary
      for the termination proof and allow it to be done automatically.
     
      The final result is perhaps about the first thing one would think to write down,
      but there are possible ways to go wrong and it is of course still necessary to discover
      the proper form required for the various induction proofs.  I followed a long path
      of rather more complicated-looking definitions, until I eventually managed to find the
      proper inductive forms for all the lemmas and eventually arrive back at this definition.
    ›

    fun mtp :: "nat ⇒ lambda ⇒ nat"
    where "mtp x ❙♯ = 0"
        | "mtp x ❙«z❙» = (if z = x then 1 else 0)"
        | "mtp x ❙λ❙[t❙] = mtp (Suc x) t"
        | "mtp x (t ❙∘ u) = mtp x t + mtp x u"
        | "mtp x (❙λ❙[t❙] ❙⦁ u) = mtp (Suc x) t + mtp x u * max 1 (mtp 0 t)"

    text ‹
      The multiplicity function generalizes the free variable predicate.
      This is not actually used, but is included for explanatory purposes.
    ›

    lemma mtp_gt_0_iff_in_FV:
    shows "mtp x t > 0 ⟷ x ∈ FV t"
    proof (induct t arbitrary: x)
      show "⋀x. 0 < mtp x ❙♯ ⟷ x ∈ FV ❙♯"
        by simp
      show "⋀x z. 0 < mtp x ❙«z❙» ⟷ x ∈ FV ❙«z❙»"
        by auto
      show Lam: "⋀t x. (⋀x. 0 < mtp x t ⟷ x ∈ FV t)
                          ⟹ 0 < mtp x ❙λ❙[t❙] ⟷ x ∈ FV ❙λ❙[t❙]"
      proof -
        fix t and x :: nat
        assume ind: "⋀x. 0 < mtp x t ⟷ x ∈ FV t"
        show "0 < mtp x ❙λ❙[t❙] ⟷ x ∈ FV ❙λ❙[t❙]"
          using ind
          apply auto
          apply (metis Diff_iff One_nat_def diff_Suc_1 empty_iff imageI insert_iff
                       nat.distinct(1))
          by (metis Suc_pred neq0_conv)
      qed
      show "⋀t u x.
              ⟦⋀x. 0 < mtp x t ⟷ x ∈ FV t;
               ⋀x. 0 < mtp x u ⟷ x ∈ FV u⟧
                 ⟹ 0 < mtp x (t ❙∘ u) ⟷ x ∈ FV (t ❙∘ u)"
        by simp
      show "⋀t u x.
              ⟦⋀x. 0 < mtp x t ⟷ x ∈ FV t;
               ⋀x. 0 < mtp x u ⟷ x ∈ FV u⟧
                 ⟹ 0 < mtp x (❙λ❙[t❙] ❙⦁ u) ⟷ x ∈ FV (❙λ❙[t❙] ❙⦁ u)"
      proof -
        fix t u and x :: nat
        assume ind1: "⋀x. 0 < mtp x t ⟷ x ∈ FV t"
        assume ind2: "⋀x. 0 < mtp x u ⟷ x ∈ FV u"
        show "0 < mtp x (❙λ❙[t❙] ❙⦁ u) ⟷ x ∈ FV (❙λ❙[t❙] ❙⦁ u)"
          using ind1 ind2
          apply simp
          by force
      qed
    qed

    text ‹
      We now establish a fact about commutation of multiplicity and Raise that will be
      needed subsequently.
    ›

    lemma mtpE_eq_Raise:
    shows "x < d ⟹ mtp x (Raise d k t) = mtp x t"
      by (induct t arbitrary: x k d) auto

    lemma mtp_Raise_ind:
    shows "⟦l ≤ d; size t ≤ s⟧ ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
    proof (induct s arbitrary: d x k l t)
      show "⋀d x k l. ⟦l ≤ d; size t ≤ 0⟧ ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
              for t
        by (cases t) auto
      show "⋀s d x k l.
               ⟦⋀d x k l t. ⟦l ≤ d; size t ≤ s⟧ ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t;
                l ≤ d; size t ≤ Suc s⟧
                  ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
        for t
      proof (cases t)
        show "⋀d x k l s. t = ❙♯ ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
          by simp
        show "⋀z d x k l s. ⟦l ≤ d; t = ❙«z❙»⟧
                               ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
          by simp
        show "⋀u d x k l s. ⟦l ≤ d; size t ≤ Suc s; t = ❙λ❙[u❙];
                             (⋀d x k l u. ⟦l ≤ d; size u ≤ s⟧
                                             ⟹ mtp (x + d + k) (Raise l k u) = mtp (x + d) u)⟧
                               ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
        proof -
          fix u d x s and k l :: nat
          assume l: "l ≤ d" and s: "size t ≤ Suc s" and t: "t = ❙λ❙[u❙]"
          assume ind: "⋀d x k l u. ⟦l ≤ d; size u ≤ s⟧
                                       ⟹ mtp (x + d + k) (Raise l k u) = mtp (x + d) u"
          show "mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
          proof -
            have "mtp (x + d + k) (Raise l k t) = mtp (Suc (x + d + k)) (Raise (Suc l) k u)"
              using t by simp
            also have "... = mtp (x + Suc d) u"
            proof -
              have "size u ≤ s"
                using t s by force
              thus ?thesis
                using l s ind [of "Suc l" "Suc d"] by simp
            qed
            also have "... = mtp (x + d) t"
              using t by auto
            finally show ?thesis by blast
          qed
        qed
        show "⋀t1 t2 d x k l s.
                ⟦⋀d x k l t1. ⟦l ≤ d; size t1 ≤ s⟧
                                 ⟹ mtp (x + d + k) (Raise l k t1) = mtp (x + d) t1;
                 ⋀d x k l t2. ⟦l ≤ d; size t2 ≤ s⟧
                                 ⟹ mtp (x + d + k) (Raise l k t2) = mtp (x + d) t2;
                 l ≤ d; size t ≤ Suc s; t = t1 ❙∘ t2⟧
                    ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
        proof -
          fix t1 t2 s
          assume s: "size t ≤ Suc s" and t: "t = t1 ❙∘ t2"
          have "size t1 ≤ s ∧ size t2 ≤ s"
            using s t by auto
          thus "⋀d x k l.
                  ⟦⋀d x k l t1. ⟦l ≤ d; size t1 ≤ s⟧
                                   ⟹ mtp (x + d + k) (Raise l k t1) = mtp (x + d) t1;
                   ⋀d x k l t2. ⟦l ≤ d; size t2 ≤ s⟧
                                   ⟹ mtp (x + d + k) (Raise l k t2) = mtp (x + d) t2;
                   l ≤ d; size t ≤ Suc s; t = t1 ❙∘ t2⟧
                      ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
            by simp
        qed
        show "⋀t1 t2 d x k l s.
                 ⟦⋀d x k l t1. ⟦l ≤ d; size t1 ≤ s⟧
                                  ⟹ mtp (x + d + k) (Raise l k t1) = mtp (x + d) t1;
                  ⋀d x k l t2. ⟦l ≤ d; size t2 ≤ s⟧
                                  ⟹ mtp (x + d + k) (Raise l k t2) = mtp (x + d) t2;
                  l ≤ d; size t ≤ Suc s; t = ❙λ❙[t1❙] ❙⦁ t2⟧
                     ⟹ mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
        proof -
          fix t1 t2 d x s and k l :: nat
          assume l: "l ≤ d" and s: "size t ≤ Suc s" and t: "t = ❙λ❙[t1❙] ❙⦁ t2"
          assume ind: "⋀d x k l N. ⟦l ≤ d; size N ≤ s⟧
                                      ⟹ mtp (x + d + k) (Raise l k N) = mtp (x + d) N"
          show "mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
          proof -
            have 1: "size t1 ≤ s ∧ size t2 ≤ s"
              using s t by auto
            have "mtp (x + d + k) (Raise l k t) =
                  mtp (Suc (x + d + k)) (Raise (Suc l) k t1) +
                    mtp (x + d + k) (Raise l k t2) * max 1 (mtp 0 (Raise (Suc l) k t1))"
              using t l by simp
            also have "... = mtp (Suc (x + d + k)) (Raise (Suc l) k t1) +
                             mtp (x + d) t2 * max 1 (mtp 0 (Raise (Suc l) k t1))"
              using l 1 ind by auto
            also have "... = mtp (x + Suc d) t1 + mtp (x + d) t2 * max 1 (mtp 0 t1)"
            proof -
              have "mtp (x + Suc d + k) (Raise (Suc l) k t1) = mtp (x + Suc d) t1"
                using l 1 ind [of "Suc l" "Suc d" t1] by simp
              moreover have "mtp 0 (Raise (Suc l) k t1) = mtp 0 t1"
                (* Raising indices already > 0 does not affect mtp⇩0. *)
                using l 1 ind [of "Suc l" "Suc d" t1 k] mtpE_eq_Raise by simp
              ultimately show ?thesis
                by simp
            qed
            also have "... = mtp (x + d) t"
              using t by auto
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

    lemma mtp_Raise:
    assumes "l ≤ d"
    shows "mtp (x + d + k) (Raise l k t) = mtp (x + d) t"
      using assms mtp_Raise_ind by blast

    lemma mtp_Raise':
    shows "mtp l (Raise l (Suc k) t) = 0"
      by (induct t arbitrary: k l) auto

    lemma mtp_raise:
    shows "mtp (x + Suc d) (raise d t) = mtp (Suc x) t"
       by (metis Suc_eq_plus1 add.assoc le_add2 le_add_same_cancel2 mtp_Raise plus_1_eq_Suc)

    lemma mtp_Subst_cancel:
    shows "mtp k (Subst (Suc d + k) u t) = mtp k t"
    proof (induct t arbitrary: k d)
      show "⋀k d. mtp k (Subst (Suc d + k) u ❙♯) = mtp k ❙♯"
        by simp
      show "⋀k z d. mtp k (Subst (Suc d + k) u ❙«z❙») = mtp k ❙«z❙»"
      using mtp_Raise'
        apply auto
        by (metis add_Suc_right add_Suc_shift order_refl raise_plus)
      show "⋀t k d. (⋀k d. mtp k (Subst (Suc d + k) u t) = mtp k t)
                        ⟹ mtp k (Subst (Suc d + k) u ❙λ❙[t❙]) = mtp k ❙λ❙[t❙]"
        by (metis Subst.simps(3) add_Suc_right mtp.simps(3))
      show "⋀t1 t2 k d.
               ⟦⋀k d. mtp k (Subst (Suc d + k) u t1) = mtp k t1;
                ⋀k d. mtp k (Subst (Suc d + k) u t2) = mtp k t2⟧
                   ⟹ mtp k (Subst (Suc d + k) u (t1 ❙∘ t2)) = mtp k (t1 ❙∘ t2)"
        by auto
      show "⋀t1 t2 k d.
         ⟦⋀k d. mtp k (Subst (Suc d + k) u t1) = mtp k t1;
          ⋀k d. mtp k (Subst (Suc d + k) u t2) = mtp k t2⟧
             ⟹ mtp k (Subst (Suc d + k) u (❙λ❙[t1❙] ❙⦁ t2)) = mtp k (❙λ❙[t1❙] ❙⦁ t2)"
        using mtp_Raise'
        apply auto
        by (metis Nat.add_0_right add_Suc_right)
    qed

    lemma mtp⇩0_Subst_cancel:
    shows "mtp 0 (Subst (Suc d) u t) = mtp 0 t"
      using mtp_Subst_cancel [of 0] by simp

    text ‹
      We can now (!) prove the desired generalization of de Vrijer's formula for the
      commutation of multiplicity and substitution.  This is the main lemma whose form
      is difficult to find.  To get this right, the proper relationships have to exist
      between the various depth parameters to ‹Subst› and the arguments to ‹mtp›.
    ›

    lemma mtp_Subst':
    shows "mtp (x + Suc d) (Subst d u t) = mtp (x + Suc (Suc d)) t + mtp (Suc x) u * mtp d t"
    proof (induct t arbitrary: d x u)
      show "⋀d x u. mtp (x + Suc d) (Subst d u ❙♯) =
            mtp (x + Suc (Suc d)) ❙♯ + mtp (Suc x) u * mtp d ❙♯"
        by simp
      show "⋀z d x u. mtp (x + Suc d) (Subst d u ❙«z❙») =
                       mtp (x + Suc (Suc d)) ❙«z❙» + mtp (Suc x) u * mtp d ❙«z❙»"
        using mtp_raise by auto
      show "⋀t d x u.
              (⋀d x u. mtp (x + Suc d) (Subst d u t) =
                        mtp (x + Suc (Suc d)) t + mtp (Suc x) u * mtp d t)
                          ⟹ mtp (x + Suc d) (Subst d u ❙λ❙[t❙]) =
                              mtp (x + Suc (Suc d)) ❙λ❙[t❙] + mtp (Suc x) u * mtp d ❙λ❙[t❙]"
      proof -
        fix t u d x
        assume ind: "⋀d x N. mtp (x + Suc d) (Subst d N t) =
                              mtp (x + Suc (Suc d)) t + mtp (Suc x) N * mtp d t"
        have "mtp (x + Suc d) (Subst d u ❙λ❙[t❙]) =
              mtp (Suc x + Suc (Suc d)) t +
              mtp (x + Suc (Suc d)) (raise (Suc d) u) * mtp (Suc d) t"
          using ind mtp_raise add_Suc_shift
          by (metis Subst.simps(3) add_Suc_right mtp.simps(3))
        also have "... = mtp (x + Suc (Suc d)) ❙λ❙[t❙] + mtp (Suc x) u * mtp d ❙λ❙[t❙]"
          using Raise_Suc
          by (metis add_Suc_right add_Suc_shift mtp.simps(3) mtp_raise)
        finally show "mtp (x + Suc d) (Subst d u ❙λ❙[t❙]) =
                      mtp (x + Suc (Suc d)) ❙λ❙[t❙] + mtp (Suc x) u * mtp d ❙λ❙[t❙]"
          by blast
      qed
      show "⋀t1 t2 u d x.
               ⟦⋀d x u. mtp (x + Suc d) (Subst d u t1) =
                        mtp (x + Suc (Suc d)) t1 + mtp (Suc x) u * mtp d t1;
                ⋀d x u. mtp (x + Suc d) (Subst d u t2) =
                         mtp (x + Suc (Suc d)) t2 + mtp (Suc x) u * mtp d t2⟧
                  ⟹ mtp (x + Suc d) (Subst d u (t1 ❙∘ t2)) =
                      mtp (x + Suc (Suc d)) (t1 ❙∘ t2) + mtp (Suc x) u * mtp d (t1 ❙∘ t2)"
        by (simp add: add_mult_distrib2)
      show "⋀t1 t2 u d x.
              ⟦⋀d x N. mtp (x + Suc d) (Subst d N t1) =
                       mtp (x + Suc (Suc d)) t1 + mtp (Suc x) N * mtp d t1;
              ⋀d x N. mtp (x + Suc d) (Subst d N t2) =
                       mtp (x + Suc (Suc d)) t2 + mtp (Suc x) N * mtp d t2⟧
                 ⟹ mtp (x + Suc d) (Subst d u (❙λ❙[t1❙] ❙⦁ t2)) =
                     mtp (x + Suc (Suc d)) (❙λ❙[t1❙] ❙⦁ t2) + mtp (Suc x) u * mtp d (❙λ❙[t1❙] ❙⦁ t2)"
      proof -
        fix t1 t2 u d x
        assume ind1: "⋀d x N. mtp (x + Suc d) (Subst d N t1) =
                               mtp (x + Suc (Suc d)) t1 + mtp (Suc x) N * mtp d t1"
        assume ind2: "⋀d x N. mtp (x + Suc d) (Subst d N t2) =
                               mtp (x + Suc (Suc d)) t2 + mtp (Suc x) N * mtp d t2"
        show "mtp (x + Suc d) (Subst d u (❙λ❙[t1❙] ❙⦁ t2)) =
              mtp (x + Suc (Suc d)) (❙λ❙[t1❙] ❙⦁ t2) + mtp (Suc x) u * mtp d (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          let ?A = "mtp (Suc x + Suc (Suc d)) t1"
          let ?B = "mtp (Suc x + Suc d) t2"
          let ?M1 = "mtp (Suc d) t1"
          let ?M2 = "mtp d t2"
          let ?M1⇩0 = "mtp 0 (Subst (Suc d) u t1)"
          let ?M1⇩0' = "mtp 0 t1"
          let ?N = "mtp (Suc x) u"
          have "mtp (x + Suc d) (Subst d u (❙λ❙[t1❙] ❙⦁ t2)) =
                mtp (x + Suc d) (❙λ❙[Subst (Suc d) u t1❙] ❙⦁ Subst d u t2)"
             by simp
          also have "... = mtp (x + Suc (Suc d)) (Subst (Suc d) u t1) +
                           mtp (x + Suc d) (Subst d u t2) *
                             max 1 (mtp 0 (Subst (Suc d) u t1))"
            by simp
          also have "... = (?A + ?N * ?M1) + (?B + ?N * ?M2) * max 1 ?M1⇩0"
            using ind1 ind2 add_Suc_shift by presburger
          also have "... = ?A + ?N * ?M1 + ?B * max 1 ?M1⇩0 + ?N * ?M2 * max 1 ?M1⇩0"
            by algebra
          also have "... = ?A + ?B * max 1 ?M1⇩0' + ?N * ?M1 + ?N * ?M2 * max 1 ?M1⇩0'"
          proof -
            have "?M1⇩0 = ?M1⇩0'"
            (* The u-dependence on the LHS is via raise (Suc d) u, which does not have
               any free occurrences of 0.  So mtp 0 0 yields the same on both. *)
              using mtp⇩0_Subst_cancel by blast
            thus ?thesis by auto
          qed
          also have "... = ?A + ?B * max 1 ?M1⇩0' + ?N * (?M1 + ?M2 * max 1 ?M1⇩0')"
            by algebra
          also have "... =  mtp (Suc x + Suc d) (❙λ❙[t1❙] ❙⦁ t2) + mtp (Suc x) u * mtp d (❙λ❙[t1❙] ❙⦁ t2)"
            by simp
          finally show ?thesis by simp
        qed
      qed
    qed

    text ‹
      The following lemma provides expansions that apply when the parameter to ‹mtp› is ‹0›,
      as opposed to the previous lemma, which only applies for parameters greater than ‹0›.
    ›

    lemma mtp_Subst:
    shows "mtp k (Subst k u t) = mtp (Suc k) t + mtp k (raise k u) * mtp k t"
    proof (induct t arbitrary: u k)
      show "⋀u k. mtp k (Subst k u ❙♯) = mtp (Suc k) ❙♯ + mtp k (raise k u) * mtp k ❙♯"
        by simp
      show "⋀x u k. mtp k (Subst k u ❙«x❙») =
                     mtp (Suc k) ❙«x❙» + mtp k (raise k u) * mtp k ❙«x❙»"
        by auto
      show "⋀t u k. (⋀u k. mtp k (Subst k u t) = mtp (Suc k) t + mtp k (raise k u) * mtp k t)
                              ⟹ mtp k (Subst k u ❙λ❙[t❙]) =
                                  mtp (Suc k) ❙λ❙[t❙] + mtp k (Raise 0 k u) * mtp k ❙λ❙[t❙]"
        using mtp_Raise [of 0]
        apply auto
        by (metis add.left_neutral)
      show "⋀t1 t2 u k.
              ⟦⋀u k. mtp k (Subst k u t1) = mtp (Suc k) t1 + mtp k (raise k u) * mtp k t1;
               ⋀u k. mtp k (Subst k u t2) = mtp (Suc k) t2 + mtp k (raise k u) * mtp k t2⟧
                   ⟹ mtp k (Subst k u (t1 ❙∘ t2)) =
                       mtp (Suc k) (t1 ❙∘ t2) + mtp k (raise k u) * mtp k (t1 ❙∘ t2)"
        by (auto simp add: distrib_left)
      show "⋀t1 t2 u k.
              ⟦⋀u k. mtp k (Subst k u t1) = mtp (Suc k) t1 + mtp k (raise k u) * mtp k t1;
               ⋀u k. mtp k (Subst k u t2) = mtp (Suc k) t2 + mtp k (raise k u) * mtp k t2⟧
                  ⟹ mtp k (Subst k u (❙λ❙[t1❙] ❙⦁ t2)) =
                      mtp (Suc k) (❙λ❙[t1❙] ❙⦁ t2) + mtp k (raise k u) * mtp k (❙λ❙[t1❙] ❙⦁ t2)"
      proof -
        fix t1 t2 u k
        assume ind1: "⋀u k. mtp k (Subst k u t1) =
                             mtp (Suc k) t1 + mtp k (raise k u) * mtp k t1"
        assume ind2: "⋀u k. mtp k (Subst k u t2) =
                             mtp (Suc k) t2 + mtp k (raise k u) * mtp k t2"
        show "mtp k (Subst k u (❙λ❙[t1❙] ❙⦁ t2)) =
              mtp (Suc k) (❙λ❙[t1❙] ❙⦁ t2) + mtp k (raise k u) * mtp k (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          have "mtp (Suc k) (Raise 0 (Suc k) u) * mtp (Suc k) t1 +
                  (mtp (Suc k) t2 + mtp k (Raise 0 k u) * mtp k t2) * max (Suc 0) (mtp 0 t1) =
                mtp (Suc k) t2 * max (Suc 0) (mtp 0 t1) +
                  mtp k (Raise 0 k u) * (mtp (Suc k) t1 + mtp k t2 * max (Suc 0) (mtp 0 t1))"
          proof -
            have "mtp (Suc k) (Raise 0 (Suc k) u) * mtp (Suc k) t1 +
                    (mtp (Suc k) t2 + mtp k (Raise 0 k u) * mtp k t2) * max (Suc 0) (mtp 0 t1) =
                  mtp (Suc k) t2 * max (Suc 0) (mtp 0 t1) +
                    mtp (Suc k) (Raise 0 (Suc k) u) * mtp (Suc k) t1 +
                      mtp k (Raise 0 k u) * mtp k t2 * max (Suc 0) (mtp 0 t1)"
              by algebra
            also have "... = mtp (Suc k) t2 * max (Suc 0) (mtp 0 t1) +
                               mtp (Suc k) (Raise 0 (Suc k) u) * mtp (Suc k) t1 +
                                  mtp 0 u * mtp k t2 * max (Suc 0) (mtp 0 t1)"
              using mtp_Raise [of 0 0 0 k u] by auto
            also have "... = mtp (Suc k) t2 * max (Suc 0) (mtp 0 t1) +
                               mtp k (Raise 0 k u) *
                                 (mtp (Suc k) t1 + mtp k t2 * max (Suc 0) (mtp 0 t1))"
              by (metis (no_types, lifting) ab_semigroup_add_class.add_ac(1)
                  ab_semigroup_mult_class.mult_ac(1) add_mult_distrib2 le_add1 mtp_Raise
                  plus_nat.add_0)
            finally show ?thesis by blast
          qed
          thus ?thesis
            using ind1 ind2 mtp⇩0_Subst_cancel by auto
        qed
      qed
    qed

    lemma mtp0_subst_le:
    shows "mtp 0 (subst u t) ≤ mtp 1 t + mtp 0 u * max 1 (mtp 0 t)"
    proof (cases t)
      show "t = ❙♯ ⟹ mtp 0 (subst u t) ≤ mtp 1 t + mtp 0 u * max 1 (mtp 0 t)"
        by auto
      show "⋀z. t = ❙«z❙» ⟹ mtp 0 (subst u t) ≤ mtp 1 t + mtp 0 u * max 1 (mtp 0 t)"
        using Raise_0 by force
      show "⋀P. t = ❙λ❙[P❙] ⟹ mtp 0 (subst u t) ≤ mtp 1 t + mtp 0 u * max 1 (mtp 0 t)"
        using mtp_Subst [of 0 u t] Raise_0 by force
      show "⋀t1 t2. t = t1 ❙∘ t2 ⟹ mtp 0 (subst u t) ≤ mtp 1 t + mtp 0 u * max 1 (mtp 0 t)"
        using mtp_Subst Raise_0 add_mult_distrib2 nat_mult_max_right by auto
      show "⋀t1 t2. t = ❙λ❙[t1❙] ❙⦁ t2 ⟹ mtp 0 (subst u t) ≤ mtp 1 t + mtp 0 u * max 1 (mtp 0 t)"
        using mtp_Subst Raise_0
        by (metis Nat.add_0_right dual_order.eq_iff max_def mult.commute mult_zero_left
            not_less_eq_eq plus_1_eq_Suc trans_le_add1)
    qed

    lemma elementary_reduction_nonincreases_mtp:
    shows "⟦elementary_reduction u; u ⊑ t⟧ ⟹ mtp x (resid t u) ≤ mtp x t"
    proof (induct t arbitrary: u x)
      show "⋀u x. ⟦elementary_reduction u; u ⊑ ❙♯⟧ ⟹ mtp x (resid ❙♯ u) ≤ mtp x ❙♯"
        by simp
      show "⋀x u i. ⟦elementary_reduction u; u ⊑ ❙«i❙»⟧
                          ⟹ mtp x (resid ❙«i❙» u) ≤ mtp x ❙«i❙»"
        by (meson Ide.simps(2) elementary_reduction_not_ide ide_backward_stable ide_char
            subs_implies_prfx)
      fix u
      show "⋀t x. ⟦⋀u x. ⟦elementary_reduction u; u ⊑ t⟧ ⟹ mtp x (resid t u) ≤ mtp x t;
                   elementary_reduction u; u ⊑ ❙λ❙[t❙]⟧
                     ⟹ mtp x (❙λ❙[t❙] \\ u) ≤ mtp x ❙λ❙[t❙]"
        by (cases u) auto
      show "⋀t1 t2 x.
               ⟦⋀u x. ⟦elementary_reduction u; u ⊑ t1⟧ ⟹ mtp x (resid t1 u) ≤ mtp x t1;
                ⋀u x. ⟦elementary_reduction u; u ⊑ t2⟧ ⟹ mtp x (resid t2 u) ≤ mtp x t2;
                elementary_reduction u; u ⊑ t1 ❙∘ t2⟧
                  ⟹ mtp x (resid (t1 ❙∘ t2) u) ≤ mtp x (t1 ❙∘ t2)"
        apply (cases u)
            apply auto
         apply (metis Coinitial_iff_Con add_mono_thms_linordered_semiring(3) resid_Arr_Ide)
        by (metis Coinitial_iff_Con add_mono_thms_linordered_semiring(2) resid_Arr_Ide)
      (*
       * TODO: Isabelle is sensitive to the order of assumptions in the induction hypotheses
       * stated in the "show". Why?
       *)
      show "⋀t1 t2 x.
               ⟦⋀u1 x. ⟦elementary_reduction u1; u1 ⊑ t1⟧ ⟹ mtp x (resid t1 u1) ≤ mtp x t1;
                ⋀u2 x. ⟦elementary_reduction u2; u2 ⊑ t2⟧ ⟹ mtp x (resid t2 u2) ≤ mtp x t2;
                elementary_reduction u; u ⊑ ❙λ❙[t1❙] ❙⦁ t2⟧
                  ⟹ mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) ≤ mtp x (❙λ❙[t1❙] ❙⦁ t2)"
      proof -
        fix t1 t2 x
        assume ind1: "⋀u1 x. ⟦elementary_reduction u1; u1 ⊑ t1⟧
                                ⟹ mtp x (t1 \\ u1) ≤ mtp x t1"
        assume ind2: "⋀u2 x. ⟦elementary_reduction u2; u2 ⊑ t2⟧
                                ⟹ mtp x (t2 \\ u2) ≤ mtp x t2"
        assume u: "elementary_reduction u"
        assume subs: "u ⊑ ❙λ❙[t1❙] ❙⦁ t2"
        have 1: "is_App u ∨ is_Beta u"
          using subs by (metis prfx_Beta_iff subs_implies_prfx)
        have "is_App u ⟹ mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) ≤ mtp x (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          assume 2: "is_App u"
          obtain u1 u2 where u1u2: "u = ❙λ❙[u1❙] ❙∘ u2"
            using 2 u
            by (metis ConD(3) Con_implies_is_Lam_iff_is_Lam Con_sym con_def is_App_def is_Lam_def
                      lambda.disc(8) null_char prfx_implies_con subs subs_implies_prfx)
          have "mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) = mtp x (❙λ❙[t1 \\ u1❙] ❙⦁ (t2 \\ u2))"
            using u1u2 subs
            by (metis Con_sym Ide.simps(1) ide_char resid.simps(6) subs_implies_prfx)
          also have "... = mtp (Suc x) (resid t1 u1) +
                           mtp x (resid t2 u2) * max 1 (mtp 0 (resid t1 u1))"
            by simp
          also have "... ≤ mtp (Suc x) t1 + mtp x (resid t2 u2) * max 1 (mtp 0 (resid t1 u1))"
            using u1u2 ind1 [of u1 "Suc x"] con_sym ide_char resid_arr_ide prfx_implies_con
                  subs subs_implies_prfx u
            by force
          also have "... ≤ mtp (Suc x) t1 + mtp x t2 * max 1 (mtp 0 (resid t1 u1))"
            using u1u2 ind2 [of u2 x]
            by (metis (no_types, lifting) Con_implies_Coinitial_ind add_left_mono
                dual_order.eq_iff elementary_reduction.simps(4) lambda.disc(11)
                mult_le_cancel2 prfx_App_iff resid.simps(31) resid_Arr_Ide subs subs.simps(4)
                subs_implies_prfx u)
          also have "... ≤ mtp (Suc x) t1 + mtp x t2 * max 1 (mtp 0 t1)"
            using ind1 [of u1 0]
            by (metis Con_implies_Coinitial_ind Ide.simps(3) elementary_reduction.simps(3)
                elementary_reduction.simps(4) lambda.disc(11) max.mono mult_le_mono
                nat_add_left_cancel_le nat_le_linear prfx_App_iff resid.simps(31) resid_Arr_Ide
                subs subs.simps(4) subs_implies_prfx u u1u2)
          also have "... = mtp x (❙λ❙[t1❙] ❙⦁ t2)"
            by auto
          finally show "mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) ≤ mtp x (❙λ❙[t1❙] ❙⦁ t2)" by blast
        qed
        moreover have "is_Beta u ⟹ mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) ≤ mtp x (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          assume 2: "is_Beta u"
          obtain u1 u2 where u1u2: "u = ❙λ❙[u1❙] ❙⦁ u2"
            using 2 u is_Beta_def by auto
          have "mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) = mtp x (subst (t2 \\ u2) (t1 \\ u1))"
            using u1u2 subs
            by (metis con_def con_sym null_char prfx_implies_con resid.simps(4) subs_implies_prfx)
          also have "... ≤ mtp (Suc x) (resid t1 u1) +
                             mtp x (resid t2 u2) * max 1 (mtp 0 (resid t1 u1))"
            apply (cases "x = 0")
            using mtp0_subst_le Raise_0 mtp_Subst' [of "x - 1" 0 "resid t2 u2" "resid t1 u1"]
            by auto
          also have "... ≤ mtp (Suc x) t1 + mtp x t2 * max 1 (mtp 0 t1)"
            using ind1 ind2
            apply simp
            by (metis Coinitial_iff_Con Ide.simps(1) dual_order.eq_iff elementary_reduction.simps(5)
                ide_char resid.simps(4) resid_Arr_Ide subs subs_implies_prfx u u1u2)
          also have "... = mtp x (❙λ❙[t1❙] ❙⦁ t2)"
            by simp
          finally show "mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) ≤ mtp x (❙λ❙[t1❙] ❙⦁ t2)" by blast
        qed
        ultimately show "mtp x ((❙λ❙[t1❙] ❙⦁ t2) \\ u) ≤ mtp x (❙λ❙[t1❙] ❙⦁ t2)"
          using 1 by blast
      qed
    qed

    text ‹
      Next we define the ``height'' of a term.  This counts the number of steps in a development
      of maximal length of the given term.
    ›

    fun hgt
    where "hgt ❙♯ = 0"
        | "hgt ❙«_❙» = 0"
        | "hgt ❙λ❙[t❙] = hgt t"
        | "hgt (t ❙∘ u) = hgt t + hgt u"
        | "hgt (❙λ❙[t❙] ❙⦁ u) = Suc (hgt t + hgt u * max 1 (mtp 0 t))"

    lemma hgt_resid_ide:
    shows "⟦ide u; u ⊑ t⟧ ⟹ hgt (resid t u) ≤ hgt t"
      by (metis con_sym eq_imp_le resid_arr_ide prfx_implies_con subs_implies_prfx)

    lemma hgt_Raise:
    shows "hgt (Raise l k t) = hgt t"
      using mtpE_eq_Raise
      by (induct t arbitrary: l k) auto

    lemma hgt_Subst:
    shows "Arr u ⟹ hgt (Subst k u t) = hgt t + hgt u * mtp k t"
    proof (induct t arbitrary: u k)
      show "⋀u k. Arr u ⟹ hgt (Subst k u ❙♯) = hgt ❙♯ + hgt u * mtp k ❙♯"
        by simp
      show "⋀x u k. Arr u ⟹ hgt (Subst k u ❙«x❙») = hgt ❙«x❙» + hgt u * mtp k ❙«x❙»"
        using hgt_Raise by auto
      show "⋀t u k. ⟦⋀u k. Arr u ⟹ hgt (Subst k u t) = hgt t + hgt u * mtp k t; Arr u⟧
                       ⟹ hgt (Subst k u ❙λ❙[t❙]) = hgt ❙λ❙[t❙] + hgt u * mtp k ❙λ❙[t❙]"
        by auto
      show "⋀t1 t2 u k.
              ⟦⋀u k. Arr u ⟹ hgt (Subst k u t1) = hgt t1 + hgt u * mtp k t1;
               ⋀u k. Arr u ⟹ hgt (Subst k u t2) = hgt t2 + hgt u * mtp k t2; Arr u⟧
                   ⟹ hgt (Subst k u (t1 ❙∘ t2)) = hgt (t1 ❙∘ t2) + hgt u * mtp k (t1 ❙∘ t2)"
        by (simp add: distrib_left)
      show "⋀t1 t2 u k.
               ⟦⋀u k. Arr u ⟹ hgt (Subst k u t1) = hgt t1 + hgt u * mtp k t1;
                ⋀u k. Arr u ⟹ hgt (Subst k u t2) = hgt t2 + hgt u * mtp k t2; Arr u⟧
                  ⟹ hgt (Subst k u (❙λ❙[t1❙] ❙⦁ t2)) = hgt (❙λ❙[t1❙] ❙⦁ t2) + hgt u * mtp k (❙λ❙[t1❙] ❙⦁ t2)"
      proof -
        fix t1 t2 u k
        assume ind1: "⋀u k. Arr u ⟹ hgt (Subst k u t1) = hgt t1 + hgt u * mtp k t1"
        assume ind2: "⋀u k. Arr u ⟹ hgt (Subst k u t2) = hgt t2 + hgt u * mtp k t2"
        assume u: "Arr u"
        show "hgt (Subst k u (❙λ❙[t1❙] ❙⦁ t2)) = hgt (❙λ❙[t1❙] ❙⦁ t2) + hgt u * mtp k (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          have "hgt (Subst k u (❙λ❙[t1❙] ❙⦁ t2)) =
                Suc (hgt (Subst (Suc k) u t1) +
                  hgt (Subst k u t2) * max 1 (mtp 0 (Subst (Suc k) u t1)))"
            by simp
          also have "... = Suc ((hgt t1 + hgt u * mtp (Suc k) t1) +
                                (hgt t2 + hgt u * mtp k t2) * max 1 (mtp 0 (Subst (Suc k) u t1)))"
            using u ind1 [of u "Suc k"] ind2 [of u k] by simp
          also have "... = Suc (hgt t1 + hgt t2 * max 1 (mtp 0 (Subst (Suc k) u t1)) +
                                hgt u * mtp (Suc k) t1) +
                                hgt u * mtp k t2 * max 1 (mtp 0 (Subst (Suc k) u t1))"
            using comm_semiring_class.distrib by force
          also have "... = Suc (hgt t1 + hgt t2 * max 1 (mtp 0 (Subst (Suc k) u t1)) +
                                hgt u * (mtp (Suc k) t1 +
                                           mtp k t2 * max 1 (mtp 0 (Subst (Suc k) u t1))))"
            by (simp add: distrib_left)
          also have "... = Suc (hgt t1 + hgt t2 * max 1 (mtp 0 t1) +
                                hgt u * (mtp (Suc k) t1 +
                                           mtp k t2 * max 1 (mtp 0 t1)))"
          proof -
            have "mtp 0 (Subst (Suc k) u t1) = mtp 0 t1"
              using mtp⇩0_Subst_cancel by auto
            thus ?thesis by simp
          qed
          also have "... = hgt (❙λ❙[t1❙] ❙⦁ t2) + hgt u * mtp k (❙λ❙[t1❙] ❙⦁ t2)"
            by simp
          finally show ?thesis by blast
        qed
      qed
    qed

    lemma elementary_reduction_decreases_hgt:
    shows "⟦elementary_reduction u; u ⊑ t⟧ ⟹ hgt (t \\ u) < hgt t"
    proof (induct t arbitrary: u)
      show "⋀u. ⟦elementary_reduction u; u ⊑ ❙♯⟧ ⟹ hgt (❙♯ \\ u) < hgt ❙♯"
        by simp
      show "⋀u x. ⟦elementary_reduction u; u ⊑ ❙«x❙»⟧ ⟹ hgt (❙«x❙» \\ u) < hgt ❙«x❙»"
        using Ide.simps(2) elementary_reduction_not_ide ide_backward_stable ide_char
              subs_implies_prfx
        by blast
      show "⋀t u. ⟦⋀u. ⟦elementary_reduction u; u ⊑ t⟧ ⟹ hgt (t \\ u) < hgt t;
                   elementary_reduction u; u ⊑ ❙λ❙[t❙]⟧
                     ⟹ hgt (❙λ❙[t❙] \\ u) < hgt ❙λ❙[t❙]"
      proof -
        fix t u
        assume ind: "⋀u. ⟦elementary_reduction u; u ⊑ t⟧ ⟹ hgt (t \\ u) < hgt t"
        assume u: "elementary_reduction u"
        assume subs: "u ⊑ ❙λ❙[t❙]"
        show "hgt (❙λ❙[t❙] \\ u) < hgt ❙λ❙[t❙]"
          using u subs ind
          apply (cases u)
              apply simp_all
          by fastforce
      qed
      show "⋀t1 t2 u.
              ⟦⋀u. ⟦elementary_reduction u; u ⊑ t1⟧ ⟹ hgt (t1 \\ u) < hgt t1;
               ⋀u. ⟦elementary_reduction u; u ⊑ t2⟧ ⟹ hgt (t2 \\ u) < hgt t2;
               elementary_reduction u; u ⊑ t1 ❙∘ t2⟧
                  ⟹ hgt ((t1 ❙∘ t2) \\ u) < hgt (t1 ❙∘ t2)"
      proof -
        fix t1 t2 u
        assume ind1: "⋀u. ⟦elementary_reduction u; u ⊑ t1⟧ ⟹ hgt (t1 \\ u) < hgt t1"
        assume ind2: "⋀u. ⟦elementary_reduction u; u ⊑ t2⟧ ⟹ hgt (t2 \\ u) < hgt t2"
        assume u: "elementary_reduction u"
        assume subs: "u ⊑ t1 ❙∘ t2"
        show "hgt ((t1 ❙∘ t2) \\ u) < hgt (t1 ❙∘ t2)"
          using u subs ind1 ind2
          apply (cases u)
              apply simp_all
          by (metis add_le_less_mono add_less_le_mono hgt_resid_ide ide_char not_less0
                    zero_less_iff_neq_zero)
      qed
      show "⋀t1 t2 u.
              ⟦⋀u. ⟦elementary_reduction u; u ⊑ t1⟧ ⟹ hgt (t1 \\ u) < hgt t1;
               ⋀u. ⟦elementary_reduction u; u ⊑ t2⟧ ⟹ hgt (t2 \\ u) < hgt t2;
               elementary_reduction u; u ⊑ ❙λ❙[t1❙] ❙⦁ t2⟧
                  ⟹ hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) < hgt (❙λ❙[t1❙] ❙⦁ t2)"
      proof -
        fix t1 t2 u
        assume ind1: "⋀u. ⟦elementary_reduction u; u ⊑ t1⟧ ⟹ hgt (t1 \\ u) < hgt t1"
        assume ind2: "⋀u. ⟦elementary_reduction u; u ⊑ t2⟧ ⟹ hgt (t2 \\ u) < hgt t2"
        assume u: "elementary_reduction u"
        assume subs: "u ⊑ ❙λ❙[t1❙] ❙⦁ t2"
        have "is_App u ∨ is_Beta u"
          using subs by (metis prfx_Beta_iff subs_implies_prfx)
        moreover have "is_App u ⟹ hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) < hgt (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          fix u1 u2
          assume 0: "is_App u"
          obtain u1 u1' u2 where 1: "u = u1 ❙∘ u2 ∧ u1 = ❙λ❙[u1'❙]"
            using u 0
            by (metis ConD(3) Con_implies_is_Lam_iff_is_Lam Con_sym con_def is_App_def is_Lam_def
                      null_char prfx_implies_con subs subs_implies_prfx)
          have "hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) = hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ (u1 ❙∘ u2))"
            using 1 by simp
          also have "... = hgt (❙λ❙[t1 \\ u1'❙] ❙⦁ t2 \\ u2)"
            by (metis "1" Con_sym Ide.simps(1) ide_char resid.simps(6) subs subs_implies_prfx)
          also have "... = Suc (hgt (t1 \\ u1') + hgt (t2 \\ u2) * max (Suc 0) (mtp 0 (t1 \\ u1')))"
            by auto
          also have "... < hgt (❙λ❙[t1❙] ❙⦁ t2)"
          proof -
            have "elementary_reduction (un_App1 u) ∧ ide (un_App2 u) ∨
                  ide (un_App1 u) ∧ elementary_reduction (un_App2 u)"
              using u 1 elementary_reduction_App_iff [of u] by simp
            moreover have "elementary_reduction (un_App1 u) ∧ ide (un_App2 u) ⟹ ?thesis"
            proof -
              assume 2: "elementary_reduction (un_App1 u) ∧ ide (un_App2 u)"
              have "elementary_reduction u1' ∧ ide (un_App2 u)"
                using 1 2 u elementary_reduction_Lam_iff by force
              moreover have "mtp 0 (t1 \\ u1') ≤ mtp 0 t1"
                using 1 calculation elementary_reduction_nonincreases_mtp subs
                      subs.simps(4)
                by blast
              moreover have "mtp 0 (t2 \\ u2) ≤ mtp 0 t2"
                using 1 hgt_resid_ide [of u2 t2]
                by (metis calculation(1) con_sym eq_refl resid_arr_ide lambda.sel(4)
                    prfx_implies_con subs subs.simps(4) subs_implies_prfx)
              ultimately show ?thesis
                using 1 2 ind1 [of u1'] hgt_resid_ide
                apply simp
                by (metis "1" Suc_le_mono ‹mtp 0 (t1 \ u1') ≤ mtp 0 t1› add_less_le_mono
                    le_add1 le_add_same_cancel1 max.mono mult_le_mono subs subs.simps(4))
            qed
            moreover have "ide (un_App1 u) ∧ elementary_reduction (un_App2 u) ⟹ ?thesis"
            proof -
              assume 2: "ide (un_App1 u) ∧ elementary_reduction (un_App2 u)"
              have "ide (un_App1 u) ∧ elementary_reduction u2"
                using 1 2 u elementary_reduction_Lam_iff by force
              moreover have "mtp 0 (t1 \\ u1') ≤ mtp 0 t1"
                using 1 hgt_resid_ide [of u1' t1]
                by (metis Ide.simps(3) calculation con_sym eq_refl ide_char resid_arr_ide
                    lambda.sel(3) prfx_implies_con subs subs.simps(4) subs_implies_prfx)
              moreover have "mtp 0 (t2 \\ u2) ≤ mtp 0 t2"
                using 1 elementary_reduction_nonincreases_mtp subs calculation(1) subs.simps(4)
                by blast
              ultimately show ?thesis
                using 1 2 ind2 [of u2]
                apply simp
                by (metis Coinitial_iff_Con Ide_iff_Src_self Nat.add_0_right add_le_less_mono
                          ide_char Ide.simps(1) subs.simps(4) le_add1 max_nat.neutr_eq_iff
                          mult_less_cancel2 nat.distinct(1) neq0_conv resid_Arr_Src subs
                          subs_implies_prfx)
            qed
            ultimately show ?thesis by blast
          qed
          also have "... = Suc (hgt t1 + hgt t2 * max 1 (mtp 0 t1))"
            by simp
          also have "... = hgt (❙λ❙[t1❙] ❙⦁ t2)"
            by simp
          finally show "hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) < hgt (❙λ❙[t1❙] ❙⦁ t2)"
            by blast
        qed
        moreover have "is_Beta u ⟹ hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) < hgt (❙λ❙[t1❙] ❙⦁ t2)"
        proof -
          fix u1 u2
          assume 0: "is_Beta u"
          obtain u1 u2 where 1: "u = ❙λ❙[u1❙] ❙⦁ u2"
            using u 0 by (metis lambda.collapse(4))
          have "hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) = hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ (❙λ❙[u1❙] ❙⦁ u2))"
            using 1 by simp
          also have "... = hgt (subst (resid t2 u2) (resid t1 u1))"
            by (metis "1" con_def con_sym null_char prfx_implies_con resid.simps(4)
                subs subs_implies_prfx)
          also have "... = hgt (resid t1 u1) + hgt (resid t2 u2) * mtp 0 (resid t1 u1)"
          proof -
            have "Arr (resid t2 u2)"
              by (metis "1" Coinitial_resid_resid Con_sym Ide.simps(1) ide_char resid.simps(4)
                  subs subs_implies_prfx)
            thus ?thesis
              using hgt_Subst [of "resid t2 u2" 0 "resid t1 u1"] by simp
          qed
          also have "... < hgt (❙λ❙[t1❙] ❙⦁ t2)"
          proof -
            have "ide u1 ∧ ide u2"
              using u 1 elementary_reduction_Beta_iff [of u] by auto
           thus ?thesis
             using 1 hgt_resid_ide
             by (metis add_le_mono con_sym hgt.simps(5) resid_arr_ide less_Suc_eq_le
                 max.cobounded2 nat_mult_max_right prfx_implies_con subs subs.simps(5)
                 subs_implies_prfx)
          qed
          finally show "hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) < hgt (❙λ❙[t1❙] ❙⦁ t2)"
            by blast
        qed
        ultimately show "hgt ((❙λ❙[t1❙] ❙⦁ t2) \\ u) < hgt (❙λ❙[t1❙] ❙⦁ t2)" by blast
      qed
    qed

  end

  context reduction_paths
  begin

    lemma length_devel_le_hgt:
    shows "development t U ⟹ length U ≤ Λ.hgt t"
      using Λ.elementary_reduction_decreases_hgt
      by (induct U arbitrary: t, auto, fastforce)

    text ‹
      We finally arrive at the main result of this section:
      the Finite Developments Theorem.
    ›

    theorem finite_developments:
    shows "FD t"
      using length_devel_le_hgt [of t] FD_def by auto

    subsection "Complete Developments"

    text ‹
      A \emph{complete development} is a development in which there are no residuals of originally
      marked redexes left to contract.
    ›

    definition complete_development
    where "complete_development t U ≡ development t U ∧ (Λ.Ide t ∨ [t] ⇧*≲⇧* U)"

    lemma complete_development_Ide_iff:
    shows "complete_development t U ⟹ Λ.Ide t ⟷ U = []"
      using complete_development_def development_Ide Ide.simps(1) ide_char
      by (induct t) auto

    lemma complete_development_cons:
    assumes "complete_development t (u # U)"
    shows "complete_development (t \\ u) U"
      using assms complete_development_def
      by (metis Ide.simps(1) Ide.simps(2) Resid_rec(1) Resid_rec(3)
          complete_development_Ide_iff ide_char development.simps(2)
          Λ.ide_char list.simps(3))

    lemma complete_development_cong:
    shows "⟦complete_development t U; ¬ Λ.Ide t⟧ ⟹ [t] ⇧*∼⇧* U"
      using complete_development_def development_implies
      by (induct U) auto

    lemma complete_developments_cong:
    assumes "¬ Λ.Ide t" and "complete_development t U" and "complete_development t V"
    shows "U ⇧*∼⇧* V"
      using assms complete_development_cong [of "t"] cong_symmetric cong_transitive
      by blast

    lemma Trgs_complete_development:
    shows "⟦complete_development t U; ¬ Λ.Ide t⟧ ⟹ Trgs U = {Λ.Trg t}"
      using complete_development_cong Ide.simps(1) Srcs_Resid Trgs.simps(2)
            Trgs_Resid_sym ide_char complete_development_def development_imp_Arr Λ.targets_char⇩Λ
      apply simp
      by (metis Srcs_Resid Trgs.simps(2) con_char ide_def)

    text ‹
      Now that we know all developments are finite, it is easy to construct a complete development
      by an iterative process that at each stage contracts one of the remaining marked redexes
      at each stage.  It is also possible to construct a complete development by structural
      induction without using the finite developments property, but it is more work to prove the
      correctness.
    ›

    fun (in lambda_calculus) bottom_up_redex
    where "bottom_up_redex ❙♯ = ❙♯"
        | "bottom_up_redex ❙«x❙» = ❙«x❙»"
        | "bottom_up_redex ❙λ❙[M❙] = ❙λ❙[bottom_up_redex M❙]"
        | "bottom_up_redex (M ❙∘ N) =
             (if ¬ Ide M then bottom_up_redex M ❙∘ Src N else M ❙∘ bottom_up_redex N)"
        | "bottom_up_redex (❙λ❙[M❙] ❙⦁ N) =
             (if ¬ Ide M then ❙λ❙[bottom_up_redex M❙] ❙∘ Src N
              else if ¬ Ide N then ❙λ❙[M❙] ❙∘ bottom_up_redex N
              else ❙λ❙[M❙] ❙⦁ N)"

    lemma (in lambda_calculus) elementary_reduction_bottom_up_redex:
    shows "⟦Arr t; ¬ Ide t⟧ ⟹ elementary_reduction (bottom_up_redex t)"
      using Ide_Src
      by (induct t) auto

    lemma (in lambda_calculus) subs_bottom_up_redex:
    shows "Arr t ⟹ bottom_up_redex t ⊑ t"
      apply (induct t)
          apply auto[3]
       apply (metis Arr.simps(4) Ide.simps(4) Ide_Src Ide_iff_Src_self Ide_implies_Arr
                    bottom_up_redex.simps(4) ide_char lambda.disc(14) lambda.sel(3) lambda.sel(4)
                    subs_App subs_Ide)
      by (metis Arr.simps(5) Ide_Src Ide_iff_Src_self Ide_implies_Arr bottom_up_redex.simps(5)
                ide_char subs.simps(4) subs.simps(5) subs_Ide)

    function (sequential) bottom_up_development
    where "bottom_up_development t =
           (if ¬ Λ.Arr t ∨ Λ.Ide t then []
            else Λ.bottom_up_redex t # (bottom_up_development (t \\ Λ.bottom_up_redex t)))"
      by pat_completeness auto

    termination bottom_up_development
      using Λ.elementary_reduction_decreases_hgt Λ.elementary_reduction_bottom_up_redex
            Λ.subs_bottom_up_redex
      by (relation "measure Λ.hgt") auto

    lemma complete_development_bottom_up_development_ind:
    shows "⟦Λ.Arr t; length (bottom_up_development t) ≤ n⟧
              ⟹ complete_development t (bottom_up_development t)"
    proof (induct n arbitrary: t)
      show "⋀t. ⟦Λ.Arr t; length (bottom_up_development t) ≤ 0⟧
                   ⟹ complete_development t (bottom_up_development t)"
        using complete_development_def development_Ide by auto
      show "⋀n t. ⟦⋀t. ⟦Λ.Arr t; length (bottom_up_development t) ≤ n⟧
                           ⟹ complete_development t (bottom_up_development t);
                   Λ.Arr t; length (bottom_up_development t) ≤ Suc n⟧
                     ⟹ complete_development t (bottom_up_development t)"
      proof -
        fix n t
        assume t: "Λ.Arr t"
        assume n: "length (bottom_up_development t) ≤ Suc n"
        assume ind: "⋀t. ⟦Λ.Arr t; length (bottom_up_development t) ≤ n⟧
                           ⟹ complete_development t (bottom_up_development t)"
        show "complete_development t (bottom_up_development t)"
        proof (cases "bottom_up_development t")
          show "bottom_up_development t = [] ⟹ ?thesis"
            using ind t by force
          fix u U
          assume uU: "bottom_up_development t = u # U"
          have 1: "Λ.elementary_reduction u ∧ u ⊑ t"
            using t uU
            by (metis bottom_up_development.simps Λ.elementary_reduction_bottom_up_redex
                list.inject list.simps(3) Λ.subs_bottom_up_redex)
          moreover have "complete_development (Λ.resid t u) U"
            using 1 ind
            by (metis Suc_le_length_iff Λ.arr_char Λ.arr_resid_iff_con bottom_up_development.simps
                      list.discI list.inject n not_less_eq_eq Λ.prfx_implies_con
                      Λ.con_sym Λ.subs_implies_prfx uU)
          ultimately show ?thesis
            by (metis Con_sym Ide.simps(2) Resid_rec(1) Resid_rec(3)
                complete_development_Ide_iff complete_development_def ide_char
                development.simps(2) development_implies Λ.ide_char list.simps(3) uU)
        qed
      qed
    qed

    lemma complete_development_bottom_up_development:
    assumes "Λ.Arr t"
    shows "complete_development t (bottom_up_development t)"
      using assms complete_development_bottom_up_development_ind by blast

  end

  section "Reduction Strategies"

  context lambda_calculus
  begin

    text ‹
      A \emph{reduction strategy} is a function taking an identity term to an arrow having that
      identity as its source.
    ›

    definition reduction_strategy
    where "reduction_strategy f ⟷ (∀t. Ide t ⟶ Coinitial (f t) t)"

    text ‹
      The following defines the iterated application of a reduction strategy to an identity term.
    ›

    fun reduce
    where "reduce f a 0 = a"
        | "reduce f a (Suc n) = reduce f (Trg (f a)) n"

    lemma red_reduce:
    assumes "reduction_strategy f"
    shows "Ide a ⟹ red a (reduce f a n)"
      apply (induct n arbitrary: a, auto)
       apply (metis Ide_iff_Src_self Ide_iff_Trg_self Ide_implies_Arr red.simps)
      by (metis Ide_Trg Ide_iff_Src_self assms red.intros(1) red.intros(2) reduction_strategy_def)

    text ‹
      A reduction strategy is \emph{normalizing} if iterated application of it to a normalizable
      term eventually yields a normal form.
    ›

    definition normalizing_strategy
    where "normalizing_strategy f ⟷ (∀a. normalizable a ⟶ (∃n. NF (reduce f a n)))"

  end

  context reduction_paths
  begin

    text ‹
      The following function constructs the reduction path that results by iterating the
      application of a reduction strategy to a term.
    ›

    fun apply_strategy
    where "apply_strategy f a 0 = []"
        | "apply_strategy f a (Suc n) = f a # apply_strategy f (Λ.Trg (f a)) n"

    lemma apply_strategy_gives_path_ind:
    assumes "Λ.reduction_strategy f"
    shows "⟦Λ.Ide a; n > 0⟧ ⟹ Arr (apply_strategy f a n) ∧
                                length (apply_strategy f a n) = n ∧
                                Src (apply_strategy f a n) = a ∧
                                Trg (apply_strategy f a n) = Λ.reduce f a n"
    proof (induct n arbitrary: a, simp)
      fix n a
      assume ind: "⋀a. ⟦Λ.Ide a; 0 < n⟧ ⟹ Arr (apply_strategy f a n) ∧
                                            length (apply_strategy f a n) = n ∧
                                            Src (apply_strategy f a n) = a ∧
                                            Trg (apply_strategy f a n) = Λ.reduce f a n"
      assume a: "Λ.Ide a"
      show "Arr (apply_strategy f a (Suc n)) ∧
            length (apply_strategy f a (Suc n)) = Suc n ∧
            Src (apply_strategy f a (Suc n)) = a ∧
            Trg (apply_strategy f a (Suc n)) = Λ.reduce f a (Suc n)"
      proof (intro conjI)
        have 1: "Λ.Arr (f a) ∧ Λ.Src (f a) = a"
          using assms a Λ.reduction_strategy_def
          by (metis Λ.Ide_iff_Src_self)
        show "Arr (apply_strategy f a (Suc n))"
          using "1" Arr.elims(3) ind Λ.targets_char⇩Λ Λ.Ide_Trg by fastforce
        show "Src (apply_strategy f a (Suc n)) = a"
          by (simp add: "1")
        show "length (apply_strategy f a (Suc n)) = Suc n"
          by (metis "1" Λ.Ide_Trg One_nat_def Suc_eq_plus1 ind list.size(3) list.size(4)
              neq0_conv apply_strategy.simps(1) apply_strategy.simps(2))
        show "Trg (apply_strategy f a (Suc n)) = Λ.reduce f a (Suc n)"
        proof (cases "apply_strategy f (Λ.Trg (f a)) n = []")
          show "apply_strategy f (Λ.Trg (f a)) n = [] ⟹ ?thesis"
            using a 1 ind [of "Λ.Trg (f a)"] Λ.Ide_Trg Λ.targets_char⇩Λ by force
          assume 2: "apply_strategy f (Λ.Trg (f a)) n ≠ []"
          have "Trg (apply_strategy f a (Suc n)) = Trg (apply_strategy f (Λ.Trg (f a)) n)"
            using a 1 ind [of "Λ.Trg (f a)"]
            by (simp add: "2")
          also have "... = Λ.reduce f a (Suc n)"
            using 1 2 Λ.Ide_Trg ind [of "Λ.Trg (f a)"] by fastforce
          finally show ?thesis by blast
        qed
      qed
    qed

    lemma apply_strategy_gives_path:
    assumes "Λ.reduction_strategy f" and "Λ.Ide a" and "n > 0"
    shows "Arr (apply_strategy f a n)"
    and "length (apply_strategy f a n) = n"
    and "Src (apply_strategy f a n) = a"
    and "Trg (apply_strategy f a n) = Λ.reduce f a n"
      using assms apply_strategy_gives_path_ind by auto

    lemma reduce_eq_Trg_apply_strategy:
    assumes "Λ.reduction_strategy S" and "Λ.Ide a"
    shows "n > 0 ⟹ Λ.reduce S a n = Trg (apply_strategy S a n)"
      using assms
      apply (induct n)
       apply simp_all
      by (metis Arr.simps(1) Trg_simp apply_strategy_gives_path_ind Λ.Ide_Trg
          Λ.reduce.simps(1) Λ.reduction_strategy_def Λ.trg_char neq0_conv
          apply_strategy.simps(1))

  end

  subsection "Parallel Reduction"

  context lambda_calculus
  begin

    text ‹
       \emph{Parallel reduction} is the strategy that contracts all available redexes at each step.
    ›

    fun parallel_strategy
    where "parallel_strategy ❙«i❙» = ❙«i❙»"
        | "parallel_strategy ❙λ❙[t❙] = ❙λ❙[parallel_strategy t❙]"
        | "parallel_strategy (❙λ❙[t❙] ❙∘ u) = ❙λ❙[parallel_strategy t❙] ❙⦁ parallel_strategy u"
        | "parallel_strategy (t ❙∘ u) = parallel_strategy t ❙∘ parallel_strategy u"
        | "parallel_strategy (❙λ❙[t❙] ❙⦁ u) = ❙λ❙[parallel_strategy t❙] ❙⦁ parallel_strategy u"
        | "parallel_strategy ❙♯ = ❙♯"

    lemma parallel_strategy_is_reduction_strategy:
    shows "reduction_strategy parallel_strategy"
    proof (unfold reduction_strategy_def, intro allI impI)
      fix t
      show "Ide t ⟹ Coinitial (parallel_strategy t) t"
        using Ide_implies_Arr
        apply (induct t, auto)
        by force+
    qed

    lemma parallel_strategy_Src_eq:
    shows "Arr t ⟹ parallel_strategy (Src t) = parallel_strategy t"
      by (induct t) auto

    lemma subs_parallel_strategy_Src:
    shows "Arr t ⟹ t ⊑ parallel_strategy (Src t)"
      by (induct t) auto

  end

  context reduction_paths
  begin

    text ‹
     Parallel reduction is a universal strategy in the sense that every reduction path is
     ‹⇧*≲⇧*›-below the path generated by the parallel reduction strategy.
    ›

    lemma parallel_strategy_is_universal:
    shows "⟦n > 0; n ≤ length U; Arr U⟧
              ⟹ take n U ⇧*≲⇧* apply_strategy Λ.parallel_strategy (Src U) n"
    proof (induct n arbitrary: U, simp)
      fix n a and U :: "Λ.lambda list"
      assume n: "Suc n ≤ length U"
      assume U: "Arr U"
      assume ind: "⋀U. ⟦0 < n; n ≤ length U; Arr U⟧
                          ⟹ take n U ⇧*≲⇧* apply_strategy Λ.parallel_strategy (Src U) n"
      have 1: "take (Suc n) U = hd U # take n (tl U)"
        by (metis U Arr.simps(1) take_Suc)
      have 2: "hd U ⊑ Λ.parallel_strategy (Src U)"
        by (metis Arr_imp_arr_hd Con_single_ideI(2) Resid_Arr_Src Src_resid Srcs_simp⇩Λ⇩P
            Trg.simps(2) U Λ.source_is_ide Λ.trg_ide empty_set Λ.arr_char Λ.sources_char⇩Λ
            Λ.subs_parallel_strategy_Src list.set_intros(1) list.simps(15))
      show "take (Suc n) U ⇧*≲⇧* apply_strategy Λ.parallel_strategy (Src U) (Suc n)"
      proof (cases "apply_strategy Λ.parallel_strategy (Src U) (Suc n)")
        show "apply_strategy Λ.parallel_strategy (Src U) (Suc n) = [] ⟹
                take (Suc n) U ⇧*≲⇧* apply_strategy Λ.parallel_strategy (Src U) (Suc n)"
          by simp
        fix v V
        assume 3: "apply_strategy Λ.parallel_strategy (Src U) (Suc n) = v # V"
        show "take (Suc n) U ⇧*≲⇧* apply_strategy Λ.parallel_strategy (Src U) (Suc n)"
        proof (cases "V = []")
          show "V = [] ⟹ ?thesis"
            using 1 2 3 ind ide_char
            by (metis Suc_inject Ide.simps(2) Resid.simps(3) list.discI list.inject
                      Λ.prfx_implies_con apply_strategy.elims Λ.subs_implies_prfx take0)
          assume V: "V ≠ []"
          have 4: "Arr (v # V)"
            using 3 apply_strategy_gives_path(1)
            by (metis Arr_imp_arr_hd Srcs_simp⇩P⇩W⇩E Srcs_simp⇩Λ⇩P U Λ.Ide_Src Λ.arr_iff_has_target
                Λ.parallel_strategy_is_reduction_strategy Λ.targets_char⇩Λ singleton_insert_inj_eq'
                zero_less_Suc)
          have 5: "Arr (hd U # take n (tl U))"
            by (metis 1 U Arr_append_iff⇩P id_take_nth_drop list.discI not_less take_all_iff)
          have 6: "Srcs (hd U # take n (tl U)) = Srcs (v # V)"
            by (metis 2 3 Λ.Coinitial_iff_Con Λ.Ide.simps(1) Srcs.simps(2) Srcs.simps(3)
                Λ.ide_char list.exhaust_sel list.inject apply_strategy.simps(2) Λ.sources_char⇩Λ
                Λ.subs_implies_prfx)
          have "take (Suc n) U ⇧*\\⇧* apply_strategy Λ.parallel_strategy (Src U) (Suc n) =
                [hd U \\ v] ⇧*\\⇧* V @ (take n (tl U) ⇧*\\⇧* [v \\ hd U]) ⇧*\\⇧* (V ⇧*\\⇧* [hd U \\ v])"
            using U V 1 3 4 5 6
            by (metis Resid.simps(1) Resid_cons(1) Resid_rec(3-4) confluence_ind)
          moreover have "Ide ..."
          proof
            have 7: "v = Λ.parallel_strategy (Src U) ∧
                      V = apply_strategy Λ.parallel_strategy (Src U \\ v) n"
              using 3 Λ.subs_implies_prfx Λ.subs_parallel_strategy_Src
              apply simp
              by (metis (full_types) Λ.Coinitial_iff_Con Λ.Ide.simps(1) Λ.Trg.simps(5)
                  Λ.parallel_strategy.simps(9) Λ.resid_Src_Arr)
            show 8: "Ide ([hd U \\ v] ⇧*\\⇧* V)"
              by (metis 2 4 5 6 7 V Con_initial_left Ide.simps(2)
                  confluence_ind Con_rec(3) Resid_Ide_Arr_ind Λ.subs_implies_prfx)
            show 9: "Ide ((take n (tl U) ⇧*\\⇧* [v \\ hd U]) ⇧*\\⇧* (V ⇧*\\⇧* [hd U \\ v]))"
            proof -
              have 10: "Λ.Ide (hd U \\ v)"
                using 2 7 Λ.ide_char Λ.subs_implies_prfx by presburger
              have 11: "V = apply_strategy Λ.parallel_strategy (Λ.Trg v) n"
                using 3 by auto
              have "(take n (tl U) ⇧*\\⇧* [v \\ hd U]) ⇧*\\⇧* (V ⇧*\\⇧* [hd U \\ v]) =
                    (take n (tl U) ⇧*\\⇧* [v \\ hd U]) ⇧*\\⇧*
                       apply_strategy Λ.parallel_strategy (Λ.Trg v) n"
                by (metis 8 10 11 Ide.simps(1) Resid_single_ide(2) Λ.prfx_char)
              moreover have "Ide ..."
              proof -
                have "Ide (take n (take n (tl U) ⇧*\\⇧* [v \\ hd U]) ⇧*\\⇧*
                             apply_strategy Λ.parallel_strategy (Λ.Trg v) n)"
                proof -
                  have "0 < n"
                  proof -
                    have "length V = n"
                      using apply_strategy_gives_path
                      by (metis 10 11 V Λ.Coinitial_iff_Con Λ.Ide_Trg Λ.Arr_not_Nil
                          Λ.Ide_implies_Arr Λ.parallel_strategy_is_reduction_strategy neq0_conv
                          apply_strategy.simps(1))
                    thus ?thesis
                      using V by blast
                  qed
                  moreover have "n ≤ length (take n (tl U) ⇧*\\⇧* [v \\ hd U])"
                  proof -
                    have "length (take n (tl U)) = n"
                      using n by force
                    thus ?thesis
                      using n U length_Resid [of "take n (tl U)" "[v \\ hd U]"]
                      by (metis 4 5 6 Arr.simps(1) Con_cons(2) Con_rec(2)
                          confluence_ind dual_order.eq_iff)
                  qed
                  moreover have "Λ.Trg v = Src (take n (tl U) ⇧*\\⇧* [v \\ hd U])"
                  proof -
                    have "Src (take n (tl U) ⇧*\\⇧* [v \\ hd U]) = Trg [v \\ hd U]"
                      by (metis Src_resid calculation(1-2) linorder_not_less list.size(3))
                    also have "... = Λ.Trg v"
                      by (metis 10 Trg.simps(2) Λ.Arr_not_Nil Λ.apex_sym Λ.trg_ide
                          Λ.Ide_iff_Src_self Λ.Ide_implies_Arr Λ.Src_resid Λ.prfx_char)
                    finally show ?thesis by simp
                  qed
                  ultimately show ?thesis
                    using ind [of "Resid (take n (tl U)) [Λ.resid v (hd U)]"] ide_char
                    by (metis Con_imp_Arr_Resid le_zero_eq less_not_refl list.size(3))
                qed
                moreover have "take n (take n (tl U) ⇧*\\⇧* [v \\ hd U]) =
                               take n (tl U) ⇧*\\⇧* [v \\ hd U]"
                proof -
                  have "Arr (take n (tl U) ⇧*\\⇧* [v \\ hd U])"
                    by (metis Con_imp_Arr_Resid Con_implies_Arr(1) Ide.simps(1) calculation
                        take_Nil)
                  thus ?thesis
                    by (metis 1 Arr.simps(1) length_Resid dual_order.eq_iff length_Cons
                              length_take min.absorb2 n old.nat.inject take_all)
                qed
                ultimately show ?thesis by simp
              qed
              ultimately show ?thesis by auto
            qed
            show "Trg ([hd U \\ v] ⇧*\\⇧* V) =
                  Src ((take n (tl U) ⇧*\\⇧* [v \\ hd U]) ⇧*\\⇧* (V ⇧*\\⇧* [hd U \\ v]))"
              by (metis 9 Ide.simps(1) Src_resid Trg_resid_sym)
          qed
          ultimately show ?thesis
            using ide_char by presburger
        qed
      qed
    qed

  end

  context lambda_calculus
  begin

    text ‹
      Parallel reduction is a normalizing strategy.
    ›

    lemma parallel_strategy_is_normalizing:
    shows "normalizing_strategy parallel_strategy"
    proof -
      interpret Λx: reduction_paths .
      (* TODO: Notation is not inherited here. *)
      have "⋀a. normalizable a ⟹ ∃n. NF (reduce parallel_strategy a n)"
      proof -
        fix a
        assume 1: "normalizable a"
        obtain U b where U: "Λx.Arr U ∧ Λx.Src U = a ∧ Λx.Trg U = b ∧ NF b"
          using 1 normalizable_def Λx.red_iff by blast
        have 2: "⋀n. ⟦0 < n; n ≤ length U⟧
                        ⟹ Λx.Ide (Λx.Resid (take n U) (Λx.apply_strategy parallel_strategy a n))"
          using U Λx.parallel_strategy_is_universal Λx.ide_char by blast
        let ?PR = "Λx.apply_strategy parallel_strategy a (length U)"
        have "Λx.Trg ?PR = b"
        proof -
          have 3: "Λx.Ide (Λx.Resid U ?PR)"
            using U 2 [of "length U"] by force
          have "Λx.Trg (Λx.Resid ?PR U) = b"
            by (metis "3" NF_reduct_is_trivial U Λx.Con_imp_Arr_Resid Λx.Con_sym Λx.Ide.simps(1)
                Λx.Src_resid reduction_paths.red_iff)
          thus ?thesis
            by (metis 3 Λx.Con_Arr_self Λx.Ide_implies_Arr Λx.Resid_Arr_Ide_ind
                Λx.Src_resid Λx.Trg_resid_sym)
        qed
        hence "reduce parallel_strategy a (length U) = b"
          using 1 U
          by (metis Λx.Arr.simps(1) length_greater_0_conv normalizable_def
              Λx.apply_strategy_gives_path(4) parallel_strategy_is_reduction_strategy)
        thus "∃n. NF (reduce parallel_strategy a n)"
          using U by blast
      qed
      thus ?thesis
        using normalizing_strategy_def by blast
    qed

    text ‹
      An alternative characterization of a normal form is a term on which the parallel
      reduction strategy yields an identity.
    ›

    abbreviation has_redex
    where "has_redex t ≡ Arr t ∧ ¬ Ide (parallel_strategy t)"

    lemma NF_iff_has_no_redex:
    shows "Arr t ⟹ NF t ⟷ ¬ has_redex t"
    proof (induct t)
      show "Arr ❙♯ ⟹ NF ❙♯ ⟷ ¬ has_redex ❙♯"
        using NF_def by simp
      show "⋀x. Arr ❙«x❙» ⟹ NF ❙«x❙» ⟷ ¬ has_redex ❙«x❙»"
        using NF_def by force
      show "⋀t. ⟦Arr t ⟹ NF t ⟷ ¬ has_redex t; Arr ❙λ❙[t❙]⟧ ⟹ NF ❙λ❙[t❙] ⟷ ¬ has_redex ❙λ❙[t❙]"
      proof -
        fix t
        assume ind: "Arr t ⟹ NF t ⟷ ¬ has_redex t"
        assume t: "Arr ❙λ❙[t❙]"
        show "NF ❙λ❙[t❙] ⟷ ¬ has_redex ❙λ❙[t❙]"
        proof
          show "NF ❙λ❙[t❙] ⟹ ¬ has_redex ❙λ❙[t❙]"
            using t ind
            by (metis NF_def Arr.simps(3) Ide.simps(3) Src.simps(3) parallel_strategy.simps(2))
          show "¬ has_redex ❙λ❙[t❙] ⟹ NF ❙λ❙[t❙]"
            using t ind
            by (metis NF_def ide_backward_stable ide_char parallel_strategy_Src_eq
                subs_implies_prfx subs_parallel_strategy_Src)
        qed
      qed
      show "⋀t1 t2. ⟦Arr t1 ⟹ NF t1 ⟷ ¬ has_redex t1;
                     Arr t2 ⟹ NF t2 ⟷ ¬ has_redex t2;
                     Arr (❙λ❙[t1❙] ❙⦁ t2)⟧
                        ⟹ NF (❙λ❙[t1❙] ❙⦁ t2) ⟷ ¬ has_redex (❙λ❙[t1❙] ❙⦁ t2)"
        using NF_def Ide.simps(5) parallel_strategy.simps(8) by presburger
      show "⋀t1 t2. ⟦Arr t1 ⟹ NF t1 ⟷ ¬ has_redex t1;
                     Arr t2 ⟹ NF t2 ⟷ ¬ has_redex t2;
                     Arr (t1 ❙∘ t2)⟧
                        ⟹ NF (t1 ❙∘ t2) ⟷ ¬ has_redex (t1 ❙∘ t2)"
      proof -
        fix t1 t2
        assume ind1: "Arr t1 ⟹ NF t1 ⟷ ¬ has_redex t1"
        assume ind2: "Arr t2 ⟹ NF t2 ⟷ ¬ has_redex t2"
        assume t: "Arr (t1 ❙∘ t2)"
        show "NF (t1 ❙∘ t2) ⟷ ¬ has_redex (t1 ❙∘ t2)"
          using t ind1 ind2 NF_def
          apply (intro iffI)
           apply (metis Ide_iff_Src_self parallel_strategy_is_reduction_strategy
              reduction_strategy_def)
          apply (cases t1)
              apply simp_all
           apply (metis Ide_iff_Src_self ide_char parallel_strategy.simps(1,5)
              parallel_strategy_is_reduction_strategy reduction_strategy_def resid_Arr_Src
              subs_implies_prfx subs_parallel_strategy_Src)
          by (metis Ide_iff_Src_self ide_char ind1 Arr.simps(4) parallel_strategy.simps(6)
              parallel_strategy_is_reduction_strategy reduction_strategy_def resid_Arr_Src
              subs_implies_prfx subs_parallel_strategy_Src)
      qed
    qed

    lemma (in lambda_calculus) not_NF_elim:
    assumes "¬ NF t" and "Ide t"
    obtains u where "coinitial t u ∧ ¬ Ide u"
      using assms NF_def by auto

    lemma (in lambda_calculus) NF_Lam_iff:
    shows "NF ❙λ❙[t❙] ⟷ NF t"
      using NF_def
      by (metis Ide_implies_Arr NF_iff_has_no_redex Ide.simps(3) parallel_strategy.simps(2))

    lemma (in lambda_calculus) NF_App_iff:
    shows "NF (t1 ❙∘ t2) ⟷ ¬ is_Lam t1 ∧ NF t1 ∧ NF t2"
    proof -
      have "¬ NF (t1 ❙∘ t2) ⟹ is_Lam t1 ∨ ¬ NF t1 ∨ ¬ NF t2"
        apply (cases "is_Lam t1")
         apply simp_all
        apply (cases t1)
            apply simp_all
        using NF_def Ide.simps(1) apply presburger
          apply (metis Ide_implies_Arr NF_def NF_iff_has_no_redex Ide.simps(4)
            parallel_strategy.simps(5))
        apply (metis Ide_implies_Arr NF_def NF_iff_has_no_redex Ide.simps(4)
            parallel_strategy.simps(6))
        using NF_def Ide.simps(5) by presburger
      moreover have "is_Lam t1 ∨ ¬ NF t1 ∨ ¬ NF t2 ⟹ ¬ NF (t1 ❙∘ t2)"
      proof -
        have "is_Lam t1 ⟹ ¬NF (t1 ❙∘ t2)"
          by (metis Ide_implies_Arr NF_def NF_iff_has_no_redex Ide.simps(5) lambda.collapse(2)
              parallel_strategy.simps(3,8))
        moreover have "¬ NF t1 ⟹ ¬NF (t1 ❙∘ t2)"
          using NF_def Ide_iff_Src_self Ide_implies_Arr
          apply auto
          by (metis (full_types) Arr.simps(4) Ide.simps(4) Src.simps(4))
        moreover have "¬ NF t2 ⟹ ¬NF (t1 ❙∘ t2)"
          using NF_def Ide_iff_Src_self Ide_implies_Arr
          apply auto
          by (metis (full_types) Arr.simps(4) Ide.simps(4) Src.simps(4))
        ultimately show "is_Lam t1 ∨ ¬ NF t1 ∨ ¬ NF t2 ⟹ ¬ NF (t1 ❙∘ t2)"
          by auto
      qed
      ultimately show ?thesis by blast
    qed

    subsection "Head Reduction"

    text ‹
      \emph{Head reduction} is the strategy that only contracts a redex at the ``head'' position,
      which is found at the end of the ``left spine'' of applications, and does nothing if there is
      no such redex.

      The following function applies to an arbitrary arrow ‹t›, and it marks the redex at
      the head position, if any, otherwise it yields ‹Src t›.
    ›

    fun head_strategy
    where "head_strategy ❙«i❙» = ❙«i❙»"
        | "head_strategy ❙λ❙[t❙] = ❙λ❙[head_strategy t❙]"
        | "head_strategy (❙λ❙[t❙] ❙∘ u) = ❙λ❙[Src t❙] ❙⦁ Src u"
        | "head_strategy (t ❙∘ u) = head_strategy t ❙∘ Src u"
        | "head_strategy (❙λ❙[t❙] ❙⦁ u) = ❙λ❙[Src t❙] ❙⦁ Src u"
        | "head_strategy ❙♯ = ❙♯"

    lemma Arr_head_strategy:
    shows "Arr t ⟹ Arr (head_strategy t)"
      apply (induct t)
          apply auto
    proof -
      fix t u
      assume ind: "Arr (head_strategy t)"
      assume t: "Arr t" and u: "Arr u"
      show "Arr (head_strategy (t ❙∘ u))"
        using t u ind
        by (cases t) auto
    qed

    lemma Src_head_strategy:
    shows "Arr t ⟹ Src (head_strategy t) = Src t"
      apply (induct t)
          apply auto
    proof -
      fix t u
      assume ind: "Src (head_strategy t) = Src t"
      assume t: "Arr t" and u: "Arr u"
      have "Src (head_strategy (t ❙∘ u)) = Src (head_strategy t ❙∘ Src u)"
        using t ind
        by (cases t) auto
      also have "... = Src t ❙∘ Src u"
        using t u ind by auto
      finally show "Src (head_strategy (t ❙∘ u)) = Src t ❙∘ Src u" by simp
    qed

    lemma Con_head_strategy:
    shows "Arr t ⟹ Con t (head_strategy t)"
      apply (induct t)
          apply auto
       apply (simp add: Arr_head_strategy Src_head_strategy)
      using Arr_Subst Arr_not_Nil by auto

    lemma head_strategy_Src:
    shows "Arr t ⟹ head_strategy (Src t) = head_strategy t"
      apply (induct t)
          apply auto
      using Arr.elims(2) by fastforce

    lemma head_strategy_is_elementary:
    shows "⟦Arr t; ¬ Ide (head_strategy t)⟧ ⟹ elementary_reduction (head_strategy t)"
      using Ide_Src
      apply (induct t)
          apply auto
    proof -
      fix t1 t2
      assume t1: "Arr t1" and t2: "Arr t2"
      assume t: "¬ Ide (head_strategy (t1 ❙∘ t2))"
      assume 1: "¬ Ide (head_strategy t1) ⟹ elementary_reduction (head_strategy t1)"
      assume 2: "¬ Ide (head_strategy t2) ⟹ elementary_reduction (head_strategy t2)"
      show "elementary_reduction (head_strategy (t1 ❙∘ t2))"
        using t t1 t2 1 2 Ide_Src Ide_implies_Arr
        by (cases t1) auto
    qed

    lemma head_strategy_is_reduction_strategy:
    shows "reduction_strategy head_strategy"
    proof (unfold reduction_strategy_def, intro allI impI)
      fix t
      show "Ide t ⟹ Coinitial (head_strategy t) t"
      proof (induct t)
        show "Ide ❙♯ ⟹ Coinitial (head_strategy ❙♯) ❙♯"
          by simp
        show "⋀x. Ide ❙«x❙» ⟹ Coinitial (head_strategy ❙«x❙») ❙«x❙»"
          by simp
        show "⋀t. ⟦Ide t ⟹ Coinitial (head_strategy t) t; Ide ❙λ❙[t❙]⟧
                      ⟹ Coinitial (head_strategy ❙λ❙[t❙]) ❙λ❙[t❙]"
          by simp
        fix t1 t2
          assume ind1: "Ide t1 ⟹ Coinitial (head_strategy t1) t1"
        assume ind2: "Ide t2 ⟹ Coinitial (head_strategy t2) t2"
        assume t: "Ide (t1 ❙∘ t2)"
        show "Coinitial (head_strategy (t1 ❙∘ t2)) (t1 ❙∘ t2)"
          using t ind1 Ide_implies_Arr Ide_iff_Src_self
          by (cases t1) simp_all
        next
        fix t1 t2
        assume ind1: "Ide t1 ⟹ Coinitial (head_strategy t1) t1"
        assume ind2: "Ide t2 ⟹ Coinitial (head_strategy t2) t2"
        assume t: "Ide (❙λ❙[t1❙] ❙⦁ t2)"
        show "Coinitial (head_strategy (❙λ❙[t1❙] ❙⦁ t2)) (❙λ❙[t1❙] ❙⦁ t2)"
          using t by auto
      qed
    qed

    text ‹
      The following function tests whether a term is an elementary reduction of the head redex.
    ›

    fun is_head_reduction
    where "is_head_reduction ❙«_❙» ⟷ False"
        | "is_head_reduction ❙λ❙[t❙] ⟷ is_head_reduction t"
        | "is_head_reduction (❙λ❙[_❙] ❙∘ _) ⟷ False"
        | "is_head_reduction (t ❙∘ u) ⟷ is_head_reduction t ∧ Ide u"
        | "is_head_reduction (❙λ❙[t❙] ❙⦁ u) ⟷ Ide t ∧ Ide u"
        | "is_head_reduction ❙♯ ⟷ False"

    lemma is_head_reduction_char:
    shows "is_head_reduction t ⟷ elementary_reduction t ∧ head_strategy (Src t) = t"
      apply (induct t)
          apply simp_all
    proof -
      fix t1 t2
      assume ind: "is_head_reduction t1 ⟷
                   elementary_reduction t1 ∧ head_strategy (Src t1) = t1"
      show "is_head_reduction (t1 ❙∘ t2) ⟷
             (elementary_reduction t1 ∧ Ide t2 ∨ Ide t1 ∧ elementary_reduction t2) ∧
              head_strategy (Src t1 ❙∘ Src t2) = t1 ❙∘ t2"
        using ind Ide_implies_Arr Ide_iff_Src_self Ide_Src elementary_reduction_not_ide
              ide_char
        apply (cases t1)
            apply simp_all
          apply (metis Ide_Src arr_char elementary_reduction_is_arr)
         apply (metis Ide_Src arr_char elementary_reduction_is_arr)
        by metis
      next
      fix t1 t2
      show "Ide t1 ∧ Ide t2 ⟷ Ide t1 ∧ Ide t2 ∧ Src (Src t1) = t1 ∧ Src (Src t2) = t2"
        by (metis Ide_iff_Src_self Ide_implies_Arr)
    qed

    lemma is_head_reductionI:
    assumes "Arr t" and "elementary_reduction t" and "head_strategy (Src t) = t"
    shows "is_head_reduction t"
      using assms is_head_reduction_char by blast

    text ‹
      The following function tests whether a redex in the head position of a term is marked.
    ›

    fun contains_head_reduction
    where "contains_head_reduction ❙«_❙» ⟷ False"
        | "contains_head_reduction ❙λ❙[t❙] ⟷ contains_head_reduction t"
        | "contains_head_reduction (❙λ❙[_❙] ❙∘ _) ⟷ False"
        | "contains_head_reduction (t ❙∘ u) ⟷ contains_head_reduction t ∧ Arr u"
        | "contains_head_reduction (❙λ❙[t❙] ❙⦁ u) ⟷ Arr t ∧ Arr u"
        | "contains_head_reduction ❙♯ ⟷ False"

    lemma is_head_reduction_imp_contains_head_reduction:
    shows "is_head_reduction t ⟹ contains_head_reduction t"
      using Ide_implies_Arr
      apply (induct t)
          apply auto
    proof -
      fix t1 t2
      assume ind1: "is_head_reduction t1 ⟹ contains_head_reduction t1"
      assume ind2: "is_head_reduction t2 ⟹ contains_head_reduction t2"
      assume t: "is_head_reduction (t1 ❙∘ t2)"
      show "contains_head_reduction (t1 ❙∘ t2)"
        using t ind1 ind2 Ide_implies_Arr
        by (cases t1) auto
    qed

    text ‹
      An \emph{internal reduction} is one that does not contract any redex at the head position.
    ›

    fun is_internal_reduction
    where "is_internal_reduction ❙«_❙» ⟷ True"
        | "is_internal_reduction ❙λ❙[t❙] ⟷ is_internal_reduction t"
        | "is_internal_reduction (❙λ❙[t❙] ❙∘ u) ⟷ Arr t ∧ Arr u"
        | "is_internal_reduction (t ❙∘ u) ⟷ is_internal_reduction t ∧ Arr u"
        | "is_internal_reduction (❙λ❙[_❙] ❙⦁ _) ⟷ False"
        | "is_internal_reduction ❙♯ ⟷ False"

    lemma is_internal_reduction_iff:
    shows "is_internal_reduction t ⟷ Arr t ∧ ¬ contains_head_reduction t"
      apply (induct t)
          apply simp_all
    proof -
      fix t1 t2
      assume ind1: "is_internal_reduction t1 ⟷ Arr t1 ∧ ¬ contains_head_reduction t1"
      assume ind2: "is_internal_reduction t2 ⟷ Arr t2 ∧ ¬ contains_head_reduction t2"
      show "is_internal_reduction (t1 ❙∘ t2) ⟷
            Arr t1 ∧ Arr t2 ∧ ¬ contains_head_reduction (t1 ❙∘ t2)"
        using ind1 ind2
        apply (cases t1)
            apply simp_all
        by blast
    qed

    text ‹
      Head reduction steps are either ‹≲›-prefixes of, or are preserved by, residuation along
      arbitrary reductions.
    ›

    lemma is_head_reduction_resid:
    shows "⟦is_head_reduction t; Arr u; Src t = Src u⟧ ⟹ t ≲ u ∨ is_head_reduction (t \\ u)"
    proof (induct t arbitrary: u)
      show "⋀u. ⟦is_head_reduction ❙♯; Arr u; Src ❙♯ = Src u⟧
                   ⟹ ❙♯ ≲ u ∨ is_head_reduction (❙♯ \\ u)"
        by auto
      show "⋀x u. ⟦is_head_reduction ❙«x❙»; Arr u; Src ❙«x❙» = Src u⟧
                     ⟹ ❙«x❙» ≲ u ∨ is_head_reduction (❙«x❙» \\ u)"
        by auto
      fix t u
      assume ind: "⋀u. ⟦is_head_reduction t; Arr u; Src t = Src u⟧
                          ⟹ t ≲ u ∨ is_head_reduction (t \\ u)"
      assume t: "is_head_reduction ❙λ❙[t❙]"
      assume u: "Arr u"
      assume tu: "Src ❙λ❙[t❙] = Src u"
      have 1: "Arr t"
        by (metis Arr_head_strategy head_strategy_Src is_head_reduction_char Arr.simps(3) t tu u)
      show " ❙λ❙[t❙] ≲ u ∨ is_head_reduction (❙λ❙[t❙] \\ u)"
        using t u tu 1 ind
        by (cases u) auto
      next
      fix t1 t2 u
      assume ind1: "⋀u1. ⟦is_head_reduction t1; Arr u1; Src t1 = Src u1⟧
                           ⟹ t1 ≲ u1 ∨ is_head_reduction (t1 \\ u1)"
      assume ind2: "⋀u2. ⟦is_head_reduction t2; Arr u2; Src t2 = Src u2⟧
                           ⟹ t2 ≲ u2 ∨ is_head_reduction (t2 \\ u2)"
      assume t: "is_head_reduction (❙λ❙[t1❙] ❙⦁ t2)"
      assume u: "Arr u"
      assume tu: "Src (❙λ❙[t1❙] ❙⦁ t2) = Src u"
      show "❙λ❙[t1❙] ❙⦁ t2 ≲ u ∨ is_head_reduction ((❙λ❙[t1❙] ❙⦁ t2) \\ u)"
        using t u tu ind1 ind2 Coinitial_iff_Con Ide_implies_Arr ide_char resid_Ide_Arr Ide_Subst
        by (cases u; cases "un_App1 u") auto
      next
      fix t1 t2 u
      assume ind1: "⋀u1. ⟦is_head_reduction t1; Arr u1; Src t1 = Src u1⟧
                           ⟹ t1 ≲ u1 ∨ is_head_reduction (t1 \\ u1)"
      assume ind2: "⋀u2. ⟦is_head_reduction t2; Arr u2; Src t2 = Src u2⟧
                           ⟹ t2 ≲ u2 ∨ is_head_reduction (t2 \\ u2)"
      assume t: "is_head_reduction (t1 ❙∘ t2)"
      assume u: "Arr u"
      assume tu: "Src (t1 ❙∘ t2) = Src u"
      have "Arr (t1 ❙∘ t2)"
        using is_head_reduction_char elementary_reduction_is_arr t by blast
      hence t1: "Arr t1" and t2: "Arr t2"
        by auto
      have 0: "¬ is_Lam t1"
        using t is_Lam_def by fastforce
      have 1: "is_head_reduction t1"
        using t t1 by force
      show "t1 ❙∘ t2 ≲ u ∨ is_head_reduction ((t1 ❙∘ t2) \\ u) "
      proof -
        have "¬ Ide ((t1 ❙∘ t2) \\ u) ⟹ is_head_reduction ((t1 ❙∘ t2) \\ u)"
        proof (intro is_head_reductionI)
          assume 2: "¬ Ide ((t1 ❙∘ t2) \\ u)"
          have 3: "is_App u ⟹ ¬ Ide (t1 \\ un_App1 u) ∨ ¬ Ide (t2 \\ un_App2 u)"
            by (metis "2" ide_char lambda.collapse(3) lambda.discI(3) lambda.sel(3-4) prfx_App_iff)
          have 4: "is_Beta u ⟹ ¬ Ide (t1 \\ un_Beta1 u) ∨ ¬ Ide (t2 \\ un_Beta2 u)"
            using u tu 2
            by (metis "0" ConI Con_implies_is_Lam_iff_is_Lam ‹Arr (t1 ❙∘ t2)›
                ConD(4) lambda.collapse(4) lambda.disc(8))
          show 5: "Arr ((t1 ❙∘ t2) \\ u)"
            using Arr_resid ‹Arr (t1 ❙∘ t2)› tu u by auto
          show "head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
          proof (cases u)
            show "u = ❙♯ ⟹ head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
              by simp
            show "⋀x. u = ❙«x❙» ⟹ head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
              by auto
            show "⋀v. u = ❙λ❙[v❙] ⟹ head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
              by simp
            show "⋀u1 u2. u = ❙λ❙[u1❙] ❙⦁ u2 ⟹ head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
              by (metis "0" "5" Arr_not_Nil ConD(4) Con_implies_is_Lam_iff_is_Lam lambda.disc(8))
            show "⋀u1 u2. u = App u1 u2 ⟹ head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
            proof -
              fix u1 u2
              assume u1u2: "u = u1 ❙∘ u2"
              have "head_strategy (Src ((t1 ❙∘ t2) \\ u)) =
                    head_strategy (Src (t1 \\ u1) ❙∘ Src (t2 \\ u2))"
                using u u1u2 tu t1 t2 Coinitial_iff_Con by auto
              also have "... = head_strategy (Trg u1 ❙∘ Trg u2)"
                using 5 u1u2 Src_resid
                by (metis Arr_not_Nil ConD(1))
              also have "... = (t1 ❙∘ t2) \\ u"
              proof (cases "Trg u1")
                show "Trg u1 = ❙♯ ⟹ head_strategy (Trg u1 ❙∘ Trg u2) = (t1 ❙∘ t2) \\ u"
                  using Arr_not_Nil u u1u2 by force
                show "⋀x. Trg u1 = ❙«x❙» ⟹ head_strategy (Trg u1 ❙∘ Trg u2) = (t1 ❙∘ t2) \\ u"
                  using tu t u t1 t2 u1u2 Arr_not_Nil Ide_iff_Src_self
                  by (cases u1; cases t1) auto
                show "⋀v. Trg u1 = ❙λ❙[v❙] ⟹ head_strategy (Trg u1 ❙∘ Trg u2) = (t1 ❙∘ t2) \\ u"
                  using tu t u t1 t2 u1u2 Arr_not_Nil Ide_iff_Src_self
                  apply (cases u1; cases t1)
                                      apply auto
                  by (metis 2 5 Src_resid Trg.simps(3-4) resid.simps(3-4) resid_Src_Arr)
                show "⋀u11 u12. Trg u1 = u11 ❙∘ u12
                                   ⟹ head_strategy (Trg u1 ❙∘ Trg u2) = (t1 ❙∘ t2) \\ u"
                proof -
                  fix u11 u12
                  assume u1: "Trg u1 = u11 ❙∘ u12"
                  show "head_strategy (Trg u1 ❙∘ Trg u2) = (t1 ❙∘ t2) \\ u"
                  proof (cases "Trg u1")
                    show "Trg u1 = ❙♯ ⟹ ?thesis"
                      using u1 by simp
                    show "⋀x. Trg u1 = ❙«x❙» ⟹ ?thesis"
                      apply simp
                      using u1 by force
                    show "⋀v. Trg u1 = ❙λ❙[v❙] ⟹ ?thesis"
                      using u1 by simp
                    show "⋀u11 u12. Trg u1 = u11 ❙∘ u12 ⟹ ?thesis"
                      using t u tu u1u2 1 2 ind1 elementary_reduction_not_ide
                            is_head_reduction_char Src_resid Ide_iff_Src_self
                            ‹Arr (t1 ❙∘ t2)› Coinitial_iff_Con
                      by fastforce
                    show "⋀u11 u12. Trg u1 = ❙λ❙[u11❙] ❙⦁ u12 ⟹ ?thesis"
                      using u1 by simp
                  qed
                qed
                show "⋀u11 u12. Trg u1 = ❙λ❙[u11❙] ❙⦁ u12 ⟹ ?thesis"
                  using u1u2 u Ide_Trg by fastforce
              qed
              finally show "head_strategy (Src ((t1 ❙∘ t2) \\ u)) = (t1 ❙∘ t2) \\ u"
                by simp
            qed
          qed
          thus "elementary_reduction ((t1 ❙∘ t2) \\ u)"
            by (metis 2 5 Ide_Src Ide_implies_Arr head_strategy_is_elementary)
        qed
        thus ?thesis by blast
      qed
    qed

    text ‹
       Internal reductions are closed under residuation.
    ›

    lemma is_internal_reduction_resid:
    shows "⟦is_internal_reduction t; is_internal_reduction u; Src t = Src u⟧
              ⟹ is_internal_reduction (t \\ u)"
      apply (induct t arbitrary: u)
          apply auto
      apply (metis Con_implies_Arr2 con_char weak_extensionality Arr.simps(2) Src.simps(2)
                   parallel_strategy.simps(1) prfx_implies_con resid_Arr_Src subs_Ide
                   subs_implies_prfx subs_parallel_strategy_Src)
    proof -
      fix t u
      assume ind: "⋀u. ⟦is_internal_reduction u; Src t = Src u⟧ ⟹ is_internal_reduction (t \\ u)"
      assume t: "is_internal_reduction t"
      assume u: "is_internal_reduction u"
      assume tu: "❙λ❙[Src t❙] = Src u"
      show "is_internal_reduction (❙λ❙[t❙] \\ u)"
        using t u tu ind
        apply (cases u)
        by auto fastforce
      next
      fix t1 t2 u
      assume ind1: "⋀u. ⟦is_internal_reduction t1; is_internal_reduction u; Src t1 = Src u⟧
                            ⟹ is_internal_reduction (t1 \\ u)"
      assume t: "is_internal_reduction (t1 ❙∘ t2)"
      assume u: "is_internal_reduction u"
      assume tu: "Src t1 ❙∘ Src t2 = Src u"
      show "is_internal_reduction ((t1 ❙∘ t2) \\ u)"
        using t u tu ind1 Coinitial_resid_resid Coinitial_iff_Con Arr_Src
              is_internal_reduction_iff
        apply auto
         apply (metis Arr.simps(4) Src.simps(4))
      proof -
        assume t1: "Arr t1" and t2: "Arr t2" and u: "Arr u"
        assume tu: "Src t1 ❙∘ Src t2 = Src u"
        assume 1: "¬ contains_head_reduction u"
        assume 2: "¬ contains_head_reduction (t1 ❙∘ t2)"
        assume 3: "contains_head_reduction ((t1 ❙∘ t2) \\ u)"
        show False
          using t1 t2 u tu 1 2 3 is_internal_reduction_iff
          apply (cases u)
              apply simp_all
          apply (cases t1; cases "un_App1 u")
                              apply simp_all
          by (metis Coinitial_iff_Con ind1 Arr.simps(4) Src.simps(4) resid.simps(3))
      qed
    qed

    text ‹
      A head reduction is preserved by residuation along an internal reduction,
      so a head reduction can only be canceled by a transition that contains a head reduction.
    ›

    lemma is_head_reduction_resid':
    shows "⟦is_head_reduction t; is_internal_reduction u; Src t = Src u⟧
               ⟹ is_head_reduction (t \\ u)"
    proof (induct t arbitrary: u)
      show "⋀u. ⟦is_head_reduction ❙♯; is_internal_reduction u; Src ❙♯ = Src u⟧
                   ⟹ is_head_reduction (❙♯ \\ u)"
        by simp
      show "⋀x u. ⟦is_head_reduction ❙«x❙»; is_internal_reduction u; Src ❙«x❙» = Src u⟧
                     ⟹ is_head_reduction (❙«x❙» \\ u)"
        by simp
      show "⋀t. ⟦⋀u. ⟦is_head_reduction t; is_internal_reduction u; Src t = Src u⟧
                         ⟹ is_head_reduction (t \\ u);
                       is_head_reduction ❙λ❙[t❙]; is_internal_reduction u; Src ❙λ❙[t❙] = Src u⟧
                    ⟹ is_head_reduction (❙λ❙[t❙] \\ u)"
        for u
        by (cases u, simp_all) fastforce
      fix t1 t2 u
      assume ind1: "⋀u. ⟦is_head_reduction t1; is_internal_reduction u; Src t1 = Src u⟧
                            ⟹ is_head_reduction (t1 \\ u)"
      assume t: "is_head_reduction (t1 ❙∘ t2)"
      assume u: "is_internal_reduction u"
      assume tu: "Src (t1 ❙∘ t2) = Src u"
      show "is_head_reduction ((t1 ❙∘ t2) \\ u)"
        using t u tu ind1
        apply (cases u)
           apply simp_all
      proof (intro conjI impI)
        fix u1 u2
        assume u1u2: "u = u1 ❙∘ u2"
        show 1: "Con t1 u1"
          using Coinitial_iff_Con tu u1u2 ide_char
          by (metis ConD(1) Ide.simps(1) is_head_reduction.simps(9) is_head_reduction_resid
              is_internal_reduction.simps(9) is_internal_reduction_resid t u)
        show "Con t2 u2"
          using Coinitial_iff_Con tu u1u2 ide_char
          by (metis ConD(1) Ide.simps(1) is_head_reduction.simps(9) is_head_reduction_resid
              is_internal_reduction.simps(9) is_internal_reduction_resid t u)
        show "is_head_reduction (t1 \\ u1 ❙∘ t2 \\ u2)"
          using t u u1u2 1 Coinitial_iff_Con ‹Con t2 u2› ide_char ind1 resid_Ide_Arr
          apply (cases t1; simp_all; cases u1; simp_all; cases "un_App1 u1")
                   apply auto
          by (metis 1 ind1 is_internal_reduction.simps(6) resid.simps(3))
      qed
      next
      fix t1 t2 u
      assume ind1: "⋀u. ⟦is_head_reduction t1; is_internal_reduction u; Src t1 = Src u⟧
                            ⟹ is_head_reduction (t1 \\ u)"
      assume t: "is_head_reduction (❙λ❙[t1❙] ❙⦁ t2)"
      assume u: "is_internal_reduction u"
      assume tu: "Src (❙λ❙[t1❙] ❙⦁ t2) = Src u"
      show "is_head_reduction ((❙λ❙[t1❙] ❙⦁ t2) \\ u)"
        using t u tu ind1
        apply (cases u)
            apply simp_all
        by (metis Con_implies_Arr1 is_head_reduction_resid is_internal_reduction.simps(9)
            is_internal_reduction_resid lambda.disc(15) prfx_App_iff t tu)
    qed

    text ‹
      The following function differs from ‹head_strategy› in that it only selects an already-marked
      redex, whereas ‹head_strategy› marks the redex at the head position.
    ›

    fun head_redex
    where "head_redex ❙♯ = ❙♯"
        | "head_redex ❙«x❙» = ❙«x❙»"
        | "head_redex ❙λ❙[t❙] = ❙λ❙[head_redex t❙]"
        | "head_redex (❙λ❙[t❙] ❙∘ u) = ❙λ❙[Src t❙] ❙∘ Src u"
        | "head_redex (t ❙∘ u) = head_redex t ❙∘ Src u"
        | "head_redex (❙λ❙[t❙] ❙⦁ u) = (❙λ❙[Src t❙] ❙⦁ Src u)"

    lemma elementary_reduction_head_redex:
    shows "⟦Arr t; ¬ Ide (head_redex t)⟧ ⟹ elementary_reduction (head_redex t)"
      using Ide_Src
      apply (induct t)
          apply auto
    proof -
      show "⋀t2. ⟦¬ Ide (head_redex t1) ⟹ elementary_reduction (head_redex t1);
                  ¬ Ide (head_redex (t1 ❙∘ t2));
                  ⋀t. Arr t ⟹ Ide (Src t); Arr t1; Arr t2⟧
                     ⟹ elementary_reduction (head_redex (t1 ❙∘ t2))"
        for t1
        using Ide_Src
        by (cases t1) auto
    qed

    lemma subs_head_redex:
    shows "Arr t ⟹ head_redex t ⊑ t"
      using Ide_Src subs_Ide
      apply (induct t)
          apply simp_all
    proof -
      show "⋀t2. ⟦head_redex t1 ⊑ t1; head_redex t2 ⊑ t2;
                  Arr t1 ∧ Arr t2; ⋀t. Arr t ⟹ Ide (Src t);
                  ⋀u t. ⟦Ide u; Src t = Src u⟧ ⟹ u ⊑ t⟧
                    ⟹ head_redex (t1 ❙∘ t2) ⊑ t1 ❙∘ t2"
        for t1
        using Ide_Src subs_Ide
        by (cases t1) auto
    qed

    lemma contains_head_reduction_iff:
    shows "contains_head_reduction t ⟷ Arr t ∧ ¬ Ide (head_redex t)"
      apply (induct t)
          apply simp_all
    proof -
      show "⋀t2. contains_head_reduction t1 = (Arr t1 ∧ ¬ Ide (head_redex t1))
                    ⟹ contains_head_reduction (t1 ❙∘ t2) =
                        (Arr t1 ∧ Arr t2 ∧ ¬ Ide (head_redex (t1 ❙∘ t2)))"
        for t1
        using Ide_Src
        by (cases t1) auto
    qed

    lemma head_redex_is_head_reduction:
    shows "⟦Arr t; contains_head_reduction t⟧ ⟹ is_head_reduction (head_redex t)"
      using Ide_Src
      apply (induct t)
          apply simp_all
    proof -
      show "⋀t2. ⟦contains_head_reduction t1 ⟹ is_head_reduction (head_redex t1);
                  Arr t1 ∧ Arr t2;
                  contains_head_reduction (t1 ❙∘ t2); ⋀t. Arr t ⟹ Ide (Src t)⟧
                    ⟹ is_head_reduction (head_redex (t1 ❙∘ t2))"
        for t1
        using Ide_Src contains_head_reduction_iff subs_implies_prfx
        by (cases t1) auto
    qed

    lemma Arr_head_redex:
    assumes "Arr t"
    shows "Arr (head_redex t)"
      using assms Ide_implies_Arr elementary_reduction_head_redex elementary_reduction_is_arr
      by blast

    lemma Src_head_redex:
    assumes "Arr t"
    shows "Src (head_redex t) = Src t"
      using assms
      by (metis Coinitial_iff_Con Ide.simps(1) ide_char subs_head_redex subs_implies_prfx)

    lemma Con_Arr_head_redex:
    assumes "Arr t"
    shows "Con t (head_redex t)"
      using assms
      by (metis Con_sym Ide.simps(1) ide_char subs_head_redex subs_implies_prfx)

    lemma is_head_reduction_if:
    shows "⟦contains_head_reduction u; elementary_reduction u⟧ ⟹ is_head_reduction u"
      apply (induct u)
          apply auto
      using contains_head_reduction.elims(2)
       apply fastforce
    proof -
      fix u1 u2
      assume u1: "Ide u1"
      assume u2: "elementary_reduction u2"
      assume 1: "contains_head_reduction (u1 ❙∘ u2)"
      have False
        using u1 u2 1
        apply (cases u1)
            apply auto
        by (metis Arr_head_redex Ide_iff_Src_self Src_head_redex contains_head_reduction_iff
            ide_char resid_Arr_Src subs_head_redex subs_implies_prfx u1)
      thus "is_head_reduction (u1 ❙∘ u2)"
        by blast
    qed

    lemma (in reduction_paths) head_redex_decomp:
    assumes "Λ.Arr t"
    shows "[Λ.head_redex t] @ [t \\ Λ.head_redex t] ⇧*∼⇧* [t]"
      using assms prfx_decomp Λ.subs_head_redex Λ.subs_implies_prfx
      by (metis Ide.simps(2) Resid.simps(3) Λ.prfx_implies_con ide_char)

    text ‹
      An internal reduction cannot create a new head redex.
    ›

    lemma internal_reduction_preserves_no_head_redex:
    shows "⟦is_internal_reduction u; Ide (head_strategy (Src u))⟧
              ⟹ Ide (head_strategy (Trg u))"
      apply (induct u)
          apply simp_all
    proof -
      fix u1 u2
      assume ind1: "⟦is_internal_reduction u1; Ide (head_strategy (Src u1))⟧
                       ⟹ Ide (head_strategy (Trg u1))"
      assume ind2: "⟦is_internal_reduction u2; Ide (head_strategy (Src u2))⟧
                       ⟹ Ide (head_strategy (Trg u2))"
      assume u: "is_internal_reduction (u1 ❙∘ u2)"
      assume 1: "Ide (head_strategy (Src u1 ❙∘ Src u2))"
      show "Ide (head_strategy (Trg u1 ❙∘ Trg u2))"
        using u 1 ind1 ind2 Ide_Src Ide_Trg Ide_implies_Arr
        by (cases u1) auto
    qed

    lemma head_reduction_unique:
    shows "⟦is_head_reduction t; is_head_reduction u; coinitial t u⟧ ⟹ t = u"
      by (metis Coinitial_iff_Con con_def confluence is_head_reduction_char null_char)

    text ‹
      Residuation along internal reductions preserves head reductions.
    ›

    lemma resid_head_strategy_internal:
    shows "is_internal_reduction u ⟹ head_strategy (Src u) \\ u = head_strategy (Trg u)"
      using internal_reduction_preserves_no_head_redex Arr_head_strategy Ide_iff_Src_self
          Src_head_strategy Src_resid head_strategy_is_elementary is_head_reduction_char
          is_head_reduction_resid' is_internal_reduction_iff
      apply (cases u)
          apply simp_all
        apply (metis head_strategy_Src resid_Src_Arr)
       apply (metis head_strategy_Src Arr.simps(4) Src.simps(4) Trg.simps(3) resid_Src_Arr)
      by blast

    text ‹
      An internal reduction followed by a head reduction can be expressed
      as a join of the internal reduction with a head reduction.
    ›

    lemma resid_head_strategy_Src:
    assumes "is_internal_reduction t" and "is_head_reduction u"
    and "seq t u"
    shows "head_strategy (Src t) \\ t = u"
    and "composite_of t u (Join (head_strategy (Src t)) t)"
    proof -
      show 1: "head_strategy (Src t) \\ t = u"
        using assms internal_reduction_preserves_no_head_redex resid_head_strategy_internal
              elementary_reduction_not_ide ide_char is_head_reduction_char seq_char
        by force
      show "composite_of t u (Join (head_strategy (Src t)) t)"
        using assms(3) 1 Arr_head_strategy Src_head_strategy join_of_Join join_of_def seq_char
        by force
    qed

    lemma App_Var_contains_no_head_reduction:
    shows "¬ contains_head_reduction (❙«x❙» ❙∘ u)"
      by simp

    lemma hgt_resid_App_head_redex:
    assumes "Arr (t ❙∘ u)" and "¬ Ide (head_redex (t ❙∘ u))"
    shows "hgt ((t ❙∘ u) \\ head_redex (t ❙∘ u)) < hgt (t ❙∘ u)"
      using assms contains_head_reduction_iff elementary_reduction_decreases_hgt
            elementary_reduction_head_redex subs_head_redex
      by blast

    subsection "Leftmost Reduction"

    text ‹
      Leftmost (or normal-order) reduction is the strategy that produces an elementary
      reduction path by contracting the leftmost redex at each step.  It agrees with
      head reduction as long as there is a head redex, otherwise it continues on with the next
      subterm to the right.
    ›

    fun leftmost_strategy
    where "leftmost_strategy ❙«x❙» = ❙«x❙»"
        | "leftmost_strategy ❙λ❙[t❙] = ❙λ❙[leftmost_strategy t❙]"
        | "leftmost_strategy (❙λ❙[t❙] ❙∘ u) = ❙λ❙[t❙] ❙⦁ u"
        | "leftmost_strategy (t ❙∘ u) =
             (if ¬ Ide (leftmost_strategy t)
              then leftmost_strategy t ❙∘ u
              else t ❙∘ leftmost_strategy u)"
        | "leftmost_strategy (❙λ❙[t❙] ❙⦁ u) = ❙λ❙[t❙] ❙⦁ u"
        | "leftmost_strategy ❙♯ = ❙♯"

    (* TODO: Consider if is_head_reduction should be done this way. *)
    definition is_leftmost_reduction
    where "is_leftmost_reduction t ⟷ elementary_reduction t ∧ leftmost_strategy (Src t) = t"

    lemma leftmost_strategy_is_reduction_strategy:
    shows "reduction_strategy leftmost_strategy"
    proof (unfold reduction_strategy_def, intro allI impI)
      fix t
      show "Ide t ⟹ Coinitial (leftmost_strategy t) t"
      proof (induct t, auto)
        show "⋀t2. ⟦Arr (leftmost_strategy t1); Arr (leftmost_strategy t2);
                    Ide t1; Ide t2;
                    Arr t1; Src (leftmost_strategy t1) = Src t1;
                    Arr t2; Src (leftmost_strategy t2) = Src t2⟧
                      ⟹ Arr (leftmost_strategy (t1 ❙∘ t2))"
              for t1
          by (cases t1) auto
      qed
    qed

    lemma elementary_reduction_leftmost_strategy:
    shows "Ide t ⟹ elementary_reduction (leftmost_strategy t) ∨ Ide (leftmost_strategy t)"
      apply (induct t)
          apply simp_all
    proof -
      fix t1 t2
      show "⟦elementary_reduction (leftmost_strategy t1) ∨ Ide (leftmost_strategy t1);
             elementary_reduction (leftmost_strategy t2) ∨ Ide (leftmost_strategy t2);
             Ide t1 ∧ Ide t2⟧
                ⟹ elementary_reduction (leftmost_strategy (t1 ❙∘ t2)) ∨
                    Ide (leftmost_strategy (t1 ❙∘ t2))"
        by (cases t1) auto
    qed

    lemma (in lambda_calculus) leftmost_strategy_selects_head_reduction:
    shows "is_head_reduction t ⟹ t = leftmost_strategy (Src t)"
    proof (induct t)
      show "⋀t1 t2. ⟦is_head_reduction t1 ⟹ t1 = leftmost_strategy (Src t1);
                     is_head_reduction (t1 ❙∘ t2)⟧
                       ⟹ t1 ❙∘ t2 = leftmost_strategy (Src (t1 ❙∘ t2))"
      proof -
        fix t1 t2
        assume ind1: "is_head_reduction t1 ⟹ t1 = leftmost_strategy (Src t1)"
        assume t: "is_head_reduction (t1 ❙∘ t2)"
        show "t1 ❙∘ t2 = leftmost_strategy (Src (t1 ❙∘ t2))"
          using t ind1
          apply (cases t1)
              apply simp_all
           apply (cases "Src t1")
               apply simp_all
          using ind1
               apply force
          using ind1
              apply force
          using ind1
             apply force
            apply (metis Ide_iff_Src_self Ide_implies_Arr elementary_reduction_not_ide
              ide_char ind1 is_head_reduction_char)
          using ind1
           apply force
          by (metis Ide_iff_Src_self Ide_implies_Arr)
      qed
      show "⋀t1 t2. ⟦is_head_reduction t1 ⟹ t1 = leftmost_strategy (Src t1);
                     is_head_reduction (❙λ❙[t1❙] ❙⦁ t2)⟧
                       ⟹ ❙λ❙[t1❙] ❙⦁ t2 = leftmost_strategy (Src (❙λ❙[t1❙] ❙⦁ t2))"
        by (metis Ide_iff_Src_self Ide_implies_Arr Src.simps(5)
            is_head_reduction.simps(8) leftmost_strategy.simps(3))
    qed auto

    lemma has_redex_iff_not_Ide_leftmost_strategy:
    shows "Arr t ⟹ has_redex t ⟷ ¬ Ide (leftmost_strategy (Src t))"
      apply (induct t)
          apply simp_all
    proof -
      fix t1 t2
      assume ind1: "Ide (parallel_strategy t1) ⟷ Ide (leftmost_strategy (Src t1))"
      assume ind2: "Ide (parallel_strategy t2) ⟷ Ide (leftmost_strategy (Src t2))"
      assume t: "Arr t1 ∧ Arr t2"
      show "Ide (parallel_strategy (t1 ❙∘ t2)) ⟷
            Ide (leftmost_strategy (Src t1 ❙∘ Src t2))"
        using t ind1 ind2 Ide_Src Ide_iff_Src_self
        by (cases t1) auto
    qed

    lemma leftmost_reduction_preservation:
    shows "⟦is_leftmost_reduction t; elementary_reduction u; ¬ is_leftmost_reduction u;
            coinitial t u⟧ ⟹ is_leftmost_reduction (t \\ u)"
    proof (induct t arbitrary: u)
      show "⋀u. coinitial ❙♯ u ⟹ is_leftmost_reduction (❙♯ \\ u)"
        by simp
      show "⋀x u. is_leftmost_reduction ❙«x❙» ⟹ is_leftmost_reduction (❙«x❙» \\ u)"
        by (simp add: is_leftmost_reduction_def)
      fix t u
      show "⟦⋀u. ⟦is_leftmost_reduction t; elementary_reduction u;
                   ¬ is_leftmost_reduction u; coinitial t u⟧ ⟹ is_leftmost_reduction (t \\ u);
             is_leftmost_reduction (Lam t); elementary_reduction u;
             ¬ is_leftmost_reduction u; coinitial ❙λ❙[t❙] u⟧
                ⟹ is_leftmost_reduction (❙λ❙[t❙] \\ u)"
        using is_leftmost_reduction_def
        by (cases u) auto
      next
      fix t1 t2 u
      show "⟦is_leftmost_reduction (❙λ❙[t1❙] ❙⦁ t2); elementary_reduction u; ¬ is_leftmost_reduction u;
             coinitial (❙λ❙[t1❙] ❙⦁ t2) u⟧
               ⟹ is_leftmost_reduction ((❙λ❙[t1❙] ❙⦁ t2) \\ u)"
        using is_leftmost_reduction_def Src_resid Ide_Trg Ide_iff_Src_self Arr_Trg Arr_not_Nil
        apply (cases u)
            apply simp_all
        by (cases "un_App1 u") auto
      assume ind1: "⋀u. ⟦is_leftmost_reduction t1; elementary_reduction u;
                          ¬ is_leftmost_reduction u; coinitial t1 u⟧
                            ⟹ is_leftmost_reduction (t1 \\ u)"
      assume ind2: "⋀u. ⟦is_leftmost_reduction t2; elementary_reduction u;
                         ¬ is_leftmost_reduction u; coinitial t2 u⟧
                            ⟹ is_leftmost_reduction (t2 \\ u)"
      assume 1: "is_leftmost_reduction (t1 ❙∘ t2)"
      assume 2: "elementary_reduction u"
      assume 3: "¬ is_leftmost_reduction u"
      assume 4: "coinitial (t1 ❙∘ t2) u"
      show "is_leftmost_reduction ((t1 ❙∘ t2) \\ u)"
        using 1 2 3 4 ind1 ind2 is_leftmost_reduction_def Src_resid
        apply (cases u)
            apply auto[3]
      proof -
        show "⋀u1 u2. u = ❙λ❙[u1❙] ❙⦁ u2 ⟹ is_leftmost_reduction ((t1 ❙∘ t2) \\ u)"
          by (metis 2 3 is_leftmost_reduction_def elementary_reduction.simps(5)
              is_head_reduction.simps(8) leftmost_strategy_selects_head_reduction)
        fix u1 u2
        assume u: "u = u1 ❙∘ u2"
        show "is_leftmost_reduction ((t1 ❙∘ t2) \\ u)"
          using u 1 2 3 4 ind1 ind2 is_leftmost_reduction_def Src_resid Ide_Trg
                elementary_reduction_not_ide
          apply (cases u)
              apply simp_all
          apply (cases u1)
              apply simp_all
            apply auto[1]
          using Ide_iff_Src_self
           apply simp_all
        proof -
          fix u11 u12
          assume u: "u = u11 ❙∘ u12 ❙∘ u2"
          assume u1: "u1 = u11 ❙∘ u12"
          have A: "(elementary_reduction t1 ∧ Src u2 = t2 ∨
                      Src u11 ❙∘ Src u12 = t1 ∧ elementary_reduction t2) ∧
                     (if ¬ Ide (leftmost_strategy (Src u11 ❙∘ Src u12))
                      then leftmost_strategy (Src u11 ❙∘ Src u12) ❙∘ Src u2
                      else Src u11 ❙∘ Src u12 ❙∘ leftmost_strategy (Src u2)) = t1 ❙∘ t2"
            using 1 4 Ide_iff_Src_self is_leftmost_reduction_def u by auto
          have B: "(elementary_reduction u11 ∧ Src u12 = u12 ∨
                      Src u11 = u11 ∧ elementary_reduction u12) ∧ Src u2 = u2 ∨
                      Src u11 = u11 ∧ Src u12 = u12 ∧ elementary_reduction u2"
            using "2" "4" Ide_iff_Src_self u by force
          have C: "t1 = u11 ❙∘ u12 ⟶ t2 ≠ u2"
            using 1 3 u by fastforce
          have D: "Arr t1 ∧ Arr t2 ∧ Arr u11 ∧ Arr u12 ∧ Arr u2 ∧
                     Src t1 = Src u11 ❙∘ Src u12 ∧ Src t2 = Src u2"
            using 4 u by force
          have E: "⋀u. ⟦elementary_reduction t1 ∧ leftmost_strategy (Src u) = t1;
                          elementary_reduction u;
                          t1 ≠ u;
                          Arr u ∧ Src u11 ❙∘ Src u12 = Src u⟧
                            ⟹ elementary_reduction (t1 \\ u) ∧
                                leftmost_strategy (Trg u) = t1 \\ u"
            using D Src_resid ind1 is_leftmost_reduction_def by auto
          have F: "⋀u. ⟦elementary_reduction t2 ∧ leftmost_strategy (Src u) = t2;
                          elementary_reduction u;
                          t2 ≠ u;
                          Arr u ∧ Src u2 = Src u⟧
                            ⟹ elementary_reduction (t2 \\ u) ∧
                                leftmost_strategy (Trg u) = t2 \\ u"
            using D Src_resid ind2 is_leftmost_reduction_def by auto
          have G: "⋀t. elementary_reduction t ⟹ ¬ Ide t"
            using elementary_reduction_not_ide ide_char by blast
          have H: "elementary_reduction (t1 \\ (u11 ❙∘ u12)) ∧ Ide (t2 \\ u2) ∨
                     Ide (t1 \\ (u11 ❙∘ u12)) ∧ elementary_reduction (t2 \\ u2)"
          proof (cases "Ide (t2 \\ u2)")
            assume 1: "Ide (t2 \\ u2)"
            hence "elementary_reduction (t1 \\ (u11 ❙∘ u12))"
              by (metis A B C D E F G Ide_Src Arr.simps(4) Src.simps(4)
                  elementary_reduction.simps(4) lambda.inject(3) resid_Arr_Src)
            thus ?thesis
              using 1 by auto
            next
            assume 1: "¬ Ide (t2 \\ u2)"
            hence "Ide (t1 \\ (u11 ❙∘ u12)) ∧ elementary_reduction (t2 \\ u2)"
              apply (intro conjI)
               apply (metis 1 A D Ide_Src Arr.simps(4) Src.simps(4) resid_Ide_Arr)
              by (metis A B C D F Ide_iff_Src_self lambda.inject(3) resid_Arr_Src resid_Ide_Arr)
            thus ?thesis by simp
          qed
          show "(¬ Ide (leftmost_strategy (Trg u11 ❙∘ Trg u12)) ⟶
                  (elementary_reduction (t1 \\ (u11 ❙∘ u12)) ∧ Ide (t2 \\ u2) ∨
                   Ide (t1 \\ (u11 ❙∘ u12)) ∧ elementary_reduction (t2 \\ u2)) ∧
                   leftmost_strategy (Trg u11 ❙∘ Trg u12) = t1 \\ (u11 ❙∘ u12) ∧ Trg u2 = t2 \\ u2) ∧
                (Ide (leftmost_strategy (Trg u11 ❙∘ Trg u12)) ⟶
                  (elementary_reduction (t1 \\ (u11 ❙∘ u12)) ∧ Ide (t2 \\ u2) ∨
                   Ide (t1 \\ (u11 ❙∘ u12)) ∧ elementary_reduction (t2 \\ u2)) ∧
                   Trg u11 ❙∘ Trg u12 = t1 \\ (u11 ❙∘ u12) ∧ leftmost_strategy (Trg u2) = t2 \\ u2)"
          proof (intro conjI impI)
            show H: "elementary_reduction (t1 \\ (u11 ❙∘ u12)) ∧ Ide (t2 \\ u2) ∨
                       Ide (t1 \\ (u11 ❙∘ u12)) ∧ elementary_reduction (t2 \\ u2)"
              by fact
            show H: "elementary_reduction (t1 \\ (u11 ❙∘ u12)) ∧ Ide (t2 \\ u2) ∨
                       Ide (t1 \\ (u11 ❙∘ u12)) ∧ elementary_reduction (t2 \\ u2)"
              by fact
            assume K: "¬ Ide (leftmost_strategy (Trg u11 ❙∘ Trg u12))"
            show J: "Trg u2 = t2 \\ u2"
              using A B D G K has_redex_iff_not_Ide_leftmost_strategy
                    NF_def NF_iff_has_no_redex NF_App_iff resid_Arr_Src resid_Src_Arr
              by (metis lambda.inject(3))
            show "leftmost_strategy (Trg u11 ❙∘ Trg u12) = t1 \\ (u11 ❙∘ u12)"
              using 2 A B C D E G H J u Ide_Trg Src_Src
                  has_redex_iff_not_Ide_leftmost_strategy resid_Arr_Ide resid_Src_Arr
              by (metis Arr.simps(4) Ide.simps(4) Src.simps(4) Trg.simps(3)
                  elementary_reduction.simps(4) lambda.inject(3))
            next
            assume K: "Ide (leftmost_strategy (Trg u11 ❙∘ Trg u12))"
            show I: "Trg u11 ❙∘ Trg u12 = t1 \\ (u11 ❙∘ u12)"
              using 2 A D E K u Coinitial_resid_resid ConI resid_Arr_self resid_Ide_Arr
                    resid_Arr_Ide Ide_iff_Src_self Src_resid
              apply (cases "Ide (leftmost_strategy (Src u11 ❙∘ Src u12))")
               apply simp
              using lambda_calculus.Con_Arr_Src(2)
               apply force
              apply simp
              using u1 G H Coinitial_iff_Con
              apply (cases "elementary_reduction u11";
                     cases "elementary_reduction u12")
                 apply simp_all
                 apply metis
                apply (metis Src.simps(4) Trg.simps(3) elementary_reduction.simps(1,4))
               apply (metis Src.simps(4) Trg.simps(3) elementary_reduction.simps(1,4))
              by (metis Trg_Src)
            show "leftmost_strategy (Trg u2) = t2 \\ u2"
              using 2 A C D F G H I u Ide_Trg Ide_iff_Src_self NF_def NF_iff_has_no_redex
                    has_redex_iff_not_Ide_leftmost_strategy resid_Ide_Arr
              by (metis Arr.simps(4) Src.simps(4) Trg.simps(3) elementary_reduction.simps(4)
                  lambda.inject(3))
          qed
        qed
      qed
    qed

  end

  section "Standard Reductions"

    text ‹
      In this section, we define the notion of a \emph{standard reduction}, which is an
      elementary reduction path that performs reductions from left to right, possibly
      skipping some redexes that could be contracted.  Once a redex has been skipped,
      neither that redex nor any redex to its left will subsequently be contracted.
      We then define and prove correct a function that transforms an arbitrary
      elementary reduction path into a congruent standard reduction path.
      Using this function, we prove the Standardization Theorem, which says that
      every elementary reduction path is congruent to a standard reduction path.
      We then show that a standard reduction path that reaches a normal form is in
      fact a leftmost reduction path.  From this fact and the Standardization Theorem
      we prove the Leftmost Reduction Theorem: leftmost reduction is a normalizing
      strategy.

      The Standardization Theorem was first proved by Curry and Feys \<^cite>‹"curry-and-feys"›,
      with subsequent proofs given by a number of authors.  Formalized proofs have also
      been given; a recent one (using Agda) is presented in \<^cite>‹"copes"›, with references
      to earlier work.  The version of the theorem that we formalize here is a ``strong''
      version, which asserts the existence of a standard reduction path congruent to a
      a given elementary reduction path.  At the core of the proof is a function that
      directly transforms a given reduction path into a standard one, using an algorithm
      roughly analogous to insertion sort.  The Finite Development Theorem is used in the
      proof of termination.  The proof of correctness is long, due to the number of cases that
      have to be considered, but the use of a proof assistant makes this manageable.
    ›

  subsection "Standard Reduction Paths"

  subsubsection "`Standardly Sequential' Reductions"

    text ‹
      We first need to define the notion of a ``standard reduction''.  In contrast to what
      is typically done by other authors, we define this notion by direct comparison of adjacent
      terms in an elementary reduction path, rather than by using devices such as a numbering
      of subterms from left to right.

      The following function decides when two terms ‹t› and ‹u› are elementary reductions that are
      ``standardly sequential''.  This means that ‹t› and ‹u› are sequential, but in addition
      no marked redex in ‹u› is the residual of an (unmarked) redex ``to the left of'' any
      marked redex in ‹t›.  Some care is required to make sure that the recursive definition
      captures what we intend.  Most of the clauses are readily understandable.
      One clause that perhaps could use some explanation is the one for
      ‹sseq ((❙λ❙[t❙] ❙⦁ u) ❙∘ v) w›.  Referring to the previously proved fact ‹seq_cases›,
      which classifies the way in which two terms ‹t› and ‹u› can be sequential,
      we see that one case that must be covered is when ‹t› has the form ‹❙λ❙[t❙] ❙⦁ v) ❙∘ w›
      and the top-level constructor of ‹u› is ‹Beta›.  In this case, it is the reduction
      of ‹t› that creates the top-level redex contracted in ‹u›, so it is impossible for ‹u› to
      be a residual of a redex that already exists in ‹Src t›.
    ›

  context lambda_calculus
  begin

    fun sseq
    where "sseq _ ❙♯ = False"
        | "sseq ❙«_❙» ❙«_❙» = False"
        | "sseq ❙λ❙[t❙] ❙λ❙[t'❙] = sseq t t'"
        | "sseq (t ❙∘ u) (t' ❙∘ u') =
                ((sseq t t' ∧ Ide u ∧ u = u') ∨
                 (Ide t ∧ t = t' ∧ sseq u u') ∨
                 (elementary_reduction t ∧ Trg t = t' ∧
                  (u = Src u' ∧ elementary_reduction u')))"
        | "sseq (❙λ❙[t❙] ❙∘ u) (❙λ❙[t'❙] ❙⦁ u') = False"
        | "sseq ((❙λ❙[t❙] ❙⦁ u) ❙∘ v) w =
                (Ide t ∧ Ide u ∧ Ide v ∧ elementary_reduction w ∧ seq ((❙λ❙[t❙] ❙⦁ u) ❙∘ v) w)"
        | "sseq (❙λ❙[t❙] ❙⦁ u) v = (Ide t ∧ Ide u ∧ elementary_reduction v ∧ seq (❙λ❙[t❙] ❙⦁ u) v)"
        | "sseq _ _ = False"

    lemma sseq_imp_seq:
    shows "sseq t u ⟹ seq t u"
    proof (induct t arbitrary: u)
      show "⋀u. sseq ❙♯ u ⟹ seq ❙♯ u"
        using sseq.elims(1) by blast
      fix u
      show "⋀x. sseq ❙«x❙» u ⟹ seq ❙«x❙» u"
        using sseq.elims(1) by blast
      show "⋀t. ⟦⋀u. sseq t u ⟹ seq t u; sseq ❙λ❙[t❙] u⟧ ⟹ seq ❙λ❙[t❙] u"
        using seq_char by (cases u) auto
      show "⋀t1 t2. ⟦⋀u. sseq t1 u ⟹ seq t1 u; ⋀u. sseq t2 u ⟹ seq t2 u;
                     sseq (❙λ❙[t1❙] ❙⦁ t2) u⟧
                        ⟹ seq (❙λ❙[t1❙] ❙⦁ t2) u"
        using seq_char Ide_implies_Arr
        by (cases u) auto
      fix t1 t2
      show "⟦⋀u. sseq t1 u ⟹ seq t1 u; ⋀u. sseq t2 u ⟹ seq t2 u; sseq (t1 ❙∘ t2) u⟧
                  ⟹ seq (t1 ❙∘ t2) u"
      proof -
        assume ind1: "⋀u. sseq t1 u ⟹ seq t1 u"
        assume ind2: "⋀u. sseq t2 u ⟹ seq t2 u"
        assume 1: "sseq (t1 ❙∘ t2) u"
        show ?thesis
          using 1 ind1 ind2 seq_char arr_char elementary_reduction_is_arr
                Ide_Src Ide_Trg Ide_implies_Arr Coinitial_iff_Con resid_Arr_self
          apply (cases u, simp_all)
             apply (cases t1, simp_all)
            apply (cases t1, simp_all)
           apply (cases "Ide t1"; cases "Ide t2")
              apply simp_all
             apply (metis Ide_iff_Src_self Ide_iff_Trg_self)
            apply (metis Ide_iff_Src_self Ide_iff_Trg_self)
           apply (metis Ide_iff_Trg_self Src_Trg)
          by (cases t1) auto
      qed
    qed

    lemma sseq_imp_elementary_reduction1:
    shows "sseq t u ⟹ elementary_reduction t"
    proof (induct u arbitrary: t)
      show "⋀t. sseq t ❙♯ ⟹ elementary_reduction t"
        by simp
      show "⋀x t. sseq t ❙«x❙» ⟹ elementary_reduction t"
        using elementary_reduction.simps(2) sseq.elims(1) by blast
      show "⋀u. ⟦⋀t. sseq t u ⟹ elementary_reduction t; sseq t ❙λ❙[u❙]⟧
                    ⟹ elementary_reduction t" for t
        using seq_cases sseq_imp_seq
        apply (cases t, simp_all)
        by force
      show "⋀u1 u2. ⟦⋀t. sseq t u1 ⟹ elementary_reduction t;
                     ⋀t. sseq t u2 ⟹ elementary_reduction t;
                     sseq t (u1 ❙∘ u2)⟧
                       ⟹ elementary_reduction t" for t
        using seq_cases sseq_imp_seq Ide_Src elementary_reduction_is_arr
        apply (cases t, simp_all)
        by blast
      show "⋀u1 u2.
       ⟦⋀t. sseq t u1 ⟹ elementary_reduction t; ⋀t. sseq t u2 ⟹ elementary_reduction t;
        sseq t (❙λ❙[u1❙] ❙⦁ u2)⟧
       ⟹ elementary_reduction t" for t
        using seq_cases sseq_imp_seq
        apply (cases t, simp_all)
        by fastforce
    qed

    lemma sseq_imp_elementary_reduction2:
    shows "sseq t u ⟹ elementary_reduction u"
    proof (induct u arbitrary: t)
      show "⋀t. sseq t ❙♯ ⟹ elementary_reduction ❙♯"
        by simp
      show "⋀x t. sseq t ❙«x❙» ⟹ elementary_reduction ❙«x❙»"
        using elementary_reduction.simps(2) sseq.elims(1) by blast
      show "⋀u. ⟦⋀t. sseq t u ⟹ elementary_reduction u; sseq t ❙λ❙[u❙]⟧
                   ⟹ elementary_reduction ❙λ❙[u❙]" for t
        using seq_cases sseq_imp_seq
        apply (cases t, simp_all)
        by force
      show "⋀u1 u2. ⟦⋀t. sseq t u1 ⟹ elementary_reduction u1;
                     ⋀t. sseq t u2 ⟹ elementary_reduction u2;
                     sseq t (u1 ❙∘ u2)⟧
                       ⟹ elementary_reduction (u1 ❙∘ u2)" for t
        using seq_cases sseq_imp_seq Ide_Trg elementary_reduction_is_arr
        by (cases t) auto
      show "⋀u1 u2. ⟦⋀t. sseq t u1 ⟹ elementary_reduction u1;
                     ⋀t. sseq t u2 ⟹ elementary_reduction u2;
                     sseq t (❙λ❙[u1❙] ❙⦁ u2)⟧
                       ⟹ elementary_reduction (❙λ❙[u1❙] ❙⦁ u2)" for t
        using seq_cases sseq_imp_seq
        apply (cases t, simp_all)
        by fastforce
    qed

    lemma sseq_Beta:
    shows "sseq (❙λ❙[t❙] ❙⦁ u) v ⟷ Ide t ∧ Ide u ∧ elementary_reduction v ∧ seq (❙λ❙[t❙] ❙⦁ u) v"
      by (cases v) auto

    lemma sseq_BetaI [intro]:
    assumes "Ide t" and "Ide u" and "elementary_reduction v" and "seq (❙λ❙[t❙] ❙⦁ u) v"
    shows "sseq (❙λ❙[t❙] ❙⦁ u) v"
      using assms sseq_Beta by simp

    text ‹
      A head reduction is standardly sequential with any elementary reduction that
      can be performed after it.
    ›

    lemma sseq_head_reductionI:
    shows "⟦is_head_reduction t; elementary_reduction u; seq t u⟧ ⟹ sseq t u"
    proof (induct t arbitrary: u)
      show "⋀u. ⟦is_head_reduction ❙♯; elementary_reduction u; seq ❙♯ u⟧ ⟹ sseq ❙♯ u"
        by simp
      show "⋀x u. ⟦is_head_reduction ❙«x❙»; elementary_reduction u; seq ❙«x❙» u⟧ ⟹ sseq ❙«x❙» u"
        by auto
      show "⋀t. ⟦⋀u. ⟦is_head_reduction t; elementary_reduction u; seq t u⟧ ⟹ sseq t u;
                 is_head_reduction ❙λ❙[t❙]; elementary_reduction u; seq ❙λ❙[t❙] u⟧
                    ⟹ sseq ❙λ❙[t❙] u" for u
        by (cases u) auto
      show "⋀t2. ⟦⋀u. ⟦is_head_reduction t1; elementary_reduction u; seq t1 u⟧ ⟹ sseq t1 u;
                  ⋀u. ⟦is_head_reduction t2; elementary_reduction u; seq t2 u⟧ ⟹ sseq t2 u;
                  is_head_reduction (t1 ❙∘ t2); elementary_reduction u; seq (t1 ❙∘ t2) u⟧
                     ⟹ sseq (t1 ❙∘ t2) u" for t1 u
        using seq_char
        apply (cases u)
            apply simp_all
        apply (metis ArrE Ide_iff_Src_self Ide_iff_Trg_self App_Var_contains_no_head_reduction
            is_head_reduction_char is_head_reduction_imp_contains_head_reduction
            is_head_reduction.simps(3,6-7))
        by (cases t1) auto
      show "⋀t1 t2 u. ⟦⋀u. ⟦is_head_reduction t1; elementary_reduction u; seq t1 u⟧ ⟹ sseq t1 u;
                       ⋀u. ⟦is_head_reduction t2; elementary_reduction u; seq t2 u⟧ ⟹ sseq t2 u;
                       is_head_reduction (❙λ❙[t1❙] ❙⦁ t2); elementary_reduction u; seq (❙λ❙[t1❙] ❙⦁ t2) u⟧
                         ⟹ sseq (❙λ❙[t1❙] ❙⦁ t2) u"
        by auto
    qed

    text ‹
      Once a head reduction is skipped in an application, then all terms that follow it
      in a standard reduction path are also applications that do not contain head reductions.
    ›

    lemma sseq_preserves_App_and_no_head_reduction:
    shows "⟦sseq t u; is_App t ∧ ¬ contains_head_reduction t⟧
               ⟹ is_App u ∧ ¬ contains_head_reduction u"
      apply (induct t arbitrary: u)
          apply simp_all
    proof -
      fix t1 t2 u
      assume ind1: "⋀u. ⟦sseq t1 u; is_App t1 ∧ ¬ contains_head_reduction t1⟧
                          ⟹ is_App u ∧ ¬ contains_head_reduction u"
      assume ind2: "⋀u. ⟦sseq t2 u; is_App t2 ∧ ¬ contains_head_reduction t2⟧
                          ⟹ is_App u ∧ ¬ contains_head_reduction u"
      assume sseq: "sseq (t1 ❙∘ t2) u"
      assume t: "¬ contains_head_reduction (t1 ❙∘ t2)"
      have u: "¬ is_Beta u"
       using sseq t sseq_imp_seq seq_cases
       by (cases t1; cases u) auto
      have 1: "is_App u"
        using u sseq sseq_imp_seq
        apply (cases u)
            apply simp_all
        by fastforce+
      moreover have "¬ contains_head_reduction u"
      proof (cases u)
        show "⋀v. u = ❙λ❙[v❙] ⟹ ¬ contains_head_reduction u"
          using 1 by auto
        show "⋀v w. u = ❙λ❙[v❙] ❙⦁ w ⟹ ¬ contains_head_reduction u"
          using u by auto
        fix u1 u2
        assume u: "u = u1 ❙∘ u2"
        have 1: "(sseq t1 u1 ∧ Ide t2 ∧ t2 = u2) ∨ (Ide t1 ∧ t1 = u1 ∧ sseq t2 u2) ∨
                 (elementary_reduction t1 ∧ u1 = Trg t1 ∧ t2 = Src u2 ∧ elementary_reduction u2)"
          using sseq u by force
        moreover have "Ide t1 ∧ t1 = u1 ∧ sseq t2 u2 ⟹ ?thesis"
          using Ide_implies_Arr ide_char sseq_imp_seq t u by fastforce
        moreover have "elementary_reduction t1 ∧ u1 = Trg t1 ∧ t2 = Src u2 ∧
                       elementary_reduction u2
                         ⟹ ?thesis"
        proof -
          assume 2: "elementary_reduction t1 ∧ u1 = Trg t1 ∧ t2 = Src u2 ∧
                     elementary_reduction u2"
          have "contains_head_reduction u ⟹ contains_head_reduction u1"
            using u
            apply simp
            using contains_head_reduction.elims(2) by fastforce
          hence "contains_head_reduction u ⟹ ¬ Ide u1"
            using contains_head_reduction_iff
            by (metis Coinitial_iff_Con Ide_iff_Src_self Ide_implies_Arr ide_char resid_Arr_Src
                subs_head_redex subs_implies_prfx)
          thus ?thesis
            using 2
            by (metis Arr.simps(4) Ide_Trg seq_char sseq sseq_imp_seq)
        qed
        moreover have "sseq t1 u1 ∧ Ide t2 ∧ t2 = u2 ⟹ ?thesis"
          using t u ind1 [of u1] Ide_implies_Arr sseq_imp_elementary_reduction1
          apply (cases t1, simp_all)
          using elementary_reduction.simps(1)
              apply blast
          using elementary_reduction.simps(2)
             apply blast
          using contains_head_reduction.elims(2)
            apply fastforce
           apply (metis contains_head_reduction.simps(6) is_App_def)
          using sseq_Beta by blast
        ultimately show ?thesis by blast
      qed auto
      ultimately show "is_App u ∧ ¬ contains_head_reduction u"
        by blast
    qed

  end

  subsubsection "Standard Reduction Paths"

  context reduction_paths
  begin

    text ‹
      A \emph{standard reduction path} is an elementary reduction path in which
      successive reductions are standardly sequential.
    ›

    fun Std
    where "Std [] = True"
        | "Std [t] = Λ.elementary_reduction t"
        | "Std (t # U) = (Λ.sseq t (hd U) ∧ Std U)"

    lemma Std_consE [elim]:
    assumes "Std (t # U)"
    and "⟦Λ.Arr t; U ≠ [] ⟹ Λ.sseq t (hd U); Std U⟧ ⟹ thesis"
    shows thesis
      using assms
      by (metis Λ.arr_char Λ.elementary_reduction_is_arr Λ.seq_char Λ.sseq_imp_seq
          list.exhaust_sel list.sel(1) Std.simps(1-3))

    lemma Std_imp_Arr [simp]:
    shows "⟦Std T; T ≠ []⟧ ⟹ Arr T"
    proof (induct T)
      show "[] ≠ [] ⟹ Arr []"
        by simp
      fix t U
      assume ind: "⟦Std U; U ≠ []⟧ ⟹ Arr U"
      assume tU: "Std (t # U)"
      show "Arr (t # U)"
      proof (cases "U = []")
        show "U = [] ⟹ Arr (t # U)"
          using Λ.elementary_reduction_is_arr tU Λ.Ide_implies_Arr Std.simps(2) Arr.simps(2)
          by blast
        assume U: "U ≠ []"
        show "Arr (t # U)"
        proof -
          have "Λ.sseq t (hd U)"
            using tU U
            by (metis list.exhaust_sel reduction_paths.Std.simps(3))
          thus ?thesis
            using U ind Λ.sseq_imp_seq
            apply auto
            using reduction_paths.Std.elims(3) tU
            by fastforce
        qed
      qed
    qed

    lemma Std_imp_sseq_last_hd:
    shows "⟦Std (T @ U); T ≠ []; U ≠ []⟧ ⟹ Λ.sseq (last T) (hd U)"
      apply (induct T arbitrary: U)
       apply simp_all
      by (metis Std.elims(3) Std.simps(3) append_self_conv2 neq_Nil_conv)

    lemma Std_implies_set_subset_elementary_reduction:
    shows "Std U ⟹ set U ⊆ Collect Λ.elementary_reduction"
      apply (induct U)
        apply auto
      by (metis Std.simps(2) Std.simps(3) neq_Nil_conv Λ.sseq_imp_elementary_reduction1)

    lemma Std_map_Lam:
    shows "Std T ⟹ Std (map Λ.Lam T)"
    proof (induct T)
      show "Std [] ⟹ Std (map Λ.Lam [])"
        by simp
      fix t U
      assume ind: "Std U ⟹ Std (map Λ.Lam U)"
      assume tU: "Std (t # U)"
      have "Std (map Λ.Lam (t # U)) ⟷ Std (❙λ❙[t❙] # map Λ.Lam U)"
        by auto
      also have "... = True"
        apply (cases "U = []")
         apply simp_all
        using Arr.simps(3) Std.simps(2) arr_char tU
         apply presburger
      proof -
        assume U: "U ≠ []"
        have "Std (❙λ❙[t❙] # map Λ.Lam U) ⟷ Λ.sseq ❙λ❙[t❙] ❙λ❙[hd U❙] ∧ Std (map Λ.Lam U)"
          using U
          by (metis Nil_is_map_conv Std.simps(3) hd_map list.exhaust_sel)
        also have "... ⟷ Λ.sseq t (hd U) ∧ Std (map Λ.Lam U)"
          by auto
        also have "... = True"
          using ind tU U
          by (metis Std.simps(3) list.exhaust_sel)
        finally show "Std (❙λ❙[t❙] # map Λ.Lam U)" by blast
      qed
      finally show "Std (map Λ.Lam (t # U))" by blast
    qed

    lemma Std_map_App1:
    shows "⟦Λ.Ide b; Std T⟧ ⟹ Std (map (λX. X ❙∘ b) T)"
    proof (induct T)
      show "⟦Λ.Ide b; Std []⟧ ⟹ Std (map (λX. X ❙∘ b) [])"
        by simp
      fix t U
      assume ind: "⟦Λ.Ide b; Std U⟧ ⟹ Std (map (λX. X ❙∘ b) U)"
      assume b: "Λ.Ide b"
      assume tU: "Std (t # U)"
      show "Std (map (λv. v ❙∘ b) (t # U))"
      proof (cases "U = []")
        show "U = [] ⟹ ?thesis"
          using Ide_implies_Arr b Λ.arr_char tU by force
        assume U: "U ≠ []"
        have "Std (map (λv. v ❙∘ b) (t # U)) = Std ((t ❙∘ b) # map (λX. X ❙∘ b) U)"
          by simp
        also have "... = (Λ.sseq (t ❙∘ b) (hd U ❙∘ b) ∧ Std (map (λX. X ❙∘ b) U))"
          using U reduction_paths.Std.simps(3) hd_map
          by (metis Nil_is_map_conv neq_Nil_conv)
        also have "... = True"
          using b tU U ind
          by (metis Std.simps(3) list.exhaust_sel Λ.sseq.simps(4))
        finally show "Std (map (λv. v ❙∘ b) (t # U))" by blast
      qed
    qed

    lemma Std_map_App2:
    shows "⟦Λ.Ide a; Std T⟧ ⟹ Std (map (λu. a ❙∘ u) T)"
    proof (induct T)
      show "⟦Λ.Ide a; Std []⟧ ⟹ Std (map (λu. a ❙∘ u) [])"
        by simp
      fix t U
      assume ind: "⟦Λ.Ide a; Std U⟧ ⟹ Std (map (λu. a ❙∘ u) U)"
      assume a: "Λ.Ide a"
      assume tU: "Std (t # U)"
      show "Std (map (λu. a ❙∘ u) (t # U))"
      proof (cases "U = []")
        show "U = [] ⟹ ?thesis"
          using a tU by force
        assume U: "U ≠ []"
        have "Std (map (λu. a ❙∘ u) (t # U)) = Std ((a ❙∘ t) # map (λu. a ❙∘ u) U)"
          by simp
        also have "... = (Λ.sseq (a ❙∘ t) (a ❙∘ hd U) ∧ Std (map (λu. a ❙∘ u) U))"
          using U
          by (metis Nil_is_map_conv Std.simps(3) hd_map list.exhaust_sel)
        also have "... = True"
          using a tU U ind
          by (metis Std.simps(3) list.exhaust_sel Λ.sseq.simps(4))
        finally show "Std (map (λu. a ❙∘ u) (t # U))" by blast
      qed
    qed

    lemma Std_map_un_Lam:
    shows "⟦Std T; set T ⊆ Collect Λ.is_Lam⟧ ⟹ Std (map Λ.un_Lam T)"
    proof (induct T)
      show "⟦Std []; set [] ⊆ Collect Λ.is_Lam⟧ ⟹ Std (map Λ.un_Lam [])"
        by simp
      fix t T
      assume ind: "⟦Std T; set T ⊆ Collect Λ.is_Lam⟧ ⟹ Std (map Λ.un_Lam T)"
      assume tT: "Std (t # T)"
      assume 1: "set (t # T) ⊆ Collect Λ.is_Lam"
      show "Std (map Λ.un_Lam (t # T))"
      proof (cases "T = []")
        show "T = [] ⟹ Std (map Λ.un_Lam (t # T))"
        by (metis "1" Std.simps(2) Λ.elementary_reduction.simps(3) Λ.lambda.collapse(2)
            list.set_intros(1) list.simps(8) list.simps(9) mem_Collect_eq subset_code(1) tT)
        assume T: "T ≠ []"
        show "Std (map Λ.un_Lam (t # T))"
          using T tT 1 ind Std.simps(3) [of "Λ.un_Lam t" "Λ.un_Lam (hd T)" "map Λ.un_Lam (tl T)"]
          by (metis Λ.lambda.collapse(2) Λ.sseq.simps(3) list.exhaust_sel list.sel(1)
              list.set_intros(1) map_eq_Cons_conv mem_Collect_eq reduction_paths.Std.simps(3)
              set_subset_Cons subset_code(1))
      qed
    qed

    lemma Std_append_single:
    shows "⟦Std T; T ≠ []; Λ.sseq (last T) u⟧ ⟹ Std (T @ [u])"
    proof (induct T)
      show "⟦Std []; [] ≠ []; Λ.sseq (last []) u⟧ ⟹ Std ([] @ [u])"
        by blast
      fix t T
      assume ind: "⟦Std T; T ≠ []; Λ.sseq (last T) u⟧ ⟹ Std (T @ [u])"
      assume tT: "Std (t # T)"
      assume sseq: "Λ.sseq (last (t # T)) u"
      have "Std (t # (T @ [u]))"
        using Λ.sseq_imp_elementary_reduction2 sseq ind tT
        apply (cases "T = []")
         apply simp
        by (metis append_Cons last_ConsR list.sel(1) neq_Nil_conv reduction_paths.Std.simps(3))
      thus "Std ((t # T) @ [u])" by simp
    qed

    lemma Std_append:
    shows "⟦Std T; Std U; T = [] ∨ U = [] ∨ Λ.sseq (last T) (hd U)⟧ ⟹ Std (T @ U)"
    proof (induct U arbitrary: T)
      show "⋀T. ⟦Std T; Std []; T = [] ∨ [] = [] ∨ Λ.sseq (last T) (hd [])⟧ ⟹ Std (T @ [])"
        by simp
      fix u T U
      assume ind: "⋀T. ⟦Std T; Std U; T = [] ∨ U = [] ∨ Λ.sseq (last T) (hd U)⟧
                          ⟹ Std (T @ U)"
      assume T: "Std T"
      assume uU: "Std (u # U)"
      have U: "Std U"
        using uU Std.elims(3) by fastforce
      assume seq: "T = [] ∨ u # U = [] ∨ Λ.sseq (last T) (hd (u # U))"
      show "Std (T @ (u # U))"
        by (metis Std_append_single T U append.assoc append.left_neutral append_Cons
            ind last_snoc list.distinct(1) list.exhaust_sel list.sel(1) Std.simps(3) seq uU)
    qed

    subsubsection "Projections of Standard `App Paths'"

    text ‹
      Given a standard reduction path, all of whose transitions have App as their top-level
      constructor, we can apply ‹un_App1› or ‹un_App2› to each transition to project the path
      onto paths formed from the ``rator'' and the ``rand'' of each application.  These projected
      paths are not standard, since the projection operation will introduce identities,
      in general.  However, in this section we show that if we remove the identities, then
      in fact we do obtain standard reduction paths.
    ›

    abbreviation notIde
    where "notIde ≡ λu. ¬ Λ.Ide u"

    lemma filter_notIde_Ide:
    shows "Ide U ⟹ filter notIde U = []"
      by (induct U) auto

    lemma cong_filter_notIde:
    shows "⟦Arr U; ¬ Ide U⟧ ⟹ filter notIde U ⇧*∼⇧* U"
    proof (induct U)
      show "⟦Arr []; ¬ Ide []⟧ ⟹ filter notIde [] ⇧*∼⇧* []"
        by simp
      fix u U
      assume ind: "⟦Arr U; ¬ Ide U⟧ ⟹ filter notIde U ⇧*∼⇧* U"
      assume Arr: "Arr (u # U)"
      assume 1: "¬ Ide (u # U)"
      show "filter notIde (u # U) ⇧*∼⇧* (u # U)"
      proof (cases "Λ.Ide u")
        assume u: "Λ.Ide u"
        have U: "Arr U ∧ ¬ Ide U"
          using Arr u 1 Ide.elims(3) by fastforce
        have "filter notIde (u # U) = filter notIde U"
          using u by simp
        also have "... ⇧*∼⇧* U"
          using U ind by blast
        also have "U ⇧*∼⇧* [u] @ U"
          using u
          by (metis (full_types) Arr Arr_has_Src Cons_eq_append_conv Ide.elims(3) Ide.simps(2)
              Srcs.simps(1) U arrI⇩P arr_append_imp_seq cong_append_ideI(3) ide_char
              Λ.ide_char not_Cons_self2)
        also have "[u] @ U = u # U"
          by simp
        finally show ?thesis by blast
        next
        assume u: "¬ Λ.Ide u"
        show ?thesis
        proof (cases "Ide U")
          assume U: "Ide U"
          have "filter notIde (u # U) = [u]"
            using u U filter_notIde_Ide by simp
          moreover have "[u] ⇧*∼⇧* [u] @ U"
            using u U cong_append_ideI(4) [of "[u]" U]
            by (metis Arr Con_Arr_self Cons_eq_appendI Resid_Ide(1) arr_append_imp_seq
                arr_char ide_char ide_implies_arr neq_Nil_conv self_append_conv2)
          moreover have "[u] @ U = u # U"
            by simp
          ultimately show ?thesis by auto
          next
          assume U: "¬ Ide U"
          have "filter notIde (u # U) = [u] @ filter notIde U"
            using u U Arr by simp
          also have "... ⇧*∼⇧* [u] @ U"
          proof (cases "U = []")
            show "U = [] ⟹ ?thesis"
              by (metis Arr arr_char cong_reflexive append_Nil2 filter.simps(1))
            assume 1: "U ≠ []"
            have "seq [u] (filter notIde U)"
              by (metis (full_types) 1 Arr Arr.simps(2-3) Con_imp_eq_Srcs Con_implies_Arr(1)
                  Ide.elims(3) Ide.simps(1) Trgs.simps(2) U ide_char ind seq_char
                  seq_implies_Trgs_eq_Srcs)
            thus ?thesis
              using u U Arr ind cong_append [of "[u]" "filter notIde U" "[u]" U]
              by (meson 1 Arr_consE cong_reflexive seqE)
          qed
          also have "[u] @ U = u # U"
            by simp
          finally show ?thesis by argo
        qed
      qed
    qed

    lemma Std_filter_map_un_App1:
    shows "⟦Std U; set U ⊆ Collect Λ.is_App⟧ ⟹ Std (filter notIde (map Λ.un_App1 U))"
    proof (induct U)
      show "⟦Std []; set [] ⊆ Collect Λ.is_App⟧ ⟹ Std (filter notIde (map Λ.un_App1 []))"
        by simp
      fix u U
      assume ind: "⟦Std U; set U ⊆ Collect Λ.is_App⟧ ⟹ Std (filter notIde (map Λ.un_App1 U))"
      assume 1: "Std (u # U)"
      assume 2: "set (u # U) ⊆ Collect Λ.is_App"
      show "Std (filter notIde (map Λ.un_App1 (u # U)))"
        using 1 2 ind
        apply (cases u)
            apply simp_all
      proof -
        fix u1 u2
        assume uU: "Std ((u1 ❙∘ u2) # U)"
        assume set: "set U ⊆ Collect Λ.is_App"
        assume ind: "Std U ⟹ Std (filter notIde (map Λ.un_App1 U))"
        assume u: "u = u1 ❙∘ u2"
        show "(¬ Λ.Ide u1 ⟶ Std (u1 # filter notIde (map Λ.un_App1 U))) ∧
              (Λ.Ide u1 ⟶ Std (filter notIde (map Λ.un_App1 U)))"
        proof (intro conjI impI)
          assume u1: "Λ.Ide u1"
          show "Std (filter notIde (map Λ.un_App1 U))"
            by (metis 1 Std.simps(1) Std.simps(3) ind neq_Nil_conv)
          next
          assume u1: "¬ Λ.Ide u1"
          show "Std (u1 # filter notIde (map Λ.un_App1 U))"
          proof (cases "Ide (map Λ.un_App1 U)")
            show "Ide (map Λ.un_App1 U) ⟹ ?thesis"
            proof -
              assume U: "Ide (map Λ.un_App1 U)"
              have "filter notIde (map Λ.un_App1 U) = []"
                by (metis U Ide_char filter_False Λ.ide_char
                    mem_Collect_eq subsetD)
              thus ?thesis
                by (metis Std.elims(1) Std.simps(2) Λ.elementary_reduction.simps(4) list.discI
                    list.sel(1) Λ.sseq_imp_elementary_reduction1 u1 uU)
            qed
            assume U: "¬ Ide (map Λ.un_App1 U)"
            show ?thesis
            proof (cases "U = []")
              show "U = [] ⟹ ?thesis"
                using 1 u u1 by fastforce
              assume "U ≠ []"
              hence U: "U ≠ [] ∧ ¬ Ide (map Λ.un_App1 U)"
                using U by simp
              have "Λ.sseq u1 (hd (filter notIde (map Λ.un_App1 U)))"
              proof -
                have "⋀u1 u2. ⟦set U ⊆ Collect Λ.is_App; ¬ Ide (map Λ.un_App1 U); U ≠ [];
                               Std ((u1 ❙∘ u2) # U); ¬ Λ.Ide u1⟧
                                   ⟹ Λ.sseq u1 (hd (filter notIde (map Λ.un_App1 U)))"
                  for U
                  apply (induct U)
                   apply simp_all
                  apply (intro conjI impI)
                proof -
                  fix u U u1 u2
                  assume ind: "⋀u1 u2. ⟦¬ Ide (map Λ.un_App1 U); U ≠ [];
                                        Std ((u1 ❙∘ u2) # U); ¬ Λ.Ide u1⟧
                                          ⟹ Λ.sseq u1 (hd (filter notIde (map Λ.un_App1 U)))"
                  assume 1: "Λ.is_App u ∧ set U ⊆ Collect Λ.is_App"
                  assume 2: "¬ Ide (Λ.un_App1 u # map Λ.un_App1 U)"
                  assume 3: "Λ.sseq (u1 ❙∘ u2) u ∧ Std (u # U)"
                  show "¬ Λ.Ide (Λ.un_App1 u) ⟹ Λ.sseq u1 (Λ.un_App1 u)"
                    by (metis 1 3 Λ.Arr.simps(4) Λ.Ide_Trg Λ.lambda.collapse(3) Λ.seq_char
                        Λ.sseq.simps(4) Λ.sseq_imp_seq)
                  assume 4: "¬ Λ.Ide u1"
                  assume 5: "Λ.Ide (Λ.un_App1 u)"
                  have u1: "Λ.elementary_reduction u1"
                    using 3 4 Λ.elementary_reduction.simps(4) Λ.sseq_imp_elementary_reduction1
                    by blast
                  have 6: "Arr (Λ.un_App1 u # map Λ.un_App1 U)"
                    using 1 3 Std_imp_Arr Arr_map_un_App1 [of "u # U"] by auto
                  have 7: "Arr (map Λ.un_App1 U)"
                    using 1 2 3 5 6 Arr_map_un_App1 Std_imp_Arr Λ.ide_char by fastforce
                  have 8: "¬ Ide (map Λ.un_App1 U)"
                    using 2 5 6 set_Ide_subset_ide by fastforce
                  have 9: "Λ.seq u (hd U)"
                    by (metis 3 7 Std.simps(3) Arr.simps(1) list.collapse list.simps(8)
                        Λ.sseq_imp_seq)
                  show "Λ.sseq u1 (hd (filter notIde (map Λ.un_App1 U)))"
                  proof -
                    have "Λ.sseq (u1 ❙∘ Λ.Trg (Λ.un_App2 u)) (hd U)"
                    proof (cases "Λ.Ide (Λ.un_App1 (hd U))")
                      assume 10: "Λ.Ide (Λ.un_App1 (hd U))"
                      hence "Λ.elementary_reduction (Λ.un_App2 (hd U))"
                        by (metis (full_types) 1 3 7 Std.elims(2) Arr.simps(1)
                            Λ.elementary_reduction_App_iff Λ.elementary_reduction_not_ide
                            Λ.ide_char list.sel(2) list.sel(3) list.set_sel(1) list.simps(8)
                            mem_Collect_eq Λ.sseq_imp_elementary_reduction2 subsetD)
                      moreover have "Λ.Trg u1 = Λ.un_App1 (hd U)"
                      proof -
                        have "Λ.Trg u1 = Λ.Src (Λ.un_App1 u)"
                          by (metis 1 3 5 Λ.Ide_iff_Src_self Λ.Ide_implies_Arr Λ.Trg_Src
                              Λ.elementary_reduction_not_ide Λ.ide_char Λ.lambda.collapse(3)
                              Λ.sseq.simps(4) Λ.sseq_imp_elementary_reduction2)
                        also have "... = Λ.Trg (Λ.un_App1 u)"
                          by (metis 5 Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self
                              Λ.Ide_implies_Arr)
                        also have "... = Λ.un_App1 (hd U)"
                          using 1 3 5 7 Λ.Ide_iff_Trg_self
                          by (metis 9 10 Arr.simps(1) lambda_calculus.Ide_iff_Src_self
                              Λ.Ide_implies_Arr Λ.Src_Src Λ.Src_eq_iff(2) Λ.Trg.simps(3)
                              Λ.lambda.collapse(3) Λ.seqE⇩Λ list.set_sel(1) list.simps(8)
                              mem_Collect_eq subsetD)
                        finally show ?thesis by argo
                      qed
                      moreover have "Λ.Trg (Λ.un_App2 u) = Λ.Src (Λ.un_App2 (hd U))"
                        by (metis 1 7 9 Arr.simps(1) hd_in_set Λ.Src.simps(4) Λ.Src_Src
                            Λ.Trg.simps(3) Λ.lambda.collapse(3) Λ.lambda.sel(4)
                            Λ.seq_char list.simps(8) mem_Collect_eq subset_code(1))
                      ultimately show ?thesis
                        using Λ.sseq.simps(4)
                        by (metis 1 7 u1 Arr.simps(1) hd_in_set Λ.lambda.collapse(3)
                            list.simps(8) mem_Collect_eq subsetD)
                      next
                      assume 10: "¬ Λ.Ide (Λ.un_App1 (hd U))"
                      have False
                      proof -
                        have "Λ.elementary_reduction (Λ.un_App2 u)"
                          using 1 3 5 Λ.elementary_reduction_App_iff
                                Λ.elementary_reduction_not_ide Λ.sseq_imp_elementary_reduction2
                          by blast
                        moreover have "Λ.sseq u (hd U)"
                          by (metis 3 7 Std.simps(3) Arr.simps(1)
                              hd_Cons_tl list.simps(8))
                        moreover have "Λ.elementary_reduction (Λ.un_App1 (hd U))"
                          by (metis 1 7 10 Nil_is_map_conv Arr.simps(1)
                              calculation(2) Λ.elementary_reduction_App_iff hd_in_set Λ.ide_char
                              mem_Collect_eq Λ.sseq_imp_elementary_reduction2 subset_iff)
                        ultimately show ?thesis
                          using Λ.sseq.simps(4)
                          by (metis 1 5 7 Arr.simps(1) Λ.elementary_reduction_not_ide
                              hd_in_set Λ.ide_char Λ.lambda.collapse(3) list.simps(8)
                              mem_Collect_eq subset_iff)
                      qed
                      thus ?thesis by argo
                    qed
                    hence " Std ((u1 ❙∘ Λ.Trg (Λ.un_App2 u)) # U)"
                      by (metis 3 7 Std.simps(3) Arr.simps(1) list.exhaust_sel list.simps(8))
                    thus ?thesis
                      using ind
                      by (metis 7 8 u1 Arr.simps(1) Λ.elementary_reduction_not_ide Λ.ide_char
                          list.simps(8))
                  qed
                qed
                thus ?thesis
                  using U set u1 uU by blast
              qed
              thus ?thesis
                by (metis 1 Std.simps(2-3) ‹U ≠ []› ind list.exhaust_sel list.sel(1)
                    Λ.sseq_imp_elementary_reduction1)
            qed
          qed
        qed
      qed
    qed

    lemma Std_filter_map_un_App2:
    shows "⟦Std U; set U ⊆ Collect Λ.is_App⟧ ⟹ Std (filter notIde (map Λ.un_App2 U))"
    proof (induct U)
      show "⟦Std []; set [] ⊆ Collect Λ.is_App⟧ ⟹ Std (filter notIde (map Λ.un_App2 []))"
        by simp
      fix u U
      assume ind: "⟦Std U; set U ⊆ Collect Λ.is_App⟧ ⟹ Std (filter notIde (map Λ.un_App2 U))"
      assume 1: "Std (u # U)"
      assume 2: "set (u # U) ⊆ Collect Λ.is_App"
      show "Std (filter notIde (map Λ.un_App2 (u # U)))"
        using 1 2 ind
        apply (cases u)
            apply simp_all
      proof -
        fix u1 u2
        assume uU: "Std ((u1 ❙∘ u2) # U)"
        assume set: "set U ⊆ Collect Λ.is_App"
        assume ind: "Std U ⟹ Std (filter notIde (map Λ.un_App2 U))"
        assume u: "u = u1 ❙∘ u2"
        show "(¬ Λ.Ide u2 ⟶ Std (u2 # filter notIde (map Λ.un_App2 U))) ∧
              (Λ.Ide u2 ⟶ Std (filter notIde (map Λ.un_App2 U)))"
        proof (intro conjI impI)
          assume u2: "Λ.Ide u2"
          show "Std (filter notIde (map Λ.un_App2 U))"
            by (metis 1 Std.simps(1) Std.simps(3) ind neq_Nil_conv)
          next
          assume u2: "¬ Λ.Ide u2"
          show "Std (u2 # filter notIde (map Λ.un_App2 U))"
          proof (cases "Ide (map Λ.un_App2 U)")
            show "Ide (map Λ.un_App2 U) ⟹ ?thesis"
            proof -
              assume U: "Ide (map Λ.un_App2 U)"
              have "filter notIde (map Λ.un_App2 U) = []"
                by (metis U Ide_char filter_False Λ.ide_char mem_Collect_eq subsetD)
              thus ?thesis
                by (metis Std.elims(1) Std.simps(2) Λ.elementary_reduction.simps(4) list.discI
                    list.sel(1) Λ.sseq_imp_elementary_reduction1 u2 uU)
            qed
            assume U: "¬ Ide (map Λ.un_App2 U)"
            show ?thesis
            proof (cases "U = []")
              show "U = [] ⟹ ?thesis"
                using "1" u u2 by fastforce
              assume "U ≠ []"
              hence U: "U ≠ [] ∧ ¬ Ide (map Λ.un_App2 U)"
                using U by simp
              have "Λ.sseq u2 (hd (filter notIde (map Λ.un_App2 U)))"
              proof -
                have "⋀u1 u2. ⟦set U ⊆ Collect Λ.is_App; ¬ Ide (map Λ.un_App2 U); U ≠ [];
                               Std ((u1 ❙∘ u2) # U); ¬ Λ.Ide u2⟧
                                   ⟹ Λ.sseq u2 (hd (filter notIde (map Λ.un_App2 U)))"
                  for U
                  apply (induct U)
                  apply simp_all
                  apply (intro conjI impI)
                proof -
                  fix u U u1 u2
                  assume ind: "⋀u1 u2. ⟦¬ Ide (map Λ.un_App2 U); U ≠ [];
                                        Std ((u1 ❙∘ u2) # U); ¬ Λ.Ide u2⟧
                                          ⟹ Λ.sseq u2 (hd (filter notIde (map Λ.un_App2 U)))"
                  assume 1: "Λ.is_App u ∧ set U ⊆ Collect Λ.is_App"
                  assume 2: "¬ Ide (Λ.un_App2 u # map Λ.un_App2 U)"
                  assume 3: "Λ.sseq (u1 ❙∘ u2) u ∧ Std (u # U)"
                  assume 4: "¬ Λ.Ide u2"
                  show "¬ Λ.Ide (Λ.un_App2 u) ⟹ Λ.sseq u2 (Λ.un_App2 u)"
                    by (metis 1 3 4 Λ.elementary_reduction.simps(4)
                        Λ.elementary_reduction_not_ide Λ.ide_char Λ.lambda.collapse(3)
                        Λ.sseq.simps(4) Λ.sseq_imp_elementary_reduction1)
                  assume 5: "Λ.Ide (Λ.un_App2 u)"
                  have False
                    by (metis 1 3 4 5 Λ.elementary_reduction_not_ide Λ.ide_char
                        Λ.lambda.collapse(3) Λ.sseq.simps(4) Λ.sseq_imp_elementary_reduction2)
                  thus "Λ.sseq u2 (hd (filter notIde (map Λ.un_App2 U)))" by argo
                qed
                thus ?thesis
                  using U set u2 uU by blast
              qed
              thus ?thesis
                by (metis "1" Std.simps(2) Std.simps(3) ‹U ≠ []› ind list.exhaust_sel list.sel(1)
                    Λ.sseq_imp_elementary_reduction1)
            qed
          qed
        qed
      qed
    qed

    text ‹
      If the first step in a standard reduction path contracts a redex that is
      not at the head position, then all subsequent terms have ‹App› as their
      top-level operator.
    ›

    lemma seq_App_Std_implies:
    shows "⟦Std (t # U); Λ.is_App t ∧ ¬ Λ.contains_head_reduction t⟧
              ⟹ set U ⊆ Collect Λ.is_App"
    proof (induct U arbitrary: t)
      show "⋀t. ⟦Std [t]; Λ.is_App t ∧ ¬ Λ.contains_head_reduction t⟧
                   ⟹ set [] ⊆ Collect Λ.is_App"
        by simp
      fix t u U
      assume ind: "⋀t. ⟦Std (t # U); Λ.is_App t ∧ ¬ Λ.contains_head_reduction t⟧
                           ⟹ set U ⊆ Collect Λ.is_App"
      assume Std: "Std (t # u # U)"
      assume t: "Λ.is_App t ∧ ¬ Λ.contains_head_reduction t"
      have U: "set (u # U) ⊆ Collect Λ.elementary_reduction"
        using Std Std_implies_set_subset_elementary_reduction by fastforce
      have u: "Λ.elementary_reduction u"
        using U by simp
      have "set U ⊆ Collect Λ.elementary_reduction"
        using U by simp
      show "set (u # U) ⊆ Collect Λ.is_App"
      proof (cases "U = []")
        show "U = [] ⟹ ?thesis"
          by (metis Std empty_set empty_subsetI insert_subset
              Λ.sseq_preserves_App_and_no_head_reduction list.sel(1) list.simps(15)
              mem_Collect_eq reduction_paths.Std.simps(3) t)
        assume U: "U ≠ []"
        have "Λ.sseq t u"
          using Std by auto
        hence "Λ.is_App u ∧ ¬ Λ.Ide u ∧ ¬ Λ.contains_head_reduction u"
          using t u U Λ.sseq_preserves_App_and_no_head_reduction [of t u]
                Λ.elementary_reduction_not_ide
          by blast
        thus ?thesis
          using Std ind [of u] ‹set U ⊆ Collect Λ.elementary_reduction› by simp
      qed
    qed

    subsection "Standard Developments"

    text ‹
      The following function takes a term ‹t› (representing a parallel reduction)
      and produces a standard reduction path that is a complete development of ‹t›
      and is thus congruent to ‹[t]›.  The proof of termination makes use of the
      Finite Development Theorem.
    ›

    function (sequential) standard_development
    where "standard_development ❙♯ = []"
        | "standard_development ❙«_❙» = []"
        | "standard_development ❙λ❙[t❙] = map Λ.Lam (standard_development t)"
        | "standard_development (t ❙∘ u) =
           (if Λ.Arr t ∧ Λ.Arr u then
              map (λv. v ❙∘ Λ.Src u) (standard_development t) @
              map (λv. Λ.Trg t ❙∘ v) (standard_development u)
            else [])"
        | "standard_development (❙λ❙[t❙] ❙⦁ u) =
           (if Λ.Arr t ∧ Λ.Arr u then
              (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) # standard_development (Λ.subst u t)
            else [])"
      by pat_completeness auto

    abbreviation (in lambda_calculus) stddev_term_rel
    where "stddev_term_rel ≡ mlex_prod hgt subterm_rel"

    lemma (in lambda_calculus) subst_lt_Beta:
    assumes "Arr t" and "Arr u"
    shows "(subst u t, ❙λ❙[t❙] ❙⦁ u) ∈ stddev_term_rel"
    proof -
      have "(❙λ❙[t❙] ❙⦁ u) \\ (❙λ❙[Src t❙] ❙⦁ Src u) = subst u t"
        using assms
        by (metis Arr_not_Nil Ide_Src Ide_iff_Src_self Ide_implies_Arr resid.simps(4)
            resid_Arr_Ide)
      moreover have "elementary_reduction (❙λ❙[Src t❙] ❙⦁ Src u)"
        by (simp add: assms Ide_Src)
      moreover have "❙λ❙[Src t❙] ❙⦁ Src u ⊑ ❙λ❙[t❙] ❙⦁ u"
        by (metis assms Arr.simps(5) head_redex.simps(9) subs_head_redex)
      ultimately show ?thesis
        using assms elementary_reduction_decreases_hgt [of "❙λ❙[Src t❙] ❙⦁ Src u" "❙λ❙[t❙] ❙⦁ u"]
        by (metis mlex_less)
    qed

    termination standard_development
    proof (relation Λ.stddev_term_rel)
      show "wf Λ.stddev_term_rel"
        using Λ.wf_subterm_rel wf_mlex by blast
      show "⋀t. (t, ❙λ❙[t❙]) ∈ Λ.stddev_term_rel"
        by (simp add: Λ.subterm_lemmas(1) mlex_prod_def)
      show "⋀t u. (t, t ❙∘ u) ∈ Λ.stddev_term_rel"
        using Λ.subterm_lemmas(3)
        by (metis antisym_conv1 Λ.hgt.simps(4) le_add1 mem_Collect_eq mlex_iff old.prod.case)
      show "⋀t u. (u, t ❙∘ u) ∈ Λ.stddev_term_rel"
        using Λ.subterm_lemmas(3) by (simp add: mlex_leq)
      show "⋀t u. Λ.Arr t ∧ Λ.Arr u ⟹ (Λ.subst u t, ❙λ❙[t❙] ❙⦁ u) ∈ Λ.stddev_term_rel"
        using Λ.subst_lt_Beta by simp
    qed

    lemma Ide_iff_standard_development_empty:
    shows "Λ.Arr t ⟹ Λ.Ide t ⟷ standard_development t = []"
      by (induct t) auto

    lemma set_standard_development:
    shows "Λ.Arr t ⟶ set (standard_development t) ⊆ Collect Λ.elementary_reduction"
      apply (rule standard_development.induct)
      using Λ.Ide_Src Λ.Ide_Trg Λ.Arr_Subst by auto

    lemma cong_standard_development:
    shows "Λ.Arr t ∧ ¬ Λ.Ide t ⟶ standard_development t ⇧*∼⇧* [t]"
    proof (rule standard_development.induct)
     show "Λ.Arr ❙♯ ∧ ¬ Λ.Ide ❙♯ ⟶ standard_development ❙♯ ⇧*∼⇧* [❙♯]"
        by simp
      show "⋀x. Λ.Arr ❙«x❙» ∧ ¬ Λ.Ide ❙«x❙»
                  ⟶ standard_development ❙«x❙» ⇧*∼⇧* [❙«x❙»]"
        by simp
      show "⋀t. Λ.Arr t ∧ ¬ Λ.Ide t ⟶ standard_development t ⇧*∼⇧* [t] ⟹
                Λ.Arr ❙λ❙[t❙] ∧ ¬ Λ.Ide ❙λ❙[t❙] ⟶ standard_development ❙λ❙[t❙] ⇧*∼⇧* [❙λ❙[t❙]]"
        by (metis (mono_tags, lifting) cong_map_Lam Λ.Arr.simps(3) Λ.Ide.simps(3)
            list.simps(8,9) standard_development.simps(3))
      show "⋀t u. ⟦Λ.Arr t ∧ Λ.Arr u
                     ⟹ Λ.Arr t ∧ ¬ Λ.Ide t ⟶ standard_development t ⇧*∼⇧* [t];
                   Λ.Arr t ∧ Λ.Arr u
                     ⟹ Λ.Arr u ∧ ¬ Λ.Ide u ⟶ standard_development u ⇧*∼⇧* [u]⟧
                       ⟹ Λ.Arr (t ❙∘ u) ∧ ¬ Λ.Ide (t ❙∘ u) ⟶
                             standard_development (t ❙∘ u) ⇧*∼⇧* [t ❙∘ u]"
      proof
        fix t u
        assume ind1: "Λ.Arr t ∧ Λ.Arr u
                        ⟹ Λ.Arr t ∧ ¬ Λ.Ide t ⟶ standard_development t ⇧*∼⇧* [t]"
        assume ind2: "Λ.Arr t ∧ Λ.Arr u
                        ⟹ Λ.Arr u ∧ ¬ Λ.Ide u ⟶ standard_development u ⇧*∼⇧* [u]"
        assume 1: "Λ.Arr (t ❙∘ u) ∧ ¬ Λ.Ide (t ❙∘ u)"
        show "standard_development (t ❙∘ u) ⇧*∼⇧* [t ❙∘ u]"
        proof (cases "standard_development t = []")
          show "standard_development t = [] ⟹ ?thesis"
            using 1 ind2 cong_map_App1 Ide_iff_standard_development_empty Λ.Ide_iff_Trg_self
            apply simp
            by (metis (no_types, opaque_lifting) list.simps(8,9))
          assume t: "standard_development t ≠ []"
          show ?thesis
          proof (cases "standard_development u = []")
            assume u: "standard_development u = []"
            have "standard_development (t ❙∘ u) = map (λX. X ❙∘ u) (standard_development t)"
              using u 1 Λ.Ide_iff_Src_self ide_char ind2 by auto
            also have "... ⇧*∼⇧* map (λa. a ❙∘ u) [t]"
              using cong_map_App2 [of u]
              by (meson 1 Λ.Arr.simps(4) Ide_iff_standard_development_empty t u ind1)
            also have "map (λa. a ❙∘ u) [t] = [t ❙∘ u]"
              by simp
            finally show ?thesis by blast
            next
            assume u: "standard_development u ≠ []"
            have "standard_development (t ❙∘ u) =
                  map (λa. a ❙∘ Λ.Src u) (standard_development t) @
                  map (λb. Λ.Trg t ❙∘ b) (standard_development u)"
              using 1 by force
            moreover have "map (λa. a ❙∘ Λ.Src u) (standard_development t) ⇧*∼⇧* [t ❙∘ Λ.Src u]"
            proof -
              have "map (λa. a ❙∘ Λ.Src u) (standard_development t) ⇧*∼⇧* map (λa. a ❙∘ Λ.Src u) [t]"
                using t u 1 ind1 Λ.Ide_Src Ide_iff_standard_development_empty cong_map_App2
                by (metis Λ.Arr.simps(4))
              also have "map (λa. a ❙∘ Λ.Src u) [t] = [t ❙∘ Λ.Src u]"
                by simp
              finally show ?thesis by blast
            qed
            moreover have "map (λb. Λ.Trg t ❙∘ b) (standard_development u) ⇧*∼⇧* [Λ.Trg t ❙∘ u]"
              using t u 1 ind2 Λ.Ide_Trg Ide_iff_standard_development_empty cong_map_App1
              by (metis (mono_tags, opaque_lifting) Λ.Arr.simps(4) list.simps(8,9))
            moreover have "seq (map (λa. a ❙∘ Λ.Src u) (standard_development t))
                               (map (λb. Λ.Trg t ❙∘ b) (standard_development u))"
            proof
              show "Arr (map (λa. a ❙∘ Λ.Src u) (standard_development t))"
                by (metis Con_implies_Arr(1) Ide.simps(1) calculation(2) ide_char)
              show "Arr (map ((❙∘) (Λ.Trg t)) (standard_development u))"
                by (metis Con_implies_Arr(1) Ide.simps(1) calculation(3) ide_char)
              show "Λ.Trg (last (map (λa. a ❙∘ Λ.Src u) (standard_development t))) =
                    Λ.Src (hd (map ((❙∘) (Λ.Trg t)) (standard_development u)))"
                using 1 Src_hd_eqI Trg_last_eqI calculation(2) calculation(3) by auto
            qed
            ultimately have "standard_development (t ❙∘ u) ⇧*∼⇧* [t ❙∘ Λ.Src u] @ [Λ.Trg t ❙∘ u]"
              using cong_append [of "map (λa. a ❙∘ Λ.Src u) (standard_development t)"
                                    "map (λb. Λ.Trg t ❙∘ b) (standard_development u)"
                                    "[t ❙∘ Λ.Src u]" "[Λ.Trg t ❙∘ u]"]
              by simp
            moreover have "[t ❙∘ Λ.Src u] @ [Λ.Trg t ❙∘ u] ⇧*∼⇧* [t ❙∘ u]"
              using 1 Λ.Ide_Trg Λ.resid_Arr_Src Λ.resid_Arr_self Λ.null_char
                    ide_char Λ.Arr_not_Nil
              by simp
            ultimately show ?thesis
              using cong_transitive by blast
          qed
        qed
      qed
      show "⋀t u. (Λ.Arr t ∧ Λ.Arr u ⟹
                     Λ.Arr (Λ.subst u t) ∧ ¬ Λ.Ide (Λ.subst u t)
                         ⟶ standard_development (Λ.subst u t) ⇧*∼⇧* [Λ.subst u t]) ⟹
                   Λ.Arr (❙λ❙[t❙] ❙⦁ u) ∧ ¬ Λ.Ide (❙λ❙[t❙] ❙⦁ u) ⟶
                     standard_development (❙λ❙[t❙] ❙⦁ u) ⇧*∼⇧* [❙λ❙[t❙] ❙⦁ u]"
      proof
        fix t u
        assume 1: "Λ.Arr (❙λ❙[t❙] ❙⦁ u) ∧ ¬ Λ.Ide (❙λ❙[t❙] ❙⦁ u)"
        assume ind: "Λ.Arr t ∧ Λ.Arr u ⟹
                       Λ.Arr (Λ.subst u t) ∧ ¬ Λ.Ide (Λ.subst u t)
                          ⟶ standard_development (Λ.subst u t) ⇧*∼⇧* [Λ.subst u t]"
        show "standard_development (❙λ❙[t❙] ❙⦁ u) ⇧*∼⇧* [❙λ❙[t❙] ❙⦁ u]"
        proof (cases "Λ.Ide (Λ.subst u t)")
          assume 2: "Λ.Ide (Λ.subst u t)"
          have "standard_development (❙λ❙[t❙] ❙⦁ u) = [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u]"
            using 1 2 Ide_iff_standard_development_empty [of "Λ.subst u t"] Λ.Arr_Subst
            by simp
          also have "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] ⇧*∼⇧* [❙λ❙[t❙] ❙⦁ u]"
            using 1 2 Λ.Ide_Src Λ.Ide_implies_Arr ide_char Λ.resid_Arr_Ide
            apply (intro conjI)
             apply simp_all
             apply (metis Λ.Ide.simps(1) Λ.Ide_Subst_iff Λ.Ide_Trg)
            by fastforce
          finally show ?thesis by blast
          next
          assume 2: "¬ Λ.Ide (Λ.subst u t)"
          have "standard_development (❙λ❙[t❙] ❙⦁ u) =
                [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ standard_development (Λ.subst u t)"
            using 1 by auto
          also have "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ standard_development (Λ.subst u t) ⇧*∼⇧*
                     [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t]"
          proof (intro cong_append)
            show "seq [Λ.Beta (Λ.Src t) (Λ.Src u)] (standard_development (Λ.subst u t))"
              using 1 2 ind arr_char ide_implies_arr Λ.Arr_Subst Con_implies_Arr(1) Src_hd_eqI
              apply (intro seqI⇩Λ⇩P)
                apply simp_all
              by (metis Arr.simps(1))
            show "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] ⇧*∼⇧* [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u]"
              using 1
              by (metis Λ.Arr.simps(5) Λ.Ide_Src Λ.Ide_implies_Arr Arr.simps(2) Resid_Arr_self
                  ide_char Λ.arr_char)
            show "standard_development (Λ.subst u t) ⇧*∼⇧* [Λ.subst u t]"
              using 1 2 Λ.Arr_Subst ind by simp
          qed
          also have "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t] ⇧*∼⇧* [❙λ❙[t❙] ❙⦁ u]"
          proof
            show "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t] ⇧*≲⇧* [❙λ❙[t❙] ❙⦁ u]"
            proof -
              have "t \\ Λ.Src t ≠ ❙♯ ∧ u \\ Λ.Src u ≠ ❙♯"
                by (metis "1" Λ.Arr.simps(5) Λ.Coinitial_iff_Con Λ.Ide_Src Λ.Ide_iff_Src_self
                    Λ.Ide_implies_Arr)
              moreover have "Λ.con (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) (❙λ❙[t❙] ❙⦁ u)"
                by (metis "1" Λ.head_redex.simps(9) Λ.prfx_implies_con Λ.subs_head_redex
                    Λ.subs_implies_prfx)
              ultimately have "([❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t]) ⇧*\\⇧* [❙λ❙[t❙] ❙⦁ u] =
                               [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] ⇧*\\⇧* [❙λ❙[t❙] ❙⦁ u] @
                                 [Λ.subst u t] ⇧*\\⇧* ([❙λ❙[t❙] ❙⦁ u] ⇧*\\⇧* [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u])"
                using Resid_append(1)
                        [of "[❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u]" "[Λ.subst u t]" "[❙λ❙[t❙] ❙⦁ u]"]
                apply simp
                by (metis Λ.Arr_Subst Λ.Coinitial_iff_Con Λ.Ide_Src Λ.resid_Arr_Ide)
              also have "... = [Λ.subst (Λ.Trg u) (Λ.Trg t)] @ ([Λ.subst u t] ⇧*\\⇧* [Λ.subst u t])"
              proof -
                have "t \\ Λ.Src t ≠ ❙♯ ∧ u \\ Λ.Src u ≠ ❙♯"
                  by (metis "1" Λ.Arr.simps(5) Λ.Coinitial_iff_Con Λ.Ide_Src
                      Λ.Ide_iff_Src_self Λ.Ide_implies_Arr)
                moreover have "Λ.Src t \\ t ≠ ❙♯ ∧ Λ.Src u \\ u ≠ ❙♯"
                  using Λ.Con_sym calculation(1) by presburger
                moreover have "Λ.con (Λ.subst u t) (Λ.subst u t)"
                  by (meson Λ.Arr_Subst Λ.Con_implies_Arr2 Λ.arr_char Λ.arr_def calculation(2))
                moreover have "Λ.con (❙λ❙[t❙] ❙⦁ u) (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u)"
                  using ‹Λ.con (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) (❙λ❙[t❙] ❙⦁ u)› Λ.con_sym by blast
                moreover have "Λ.con (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) (❙λ❙[t❙] ❙⦁ u)"
                  using ‹Λ.con (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) (❙λ❙[t❙] ❙⦁ u)› by blast
                moreover have "Λ.con (Λ.subst u t) (Λ.subst (u \\ Λ.Src u) (t \\ Λ.Src t))"
                  by (metis Λ.Coinitial_iff_Con Λ.Ide_Src calculation(1-3) Λ.resid_Arr_Ide)
                ultimately show ?thesis
                  using "1" by auto
              qed
              finally have "([❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t]) ⇧*\\⇧* [❙λ❙[t❙] ❙⦁ u] =
                            [Λ.subst (Λ.Trg u) (Λ.Trg t)] @ [Λ.subst u t] ⇧*\\⇧* [Λ.subst u t]"
                by blast
              moreover have "Ide ..."
                by (metis "1" "2" Λ.Arr.simps(5) Λ.Arr_Subst Λ.Ide_Subst Λ.Ide_Trg
                    Nil_is_append_conv Arr_append_iff⇩P⇩W⇩E Con_implies_Arr(2) Ide.simps(1-2)
                    Ide_appendI⇩P⇩W⇩E Resid_Arr_self ide_char calculation Λ.ide_char ind
                    Con_imp_Arr_Resid)
              ultimately show ?thesis
                using ide_char by presburger
            qed
            show "[❙λ❙[t❙] ❙⦁ u] ⇧*≲⇧* [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t]"
            proof -
              have "[❙λ❙[t❙] ❙⦁ u] ⇧*\\⇧* ([❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t]) =
                    ([❙λ❙[t❙] ❙⦁ u] ⇧*\\⇧* [❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u]) ⇧*\\⇧* [Λ.subst u t]"
                by fastforce
              also have "... = [Λ.subst u t] ⇧*\\⇧* [Λ.subst u t]"
              proof -
                have "t \\ Λ.Src t ≠ ❙♯ ∧ u \\ Λ.Src u ≠ ❙♯"
                  by (metis "1" Λ.Arr.simps(5) Λ.Coinitial_iff_Con Λ.Ide_Src
                      Λ.Ide_iff_Src_self Λ.Ide_implies_Arr)
                moreover have "Λ.con (Λ.subst u t) (Λ.subst u t)"
                  by (metis "1" Λ.Arr.simps(5) Λ.Arr_Subst Λ.Coinitial_iff_Con
                      Λ.con_def Λ.null_char)
                moreover have "Λ.con (❙λ❙[t❙] ❙⦁ u) (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u)"
                  by (metis "1" Λ.Con_sym Λ.con_def Λ.head_redex.simps(9) Λ.null_char
                      Λ.prfx_implies_con Λ.subs_head_redex Λ.subs_implies_prfx)
                moreover have "Λ.con (Λ.subst (u \\ Λ.Src u) (t \\ Λ.Src t)) (Λ.subst u t)"
                  by (metis Λ.Coinitial_iff_Con Λ.Ide_Src calculation(1) calculation(2)
                      Λ.resid_Arr_Ide)
                ultimately show ?thesis
                  using Λ.resid_Arr_Ide
                  apply simp
                  by (metis Λ.Coinitial_iff_Con Λ.Ide_Src)
              qed
              finally have "[❙λ❙[t❙] ❙⦁ u] ⇧*\\⇧* ([❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u] @ [Λ.subst u t]) =
                            [Λ.subst u t] ⇧*\\⇧* [Λ.subst u t]"
                by blast
              moreover have "Ide ..."
                by (metis "1" "2" Λ.Arr.simps(5) Λ.Arr_Subst Con_implies_Arr(2) Resid_Arr_self
                    ind ide_char)
              ultimately show ?thesis
                using ide_char by presburger
            qed
          qed
          finally show ?thesis by blast
        qed
      qed
    qed

    lemma Src_hd_standard_development:
    assumes "Λ.Arr t" and "¬ Λ.Ide t"
    shows "Λ.Src (hd (standard_development t)) = Λ.Src t"
      by (metis assms Src_hd_eqI cong_standard_development list.sel(1))

    lemma Trg_last_standard_development:
    assumes "Λ.Arr t" and "¬ Λ.Ide t"
    shows "Λ.Trg (last (standard_development t)) = Λ.Trg t"
      by (metis assms Trg_last_eqI cong_standard_development last_ConsL)

    lemma Srcs_standard_development:
    shows "⟦Λ.Arr t; standard_development t ≠ []⟧
              ⟹ Srcs (standard_development t) = {Λ.Src t}"
      by (metis Con_implies_Arr(1) Ide.simps(1) Ide_iff_standard_development_empty
          Src_hd_standard_development Srcs_simp⇩Λ⇩P cong_standard_development ide_char)

    lemma Trgs_standard_development:
    shows "⟦Λ.Arr t; standard_development t ≠ []⟧
              ⟹ Trgs (standard_development t) = {Λ.Trg t}"
      by (metis Con_implies_Arr(2) Ide.simps(1) Ide_iff_standard_development_empty
          Trg_last_standard_development Trgs_simp⇩Λ⇩P cong_standard_development ide_char)

    lemma development_standard_development:
    shows "Λ.Arr t ⟶ development t (standard_development t)"
      apply (rule standard_development.induct)
          apply blast
         apply simp
        apply (simp add: development_map_Lam)
    proof
      fix t1 t2
      assume ind1: "Λ.Arr t1 ∧ Λ.Arr t2
                       ⟹ Λ.Arr t1 ⟶ development t1 (standard_development t1)"
      assume ind2: "Λ.Arr t1 ∧ Λ.Arr t2
                       ⟹ Λ.Arr t2 ⟶ development t2 (standard_development t2)"
      assume t: "Λ.Arr (t1 ❙∘ t2)"
      show "development (t1 ❙∘ t2) (standard_development (t1 ❙∘ t2))"
      proof (cases "standard_development t1 = []")
        show "standard_development t1 = []
                ⟹ development (t1 ❙∘ t2) (standard_development (t1 ❙∘ t2))"
          using t ind2 Λ.Ide_Src Λ.Ide_Trg Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self
                Ide_iff_standard_development_empty
                development_map_App_2 [of "Λ.Src t1" t2 "standard_development t2"]
          by fastforce
        assume t1: "standard_development t1 ≠ []"
        show "development (t1 ❙∘ t2) (standard_development (t1 ❙∘ t2))"
        proof (cases "standard_development t2 = []")
          assume t2: "standard_development t2 = []"
          show ?thesis
            using t t2 ind1 Ide_iff_standard_development_empty development_map_App_1 by simp
          next
          assume t2: "standard_development t2 ≠ []"
          have "development (t1 ❙∘ t2) (map (λa. a ❙∘ Λ.Src t2) (standard_development t1))"
            using Λ.Arr.simps(4) development_map_App_1 ind1 t by presburger
          moreover have "development ((t1 ❙∘ t2) ⇧1\\⇧*
                                        map (λa. a ❙∘ Λ.Src t2) (standard_development t1))
                                     (map (λa. Λ.Trg t1 ❙∘ a) (standard_development t2))"
          proof -
            have "Λ.App t1 t2 ⇧1\\⇧* map (λa. a ❙∘ Λ.Src t2) (standard_development t1) =
                  Λ.Trg t1 ❙∘ t2"
            proof -
              have "map (λa. a ❙∘ Λ.Src t2) (standard_development t1) ⇧*∼⇧* [t1 ❙∘ Λ.Src t2]"
              proof -
                have "map (λa. a ❙∘ Λ.Src t2) (standard_development t1) =
                      standard_development (t1 ❙∘ Λ.Src t2)"
                  by (metis Λ.Arr.simps(4) Λ.Ide_Src Λ.Ide_iff_Src_self
                      Ide_iff_standard_development_empty Λ.Ide_implies_Arr Nil_is_map_conv
                      append_Nil2 standard_development.simps(4) t)
                also have "standard_development (t1 ❙∘ Λ.Src t2) ⇧*∼⇧* [t1 ❙∘ Λ.Src t2]"
                  by (metis Λ.Arr.simps(4) Λ.Ide.simps(4) Λ.Ide_Src Λ.Ide_implies_Arr
                      cong_standard_development development_Ide ind1 t t1)
                finally show ?thesis by blast
              qed
              hence "[t1 ❙∘ t2] ⇧*\\⇧* map (λa. a ❙∘ Λ.Src t2) (standard_development t1) =
                     [t1 ❙∘ t2] ⇧*\\⇧* [t1 ❙∘ Λ.Src t2]"
                by (metis Resid_parallel con_imp_coinitial prfx_implies_con calculation
                    development_implies map_is_Nil_conv t1)
              also have "[t1 ❙∘ t2] ⇧*\\⇧* [t1 ❙∘ Λ.Src t2] = [Λ.Trg t1 ❙∘ t2]"
                using t Λ.arr_resid_iff_con Λ.resid_Arr_self
                by simp force
              finally have "[t1 ❙∘ t2] ⇧*\\⇧* map (λa. a ❙∘ Λ.Src t2) (standard_development t1) =
                            [Λ.Trg t1 ❙∘ t2]"
                by blast
              thus ?thesis
                by (simp add: Resid1x_as_Resid')
            qed
            thus ?thesis
              by (metis ind2 Λ.Arr.simps(4) Λ.Ide_Trg Λ.Ide_iff_Src_self development_map_App_2
                  Λ.reduction_strategy_def Λ.head_strategy_is_reduction_strategy t)
          qed
          ultimately show ?thesis
            using t development_append [of "t1 ❙∘ t2"
                                           "map (λa. a ❙∘ Λ.Src t2) (standard_development t1)"
                                           "map (λb. Λ.Trg t1 ❙∘ b) (standard_development t2)"]
            by auto
        qed
      qed
      next
      fix t1 t2
      assume ind: "Λ.Arr t1 ∧ Λ.Arr t2 ⟹
                     Λ.Arr (Λ.subst t2 t1)
                        ⟶ development (Λ.subst t2 t1) (standard_development (Λ.subst t2 t1))"
      show "Λ.Arr (❙λ❙[t1❙] ❙⦁ t2) ⟶ development (❙λ❙[t1❙] ❙⦁ t2) (standard_development (❙λ❙[t1❙] ❙⦁ t2))"
      proof
        assume 1: "Λ.Arr (❙λ❙[t1❙] ❙⦁ t2)"
        have "development (Λ.subst t2 t1) (standard_development (Λ.subst t2 t1))"
          using 1 ind by (simp add: Λ.Arr_Subst)
        thus "development (❙λ❙[t1❙] ❙⦁ t2) (standard_development (❙λ❙[t1❙] ❙⦁ t2))"
          using 1 Λ.Ide_Src Λ.subs_Ide by auto
      qed
    qed

    lemma Std_standard_development:
    shows "Std (standard_development t)"
      apply (rule standard_development.induct)
          apply simp_all
      using Std_map_Lam
        apply blast
    proof
      fix t u
      assume t: "Λ.Arr t ∧ Λ.Arr u ⟹ Std (standard_development t)"
      assume u: "Λ.Arr t ∧ Λ.Arr u ⟹ Std (standard_development u)"
      assume 0: "Λ.Arr t ∧ Λ.Arr u"
      show "Std (map (λa. a ❙∘ Λ.Src u) (standard_development t) @
                 map (λb. Λ.Trg t ❙∘ b) (standard_development u))"
      proof (cases "Λ.Ide t")
        show "Λ.Ide t ⟹ ?thesis"
          using 0 Λ.Ide_iff_Trg_self Ide_iff_standard_development_empty u Std_map_App2
          by fastforce
        assume 1: "¬ Λ.Ide t"
        show ?thesis
        proof (cases "Λ.Ide u")
          show "Λ.Ide u ⟹ ?thesis"
            using t u 0 1 Std_map_App1 [of "Λ.Src u" "standard_development t"] Λ.Ide_Src
            by (metis Ide_iff_standard_development_empty append_Nil2 list.simps(8))
          assume 2: "¬ Λ.Ide u"
          show ?thesis
          proof (intro Std_append)
            show 3: "Std (map (λa. a ❙∘ Λ.Src u) (standard_development t))"
              using t 0 Std_map_App1 Λ.Ide_Src by blast
            show "Std (map (λb. Λ.Trg t ❙∘ b) (standard_development u))"
              using u 0 Std_map_App2 Λ.Ide_Trg by simp
            show "map (λa. a ❙∘ Λ.Src u) (standard_development t) = [] ∨
                  map (λb. Λ.Trg t ❙∘ b) (standard_development u) = [] ∨
                  Λ.sseq (last (map (λa. a ❙∘ Λ.Src u) (standard_development t)))
                       (hd (map (λb. Λ.Trg t ❙∘ b) (standard_development u)))"
            proof -
              have "Λ.sseq (last (map (λa. a ❙∘ Λ.Src u) (standard_development t)))
                           (hd (map (λb. Λ.Trg t ❙∘ b) (standard_development u)))"
              proof -
                obtain x where x: "last (map (λa. a ❙∘ Λ.Src u) (standard_development t)) =
                                   x ❙∘ Λ.Src u"
                  using 0 1 Ide_iff_standard_development_empty last_map by auto
                obtain y where y: "hd (map (λb. Λ.Trg t ❙∘ b) (standard_development u)) =
                                   Λ.Trg t ❙∘ y"
                  using 0 2 Ide_iff_standard_development_empty list.map_sel(1) by auto
                have "Λ.elementary_reduction x"
                proof -
                  have "Λ.elementary_reduction (x ❙∘ Λ.Src u)"
                    using x
                    by (metis 0 1 3 Ide_iff_standard_development_empty Nil_is_map_conv Std.simps(2)
                        Std_imp_sseq_last_hd append_butlast_last_id append_self_conv2 list.discI
                        list.sel(1) Λ.sseq_imp_elementary_reduction2)
                  thus ?thesis
                    using 0 Λ.Ide_Src Λ.elementary_reduction_not_ide by auto
                qed
                moreover have "Λ.elementary_reduction y"
                proof -
                  have "Λ.elementary_reduction (Λ.Trg t ❙∘ y)"
                    using y
                    by (metis 0 2 Λ.Ide_Trg Ide_iff_standard_development_empty
                        u Std.elims(2) Λ.elementary_reduction.simps(4) list.map_sel(1) list.sel(1)
                        Λ.sseq_imp_elementary_reduction1)
                  thus ?thesis
                    using 0 Λ.Ide_Trg Λ.elementary_reduction_not_ide by auto
                qed
                moreover have "Λ.Trg t = Λ.Trg x"
                  by (metis 0 1 Ide_iff_standard_development_empty Trg_last_standard_development
                      x Λ.lambda.inject(3) last_map)
                moreover have "Λ.Src u = Λ.Src y"
                  using y
                  by (metis 0 2 Λ.Arr_not_Nil Λ.Coinitial_iff_Con
                      Ide_iff_standard_development_empty development.elims(2) development_imp_Arr
                      development_standard_development Λ.lambda.inject(3) list.map_sel(1)
                      list.sel(1))
                ultimately show ?thesis
                  using x y by simp
              qed
              thus ?thesis by blast
            qed
          qed
        qed
      qed
      next
      fix t u
      assume ind: "Λ.Arr t ∧ Λ.Arr u ⟹ Std (standard_development (Λ.subst u t))"
      show "Λ.Arr t ∧ Λ.Arr u
              ⟶ Std ((❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) # standard_development (Λ.subst u t))"
      proof
        assume 1: "Λ.Arr t ∧ Λ.Arr u"
        show "Std ((❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) # standard_development (Λ.subst u t))"
        proof (cases "Λ.Ide (Λ.subst u t)")
          show "Λ.Ide (Λ.subst u t)
                  ⟹ Std ((❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) # standard_development (Λ.subst u t))"
            using 1 Λ.Arr_Subst Λ.Ide_Src Ide_iff_standard_development_empty by simp
          assume 2: "¬ Λ.Ide (Λ.subst u t)"
          show "Std ((❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) # standard_development (Λ.subst u t))"
          proof -
            have "Λ.sseq (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) (hd (standard_development (Λ.subst u t)))"
            proof -
              have "Λ.elementary_reduction (hd (standard_development (Λ.subst u t)))"
                using ind
                by (metis 1 2 Λ.Arr_Subst Ide_iff_standard_development_empty
                    Std.elims(2) list.sel(1) Λ.sseq_imp_elementary_reduction1)
              moreover have "Λ.seq (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u)
                                   (hd (standard_development (Λ.subst u t)))"
                using 1 2 Src_hd_standard_development calculation Λ.Arr.simps(5)
                       Λ.Arr_Src Λ.Arr_Subst Λ.Src_Subst Λ.Trg.simps(4) Λ.Trg_Src Λ.arr_char
                       Λ.elementary_reduction_is_arr Λ.seq_char
                by presburger
              ultimately show ?thesis
                using 1 Λ.Ide_Src Λ.sseq_Beta by auto
            qed
            moreover have "Std (standard_development (Λ.subst u t))"
              using 1 ind by blast
            ultimately show ?thesis
              by (metis 1 2 Λ.Arr_Subst Ide_iff_standard_development_empty Std.simps(3)
                  list.collapse)
          qed
        qed
      qed
    qed

    subsection "Standardization"

    text ‹
      In this section, we define and prove correct a function that takes an arbitrary
      reduction path and produces a standard reduction path congruent to it.
      The method is roughly analogous to insertion sort: given a path, recursively
      standardize the tail and then ``insert'' the head into to the result.
      A complication is that in general the head may be a parallel reduction instead
      of an elementary reduction, and in any case elementary reductions are
      not preserved under residuation so we need to be able to handle the parallel
      reductions that arise from permuting elementary reductions.
      In general, this means that parallel reduction steps have to be decomposed into factors,
      and then each factor has to be inserted at its proper position.
      Another issue is that reductions don't all happen at the top level of a term,
      so we need to be able to descend recursively into terms during the insertion
      procedure.  The key idea here is: in a standard reduction, once a step has occurred
      that is not a head reduction, then all subsequent terms will have ‹App› as their
      top-level constructor.  So, once we have passed a step that is not a head reduction,
      we can recursively descend into the subsequent applications and treat the ``rator''
      and the ``rand'' parts independently.

      The following function performs the core insertion part of the standardization
      algorithm.  It assumes that it is given an arbitrary parallel reduction ‹t› and
      an already-standard reduction path ‹U›, and it inserts ‹t› into ‹U›, producing a
      standard reduction path that is congruent to ‹t # U›.  A somewhat elaborate case
      analysis is required to determine whether ‹t› needs to be factored and whether
      part of it might need to be permuted with the head of ‹U›.  The recursion is complicated
      by the need to make sure that the second argument ‹U› is always a standard reduction
      path.  This is so that it is possible to decide when the rest of the steps will be
      applications and it is therefore possible to recurse into them.  This constrains what
      recursive calls we can make, since we are not able to make a recursive call in which
      an identity has been prepended to ‹U›.  Also, if ‹t # U› consists completely of
      identities, then its standardization is the empty list ‹[]›, which is not a path
      and cannot be congruent to ‹t # U›.  So in order to be able to apply the induction
      hypotheses in the correctness proof, we need to make sure that we don't make
      recursive calls when ‹U› itself would consist entirely of identities.
      Finally, when we descend through an application, the step ‹t› and the path ‹U› are
      projected to their ``rator'' and ``rand'' components, which are treated separately
      and the results concatenated.  However, the projection operations can introduce
      identities and therefore do not preserve elementary reductions.  To handle this,
      we need to filter out identities after projection but before the recursive call.

      Ensuring termination also involves some care: we make recursive calls in which
      the length of the second argument is increased, but the ``height'' of the first
      argument is decreased.  So we use a lexicographic order that makes the height
      of the first argument more significant and the length of the second argument
      secondary.  The base cases either discard paths that consist entirely of
      identities, or else they expand a single parallel reduction ‹t› into a standard
      development.
    ›

    function (sequential) stdz_insert
    where "stdz_insert t [] = standard_development t"
        | "stdz_insert ❙«_❙» U = stdz_insert (hd U) (tl U)"
        | "stdz_insert ❙λ❙[t❙] U =
           (if Λ.Ide t then
              stdz_insert (hd U) (tl U)
            else
              map Λ.Lam (stdz_insert t (map Λ.un_Lam U)))"
        | "stdz_insert (❙λ❙[t❙] ❙∘ u) ((❙λ❙[_❙] ❙⦁ _) # U) = stdz_insert (❙λ❙[t❙] ❙⦁ u) U"
        | "stdz_insert (t ❙∘ u) U =
           (if Λ.Ide (t ❙∘ u) then
              stdz_insert (hd U) (tl U)
            else if Λ.seq (t ❙∘ u) (hd U) then
              if Λ.contains_head_reduction (t ❙∘ u) then
                if Λ.Ide ((t ❙∘ u) \\ Λ.head_redex (t ❙∘ u)) then
                  Λ.head_redex (t ❙∘ u) # stdz_insert (hd U) (tl U)
                else
                  Λ.head_redex (t ❙∘ u) # stdz_insert ((t ❙∘ u) \\ Λ.head_redex (t ❙∘ u)) U
              else if Λ.contains_head_reduction (hd U) then
                if Λ.Ide ((t ❙∘ u) \\ Λ.head_strategy (t ❙∘ u)) then
                  stdz_insert (Λ.head_strategy (t ❙∘ u)) (tl U)
                else
                  Λ.head_strategy (t ❙∘ u) # stdz_insert ((t ❙∘ u) \\ Λ.head_strategy (t ❙∘ u)) (tl U)
              else
                map (λa. a ❙∘ Λ.Src u)
                    (stdz_insert t (filter notIde (map Λ.un_App1 U))) @
                map (λb. Λ.Trg (Λ.un_App1 (last U)) ❙∘ b)
                    (stdz_insert u (filter notIde (map Λ.un_App2 U)))
            else [])"
        | "stdz_insert (❙λ❙[t❙] ❙⦁ u) U =
           (if Λ.Arr t ∧ Λ.Arr u then
              (❙λ❙[Λ.Src t❙] ❙⦁ Λ.Src u) # stdz_insert (Λ.subst u t) U
            else [])"
        | "stdz_insert _ _ = []"
    by pat_completeness auto

    (*
     * TODO:
     * In the case "stdz_insert (M ❙∘ N) U":
     *   The "if Λ.seq (M ❙∘ N) (hd U)" is needed for the termination proof.
     *   The first "if Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N)))"
     *     cannot be removed because the resulting induction rule does not contain
     *     the induction hypotheses necessary to prove the correctness.
     *   The second "if Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N)))"
     *     results in a similar, but different problem.
     * In the case "stdz_insert (Λ.Beta M N) U":
     *   The "if Λ.Arr M ∧ Λ.Arr N" is needed for the termination proof.
     * It is possible that the function would still be correct if some of the tests
     *   for whether the term being inserted is an identity were omitted, but if these
     *   tests are removed, then the correctness proof fails ways that are not obviously
     *   repairable, probably due to the induction rule not having all the needed
     *   induction hypotheses.
     *)

    fun standardize
    where "standardize [] = []"
        | "standardize U = stdz_insert (hd U) (standardize (tl U))"

    abbreviation stdzins_rel
    where "stdzins_rel ≡ mlex_prod (length o snd) (inv_image (mlex_prod Λ.hgt Λ.subterm_rel) fst)"

    termination stdz_insert
      using Λ.subterm.intros(2-3) Λ.hgt_Subst less_Suc_eq_le Λ.elementary_reduction_decreases_hgt
            Λ.elementary_reduction_head_redex Λ.contains_head_reduction_iff
            Λ.elementary_reduction_is_arr Λ.Src_head_redex Λ.App_Var_contains_no_head_reduction
            Λ.hgt_resid_App_head_redex Λ.seq_char
      apply (relation stdzins_rel)
      apply (auto simp add: wf_mlex Λ.wf_subterm_rel mlex_iff mlex_less Λ.subterm_lemmas(1))
      by (meson dual_order.eq_iff length_filter_le not_less_eq_eq)+

    lemma stdz_insert_Ide:
    shows "Ide (t # U) ⟹ stdz_insert t U = []"
    proof (induct U arbitrary: t)
      show "⋀t. Ide [t] ⟹ stdz_insert t [] = []"
        by (metis Ide_iff_standard_development_empty Λ.Ide_implies_Arr Ide.simps(2)
            Λ.ide_char stdz_insert.simps(1))
      show "⋀U. ⟦⋀t. Ide (t # U) ⟹ stdz_insert t U = []; Ide (t # u # U)⟧
                       ⟹ stdz_insert t (u # U) = []"
        for t u
        using Λ.ide_char
        apply (cases t; cases u)
            apply simp_all
        by fastforce
    qed

    lemma stdz_insert_Ide_Std:
    shows "⟦Λ.Ide u; seq [u] U; Std U⟧ ⟹ stdz_insert u U = stdz_insert (hd U) (tl U)"
    proof (induct U arbitrary: u)
      show "⋀u. ⟦Λ.Ide u; seq [u] []; Std []⟧ ⟹ stdz_insert u [] = stdz_insert (hd []) (tl [])"
        by (simp add: seq_char)
      fix u v U
      assume u: "Λ.Ide u"
      assume seq: "seq [u] (v # U)"
      assume Std: "Std (v # U)"
      assume ind: "⋀u. ⟦Λ.Ide u; seq [u] U; Std U⟧
                          ⟹ stdz_insert u U = stdz_insert (hd U) (tl U)"
      show "stdz_insert u (v # U) = stdz_insert (hd (v # U)) (tl (v # U))"
        using u ind stdz_insert_Ide Ide_implies_Arr
        apply (cases u; cases v)
                            apply simp_all
      proof -
        fix x y a b
        assume xy: "Λ.Ide x ∧ Λ.Ide y"
        assume u': "u = x ❙∘ y"
        assume v': "v = ❙λ❙[a❙] ❙⦁ b"
        have ab: "Λ.Ide a ∧ Λ.Ide b"
          using Std ‹v = ❙λ❙[a❙] ❙⦁ b› Std.elims(2) Λ.sseq_Beta
          by (metis Std_consE Λ.elementary_reduction.simps(5) Std.simps(2))
        have "x = ❙λ❙[a❙] ∧ y = b"
          using xy ab u u' v' seq seq_char
          by (metis Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self Λ.Ide_implies_Arr Λ.Src.simps(5)
              Srcs_simp⇩Λ⇩P Trgs.simps(2) Λ.lambda.inject(3) list.sel(1) singleton_insert_inj_eq
              Λ.targets_char⇩Λ)
        thus "stdz_insert (x ❙∘ y) ((❙λ❙[a❙] ❙⦁ b) # U) = stdz_insert (❙λ❙[a❙] ❙⦁ b) U"
          using u u' stdz_insert.simps(4) by presburger
      qed
    qed

    text ‹
      Insertion of a term with ‹Beta› as its top-level constructor always
      leaves such a term at the head of the result.  Stated another way,
      ‹Beta› at the top-level must always come first in a standard reduction path.
    ›

    lemma stdz_insert_Beta_ind:
    shows "⟦Λ.hgt t + length U ≤ n; Λ.is_Beta t; seq [t] U⟧
              ⟹ Λ.is_Beta (hd (stdz_insert t U))"
    proof (induct n arbitrary: t U)
      show "⋀t U. ⟦Λ.hgt t + length U ≤ 0; Λ.is_Beta t; seq [t] U⟧
                      ⟹ Λ.is_Beta (hd (stdz_insert t U))"
        using Arr.simps(1) seq_char by blast
      fix n t U
      assume ind: "⋀t U. ⟦Λ.hgt t + length U ≤ n; Λ.is_Beta t; seq [t] U⟧
                             ⟹ Λ.is_Beta (hd (stdz_insert t U))"
      assume seq: "seq [t] U"
      assume n: "Λ.hgt t + length U ≤ Suc n"
      assume t: "Λ.is_Beta t"
      show "Λ.is_Beta (hd (stdz_insert t U))"
        using t seq seq_char
        by (cases U; cases t; cases "hd U") auto
    qed

    lemma stdz_insert_Beta:
    assumes "Λ.is_Beta t" and "seq [t] U"
    shows "Λ.is_Beta (hd (stdz_insert t U))"
      using assms stdz_insert_Beta_ind by blast

    text ‹
      This is the correctness lemma for insertion:
      Given a term ‹t› and standard reduction path ‹U› sequential with it,
      the result of insertion is a standard reduction path which is
      congruent to ‹t # U› unless ‹t # U› consists entirely of identities.

      The proof is very long.  Its structure parallels that of the definition
      of the function ‹stdz_insert›.  For really understanding the details,
      I strongly suggest viewing the proof in Isabelle/JEdit and using the
      code folding feature to unfold the proof a little bit at a time.
    ›

    lemma stdz_insert_correctness:
    shows "seq [t] U ∧ Std U ⟶
              Std (stdz_insert t U) ∧ (¬ Ide (t # U) ⟶ cong (stdz_insert t U) (t # U))"
           (is "?P t U")
    proof (rule stdz_insert.induct [of ?P])
      show "⋀t. ?P t []"
        using seq_char by simp
      show "⋀u U. ?P ❙♯ (u # U)"
        using seq_char not_arr_null null_char by auto
      show "⋀x u U. ?P (hd (u # U)) (tl (u # U)) ⟹ ?P ❙«x❙» (u # U)"
      proof -
        fix x u U
        assume ind: "?P (hd (u # U)) (tl (u # U))"
        show "?P ❙«x❙» (u # U)"
        proof (intro impI, elim conjE, intro conjI)
          assume seq: "seq [❙«x❙»] (u # U)"
          assume Std: "Std (u # U)"
          have 1: "stdz_insert ❙«x❙» (u # U) = stdz_insert u U"
            by simp
          have 2: "U ≠ [] ⟹ seq [u] U"
            using Std Std_imp_Arr
            by (simp add: arrI⇩P arr_append_imp_seq)
          show "Std (stdz_insert ❙«x❙» (u # U))"
            using ind
            by (metis 1 2 Std Std_standard_development list.exhaust_sel list.sel(1) list.sel(3)
                reduction_paths.Std.simps(3) reduction_paths.stdz_insert.simps(1))
          show "¬ Ide (❙«x❙» # u # U) ⟶ stdz_insert ❙«x❙» (u # U) ⇧*∼⇧* ❙«x❙» # u # U"
          proof (cases "U = []")
            show "U = [] ⟹ ?thesis"
              using cong_standard_development cong_cons_ideI(1)
              apply simp
              by (metis Arr.simps(1-2) Arr_iff_Con_self Con_rec(3) Λ.in_sourcesI con_char
                  cong_transitive ideE Λ.Ide.simps(2) Λ.arr_char Λ.ide_char seq)
            assume U: "U ≠ []"
            show ?thesis
              using 1 2 ind seq seq_char cong_cons_ideI(1)
              apply simp
              by (metis Std Std_consE U Λ.Arr.simps(2) Λ.Ide.simps(2) Λ.targets_simps(2)
                  prfx_transitive)
          qed
        qed
      qed
      show "⋀M u U. ⟦Λ.Ide M ⟹ ?P (hd (u # U)) (tl (u # U));
                     ¬ Λ.Ide M ⟹ ?P M (map Λ.un_Lam (u # U))⟧
                         ⟹ ?P ❙λ❙[M❙] (u # U)"
      proof -
        fix M u U
        assume ind1: "Λ.Ide M ⟹ ?P (hd (u # U)) (tl (u # U))"
        assume ind2: "¬ Λ.Ide M ⟹ ?P M (map Λ.un_Lam (u # U))"
        show "?P ❙λ❙[M❙] (u # U)"
        proof (intro impI, elim conjE)
          assume seq: "seq [❙λ❙[M❙]] (u # U)"
          assume Std: "Std (u # U)"
          have u: "Λ.is_Lam u"
            using seq
            by (metis insert_subset Λ.lambda.disc(8) list.simps(15) mem_Collect_eq
                seq_Lam_Arr_implies)
          have U: "set U ⊆ Collect Λ.is_Lam"
            using u seq
            by (metis insert_subset Λ.lambda.disc(8) list.simps(15) seq_Lam_Arr_implies)
          show "Std (stdz_insert ❙λ❙[M❙] (u # U)) ∧
                  (¬ Ide (❙λ❙[M❙] # u # U) ⟶ stdz_insert ❙λ❙[M❙] (u # U) ⇧*∼⇧* ❙λ❙[M❙] # u # U)"
          proof (cases "Λ.Ide M")
            assume M: "Λ.Ide M"
            have 1: "stdz_insert ❙λ❙[M❙] (u # U) = stdz_insert u U"
              using M by simp
            show ?thesis
            proof (cases "Ide (u # U)")
              show "Ide (u # U) ⟹ ?thesis"
                using 1 Std_standard_development Ide_iff_standard_development_empty
                by (metis Ide_imp_Ide_hd Std Std_implies_set_subset_elementary_reduction
                    Λ.elementary_reduction_not_ide list.sel(1) list.set_intros(1)
                    mem_Collect_eq subset_code(1))
              assume 2: "¬ Ide (u # U)"
              show ?thesis
              proof (cases "U = []")
                assume 3: "U = []"
                have 4: "standard_development u ⇧*∼⇧* [❙λ❙[M❙]] @ [u]"
                  using M 2 3 seq ide_char cong_standard_development [of u]
                        cong_append_ideI(1) [of "[❙λ❙[M❙]]" "[u]"]
                  by (metis Arr_imp_arr_hd Ide.simps(2) Std Std_imp_Arr cong_transitive
                      Λ.Ide.simps(3) Λ.arr_char Λ.ide_char list.sel(1) not_Cons_self2)
                show ?thesis
                  using 1 3 4 Std_standard_development by force
                next
                assume 3: "U ≠ []"
                have "stdz_insert ❙λ❙[M❙] (u # U) = stdz_insert u U"
                  using M 3 by simp
                have 5: "Λ.Arr u ∧ ¬ Λ.Ide u"
                  by (meson "3" Std Std_consE Λ.elementary_reduction_not_ide Λ.ide_char
                      Λ.sseq_imp_elementary_reduction1)
                have 4: "standard_development u @ U ⇧*∼⇧* ([❙λ❙[M❙]] @ [u]) @ U"
                proof (intro cong_append seqI⇩Λ⇩P)
                  show "Arr (standard_development u)"
                    using 5 Std_standard_development Std_imp_Arr Ide_iff_standard_development_empty
                    by force
                  show "Arr U"
                    using Std 3 by auto
                  show "Λ.Trg (last (standard_development u)) = Λ.Src (hd U)"
                    by (metis "3" "5" Std Std_consE Trg_last_standard_development Λ.seq_char
                        Λ.sseq_imp_seq)
                  show "standard_development u ⇧*∼⇧* [❙λ❙[M❙]] @ [u]"
                    using M 5 Std Std_imp_Arr cong_standard_development [of u]
                          cong_append_ideI(3) [of "[❙λ❙[M❙]]" "[u]"]
                    by (metis (no_types, lifting) Arr.simps(2) Ide.simps(2) arr_char ide_char
                        Λ.Ide.simps(3) Λ.arr_char Λ.ide_char prfx_transitive seq seq_def
                        sources_cons)
                  show "U ⇧*∼⇧* U"
                    by (simp add: ‹Arr U› arr_char prfx_reflexive)
                qed
                show ?thesis
                proof (intro conjI)
                  show "Std (stdz_insert ❙λ❙[M❙] (u # U))"
                    by (metis (no_types, lifting) 1 3 M Std Std_consE append_Cons
                        append_eq_append_conv2 append_self_conv arr_append_imp_seq ind1
                        list.sel(1) list.sel(3) not_Cons_self2 seq seq_def)
                  show "¬ Ide (❙λ❙[M❙] # u # U) ⟶ stdz_insert ❙λ❙[M❙] (u # U) ⇧*∼⇧* ❙λ❙[M❙] # u # U"
                  proof
                    have "seq [u] U ∧ Std U"
                      using 2 3 Std
                      by (metis Cons_eq_appendI Std_consE arr_append_imp_seq neq_Nil_conv
                          self_append_conv2 seq seqE)
                    thus "stdz_insert ❙λ❙[M❙] (u # U) ⇧*∼⇧* ❙λ❙[M❙] # u # U"
                      using M 1 2 3 4 ind1 cong_cons_ideI(1) [of "❙λ❙[M❙]" "u # U"]
                      apply simp
                      by (meson cong_transitive seq)
                  qed
                qed
              qed
            qed
            next
            assume M: "¬ Λ.Ide M"
            have 1: "stdz_insert ❙λ❙[M❙] (u # U) =
                     map Λ.Lam (stdz_insert M (Λ.un_Lam u # map Λ.un_Lam U))"
              using M by simp
            show ?thesis
            proof (intro conjI)
              show "Std (stdz_insert ❙λ❙[M❙] (u # U))"
                by (metis "1" M Std Std_map_Lam Std_map_un_Lam ind2 Λ.lambda.disc(8)
                    list.simps(9) seq seq_Lam_Arr_implies seq_map_un_Lam)
              show "¬ Ide (❙λ❙[M❙] # u # U) ⟶ stdz_insert ❙λ❙[M❙] (u # U) ⇧*∼⇧* ❙λ❙[M❙] # u # U"
              proof
                have "map Λ.Lam (stdz_insert M (Λ.un_Lam u # map Λ.un_Lam U)) ⇧*∼⇧*
                      ❙λ❙[M❙] # u # U"
                proof - 
                  have "map Λ.Lam (stdz_insert M (Λ.un_Lam u # map Λ.un_Lam U)) ⇧*∼⇧*
                        map Λ.Lam (M # Λ.un_Lam u # map Λ.un_Lam U)"
                    by (metis (mono_tags, opaque_lifting) Ide_imp_Ide_hd M Std Std_map_un_Lam
                        cong_map_Lam ind2 Λ.ide_char Λ.lambda.discI(2)
                        list.sel(1) list.simps(9) seq seq_Lam_Arr_implies seq_map_un_Lam)
                  thus ?thesis
                    using u U
                    by (simp add: map_idI subset_code(1))
                qed
                thus "stdz_insert ❙λ❙[M❙] (u # U) ⇧*∼⇧* ❙λ❙[M❙] # u # U"
                  using "1" by presburger
              qed
            qed
          qed
        qed
      qed
      show "⋀M N A B U. ?P (❙λ❙[M❙] ❙⦁ N) U ⟹ ?P (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U)"
      proof -
        fix M N A B U
        assume ind: "?P (❙λ❙[M❙] ❙⦁ N) U"
        show "?P (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U)"
        proof (intro impI, elim conjE)
          assume seq: "seq [❙λ❙[M❙] ❙∘ N] ((❙λ❙[A❙] ❙⦁ B) # U)"
          assume Std: "Std ((❙λ❙[A❙] ❙⦁ B) # U)"
          have MN: "Λ.Arr M ∧ Λ.Arr N"
            using seq
            by (simp add: seq_char)
          have AB: "Λ.Trg M = A ∧ Λ.Trg N = B"
          proof -
            have 1: "Λ.Ide A ∧ Λ.Ide B"
              using Std
              by (metis Std.simps(2) Std.simps(3) Λ.elementary_reduction.simps(5)
                        list.exhaust_sel Λ.sseq_Beta)
            moreover have "Trgs [❙λ❙[M❙] ❙∘ N] = Srcs [❙λ❙[A❙] ❙⦁ B]"
              using 1 seq seq_char
              by (simp add: Λ.Ide_implies_Arr Srcs_simp⇩Λ⇩P)
            ultimately show ?thesis
              by (metis Λ.Ide_iff_Src_self Λ.Ide_implies_Arr Λ.Src.simps(5) Srcs_simp⇩Λ⇩P
                  Λ.Trg.simps(2-3) Trgs_simp⇩Λ⇩P Λ.lambda.inject(2) Λ.lambda.sel(3-4)
                  last.simps list.sel(1) seq_char seq the_elem_eq)
          qed
          have 1: "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) = stdz_insert (❙λ❙[M❙] ❙⦁ N) U"
            by auto
          show "Std (stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U)) ∧
                (¬ Ide ((❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U) ⟶
                   stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) ⇧*∼⇧* (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U)"
          proof (cases "U = []")
            assume U: "U = []"
            have 1: "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) =
                     standard_development (❙λ❙[M❙] ❙⦁ N)"
              using U by simp
            show ?thesis
            proof (intro conjI)
              show "Std (stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U))"
                using 1 Std_standard_development by presburger
              show "¬ Ide ((❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U) ⟶
                      stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) ⇧*∼⇧* (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U"
              proof (intro impI)
                assume 2: "¬ Ide ((❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U)"
                have "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) =
                      (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) # standard_development (Λ.subst N M)"
                  using 1 MN by simp
                also have "... ⇧*∼⇧* [❙λ❙[M❙] ❙⦁ N]"
                  using MN AB cong_standard_development
                  by (metis 1 calculation Λ.Arr.simps(5) Λ.Ide.simps(5))
                also have "[❙λ❙[M❙] ❙⦁ N] ⇧*∼⇧* (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U"
                  using AB MN U Beta_decomp(2) [of M N] by simp
                finally show "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) ⇧*∼⇧*
                              (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U"
                  by blast
              qed
            qed
            next
            assume U: "U ≠ []"
            have 1: "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) = stdz_insert (❙λ❙[M❙] ❙⦁ N) U"
              using U by simp
            have 2: "seq [❙λ❙[M❙] ❙⦁ N] U"
              using MN AB U Std Λ.sseq_imp_seq
              apply (intro seqI⇩Λ⇩P)
                apply auto
              by fastforce
            have 3: "Std U"
              using Std by fastforce
            show ?thesis
            proof (intro conjI)
              show "Std (stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U))"
                using 2 3 ind by simp
              show "¬ Ide ((❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U) ⟶
                      stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) ⇧*∼⇧* (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U"
              proof
                have "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) ⇧*∼⇧* [❙λ❙[M❙] ❙⦁ N] @ U"
                  by (metis "1" "2" "3" Λ.Ide.simps(5) U Ide.simps(3) append.left_neutral
                      append_Cons Λ.ide_char ind list.exhaust)
                also have "[❙λ❙[M❙] ❙⦁ N] @ U ⇧*∼⇧* ([❙λ❙[M❙] ❙∘ N] @ [❙λ❙[A❙] ❙⦁ B]) @ U"
                  using MN AB Beta_decomp
                  by (meson "2" cong_append cong_reflexive seqE)
                also have "([❙λ❙[M❙] ❙∘ N] @ [❙λ❙[A❙] ❙⦁ B]) @ U = (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U"
                  by simp
                finally show "stdz_insert (❙λ❙[M❙] ❙∘ N) ((❙λ❙[A❙] ❙⦁ B) # U) ⇧*∼⇧*
                              (❙λ❙[M❙] ❙∘ N) # (❙λ❙[A❙] ❙⦁ B) # U"
                  by argo
              qed
            qed
          qed
        qed
      qed
      show "⋀M N u U. (Λ.Arr M ∧ Λ.Arr N ⟹ ?P (Λ.subst N M) (u # U))
                          ⟹ ?P (❙λ❙[M❙] ❙⦁ N) (u # U)"
      proof -
        fix M N u U
        assume ind: "Λ.Arr M ∧ Λ.Arr N ⟹ ?P (Λ.subst N M) (u # U)"
        show "?P (❙λ❙[M❙] ❙⦁ N) (u # U)"
        proof (intro impI, elim conjE)
          assume seq: "seq [❙λ❙[M❙] ❙⦁ N] (u # U)"
          assume Std: "Std (u # U)"
          have MN: "Λ.Arr M ∧ Λ.Arr N"
            using seq seq_char by simp
          show "Std (stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U)) ∧
                (¬ Ide (Λ.Beta M N # u # U) ⟶
                    cong (stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U)) ((❙λ❙[M❙] ❙⦁ N) # u # U))"
          proof (cases "Λ.Ide (Λ.subst N M)")
            assume 1: "Λ.Ide (Λ.subst N M)"
            have 2: "¬ Ide (u # U)"
              using Std Std_implies_set_subset_elementary_reduction Λ.elementary_reduction_not_ide
              by force
            have 3: "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) = (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) # stdz_insert u U"
              using MN 1 seq seq_char Std stdz_insert_Ide_Std [of "Λ.subst N M" "u # U"]
                     Λ.Ide_implies_Arr
              by (cases "U = []") auto
            show ?thesis
            proof (cases "U = []")
              assume U: "U = []"
              have 3: "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) =
                       (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) # standard_development u"
                using 2 3 U by force
              have 4: "Λ.seq (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) (hd (standard_development u))"
              proof
                show "Λ.Arr (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N)"
                  using MN by simp
                show "Λ.Arr (hd (standard_development u))"
                  by (metis 2 Arr_imp_arr_hd Ide.simps(2) Ide_iff_standard_development_empty
                      Std Std_consE Std_imp_Arr Std_standard_development U Λ.arr_char
                      Λ.ide_char)
                show "Λ.Trg (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) = Λ.Src (hd (standard_development u))"
                  by (metis 1 2 Ide.simps(2) MN Src_hd_standard_development Std Std_consE
                      Trg_last_Src_hd_eqI U Λ.Ide_iff_Src_self Λ.Ide_implies_Arr Λ.Src_Subst
                      Λ.Trg.simps(4) Λ.Trg_Src Λ.Trg_Subst Λ.ide_char last_ConsL list.sel(1) seq)
              qed
              show ?thesis
              proof (intro conjI)
                show "Std (stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U))"
                proof -
                  have "Λ.sseq (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) (hd (standard_development u))"
                    using MN 2 4 U Λ.Ide_Src
                    apply (intro Λ.sseq_BetaI)
                       apply auto
                    by (metis Ide.simps(1) Resid.simps(2) Std Std_consE
                        Std_standard_development cong_standard_development hd_Cons_tl ide_char
                        Λ.sseq_imp_elementary_reduction1 Std.simps(2))
                  thus ?thesis
                    by (metis 3 Std.simps(2-3) Std_standard_development hd_Cons_tl
                        Λ.sseq_imp_elementary_reduction1)
                qed
                show "¬ Ide ((❙λ❙[M❙] ❙⦁ N) # u # U)
                          ⟶ stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) ⇧*∼⇧* (❙λ❙[M❙] ❙⦁ N) # u # U"
                proof
                  have "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) =
                        [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ standard_development u"
                    using 3 by simp
                  also have 5: "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ standard_development u ⇧*∼⇧*
                                [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [u]"
                  proof (intro cong_append)
                    show "seq [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] (standard_development u)"
                      by (metis 2 3 Ide.simps(2) Ide_iff_standard_development_empty
                          Std Std_consE Std_imp_Arr U ‹Std (stdz_insert (Λ.Beta M N) (u # U))›
                          arr_append_imp_seq arr_char calculation Λ.ide_char neq_Nil_conv)
                    thus "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] ⇧*∼⇧* [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N]"
                      using cong_reflexive by blast
                    show "standard_development u ⇧*∼⇧* [u]"
                      by (metis 2 Arr.simps(2) Ide.simps(2) Std Std_imp_Arr U
                          cong_standard_development Λ.arr_char Λ.ide_char not_Cons_self2)
                  qed
                  also have "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [u] ⇧*∼⇧*
                             ([❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [Λ.subst N M]) @ [u]"
                  proof (intro cong_append)
                    show "seq [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] [u]"
                      by (metis 5 Con_implies_Arr(1) Ide.simps(1) arr_append_imp_seq
                          arr_char ide_char not_Cons_self2)
                    show "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] ⇧*∼⇧* [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [Λ.subst N M]"
                      by (metis (full_types) 1 MN Ide_iff_standard_development_empty
                          cong_standard_development cong_transitive Λ.Arr.simps(5) Λ.Arr_Subst
                          Λ.Ide.simps(5) Beta_decomp(1) standard_development.simps(5))
                    show "[u] ⇧*∼⇧* [u]"
                      using Resid_Arr_self Std Std_imp_Arr U ide_char by blast
                  qed
                  also have "([❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [Λ.subst N M]) @ [u] ⇧*∼⇧* [❙λ❙[M❙] ❙⦁ N] @ [u]"
                    by (metis Beta_decomp(1) MN U Resid_Arr_self cong_append
                        ide_char seq_char seq)
                  also have "[❙λ❙[M❙] ❙⦁ N] @ [u] = (❙λ❙[M❙] ❙⦁ N) # u # U"
                    using U by simp
                  finally show "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) ⇧*∼⇧* (❙λ❙[M❙] ❙⦁ N) # u # U"
                    by blast
                qed
              qed
              next
              assume U: "U ≠ []"
              have 4: "seq [u] U"
                by (simp add: Std U arrI⇩P arr_append_imp_seq)
              have 5: "Std U"
                using Std by auto
              have 6: "Std (stdz_insert u U) ∧
                       set (stdz_insert u U) ⊆ {a. Λ.elementary_reduction a} ∧
                       (¬ Ide (u # U) ⟶
                       cong (stdz_insert u U) (u # U))"
              proof -
                have "seq [Λ.subst N M] (u # U) ∧ Std (u # U)"
                  using MN Std Std_imp_Arr Λ.Arr_Subst
                  apply (intro conjI seqI⇩Λ⇩P)
                     apply simp_all
                  by (metis Trg_last_Src_hd_eqI Λ.Trg.simps(4) last_ConsL list.sel(1) seq)
                thus ?thesis
                  using MN 1 2 3 4 5 ind Std_implies_set_subset_elementary_reduction
                        stdz_insert_Ide_Std
                  apply simp
                  by (meson cong_cons_ideI(1) cong_transitive lambda_calculus.ide_char)
              qed
              have 7: "Λ.seq (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) (hd (stdz_insert u U))"
                using MN 1 2 6 Arr_imp_arr_hd Con_implies_Arr(2) ide_char Λ.arr_char
                      Ide_iff_standard_development_empty Src_hd_eqI Trg_last_Src_hd_eqI
                      Trg_last_standard_development Λ.Ide_implies_Arr seq
                apply (intro Λ.seqI⇩Λ)
                  apply simp
                 apply (metis Ide.simps(1))
                by (metis Λ.Arr.simps(5) Λ.Ide.simps(5) last.simps standard_development.simps(5))
              have 8: "seq [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] (stdz_insert u U)"
                by (metis 2 6 7 seqI⇩Λ⇩P Arr.simps(2) Con_implies_Arr(2)
                    Ide.simps(1) ide_char last.simps Λ.seqE Λ.seq_char)
              show ?thesis
              proof (intro conjI)
                show "Std (stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U))"
                proof -
                  have "Λ.sseq (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) (hd (stdz_insert u U))"
                    by (metis MN 2 6 7 Λ.Ide_Src Std.elims(2) Ide.simps(1)
                        Resid.simps(2) ide_char list.sel(1) Λ.sseq_BetaI
                        Λ.sseq_imp_elementary_reduction1)
                  thus ?thesis
                    by (metis 2 3 6 Std.simps(3) Resid.simps(1) con_char prfx_implies_con
                        list.exhaust_sel)
                qed
                show "¬ Ide ((❙λ❙[M❙] ❙⦁ N) # u # U)
                          ⟶ stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) ⇧*∼⇧* (❙λ❙[M❙] ❙⦁ N) # u # U"
                proof
                  have "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) = [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ stdz_insert u U"
                    using 3 by simp
                  also have "... ⇧*∼⇧* [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ u # U"
                    using MN 2 3 6 8 cong_append
                    by (meson cong_reflexive seqE)
                  also have "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ u # U ⇧*∼⇧*
                             ([❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [Λ.subst N M]) @ u # U"
                    using MN 1 2 6 8 Beta_decomp(1) Std Src_hd_eqI Trg_last_Src_hd_eqI
                          Λ.Arr_Subst Λ.ide_char ide_char
                    apply (intro cong_append cong_append_ideI seqI⇩Λ⇩P)
                           apply auto[2]
                         apply metis
                        apply auto[4]
                    by (metis cong_transitive)
                  also have "([❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [Λ.subst N M]) @ u # U ⇧*∼⇧*
                             [❙λ❙[M❙] ❙⦁ N] @ u # U"
                    by (meson MN 2 6 Beta_decomp(1) cong_append prfx_transitive seq)
                  also have "[❙λ❙[M❙] ❙⦁ N] @ u # U = (❙λ❙[M❙] ❙⦁ N) # u # U"
                    by simp
                  finally show "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) ⇧*∼⇧* (❙λ❙[M❙] ❙⦁ N) # u # U"
                    by simp
                qed
              qed
            qed
            next
            assume 1: "¬ Λ.Ide (Λ.subst N M)"
            have 2: "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) =
                     (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) # stdz_insert (Λ.subst N M) (u # U)"
              using 1 MN by simp
            have 3: "seq [Λ.subst N M] (u # U)"
              using Λ.Arr_Subst MN seq_char seq by force
            have 4: "Std (stdz_insert (Λ.subst N M) (u # U)) ∧
                     set (stdz_insert (Λ.subst N M) (u # U)) ⊆ {a. Λ.elementary_reduction a} ∧
                     stdz_insert (Λ.Subst 0 N M) (u # U) ⇧*∼⇧* Λ.subst N M # u # U"
              using 1 3 Std ind MN Ide.simps(3) Λ.ide_char
                    Std_implies_set_subset_elementary_reduction
              by presburger
            have 5: "Λ.seq (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) (hd (stdz_insert (Λ.subst N M) (u # U)))"
              using MN 4
              apply (intro Λ.seqI⇩Λ)
                apply simp
               apply (metis Arr_imp_arr_hd Con_implies_Arr(1) Ide.simps(1) ide_char Λ.arr_char)
              using Src_hd_eqI
              by force
            show ?thesis
            proof (intro conjI)
              show "Std (stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U))"
              proof -
                have "Λ.sseq (❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N) (hd (stdz_insert (Λ.subst N M) (u # U)))"
                  using 5
                  by (metis 4 MN Λ.Ide_Src Std.elims(2) Ide.simps(1) Resid.simps(2)
                      ide_char list.sel(1) Λ.sseq_BetaI Λ.sseq_imp_elementary_reduction1)
                thus ?thesis
                  by (metis 2 4 Std.simps(3) Arr.simps(1) Con_implies_Arr(2)
                      Ide.simps(1) ide_char list.exhaust_sel)
              qed
              show "¬ Ide ((❙λ❙[M❙] ❙⦁ N) # u # U)
                        ⟶ stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) ⇧*∼⇧* (❙λ❙[M❙] ❙⦁ N) # u # U"
              proof
                have "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) =
                      [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ stdz_insert (Λ.subst N M) (u # U)"
                  using 2 by simp
                also have "... ⇧*∼⇧* [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ Λ.subst N M # u # U"
                proof (intro cong_append)
                  show "seq [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] (stdz_insert (Λ.subst N M) (u # U))"
                    by (metis 4 5 Arr.simps(2) Con_implies_Arr(1) Ide.simps(1) ide_char
                        Λ.arr_char Λ.seq_char last_ConsL seqI⇩Λ⇩P)
                  show "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] ⇧*∼⇧* [❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N]"
                    by (meson MN cong_transitive Λ.Arr_Src Beta_decomp(1))
                  show "stdz_insert (Λ.subst N M) (u # U) ⇧*∼⇧* Λ.subst N M # u # U"
                    using 4 by fastforce
                qed
                also have "[❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ Λ.subst N M # u # U =
                           ([❙λ❙[Λ.Src M❙] ❙⦁ Λ.Src N] @ [Λ.subst N M]) @ u # U"
                  by simp
                also have "... ⇧*∼⇧* [❙λ❙[M❙] ❙⦁ N] @ u # U"
                  by (meson Beta_decomp(1) MN cong_append cong_reflexive seqE seq)
                also have "[❙λ❙[M❙] ❙⦁ N] @ u # U = (❙λ❙[M❙] ❙⦁ N) # u # U"
                  by simp
                finally show "stdz_insert (❙λ❙[M❙] ❙⦁ N) (u # U) ⇧*∼⇧* (❙λ❙[M❙] ❙⦁ N) # u # U"
                  by blast
              qed
            qed
          qed
        qed
      qed
      text ‹
        Because of the way the function package processes the pattern matching in the
        definition of ‹stdz_insert›, it produces eight separate subgoals for the remainder
        of the proof, even though these subgoals are all simple consequences of a single,
        more general fact.  We first prove this fact, then use it to discharge the eight
        subgoals.
      ›
      have *: "⋀M N u U.
                 ⟦¬ (Λ.is_Lam M ∧ Λ.is_Beta u);
                  Λ.Ide (M ❙∘ N) ⟹ ?P (hd (u # U)) (tl (u # U));
                  ⟦¬ Λ.Ide (M ❙∘ N);
                   Λ.seq (M ❙∘ N) (hd (u # U));
                   Λ.contains_head_reduction (M ❙∘ N);
                   Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N)))⟧
                      ⟹ ?P (hd (u # U)) (tl (u # U));
                  ⟦¬ Λ.Ide (M ❙∘ N);
                   Λ.seq (M ❙∘ N) (hd (u # U));
                   Λ.contains_head_reduction (M ❙∘ N);
                   ¬ Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N)))⟧
                      ⟹ ?P (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N))) (u # U);
                  ⟦¬ Λ.Ide (M ❙∘ N);
                   Λ.seq (M ❙∘ N) (hd (u # U));
                   ¬ Λ.contains_head_reduction (M ❙∘ N);
                   Λ.contains_head_reduction (hd (u # U));
                   Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N)))⟧
                      ⟹ ?P (Λ.head_strategy (M ❙∘ N)) (tl (u # U));
                  ⟦¬ Λ.Ide (M ❙∘ N);
                   Λ.seq (M ❙∘ N) (hd (u # U));
                   ¬ Λ.contains_head_reduction (M ❙∘ N);
                   Λ.contains_head_reduction (hd (u # U));
                   ¬ Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N)))⟧
                      ⟹ ?P (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N))) (tl (u # U));
                  ⟦¬ Λ.Ide (M ❙∘ N);
                   Λ.seq (M ❙∘ N) (hd (u # U));
                   ¬ Λ.contains_head_reduction (M ❙∘ N);
                   ¬ Λ.contains_head_reduction (hd (u # U))⟧
                      ⟹ ?P M (filter notIde (map Λ.un_App1 (u # U)));
                  ⟦¬ Λ.Ide (M ❙∘ N);
                   Λ.seq (M ❙∘ N) (hd (u # U));
                   ¬ Λ.contains_head_reduction (M ❙∘ N);
                   ¬ Λ.contains_head_reduction (hd (u # U))⟧
                      ⟹ ?P N (filter notIde (map Λ.un_App2 (u # U)))⟧
                    ⟹ ?P (M ❙∘ N) (u # U)"
      proof -
        fix M N u U
        assume ind1: "Λ.Ide (M ❙∘ N) ⟹ ?P (hd (u # U)) (tl (u # U))"
        assume ind2: "⟦¬ Λ.Ide (M ❙∘ N);
                       Λ.seq (M ❙∘ N) (hd (u # U));
                       Λ.contains_head_reduction (M ❙∘ N);
                       Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N)))⟧
                          ⟹ ?P (hd (u # U)) (tl (u # U))"
        assume ind3: "⟦¬ Λ.Ide (M ❙∘ N);
                       Λ.seq (M ❙∘ N) (hd (u # U));
                       Λ.contains_head_reduction (M ❙∘ N);
                       ¬ Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N)))⟧
                          ⟹ ?P (Λ.resid (M ❙∘ N) (Λ.head_redex (M ❙∘ N))) (u # U)"
        assume ind4: "⟦¬ Λ.Ide (M ❙∘ N);
                       Λ.seq (M ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (M ❙∘ N);
                       Λ.contains_head_reduction (hd (u # U));
                       Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N)))⟧
                         ⟹ ?P (Λ.head_strategy (M ❙∘ N)) (tl (u # U))"
        assume ind5: "⟦¬ Λ.Ide (M ❙∘ N);
                       Λ.seq (M ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (M ❙∘ N);
                       Λ.contains_head_reduction (hd (u # U));
                       ¬ Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N)))⟧
                          ⟹ ?P (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N))) (tl (u # U))"
        assume ind7: "⟦¬ Λ.Ide (M ❙∘ N);
                       Λ.seq (M ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (M ❙∘ N);
                       ¬ Λ.contains_head_reduction (hd (u # U))⟧
                          ⟹ ?P M (filter notIde (map Λ.un_App1 (u # U)))"
        assume ind8: "⟦¬ Λ.Ide (M ❙∘ N);
                       Λ.seq (M ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (M ❙∘ N);
                       ¬ Λ.contains_head_reduction (hd (u # U))⟧
                          ⟹ ?P N (filter notIde (map Λ.un_App2 (u # U)))"
        assume *: "¬ (Λ.is_Lam M ∧ Λ.is_Beta u)"
        show "?P (M ❙∘ N) (u # U)"
        proof (intro impI, elim conjE)
          assume seq: "seq [M ❙∘ N] (u # U)"
          assume Std: "Std (u # U)"
          have MN: "Λ.Arr M ∧ Λ.Arr N"
            using seq_char seq by force
          have u: "Λ.Arr u"
            using Std
            by (meson Std_imp_Arr Arr.simps(2) Con_Arr_self Con_implies_Arr(1)
                Con_initial_left Λ.arr_char list.simps(3))
          have "U ≠ [] ⟹ Arr U"
            using Std Std_imp_Arr Arr.simps(3)
            by (metis Arr.elims(3) list.discI)
          have "Λ.is_App u ∨ Λ.is_Beta u"
            using * seq MN u seq_char Λ.arr_char Srcs_simp⇩Λ⇩P Λ.targets_char⇩Λ
            by (cases M; cases u) auto
          have **: "Λ.seq (M ❙∘ N) u"
            using Srcs_simp⇩Λ⇩P seq_char seq Λ.seq_def u by force
          show "Std (stdz_insert (M ❙∘ N) (u # U)) ∧
                (¬ Ide ((M ❙∘ N) # u # U)
                    ⟶ cong (stdz_insert (M ❙∘ N) (u # U)) ((M ❙∘ N) # u # U))"
          proof (cases "Λ.Ide (M ❙∘ N)")
            assume 1: "Λ.Ide (M ❙∘ N)"
            have MN: "Λ.Arr M ∧ Λ.Arr N ∧ Λ.Ide M ∧ Λ.Ide N"
              using MN 1 by simp
            have 2: "stdz_insert (M ❙∘ N) (u # U) = stdz_insert u U"
              using MN 1
              by (simp add: Std seq stdz_insert_Ide_Std)
            show ?thesis
            proof (cases "U = []")
              assume U: "U = []"
              have 2: "stdz_insert (M ❙∘ N) (u # U) = standard_development u"
                using 1 2 U by simp
              show ?thesis
              proof (intro conjI)
                show "Std (stdz_insert (M ❙∘ N) (u # U))"
                  using "2" Std_standard_development by presburger
                show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                          stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                  by (metis "1" "2" Ide.simps(2) U cong_cons_ideI(1) cong_standard_development
                      ide_backward_stable ide_char Λ.ide_char prfx_transitive seq u)
              qed
              next
              assume U: "U ≠ []"
              have 2: "stdz_insert (M ❙∘ N) (u # U) = stdz_insert u U"
                using 1 2 U by simp
              have 3: "seq [u] U"
                by (simp add: Std U arrI⇩P arr_append_imp_seq)
              have 4: "Std (stdz_insert u U) ∧
                       set (stdz_insert u U) ⊆ {a. Λ.elementary_reduction a} ∧
                       (¬ Ide (u # U) ⟶ cong (stdz_insert u U) (u # U))"
                using MN 3 Std ind1 Std_implies_set_subset_elementary_reduction
                by (metis "1" Std.simps(3) U list.sel(1) list.sel(3) standardize.cases)
              show ?thesis
              proof (intro conjI)
                show "Std (stdz_insert (M ❙∘ N) (u # U))"
                  by (metis "1" "2" "3" Std Std.simps(3) U ind1 list.exhaust_sel list.sel(1,3))
                show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                          stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                proof
                  assume 5: "¬ Ide ((M ❙∘ N) # u # U)"
                  have "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* u # U"
                    using "1" "2" "4" "5" seq_char seq by force
                  also have "u # U ⇧*∼⇧* [M ❙∘ N] @ u # U"
                    using "1" Ide.simps(2) cong_append_ideI(1) ide_char seq by blast
                  also have "[M ❙∘ N] @ (u # U) = (M ❙∘ N) # u # U"
                    by simp
                  finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                    by blast
                qed
              qed
            qed
            next
            assume 1: "¬ Λ.Ide (M ❙∘ N)"
            show ?thesis
            proof (cases "Λ.contains_head_reduction (M ❙∘ N)")
              assume 2: "Λ.contains_head_reduction (M ❙∘ N)"
              show ?thesis
              proof (cases "Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))")
                assume 3: "Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))"
                have 4: "¬ Ide (u # U)"
                  by (metis Std Std_implies_set_subset_elementary_reduction in_mono
                      Λ.elementary_reduction_not_ide list.set_intros(1) mem_Collect_eq
                      set_Ide_subset_ide)
                have 5: "stdz_insert (M ❙∘ N) (u # U) = Λ.head_redex (M ❙∘ N) # stdz_insert u U"
                  using MN 1 2 3 4 ** by auto
                show ?thesis
                proof (cases "U = []")
                  assume U: "U = []"
                  have u: "Λ.Arr u ∧ ¬ Λ.Ide u"
                      using 4 U u by force
                  have 5: "stdz_insert (M ❙∘ N) (u # U) =
                           Λ.head_redex (M ❙∘ N) # standard_development u"
                    using 5 U by simp
                  show ?thesis
                  proof (intro conjI)
                    show "Std (stdz_insert (M ❙∘ N) (u # U))"
                    proof -
                      have "Λ.sseq (Λ.head_redex (M ❙∘ N)) (hd (standard_development u))"
                      proof -
                        have "Λ.seq (Λ.head_redex (M ❙∘ N)) (hd (standard_development u))"
                        proof
                          show "Λ.Arr (Λ.head_redex (M ❙∘ N))"
                            using MN Λ.Arr.simps(4) Λ.Arr_head_redex by presburger
                          show "Λ.Arr (hd (standard_development u))"
                            using Arr_imp_arr_hd Ide_iff_standard_development_empty
                                  Std_standard_development u
                            by force
                          show "Λ.Trg (Λ.head_redex (M ❙∘ N)) = Λ.Src (hd (standard_development u))"
                          proof -
                            have "Λ.Trg (Λ.head_redex (M ❙∘ N)) =
                                  Λ.Trg ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))"
                              by (metis 3 MN Λ.Con_Arr_head_redex Λ.Src_resid
                                  Λ.Arr.simps(4) Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self
                                  Λ.Ide_implies_Arr)
                            also have "... = Λ.Src u"
                              using MN
                              by (metis Trg_last_Src_hd_eqI Trg_last_eqI head_redex_decomp
                                  Λ.Arr.simps(4) last_ConsL last_appendR list.sel(1)
                                  not_Cons_self2 seq)
                            also have "... = Λ.Src (hd (standard_development u))"
                              using ** 2 3 u MN Src_hd_standard_development [of u] by metis
                            finally show ?thesis by blast
                          qed
                        qed
                        thus ?thesis
                          by (metis 2 u MN Λ.Arr.simps(4) Ide_iff_standard_development_empty
                              development.simps(2) development_standard_development
                              Λ.head_redex_is_head_reduction list.exhaust_sel
                              Λ.sseq_head_reductionI)
                      qed
                      thus ?thesis
                        by (metis 5 Ide_iff_standard_development_empty Std.simps(3)
                            Std_standard_development list.exhaust u)
                    qed
                    show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                              stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                    proof
                      have "stdz_insert (M ❙∘ N) (u # U) =
                            [Λ.head_redex (M ❙∘ N)] @ standard_development u"
                        using 5 by simp
                      also have "... ⇧*∼⇧* [Λ.head_redex (M ❙∘ N)] @ [u]"
                        using u cong_standard_development [of u] cong_append
                        by (metis 2 5 Ide_iff_standard_development_empty Std_imp_Arr
                            ‹Std (stdz_insert (M ❙∘ N) (u # U))›
                            arr_append_imp_seq arr_char calculation cong_standard_development
                            cong_transitive Λ.Arr_head_redex Λ.contains_head_reduction_iff
                            list.distinct(1))
                      also have "[Λ.head_redex (M ❙∘ N)] @ [u] ⇧*∼⇧*
                                 ([Λ.head_redex (M ❙∘ N)] @ [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]) @ [u]"
                      proof -
                        have "[Λ.head_redex (M ❙∘ N)] ⇧*∼⇧*
                              [Λ.head_redex (M ❙∘ N)] @ [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]"
                          by (metis (no_types, lifting) 1 3 MN Arr_iff_Con_self Ide.simps(2)
                              Resid.simps(2) arr_append_imp_seq arr_char cong_append_ideI(4)
                              cong_transitive head_redex_decomp ide_backward_stable ide_char
                              Λ.Arr.simps(4) Λ.ide_char not_Cons_self2)
                        thus ?thesis
                          using MN U u seq
                          by (meson cong_append head_redex_decomp Λ.Arr.simps(4) prfx_transitive)
                      qed
                      also have "([Λ.head_redex (M ❙∘ N)] @
                                    [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]) @ [u] ⇧*∼⇧*
                                 [M ❙∘ N] @ [u]"
                        by (metis Λ.Arr.simps(4) MN U Resid_Arr_self cong_append ide_char
                            seq_char head_redex_decomp seq)
                      also have "[M ❙∘ N] @ [u] = (M ❙∘ N) # u # U"
                        using U by simp
                      finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                        by blast
                    qed
                  qed
                  next
                  assume U: "U ≠ []"
                  have 6: "Std (stdz_insert u U) ∧
                           set (stdz_insert u U) ⊆ {a. Λ.elementary_reduction a} ∧
                           cong (stdz_insert u U) (u # U)"
                  proof -
                    have "seq [u] U"
                      by (simp add: Std U arrI⇩P arr_append_imp_seq)
                    moreover have "Std U"
                      using Std Std.elims(2) U by blast
                    ultimately show ?thesis
                      using ind2 ** 1 2 3 4 Std_implies_set_subset_elementary_reduction
                      by force
                  qed
                  show ?thesis
                  proof (intro conjI)
                    show "Std (stdz_insert (M ❙∘ N) (u # U))"
                    proof -
                      have "Λ.sseq (Λ.head_redex (M ❙∘ N)) (hd (stdz_insert u U))"
                      proof -
                        have "Λ.seq (Λ.head_redex (M ❙∘ N)) (hd (stdz_insert u U))"
                        proof
                          show "Λ.Arr (Λ.head_redex (M ❙∘ N))"
                            using MN Λ.Arr_head_redex by force
                          show "Λ.Arr (hd (stdz_insert u U))"
                            using 6
                            by (metis Arr_imp_arr_hd Con_implies_Arr(2) Ide.simps(1) ide_char
                                Λ.arr_char)
                          show "Λ.Trg (Λ.head_redex (M ❙∘ N)) = Λ.Src (hd (stdz_insert u U))"
                          proof -
                            have "Λ.Trg (Λ.head_redex (M ❙∘ N)) =
                                  Λ.Trg ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))"
                              by (metis 3 Λ.Arr_not_Nil Λ.Ide_iff_Src_self
                                  Λ.Ide_iff_Trg_self Λ.Ide_implies_Arr Λ.Src_resid)
                            also have "... = Λ.Trg (M ❙∘ N)"
                              by (metis 1 MN Trg_last_eqI Trg_last_standard_development
                                  cong_standard_development head_redex_decomp Λ.Arr.simps(4)
                                  last_snoc)
                            also have "... = Λ.Src (hd (stdz_insert u U))"
                              by (metis ** 6 Src_hd_eqI Λ.seqE⇩Λ list.sel(1))
                            finally show ?thesis by blast
                          qed
                        qed
                        thus ?thesis
                          by (metis 2 6 MN Λ.Arr.simps(4) Std.elims(1) Ide.simps(1)
                              Resid.simps(2) ide_char Λ.head_redex_is_head_reduction
                              list.sel(1) Λ.sseq_head_reductionI Λ.sseq_imp_elementary_reduction1)
                      qed
                      thus ?thesis
                        by (metis 5 6 Std.simps(3) Arr.simps(1) Con_implies_Arr(1)
                            con_char prfx_implies_con list.exhaust_sel)
                    qed
                    show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                              stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                    proof
                      have "stdz_insert (M ❙∘ N) (u # U) =
                            [Λ.head_redex (M ❙∘ N)] @ stdz_insert u U"
                        using 5 by simp
                      also have 7: "[Λ.head_redex (M ❙∘ N)] @ stdz_insert u U ⇧*∼⇧*
                                    [Λ.head_redex (M ❙∘ N)] @ u # U"
                        using 6 cong_append [of "[Λ.head_redex (M ❙∘ N)]" "stdz_insert u U"
                                                "[Λ.head_redex (M ❙∘ N)]" "u # U"]
                        by (metis 2 5 Arr.simps(1) Resid.simps(2) Std_imp_Arr
                            ‹Std (stdz_insert (M ❙∘ N) (u # U))›
                            arr_append_imp_seq arr_char calculation cong_standard_development
                            cong_transitive ide_implies_arr Λ.Arr_head_redex
                            Λ.contains_head_reduction_iff list.distinct(1))
                      also have "[Λ.head_redex (M ❙∘ N)] @ u # U ⇧*∼⇧*
                                 ([Λ.head_redex (M ❙∘ N)] @
                                    [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]) @ u # U"
                      proof -
                        have "[Λ.head_redex (M ❙∘ N)] ⇧*∼⇧*
                              [Λ.head_redex (M ❙∘ N)] @ [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]"
                          by (metis 2 3 head_redex_decomp Λ.Arr_head_redex
                              Λ.Con_Arr_head_redex Λ.Ide_iff_Src_self Λ.Ide_implies_Arr
                              Λ.Src_resid Λ.contains_head_reduction_iff Λ.resid_Arr_self
                              prfx_decomp prfx_transitive)
                        moreover have "seq [Λ.head_redex (M ❙∘ N)] (u # U)"
                          by (metis 7 arr_append_imp_seq cong_implies_coterminal coterminalE
                              list.distinct(1))
                        ultimately show ?thesis
                          using 3 ide_char cong_symmetric cong_append
                          by (meson 6 prfx_transitive)
                      qed
                      also have "([Λ.head_redex (M ❙∘ N)] @
                                    [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]) @ u # U ⇧*∼⇧*
                                 [M ❙∘ N] @ u # U"
                        by (meson 6 MN Λ.Arr.simps(4) cong_append prfx_transitive
                            head_redex_decomp seq)
                      also have "[M ❙∘ N] @ (u # U) = (M ❙∘ N) # u # U"
                        by simp
                      finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                        by blast
                    qed
                  qed
                qed
                next
                assume 3: "¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))"
                have 4: "stdz_insert (M ❙∘ N) (u # U) =
                         Λ.head_redex (M ❙∘ N) #
                           stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U)"
                  using MN 1 2 3 ** by auto
                have 5: "Std (stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U)) ∧
                         set (stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U))
                            ⊆ {a. Λ.elementary_reduction a} ∧
                         stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U) ⇧*∼⇧*
                         (M ❙∘ N) \\ Λ.head_redex (M ❙∘ N) # u # U"
                proof -
                  have "seq [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)] (u # U)"
                    by (metis (full_types) MN arr_append_imp_seq cong_implies_coterminal
                        coterminalE head_redex_decomp Λ.Arr.simps(4) not_Cons_self2
                        seq seq_def targets_append)
                  thus ?thesis
                    using ind3 1 2 3 ** Std Std_implies_set_subset_elementary_reduction
                    by auto
                qed
                show ?thesis
                proof (intro conjI)
                  show "Std (stdz_insert (M ❙∘ N) (u # U))"
                  proof -
                    have "Λ.sseq (Λ.head_redex (M ❙∘ N))
                                 (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U)))"
                    proof -
                      have "Λ.seq (Λ.head_redex (M ❙∘ N))
                                  (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U)))"
                        using MN 5 Λ.Arr_head_redex
                        by (metis (no_types, lifting) Arr_imp_arr_hd Con_implies_Arr(2)
                            Ide.simps(1) Src_hd_eqI ide_char Λ.Arr.simps(4) Λ.Arr_head_redex
                            Λ.Con_Arr_head_redex Λ.Src_resid Λ.arr_char Λ.seq_char list.sel(1))
                      moreover have "Λ.elementary_reduction
                                       (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))
                                                        (u # U)))"
                        using 5
                        by (metis Arr.simps(1) Con_implies_Arr(2) Ide.simps(1) hd_in_set
                            ide_char mem_Collect_eq subset_code(1))
                      ultimately show ?thesis
                        using MN 2 Λ.head_redex_is_head_reduction Λ.sseq_head_reductionI
                        by simp
                    qed
                    thus ?thesis
                      by (metis 4 5 Std.simps(3) Arr.simps(1) Con_implies_Arr(2)
                          Ide.simps(1) ide_char list.exhaust_sel)
                  qed
                  show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                             stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                  proof
                    have "stdz_insert (M ❙∘ N) (u # U) =
                         [Λ.head_redex (M ❙∘ N)] @
                           stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U)"
                      using 4 by simp
                    also have "... ⇧*∼⇧* [Λ.head_redex (M ❙∘ N)] @
                                         ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N) # u # U)"
                    proof (intro cong_append)
                      show "seq [Λ.head_redex (M ❙∘ N)]
                                (stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U))"
                        by (metis 4 5 Ide.simps(1) Resid.simps(1) Std_imp_Arr
                            ‹Std (stdz_insert (M ❙∘ N) (u # U))› arrI⇩P arr_append_imp_seq
                            calculation ide_char list.discI)
                      show "[Λ.head_redex (M ❙∘ N)] ⇧*∼⇧* [Λ.head_redex (M ❙∘ N)]"
                        using MN Λ.cong_reflexive ide_char Λ.Arr_head_redex by force
                      show "stdz_insert ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (u # U) ⇧*∼⇧* (M ❙∘ N) \\
                            Λ.head_redex (M ❙∘ N) # u # U"
                        using 5 by fastforce
                    qed
                    also have "([Λ.head_redex (M ❙∘ N)] @
                                 ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N) # u # U)) =
                               ([Λ.head_redex (M ❙∘ N)] @
                                  [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]) @ (u # U)"
                      by simp
                    also have "([Λ.head_redex (M ❙∘ N)] @
                                 [(M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)]) @ u # U ⇧*∼⇧*
                               [M ❙∘ N] @ u # U"
                      by (meson ** cong_append cong_reflexive seqE head_redex_decomp
                          seq Λ.seq_char)
                    also have "[M ❙∘ N] @ (u # U) = (M ❙∘ N) # u # U"
                      by simp
                    finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                      by blast
                  qed
                qed
              qed
              next
              assume 2: "¬ Λ.contains_head_reduction (M ❙∘ N)"
              show ?thesis
              proof (cases "Λ.contains_head_reduction u")
                assume 3: "Λ.contains_head_reduction u"
                have B: "[Λ.head_strategy (M ❙∘ N)] @ [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)] ⇧*∼⇧*
                         [M ❙∘ N] @ [u]"
                proof -
                  have "[M ❙∘ N] @ [u] ⇧*∼⇧* [Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N]"
                  proof -
                    have "Λ.is_internal_reduction (M ❙∘ N)"
                      using 2 ** Λ.is_internal_reduction_iff by blast
                    moreover have "Λ.is_head_reduction u"
                    proof -
                      have "Λ.elementary_reduction u"
                        by (metis Std lambda_calculus.sseq_imp_elementary_reduction1
                            list.discI list.sel(1) reduction_paths.Std.elims(2))
                      thus ?thesis
                        using Λ.is_head_reduction_if 3 by force
                    qed
                    moreover have "Λ.head_strategy (Λ.Src (M ❙∘ N)) \\ (M ❙∘ N) = u"
                      using Λ.resid_head_strategy_Src(1) ** calculation(1-2) by fastforce
                    moreover have "[M ❙∘ N] ⇧*≲⇧* [Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N]"
                      using MN Λ.prfx_implies_con ide_char Λ.Arr_head_strategy
                            Λ.Src_head_strategy Λ.prfx_Join
                      by force
                    ultimately show ?thesis
                      using u Λ.Coinitial_iff_Con Λ.Arr_not_Nil Λ.resid_Join
                            prfx_decomp [of "M ❙∘ N" "Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N"]
                      by simp
                  qed
                  also have "[Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N] ⇧*∼⇧*
                             [Λ.head_strategy (Λ.Src (M ❙∘ N))] @
                               [(M ❙∘ N) \\ Λ.head_strategy (Λ.Src (M ❙∘ N))]"
                  proof -
                    have 3: "Λ.composite_of
                               (Λ.head_strategy (Λ.Src (M ❙∘ N)))
                               ((M ❙∘ N) \\ Λ.head_strategy (Λ.Src (M ❙∘ N)))
                               (Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N)"
                      using Λ.Arr_head_strategy MN Λ.Src_head_strategy Λ.join_of_Join
                            Λ.join_of_def
                      by force
                    hence "composite_of
                             [Λ.head_strategy (Λ.Src (M ❙∘ N))]
                             [(M ❙∘ N) \\ Λ.head_strategy (Λ.Src (M ❙∘ N))]
                             [Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N]"
                      using composite_of_single_single
                      by (metis (no_types, lifting) Λ.Con_sym Ide.simps(2) Resid.simps(3)
                          composite_ofI Λ.composite_ofE Λ.con_char ide_char Λ.prfx_implies_con)
                    hence "[Λ.head_strategy (Λ.Src (M ❙∘ N))] @
                             [(M ❙∘ N) \\ Λ.head_strategy (Λ.Src (M ❙∘ N))] ⇧*∼⇧*
                           [Λ.head_strategy (Λ.Src (M ❙∘ N)) ⊔ M ❙∘ N]"
                      using Λ.resid_Join
                      by (meson 3 composite_of_single_single composite_of_unq_upto_cong)
                    thus ?thesis by blast
                  qed
                  also have "[Λ.head_strategy (Λ.Src (M ❙∘ N))] @
                               [(M ❙∘ N) \\ Λ.head_strategy (Λ.Src (M ❙∘ N))] ⇧*∼⇧*
                             [Λ.head_strategy (M ❙∘ N)] @
                               [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]"
                    by (metis (full_types) Λ.Arr.simps(4) MN prfx_transitive calculation
                        Λ.head_strategy_Src)
                  finally show ?thesis by blast
                qed
                show ?thesis
                proof (cases "Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))")
                  assume 4: "Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))"
                  have A: "[Λ.head_strategy (M ❙∘ N)] ⇧*∼⇧*
                           [Λ.head_strategy (M ❙∘ N)] @ [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]"
                    by (meson 4 B Con_implies_Arr(1) Ide.simps(2) arr_append_imp_seq arr_char
                        con_char cong_append_ideI(2) ide_char Λ.ide_char not_Cons_self2
                        prfx_implies_con)
                  have 5: "¬ Ide (u # U)"
                    by (meson 3 Ide_consE Λ.ide_backward_stable Λ.subs_head_redex
                        Λ.subs_implies_prfx Λ.contains_head_reduction_iff
                        Λ.elementary_reduction_head_redex Λ.elementary_reduction_not_ide)
                  have 6: "stdz_insert (M ❙∘ N) (u # U) =
                           stdz_insert (Λ.head_strategy (M ❙∘ N)) U"
                    using 1 2 3 4 5 * ** ‹Λ.is_App u ∨ Λ.is_Beta u›
                    apply (cases u)
                        apply simp_all
                     apply blast
                    by (cases M) auto
                  show ?thesis
                  proof (cases "U = []")
                    assume U: "U = []"
                    have u: "¬ Λ.Ide u"
                      using 5 U by simp
                    have 6: "stdz_insert (M ❙∘ N) (u # U) =
                             standard_development (Λ.head_strategy (M ❙∘ N))"
                      using 6 U by simp
                    show ?thesis
                    proof (intro conjI)
                      show "Std (stdz_insert (M ❙∘ N) (u # U))"
                        using "6" Std_standard_development by presburger
                      show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                                stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                      proof
                        have "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* [Λ.head_strategy (M ❙∘ N)]"
                          using 4 6 cong_standard_development ** 1 2 3 Λ.Arr.simps(4)
                                Λ.Arr_head_strategy MN Λ.ide_backward_stable Λ.ide_char
                          by metis
                        also have "[Λ.head_strategy (M ❙∘ N)] ⇧*∼⇧* [M ❙∘ N] @ [u]"
                          by (meson A B prfx_transitive)
                        also have "[M ❙∘ N] @ [u] = (M ❙∘ N) # u # U"
                          using U by auto
                        finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                          by blast
                      qed
                    qed
                    next
                    assume U: "U ≠ []"
                    have 7: "seq [Λ.head_strategy (M ❙∘ N)] U"
                    proof
                      show "Arr [Λ.head_strategy (M ❙∘ N)]"
                        by (meson A Con_implies_Arr(1) con_char prfx_implies_con)
                      show "Arr U"
                        using U ‹U ≠ [] ⟹ Arr U› by presburger
                      show "Λ.Trg (last [Λ.head_strategy (M ❙∘ N)]) = Λ.Src (hd U)"
                        by (metis A B Std Std_consE Trg_last_eqI U Λ.seqE⇩Λ Λ.sseq_imp_seq last_snoc)
                    qed
                    have 8: "Std (stdz_insert (Λ.head_strategy (M ❙∘ N)) U) ∧
                             set (stdz_insert (Λ.head_strategy (M ❙∘ N)) U)
                                ⊆ {a. Λ.elementary_reduction a} ∧
                             stdz_insert (Λ.head_strategy (M ❙∘ N)) U ⇧*∼⇧*
                             Λ.head_strategy (M ❙∘ N) # U"
                    proof -
                      have "Std U"
                        by (metis Std Std.simps(3) U list.exhaust_sel)
                      moreover have "¬ Ide (Λ.head_strategy (M ❙∘ N) # tl (u # U))"
                        using 1 4 Λ.ide_backward_stable by blast
                      ultimately show ?thesis
                        using ind4 ** 1 2 3 4 7 Std_implies_set_subset_elementary_reduction
                        by force
                    qed
                    show ?thesis
                    proof (intro conjI)
                      show "Std (stdz_insert (M ❙∘ N) (u # U))"
                        using 6 8 by presburger
                      show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                                 stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                      proof
                        have "stdz_insert (M ❙∘ N) (u # U) =
                              stdz_insert (Λ.head_strategy (M ❙∘ N)) U"
                          using 6 by simp
                        also have "... ⇧*∼⇧* [Λ.head_strategy (M ❙∘ N)] @ U"
                          using 8 by simp
                        also have "[Λ.head_strategy (M ❙∘ N)] @ U ⇧*∼⇧* ([M ❙∘ N] @ [u]) @ U"
                          by (meson A B U 7 Resid_Arr_self cong_append ide_char
                              prfx_transitive ‹U ≠ [] ⟹ Arr U›)
                        also have "([M ❙∘ N] @ [u]) @ U = (M ❙∘ N) # u # U"
                          by simp
                        finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                          by blast
                      qed
                    qed
                  qed
                  next
                  assume 4: "¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))"
                  show ?thesis
                  proof (cases "U = []")
                    assume U: "U = []"
                    have 5: "stdz_insert (M ❙∘ N) (u # U) =
                             Λ.head_strategy (M ❙∘ N) #
                               standard_development ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))"
                      using 1 2 3 4 U * ** ‹Λ.is_App u ∨ Λ.is_Beta u›
                      apply (cases u)
                         apply simp_all
                       apply blast
                      apply (cases M)
                          apply simp_all
                      by blast+
                    show ?thesis
                    proof (intro conjI)
                      show "Std (stdz_insert (M ❙∘ N) (u # U))"
                      proof -
                        have "Λ.sseq (Λ.head_strategy (M ❙∘ N))
                                     (hd (standard_development
                                            ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))))"
                        proof -
                          have "Λ.seq (Λ.head_strategy (M ❙∘ N))
                                      (hd (standard_development
                                             ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))))"
                            using MN ** 4 Λ.Arr_head_strategy Arr_imp_arr_hd
                                  Ide_iff_standard_development_empty Src_hd_standard_development
                                  Std_imp_Arr Std_standard_development Λ.Arr_resid
                                  Λ.Src_head_strategy Λ.Src_resid
                            by force
                          moreover have "Λ.elementary_reduction
                                           (hd (standard_development
                                                 ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))))"
                            by (metis 4 Ide_iff_standard_development_empty MN Std_consE
                                Std_standard_development hd_Cons_tl Λ.Arr.simps(4)
                                Λ.Arr_resid Λ.Con_head_strategy
                                Λ.sseq_imp_elementary_reduction1 Std.simps(2))
                          ultimately show ?thesis
                            using Λ.sseq_head_reductionI Std_standard_development
                            by (metis ** 2 3 Std U Λ.internal_reduction_preserves_no_head_redex
                                Λ.is_internal_reduction_iff Λ.Src_head_strategy
                                Λ.elementary_reduction_not_ide Λ.head_strategy_Src
                                Λ.head_strategy_is_elementary Λ.ide_char Λ.is_head_reduction_char
                                Λ.is_head_reduction_if Λ.seqE⇩Λ Std.simps(2))
                        qed
                        thus ?thesis
                          by (metis 4 5 MN Ide_iff_standard_development_empty
                              Std_standard_development Λ.Arr.simps(4) Λ.Arr_resid
                              Λ.Con_head_strategy list.exhaust_sel Std.simps(3))
                      qed
                      show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                              stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                      proof
                        have "stdz_insert (M ❙∘ N) (u # U) =
                              [Λ.head_strategy (M ❙∘ N)] @
                                standard_development ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))"
                          using 5 by simp
                        also have "... ⇧*∼⇧* [Λ.head_strategy (M ❙∘ N)] @
                                             [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]"
                        proof (intro cong_append)
                          show 6: "seq [Λ.head_strategy (M ❙∘ N)]
                                       (standard_development
                                         ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)))"
                            using 4 Ide_iff_standard_development_empty MN
                                  ‹Std (stdz_insert (M ❙∘ N) (u # U))›
                                  arr_append_imp_seq arr_char calculation Λ.Arr_head_strategy
                                  Λ.Arr_resid lambda_calculus.Src_head_strategy
                            by force
                          show "[Λ.head_strategy (M ❙∘ N)] ⇧*∼⇧* [Λ.head_strategy (M ❙∘ N)]"
                            by (meson MN 6 cong_reflexive seqE)
                          show "standard_development ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) ⇧*∼⇧*
                                [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]"
                            using 4 MN cong_standard_development Λ.Arr.simps(4)
                                  Λ.Arr_resid Λ.Con_head_strategy
                            by presburger
                        qed
                        also have "[Λ.head_strategy (M ❙∘ N)] @
                                     [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)] ⇧*∼⇧*
                                   [M ❙∘ N] @ [u]"
                          using B by blast
                        also have "[M ❙∘ N] @ [u] = (M ❙∘ N) # u # U"
                          using U by simp
                        finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                          by blast
                      qed
                    qed
                    next
                    assume U: "U ≠ []"
                    have 5: "stdz_insert (M ❙∘ N) (u # U) =
                             Λ.head_strategy (M ❙∘ N) #
                               stdz_insert (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N))) U"
                      using 1 2 3 4 U * ** ‹Λ.is_App u ∨ Λ.is_Beta u›
                      apply (cases u)
                         apply simp_all
                       apply blast
                      apply (cases M)
                          apply simp_all
                      by blast+
                    have 6: "Std (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U) ∧
                             set (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U)
                               ⊆ {a. Λ.elementary_reduction a} ∧
                             stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U ⇧*∼⇧*
                             (M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N) # U"
                    proof -
                      have "seq [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)] U"
                      proof
                        show "Arr [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]"
                          by (simp add: MN Λ.Arr_resid Λ.Con_head_strategy)
                        show "Arr U"
                          using U ‹U ≠ [] ⟹ Arr U› by blast
                        show "Λ.Trg (last [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]) = Λ.Src (hd U)"
                          by (metis (mono_tags, lifting) B U Std Std_consE Trg_last_eqI
                              Λ.seq_char Λ.sseq_imp_seq last_ConsL last_snoc)
                      qed
                      thus ?thesis
                        using ind5 Std_implies_set_subset_elementary_reduction
                        by (metis ** 1 2 3 4 Std Std.simps(3) Arr_iff_Con_self Ide.simps(3)
                            Resid.simps(1) seq_char Λ.ide_char list.exhaust_sel list.sel(1,3))
                    qed
                    show ?thesis
                    proof (intro conjI)
                      show "Std (stdz_insert (M ❙∘ N) (u # U))"
                      proof -
                        have "Λ.sseq (Λ.head_strategy (M ❙∘ N))
                                   (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U))"
                        proof -
                          have "Λ.seq (Λ.head_strategy (M ❙∘ N))
                                      (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U))"
                          proof
                            show "Λ.Arr (Λ.head_strategy (M ❙∘ N))"
                              using MN Λ.Arr_head_strategy by force
                            show "Λ.Arr (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U))"
                              using 6
                              by (metis Ide.simps(1) Resid.simps(2) Std_consE hd_Cons_tl ide_char)
                            show "Λ.Trg (Λ.head_strategy (M ❙∘ N)) =
                                  Λ.Src (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U))"
                              using 6
                              by (metis MN Src_hd_eqI Λ.Arr.simps(4) Λ.Con_head_strategy
                                  Λ.Src_resid list.sel(1))
                          qed
                          moreover have "Λ.is_head_reduction (Λ.head_strategy (M ❙∘ N))"
                            using ** 1 2 3 Λ.Src_head_strategy Λ.head_strategy_is_elementary
                                  Λ.head_strategy_Src Λ.is_head_reduction_char Λ.seq_char
                            by (metis Λ.Src_head_redex Λ.contains_head_reduction_iff
                                Λ.head_redex_is_head_reduction
                                Λ.internal_reduction_preserves_no_head_redex
                                Λ.is_internal_reduction_iff)
                          moreover have "Λ.elementary_reduction
                                          (hd (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U))"
                            by (metis 6 Ide.simps(1) Resid.simps(2) ide_char hd_in_set
                                in_mono mem_Collect_eq)
                          ultimately show ?thesis
                            using Λ.sseq_head_reductionI by blast
                        qed
                        thus ?thesis
                          by (metis 5 6 Std.simps(3) Arr.simps(1) Con_implies_Arr(1)
                              con_char prfx_implies_con list.exhaust_sel)
                      qed
                      show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                                stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                      proof
                        have "stdz_insert (M ❙∘ N) (u # U) =
                              [Λ.head_strategy (M ❙∘ N)] @
                                stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U"
                          using 5 by simp
                        also have 10: "... ⇧*∼⇧* [Λ.head_strategy (M ❙∘ N)] @
                                                 ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N) # U)"
                        proof (intro cong_append)
                          show 10: "seq [Λ.head_strategy (M ❙∘ N)]
                                        (stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U)"
                            by (metis 5 6 Ide.simps(1) Resid.simps(1) Std_imp_Arr
                                ‹Std (stdz_insert (M ❙∘ N) (u # U))› arr_append_imp_seq
                                arr_char calculation ide_char list.distinct(1))
                          show "[Λ.head_strategy (M ❙∘ N)] ⇧*∼⇧* [Λ.head_strategy (M ❙∘ N)]"
                            using MN 10 cong_reflexive by blast
                          show "stdz_insert ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) U ⇧*∼⇧*
                                (M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N) # U"
                            using 6 by auto
                        qed
                        also have 11: "[Λ.head_strategy (M ❙∘ N)] @
                                         ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N) # U) =
                                       ([Λ.head_strategy (M ❙∘ N)] @
                                         [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]) @ U"
                          by simp
                        also have "... ⇧*∼⇧* (([M ❙∘ N] @ [u]) @ U)"
                        proof -
                          have "seq ([Λ.head_strategy (M ❙∘ N)] @
                                       [(M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)]) U"
                            by (metis U 10 11 append_is_Nil_conv arr_append_imp_seq
                                cong_implies_coterminal coterminalE not_Cons_self2)
                          thus ?thesis
                            using B cong_append cong_reflexive by blast
                        qed
                        also have "([M ❙∘ N] @ [u]) @ U = (M ❙∘ N) # u # U"
                          by simp
                        finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                          by blast
                      qed
                    qed
                  qed
                qed
                next
                assume 3: "¬ Λ.contains_head_reduction u"
                have u: "Λ.Arr u ∧ Λ.is_App u ∧ ¬ Λ.contains_head_reduction u"
                  using "3" ‹Λ.is_App u ∨ Λ.is_Beta u› Λ.is_Beta_def u by force
                have 5: "¬ Λ.Ide u"
                  by (metis Std Std.simps(2) Std.simps(3) Λ.elementary_reduction_not_ide
                      Λ.ide_char neq_Nil_conv Λ.sseq_imp_elementary_reduction1)
                show ?thesis
                proof -
                  have 4: "stdz_insert (M ❙∘ N) (u # U) =
                           map (λX. Λ.App X (Λ.Src N))
                               (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) @
                           map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                               (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))"
                    using MN 1 2 3 5 * ** ‹Λ.is_App u ∨ Λ.is_Beta u›
                    apply (cases "U = []"; cases M; cases u)
                                        apply simp_all
                    by blast+
                  have ***: "set U ⊆ Collect Λ.is_App"
                    using u 5 Std seq_App_Std_implies by blast
                  have X: "Std (filter notIde (map Λ.un_App1 (u # U)))"
                    by (metis *** Std Std_filter_map_un_App1 insert_subset list.simps(15)
                        mem_Collect_eq u)
                  have Y: "Std (filter notIde (map Λ.un_App2 (u # U)))"
                    by (metis *** u Std Std_filter_map_un_App2 insert_subset list.simps(15)
                        mem_Collect_eq)
                  have A: "¬ Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide ⟹
                             Std (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) ∧
                             set (stdz_insert M (filter notIde (map Λ.un_App1 (u # U))))
                                ⊆ {a. Λ.elementary_reduction a} ∧
                             stdz_insert M (filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                             M # filter notIde (map Λ.un_App1 (u # U))"
                  proof -
                    assume *: "¬ Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide"
                    have "seq [M] (filter notIde (map Λ.un_App1 (u # U)))"
                    proof
                      show "Arr [M]"
                        using MN by simp
                      show "Arr (filter notIde (map Λ.un_App1 (u # U)))"
                        by (metis (mono_tags, lifting) "*" Std_imp_Arr X empty_filter_conv
                            list.set_map mem_Collect_eq subset_code(1))
                      show "Λ.Trg (last [M]) = Λ.Src (hd (filter notIde (map Λ.un_App1 (u # U))))"
                      proof -
                        have "Λ.Trg (last [M]) = Λ.Src (hd (map Λ.un_App1 (u # U)))"
                          using ** u by fastforce
                        also have "... = Λ.Src (hd (filter notIde (map Λ.un_App1 (u # U))))"
                        proof -
                          have "Arr (map Λ.un_App1 (u # U))"
                            using u ***
                            by (metis Arr_map_un_App1 Std Std_imp_Arr insert_subset
                                list.simps(15) mem_Collect_eq neq_Nil_conv)
                          moreover have "¬ Ide (map Λ.un_App1 (u # U))"
                            by (metis "*" Collect_cong Λ.ide_char list.set_map set_Ide_subset_ide)
                          ultimately show ?thesis
                            using Src_hd_eqI cong_filter_notIde by blast
                        qed
                        finally show ?thesis by blast
                      qed
                    qed
                    moreover have "¬ Ide (M # filter notIde (map Λ.un_App1 (u # U)))"
                      using *
                      by (metis (no_types, lifting) *** Arr_map_un_App1 Std Std_imp_Arr
                          Arr.simps(1) Ide.elims(2) Resid_Arr_Ide_ind ide_char
                          seq_char calculation(1) cong_filter_notIde filter_notIde_Ide
                          insert_subset list.discI list.sel(3) list.simps(15) mem_Collect_eq u)
                    ultimately show ?thesis
                      by (metis X 1 2 3 ** ind7 Std_implies_set_subset_elementary_reduction
                          list.sel(1))
                  qed
                  have B: "¬ Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide ⟹
                             Std (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))) ∧
                             set (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))
                                ⊆ {a. Λ.elementary_reduction a} ∧
                             stdz_insert N (filter notIde (map Λ.un_App2 (u # U))) ⇧*∼⇧*
                             N # filter notIde (map Λ.un_App2 (u # U))"
                  proof -
                    assume **: "¬ Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide"
                    have "seq [N] (filter notIde (map Λ.un_App2 (u # U)))"
                    proof
                      show "Arr [N]"
                        using MN by simp
                      show "Arr (filter (λu. ¬ Λ.Ide u) (map Λ.un_App2 (u # U)))"
                        by (metis (mono_tags, lifting) ** Std_imp_Arr Y empty_filter_conv
                            list.set_map mem_Collect_eq subset_code(1))
                      show "Λ.Trg (last [N]) = Λ.Src (hd (filter notIde (map Λ.un_App2 (u # U))))"
                      proof -
                        have "Λ.Trg (last [N]) = Λ.Src (hd (map Λ.un_App2 (u # U)))"
                          by (metis u seq Trg_last_Src_hd_eqI Λ.Src.simps(4)
                              Λ.Trg.simps(3) Λ.is_App_def Λ.lambda.sel(4) last_ConsL
                              list.discI list.map_sel(1) list.sel(1))
                        also have "... = Λ.Src (hd (filter notIde (map Λ.un_App2 (u # U))))"
                        proof -
                          have "Arr (map Λ.un_App2 (u # U))"
                            using u ***
                            by (metis Arr_map_un_App2 Std Std_imp_Arr list.distinct(1)
                                mem_Collect_eq set_ConsD subset_code(1))
                          moreover have "¬ Ide (map Λ.un_App2 (u # U))"
                            by (metis ** Collect_cong Λ.ide_char list.set_map set_Ide_subset_ide)
                          ultimately show ?thesis
                            using Src_hd_eqI cong_filter_notIde by blast
                        qed
                        finally show ?thesis by blast
                      qed
                    qed 
                    moreover have "Λ.seq (M ❙∘ N) u"
                      by (metis u Srcs_simp⇩Λ⇩P Arr.simps(2) Trgs.simps(2) seq_char
                          list.sel(1) seq Λ.seqI(1) Λ.sources_char⇩Λ)
                    moreover have "¬ Ide (N # filter notIde (map Λ.un_App2 (u # U)))"
                      using u *
                      by (metis (no_types, lifting) *** Arr_map_un_App2 Std Std_imp_Arr
                          Arr.simps(1) Ide.elims(2) Resid_Arr_Ide_ind ide_char
                          seq_char calculation(1) cong_filter_notIde filter_notIde_Ide
                          insert_subset list.discI list.sel(3) list.simps(15) mem_Collect_eq)
                    ultimately show ?thesis
                      using * 1 2 3 Y ind8 Std_implies_set_subset_elementary_reduction
                      by simp
                  qed
                  show ?thesis
                  proof (cases "Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide";
                         cases "Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide")
                    show "⟦Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide;
                           Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide⟧
                             ⟹ ?thesis"
                    proof -
                      assume *: "Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide"
                      assume **: "Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide"
                      have False
                        using u 5 * ** Ide_iff_standard_development_empty
                        by (metis Λ.Ide.simps(4) image_subset_iff Λ.lambda.collapse(3)
                            list.set_intros(1) mem_Collect_eq)
                      thus ?thesis by blast
                    qed
                    show "⟦Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide;
                           ¬ Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide⟧
                             ⟹ ?thesis"
                    proof -
                      assume *: "Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide"
                      assume **: "¬ Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide"
                      have 6: "Λ.Trg (Λ.un_App1 (last (u # U))) = Λ.Trg M"
                      proof -
                        have "Λ.Trg M = Λ.Src (hd (map Λ.un_App1 (u # U)))"
                          by (metis u seq Trg_last_Src_hd_eqI hd_map Λ.Src.simps(4) Λ.Trg.simps(3)
                              Λ.is_App_def Λ.lambda.sel(3) last_ConsL list.discI list.sel(1))
                        also have "... = Λ.Trg (last (map Λ.un_App1 (u # U)))"
                        proof -
                          have 6: "Ide (map Λ.un_App1 (u # U))"
                            using * *** u Std Std_imp_Arr Ide_char ide_char Arr_map_un_App1
                            by (metis (mono_tags, lifting) Collect_cong insert_subset
                                Λ.ide_char list.distinct(1) list.set_map list.simps(15)
                                mem_Collect_eq)
                          hence "Src (map Λ.un_App1 (u # U)) = Trg (map Λ.un_App1 (u # U))"
                            using Ide_imp_Src_eq_Trg by blast
                          thus ?thesis
                            using 6 Ide_implies_Arr by force
                        qed
                        also have "... = Λ.Trg (Λ.un_App1 (last (u # U)))"
                          by (simp add: last_map)
                        finally show ?thesis by simp
                      qed
                      have "filter notIde (map Λ.un_App1 (u # U)) = []"
                        using * by (simp add: subset_eq)
                      hence 4: "stdz_insert (M ❙∘ N) (u # U) =
                                map (λX. X ❙∘ Λ.Src N) (standard_development M) @
                                map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                    (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))"
                        using u 4 5 * ** Ide_iff_standard_development_empty MN
                        by simp
                      show ?thesis
                      proof (intro conjI)
                        have "Std (map (λX. X ❙∘ Λ.Src N) (standard_development M) @
                                   map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                       (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))))"
                        proof (intro Std_append)
                          show "Std (map (λX. X ❙∘ Λ.Src N) (standard_development M))"
                            using Std_map_App1 Std_standard_development MN Λ.Ide_Src
                            by force
                          show "Std (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                         (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))))"
                            using "**" B MN 6 Std_map_App2 Λ.Ide_Trg by presburger
                          show "map (λX. X ❙∘ Λ.Src N) (standard_development M) = [] ∨
                                map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                    (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))) = [] ∨
                                Λ.sseq (last (map (λX. X ❙∘ Λ.Src N) (standard_development M)))
                                       (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                (stdz_insert N (filter notIde
                                                               (map Λ.un_App2 (u # U))))))"
                          proof (cases "Λ.Ide M")
                            show "Λ.Ide M ⟹ ?thesis"
                              using Ide_iff_standard_development_empty MN by blast
                            assume M: "¬ Λ.Ide M"
                            have "Λ.sseq (last (map (λX. X ❙∘ Λ.Src N) (standard_development M)))
                                         (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                  (stdz_insert N (filter notIde
                                                                 (map Λ.un_App2 (u # U))))))"
                            proof -
                              have "last (map (λX. X ❙∘ Λ.Src N) (standard_development M)) =
                                    Λ.App (last (standard_development M)) (Λ.Src N)"
                                using M
                                by (simp add: Ide_iff_standard_development_empty MN last_map)
                              moreover have "hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                     (stdz_insert N (filter notIde
                                                                    (map Λ.un_App2 (u # U))))) =
                                             Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))
                                                   (hd (stdz_insert N (filter notIde
                                                                      (map Λ.un_App2 (u # U)))))"
                                by (metis ** B Ide.simps(1) Resid.simps(2) hd_map ide_char)
                              moreover
                              have "Λ.sseq (Λ.App (last (standard_development M)) (Λ.Src N))
                                            ..."
                              proof -
                                have "Λ.elementary_reduction (last (standard_development M))"
                                  using M MN Std_standard_development
                                        Ide_iff_standard_development_empty last_in_set
                                        mem_Collect_eq set_standard_development subsetD
                                  by metis
                                moreover have "Λ.elementary_reduction
                                                 (hd (stdz_insert N
                                                        (filter notIde (map Λ.un_App2 (u # U)))))"
                                  using ** B
                                  by (metis Arr.simps(1) Con_implies_Arr(2) Ide.simps(1)
                                      ide_char in_mono list.set_sel(1) mem_Collect_eq)
                                moreover have "Λ.Trg (last (standard_development M)) =
                                               Λ.Trg (Λ.un_App1 (last (u # U)))"
                                  using M MN 6 Trg_last_standard_development by presburger
                                moreover have "Λ.Src N =
                                               Λ.Src (hd (stdz_insert N
                                                            (filter notIde (map Λ.un_App2 (u # U)))))"
                                  by (metis "**" B Src_hd_eqI list.sel(1))
                                ultimately show ?thesis
                                  by simp
                              qed
                              ultimately show ?thesis by simp
                            qed
                            thus ?thesis by blast
                          qed
                        qed
                        thus "Std (stdz_insert (M ❙∘ N) (u # U))"
                          using 4 by simp
                        show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                                  stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                        proof
                          show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                          proof (cases "Λ.Ide M")
                            assume M: "Λ.Ide M"
                            have "stdz_insert (M ❙∘ N) (u # U) =
                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))"
                              using 4 M MN Ide_iff_standard_development_empty by simp
                            also have "... ⇧*∼⇧* (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                    (N # filter notIde (map Λ.un_App2 (u # U))))"
                            proof -
                              have "Λ.Ide (Λ.Trg (Λ.un_App1 (last (u # U))))"
                                using M 6 Λ.Ide_Trg Λ.Ide_implies_Arr by fastforce
                              thus ?thesis
                                using ** *** B u cong_map_App1 by blast
                            qed
                            also have "map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (N # filter notIde (map Λ.un_App2 (u # U))) =
                                       map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (filter notIde (N # map Λ.un_App2 (u # U)))"
                              using 1 M by force
                            also have "map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (filter notIde (N # map Λ.un_App2 (u # U))) ⇧*∼⇧*
                                       map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (N # map Λ.un_App2 (u # U))"
                            proof -
                              have "Arr (N # map Λ.un_App2 (u # U))"
                              proof
                                show "Λ.arr N"
                                  using MN by blast
                                show "Arr (map Λ.un_App2 (u # U))"
                                  using *** u Std Arr_map_un_App2
                                  by (metis Std_imp_Arr insert_subset list.distinct(1)
                                      list.simps(15) mem_Collect_eq)
                                show "Λ.trg N = Src (map Λ.un_App2 (u # U))"
                                  using u ‹Λ.seq (M ❙∘ N) u› Λ.seq_char Λ.is_App_def by auto
                              qed
                              moreover have "¬ Ide (N # map Λ.un_App2 (u # U))"
                                using 1 M by force
                              moreover have "Λ.Ide (Λ.Trg (Λ.un_App1 (last (u # U))))"
                                using M 6 Λ.Ide_Trg Λ.Ide_implies_Arr by presburger
                              ultimately show ?thesis
                                using cong_filter_notIde cong_map_App1 by blast
                            qed
                            also have "map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (N # map Λ.un_App2 (u # U)) =
                                       map (Λ.App M) (N # map Λ.un_App2 (u # U))"
                              using M MN ‹Λ.Trg (Λ.un_App1 (last (u # U))) = Λ.Trg M›
                                    Λ.Ide_iff_Trg_self
                              by force
                            also have "... = (M ❙∘ N) # map (Λ.App M) (map Λ.un_App2 (u # U))"
                              by simp
                            also have "... = (M ❙∘ N) # u # U"
                            proof -
                              have "Arr (u # U)"
                                using Std Std_imp_Arr by blast
                              moreover have "set (u # U) ⊆ Collect Λ.is_App"
                                using *** u by simp
                              moreover have "Λ.un_App1 u = M"
                                by (metis * u M seq Trg_last_Src_hd_eqI Λ.Ide_iff_Src_self
                                    Λ.Ide_iff_Trg_self Λ.Ide_implies_Arr Λ.Src.simps(4)
                                    Λ.Trg.simps(3) Λ.lambda.collapse(3) Λ.lambda.sel(3)
                                    last.simps list.distinct(1) list.sel(1) list.set_intros(1)
                                    list.set_map list.simps(9) mem_Collect_eq standardize.cases
                                    subset_iff)
                              moreover have "Λ.un_App1 ` set (u # U) ⊆ {M}"
                              proof -
                                have "Ide (map Λ.un_App1 (u # U))"
                                  using * *** Std Std_imp_Arr Arr_map_un_App1
                                  by (metis Collect_cong Ide_char calculation(1-2) Λ.ide_char
                                      list.set_map)
                                thus ?thesis
                                  by (metis calculation(3) hd_map list.discI list.sel(1)
                                      list.set_map set_Ide_subset_single_hd)
                              qed
                              ultimately show ?thesis
                                using M map_App_map_un_App2 by blast
                            qed
                            finally show ?thesis by blast
                            next
                            assume M: "¬ Λ.Ide M"
                            have "stdz_insert (M ❙∘ N) (u # U) =
                                  map (λX. X ❙∘ Λ.Src N) (standard_development M) @
                                  map (λX. Λ.Trg M ❙∘ X)
                                      (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))"
                              using 4 6 by simp
                            also have "... ⇧*∼⇧* [M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N] @
                                                 map (λX. Λ.Trg M ❙∘ X)
                                                     (filter notIde (map Λ.un_App2 (u # U)))"
                            proof (intro cong_append)
                              show "map (λX. X ❙∘ Λ.Src N) (standard_development M) ⇧*∼⇧*
                                    [M ❙∘ Λ.Src N]"
                                using MN M cong_standard_development Λ.Ide_Src
                                      cong_map_App2 [of "Λ.Src N" "standard_development M" "[M]"]
                                by simp
                              show "map (λX. Λ.Trg M ❙∘ X)
                                        (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))) ⇧*∼⇧*
                                    [Λ.Trg M ❙∘ N] @
                                      map (λX. Λ.Trg M ❙∘ X)
                                          (filter notIde (map Λ.un_App2 (u # U)))"
                              proof -
                                have "map (λX. Λ.Trg M ❙∘ X)
                                          (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))) ⇧*∼⇧*
                                      map (λX. Λ.Trg M ❙∘ X)
                                          (N # filter notIde (map Λ.un_App2 (u # U)))"
                                  using ** B MN cong_map_App1 lambda_calculus.Ide_Trg
                                  by presburger
                                also have "map (λX. Λ.Trg M ❙∘ X)
                                               (N # filter notIde (map Λ.un_App2 (u # U))) =
                                           [Λ.Trg M ❙∘ N] @
                                             map (λX. Λ.Trg M ❙∘ X)
                                                 (filter notIde (map Λ.un_App2 (u # U)))"
                                  by simp
                                finally show ?thesis by blast
                              qed
                              show "seq (map (λX. X ❙∘ Λ.Src N) (standard_development M))
                                        (map (λX. Λ.Trg M ❙∘ X)
                                             (stdz_insert N (filter notIde
                                                                    (map Λ.un_App2 (u # U)))))"
                                using MN M ** B cong_standard_development [of M]
                                by (metis Nil_is_append_conv Resid.simps(2) Std_imp_Arr
                                    ‹Std (stdz_insert (M ❙∘ N) (u # U))› arr_append_imp_seq
                                    arr_char calculation complete_development_Ide_iff
                                    complete_development_def list.map_disc_iff development.simps(1))
                            qed
                            also have "[M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N] @
                                          map (λX. Λ.Trg M ❙∘ X)
                                              (filter notIde (map Λ.un_App2 (u # U))) =
                                       ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N]) @
                                         map (λX. Λ.Trg M ❙∘ X)
                                             (filter notIde (map Λ.un_App2 (u # U)))"
                              by simp
                            also have "([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N]) @
                                          map (λX. Λ.Trg M ❙∘ X)
                                              (filter notIde (map Λ.un_App2 (u # U))) ⇧*∼⇧*
                                        ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N]) @
                                           map (λX. Λ.Trg M ❙∘ X) (map Λ.un_App2 (u # U))"
                            proof (intro cong_append)
                              show "seq ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])
                                        (map (λX. Λ.Trg M ❙∘ X)
                                             (filter notIde (map Λ.un_App2 (u # U))))"
                              proof
                                show "Arr ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])"
                                  by (simp add: MN)
                                show 9: "Arr (map (λX. Λ.Trg M ❙∘ X)
                                             (filter notIde (map Λ.un_App2 (u # U))))"
                                proof -
                                  have "Arr (map Λ.un_App2 (u # U))"
                                    using *** u Arr_map_un_App2
                                    by (metis Std Std_imp_Arr list.distinct(1) mem_Collect_eq
                                        set_ConsD subset_code(1))
                                  moreover have "¬ Ide (map Λ.un_App2 (u # U))"
                                    using **
                                    by (metis Collect_cong Λ.ide_char list.set_map
                                        set_Ide_subset_ide)
                                  ultimately show ?thesis
                                    using cong_filter_notIde
                                    by (metis Arr_map_App2 Con_implies_Arr(2) Ide.simps(1)
                                        MN ide_char Λ.Ide_Trg)
                                qed
                                show "Λ.Trg (last ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])) =
                                      Λ.Src (hd (map (λX. Λ.Trg M ❙∘ X)
                                            (filter notIde (map Λ.un_App2 (u # U)))))"
                                proof -
                                  have "Λ.Trg (last ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])) =
                                        Λ.Trg M ❙∘ Λ.Trg N"
                                    using MN by auto
                                  also have "... = Λ.Src u"
                                    using Trg_last_Src_hd_eqI seq by force
                                  also have "... = Λ.Src (Λ.Trg M ❙∘ Λ.un_App2 u)"
                                    using MN ‹Λ.App (Λ.Trg M) (Λ.Trg N) = Λ.Src u› u by auto
                                  also have 8: "... = Λ.Trg M ❙∘ Λ.Src (Λ.un_App2 u)"
                                    using MN by simp
                                  also have 7: "... = Λ.Trg M ❙∘ 
                                                          Λ.Src (hd (filter notIde
                                                                       (map Λ.un_App2 (u # U))))"
                                    using u 5 list.simps(9) cong_filter_notIde
                                          ‹filter notIde (map Λ.un_App1 (u # U)) = []›
                                    by auto
                                  also have "... = Λ.Src (hd (map (λX. Λ.Trg M ❙∘ X)
                                                             (filter notIde
                                                                (map Λ.un_App2 (u # U)))))"
                                    (* TODO: Figure out what is going on with 7 8 9. *)
                                    by (metis 7 8 9 Arr.simps(1) hd_map Λ.Src.simps(4)
                                        Λ.lambda.sel(4) list.simps(8))
                                  finally show "Λ.Trg (last ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])) =
                                                Λ.Src (hd (map (λX. Λ.Trg M ❙∘ X)
                                                             (filter notIde
                                                                     (map Λ.un_App2 (u # U)))))"
                                    by blast
                                qed
                              qed
                              show "seq [M ❙∘ Λ.Src N] [Λ.Trg M ❙∘ N]"
                                using MN by force
                              show "[M ❙∘ Λ.Src N] ⇧*∼⇧* [M ❙∘ Λ.Src N]"
                                using MN
                                by (meson head_redex_decomp Λ.Arr.simps(4) Λ.Arr_Src
                                    prfx_transitive)
                              show "[Λ.Trg M ❙∘ N] ⇧*∼⇧* [Λ.Trg M ❙∘ N]"
                                using MN
                                by (meson ‹seq [M ❙∘ Λ.Src N] [Λ.Trg M ❙∘ N]› cong_reflexive seqE)
                              show "map (λX. Λ.Trg M ❙∘ X)
                                        (filter notIde (map Λ.un_App2 (u # U))) ⇧*∼⇧*
                                    map (λX. Λ.Trg M ❙∘ X) (map Λ.un_App2 (u # U))"
                              proof -
                                have "Arr (map Λ.un_App2 (u # U))"
                                  using *** u Arr_map_un_App2
                                  by (metis Std Std_imp_Arr list.distinct(1) mem_Collect_eq
                                      set_ConsD subset_code(1))
                                moreover have "¬ Ide (map Λ.un_App2 (u # U))"
                                  using **
                                  by (metis Collect_cong Λ.ide_char list.set_map
                                      set_Ide_subset_ide)
                                ultimately show ?thesis
                                  using M MN cong_filter_notIde cong_map_App1 Λ.Ide_Trg
                                  by presburger
                              qed
                            qed
                            also have "([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N]) @
                                          map (λX. Λ.Trg M ❙∘ X) (map Λ.un_App2 (u # U)) ⇧*∼⇧*
                                       [M ❙∘ N] @ u # U"
                            proof (intro cong_append)
                              show "seq ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])
                                        (map (λX. Λ.Trg M ❙∘ X) (map Λ.un_App2 (u # U)))"
                                by (metis Nil_is_append_conv Nil_is_map_conv arr_append_imp_seq
                                    calculation cong_implies_coterminal coterminalE
                                    list.distinct(1))
                              show "[M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N] ⇧*∼⇧* [M ❙∘ N]"
                                using MN Λ.resid_Arr_self Λ.Arr_not_Nil Λ.Ide_Trg ide_char by simp
                              show " map (λX. Λ.Trg M ❙∘ X) (map Λ.un_App2 (u # U)) ⇧*∼⇧* u # U"
                              proof -
                                have "map (λX. Λ.Trg M ❙∘ X) (map Λ.un_App2 (u # U)) = u # U"
                                proof (intro map_App_map_un_App2)
                                  show "Arr (u # U)"
                                    using Std Std_imp_Arr by blast
                                  show "set (u # U) ⊆ Collect Λ.is_App"
                                    using *** u by auto
                                  show "Λ.Ide (Λ.Trg M)"
                                    using MN Λ.Ide_Trg by blast
                                  show "Λ.un_App1 ` set (u # U) ⊆ {Λ.Trg M}"
                                  proof -
                                    have "Λ.un_App1 u = Λ.Trg M"
                                      using * u seq seq_char
                                      apply (cases u)
                                          apply simp_all
                                      by (metis Trg_last_Src_hd_eqI Λ.Ide_iff_Src_self
                                          Λ.Src_Src Λ.Src_Trg Λ.Src_eq_iff(2) Λ.Trg.simps(3)
                                          last_ConsL list.sel(1) seq u)
                                    moreover have "Ide (map Λ.un_App1 (u # U))"
                                      using * Std Std_imp_Arr Arr_map_un_App1
                                      by (metis Collect_cong Ide_char
                                          ‹Arr (u # U)› ‹set (u # U) ⊆ Collect Λ.is_App›
                                          Λ.ide_char list.set_map)
                                    ultimately show ?thesis
                                      using set_Ide_subset_single_hd by force 
                                  qed
                                qed
                                thus ?thesis
                                  by (simp add: Resid_Arr_self Std ide_char)
                              qed
                            qed
                            also have "[M ❙∘ N] @ u # U = (M ❙∘ N) # u # U"
                              by simp
                            finally show ?thesis by blast
                          qed
                        qed
                      qed
                    qed
                    show "⟦¬ Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide;
                           Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide⟧
                             ⟹ ?thesis"
                    proof -
                      assume *: "¬ Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide"
                      assume **: "Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide"
                      have 10: "filter notIde (map Λ.un_App2 (u # U)) = []"
                        using ** by (simp add: subset_eq)
                      hence 4: "stdz_insert (M ❙∘ N) (u # U) =
                                map (λX. X ❙∘ Λ.Src N)
                                    (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) @
                                map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                    (standard_development N)"
                        using u 4 5 * ** Ide_iff_standard_development_empty MN
                        by simp
                      have 6: "Λ.Ide (Λ.Trg (Λ.un_App1 (last (u # U))))"
                        using *** u Std Std_imp_Arr
                        by (metis Arr_imp_arr_last in_mono Λ.Arr.simps(4) Λ.Ide_Trg Λ.arr_char
                            Λ.lambda.collapse(3) last.simps last_in_set list.discI mem_Collect_eq)
                      show ?thesis
                      proof (intro conjI)
                        show "Std (stdz_insert (M ❙∘ N) (u # U))"
                        proof -
                          have "Std (map (λX. X ❙∘ Λ.Src N)
                                         (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) @
                                     map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                         (standard_development N))"
                          proof (intro Std_append)
                            show "Std (map (λX. X ❙∘ Λ.Src N)
                                           (stdz_insert M (filter notIde
                                                                  (map Λ.un_App1 (u # U)))))"
                              using * A MN Std_map_App1 Λ.Ide_Src by presburger
                            show "Std (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (standard_development N))"
                              using MN 6 Std_map_App2 Std_standard_development by simp
                            show "map (λX. X ❙∘ Λ.Src N)
                                      (stdz_insert M
                                        (filter notIde (map Λ.un_App1 (u # U)))) = [] ∨
                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (standard_development N) = [] ∨
                                  Λ.sseq (last (map (λX. Λ.App X (Λ.Src N))
                                                    (stdz_insert M
                                                      (filter notIde (map Λ.un_App1 (u # U))))))
                                         (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                  (standard_development N)))"
                            proof (cases "Λ.Ide N")
                              show "Λ.Ide N ⟹ ?thesis"
                                using Ide_iff_standard_development_empty MN by blast
                              assume N: "¬ Λ.Ide N"
                              have "Λ.sseq (last (map (λX. X ❙∘ Λ.Src N)
                                                      (stdz_insert M
                                                        (filter notIde (map Λ.un_App1 (u # U))))))
                                           (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                    (standard_development N)))"
                              proof -
                                have "hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                     (standard_development N)) =
                                      Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))
                                            (hd (standard_development N))"
                                  by (meson Ide_iff_standard_development_empty MN N list.map_sel(1))
                                moreover have "last (map (λX. X ❙∘ Λ.Src N)
                                                      (stdz_insert M
                                                        (filter notIde (map Λ.un_App1 (u # U))))) =
                                               Λ.App (last (stdz_insert M
                                                              (filter notIde
                                                                      (map Λ.un_App1 (u # U)))))
                                                     (Λ.Src N)"
                                  by (metis * A Ide.simps(1) Resid.simps(1) ide_char last_map)
                                moreover have "Λ.sseq ... (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))
                                                                  (hd (standard_development N)))"
                                proof -
                                  have 7: "Λ.elementary_reduction
                                             (last (stdz_insert M (filter notIde
                                                                  (map Λ.un_App1 (u # U)))))"
                                    using * A
                                    by (metis Ide.simps(1) Resid.simps(2) ide_char last_in_set
                                        mem_Collect_eq subset_iff)
                                  moreover
                                  have "Λ.elementary_reduction (hd (standard_development N))"
                                    using MN N hd_in_set set_standard_development
                                          Ide_iff_standard_development_empty
                                    by blast
                                  moreover have "Λ.Src N = Λ.Src (hd (standard_development N))"
                                    using MN N Src_hd_standard_development by auto
                                  moreover have "Λ.Trg (last (stdz_insert M 
                                                                (filter notIde
                                                                        (map Λ.un_App1 (u # U))))) =
                                                 Λ.Trg (Λ.un_App1 (last (u # U)))"
                                  proof -
                                    have "[Λ.Trg (last (stdz_insert M 
                                                          (filter notIde
                                                                  (map Λ.un_App1 (u # U)))))] =
                                          [Λ.Trg (Λ.un_App1 (last (u # U)))]"
                                    proof -
                                      have "Λ.Trg (last (stdz_insert M
                                                           (filter notIde
                                                                   (map Λ.un_App1 (u # U))))) =
                                            Λ.Trg (last (map Λ.un_App1 (u # U)))"
                                      proof -
                                        have "Λ.Trg (last (stdz_insert M
                                                             (filter notIde (map Λ.un_App1 (u # U))))) =
                                              Λ.Trg (last (M # filter notIde (map Λ.un_App1 (u # U))))"
                                          using * A Trg_last_eqI by blast
                                        also have "... = Λ.Trg (last ([M] @ filter notIde
                                                                              (map Λ.un_App1 (u # U))))"
                                          by simp
                                        also have "... = Λ.Trg (last (filter notIde
                                                                        (map Λ.un_App1 (u # U))))"
                                        proof -
                                          have "seq [M] (filter notIde (map Λ.un_App1 (u # U)))"
                                          proof
                                            show "Arr [M]"
                                              using MN by simp
                                            show "Arr (filter notIde (map Λ.un_App1 (u # U)))"
                                              using * Std_imp_Arr
                                              by (metis (no_types, lifting)
                                                  X empty_filter_conv list.set_map mem_Collect_eq subsetI)
                                            show "Λ.Trg (last [M]) =
                                                  Λ.Src (hd (filter notIde (map Λ.un_App1 (u # U))))"
                                            proof -
                                              have "Λ.Trg (last [M]) = Λ.Trg M"
                                                using MN by simp
                                              also have "... = Λ.Src (Λ.un_App1 u)"
                                                by (metis Trg_last_Src_hd_eqI Λ.Src.simps(4)
                                                    Λ.Trg.simps(3) Λ.lambda.collapse(3)
                                                    Λ.lambda.inject(3) last_ConsL list.sel(1) seq u)
                                              also have "... = Λ.Src (hd (map Λ.un_App1 (u # U)))"
                                                by auto
                                              also have "... = Λ.Src (hd (filter notIde
                                                                         (map Λ.un_App1 (u # U))))"
                                                using u 5 10 by force
                                              finally show ?thesis by blast
                                            qed
                                          qed
                                          thus ?thesis by fastforce
                                        qed
                                        also have "... = Λ.Trg (last (map Λ.un_App1 (u # U)))"
                                        proof -
                                          have "filter (λu. ¬ Λ.Ide u) (map Λ.un_App1 (u # U)) ⇧*∼⇧*
                                                map Λ.un_App1 (u # U)"
                                            using * *** u Std Std_imp_Arr Arr_map_un_App1 [of "u # U"]
                                                  cong_filter_notIde
                                            by (metis (mono_tags, lifting) empty_filter_conv
                                                filter_notIde_Ide list.discI list.set_map
                                                mem_Collect_eq set_ConsD subset_code(1))
                                          thus ?thesis
                                            using cong_implies_coterminal Trg_last_eqI
                                            by presburger
                                        qed
                                        finally show ?thesis by blast
                                      qed
                                      thus ?thesis
                                        by (simp add: last_map)
                                    qed
                                    moreover
                                    have "Λ.Ide (Λ.Trg (last (stdz_insert M
                                                                (filter notIde
                                                                        (map Λ.un_App1 (u # U))))))"
                                      using 7 Λ.Ide_Trg Λ.elementary_reduction_is_arr by blast
                                    moreover have "Λ.Ide (Λ.Trg (Λ.un_App1 (last (u # U))))"
                                      using 6 by blast
                                    ultimately show ?thesis by simp
                                  qed
                                  ultimately show ?thesis
                                    using Λ.sseq.simps(4) by blast
                                qed
                                ultimately show ?thesis by argo
                              qed
                              thus ?thesis by blast
                            qed
                          qed
                          thus ?thesis
                            using 4 by simp
                        qed
                        show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                                  stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                        proof
                          show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                          proof (cases "Λ.Ide N")
                            assume N: "Λ.Ide N"
                            have "stdz_insert (M ❙∘ N) (u # U) =
                                  map (λX. X ❙∘ N)
                                      (stdz_insert M (filter notIde
                                                     (map Λ.un_App1 (u # U))))"
                              using 4 N MN Ide_iff_standard_development_empty Λ.Ide_iff_Src_self
                              by force
                            also have "... ⇧*∼⇧* map (λX. X ❙∘ N)
                                                   (M # filter notIde
                                                               (map Λ.un_App1 (u # U)))"
                              using * A MN N Λ.Ide_Src cong_map_App2 Λ.Ide_iff_Src_self
                              by blast
                            also have "map (λX. X ❙∘ N)
                                           (M # filter notIde
                                                       (map Λ.un_App1 (u # U))) =
                                       [M ❙∘ N] @
                                         map (λX. Λ.App X N)
                                             (filter notIde (map Λ.un_App1 (u # U)))"
                              by auto
                            also have "[M ❙∘ N] @
                                         map (λX. X ❙∘ N)
                                             (filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                                       [M ❙∘ N] @ map (λX. X ❙∘ N) (map Λ.un_App1 (u # U))"
                            proof (intro cong_append)
                              show "seq [M ❙∘ N]
                                        (map (λX. X ❙∘ N)
                                             (filter notIde (map Λ.un_App1 (u # U))))"
                              proof
                                have 20: "Arr (map Λ.un_App1 (u # U))"
                                  using *** u Std Arr_map_un_App1
                                  by (metis Std_imp_Arr insert_subset list.discI list.simps(15)
                                      mem_Collect_eq)
                                show "Arr [M ❙∘ N]"
                                  using MN by auto
                                show 21: "Arr (map (λX. X ❙∘ N)
                                                   (filter notIde (map Λ.un_App1 (u # U))))"
                                proof -
                                  have "Arr (filter notIde (map Λ.un_App1 (u # U)))"
                                    using u 20 cong_filter_notIde
                                    by (metis (no_types, lifting) * Std_imp_Arr
                                        ‹Std (filter notIde (map Λ.un_App1 (u # U)))›
                                        empty_filter_conv list.set_map mem_Collect_eq subsetI)
                                  thus ?thesis
                                    using MN N Arr_map_App1 Λ.Ide_Src by presburger
                                qed
                                show "Λ.Trg (last [M ❙∘ N]) =
                                      Λ.Src (hd (map (λX. X ❙∘ N)
                                                     (filter notIde (map Λ.un_App1 (u # U)))))"
                                proof -
                                  have "Λ.Trg (last [M ❙∘ N]) = Λ.Trg M ❙∘ N"
                                    using MN N Λ.Ide_iff_Trg_self by simp
                                  also have "... = Λ.Src (Λ.un_App1 u) ❙∘ N"
                                    using MN u seq seq_char
                                    by (metis Trg_last_Src_hd_eqI calculation Λ.Src_Src Λ.Src_Trg
                                        Λ.Src_eq_iff(2) Λ.is_App_def Λ.lambda.sel(3) list.sel(1))
                                  also have "... = Λ.Src (Λ.un_App1 u ❙∘ N)"
                                    using MN N Λ.Ide_iff_Src_self by simp
                                  also have "... = Λ.Src (hd (map (λX. X ❙∘ N)
                                                                  (map Λ.un_App1 (u # U))))"
                                    by simp
                                  also have "... = Λ.Src (hd (map (λX. X ❙∘ N)
                                                                  (filter notIde
                                                                          (map Λ.un_App1 (u # U)))))"
                                  proof -
                                    have "cong (map Λ.un_App1 (u # U))
                                               (filter notIde (map Λ.un_App1 (u # U)))"
                                      using * 20 21 cong_filter_notIde
                                      by (metis Arr.simps(1) filter_notIde_Ide map_is_Nil_conv)
                                    thus ?thesis
                                      by (metis (no_types, lifting) Ide.simps(1) Resid.simps(2)
                                          Src_hd_eqI hd_map ide_char Λ.Src.simps(4)
                                          list.distinct(1) list.simps(9))
                                  qed
                                  finally show ?thesis by blast
                                qed
                              qed
                              show "cong [M ❙∘ N] [M ❙∘ N]"
                                using MN
                                by (meson head_redex_decomp Λ.Arr.simps(4) Λ.Arr_Src
                                    prfx_transitive)
                              show "map (λX. X ❙∘ N) (filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                                    map (λX. X ❙∘ N) (map Λ.un_App1 (u # U))"
                              proof -
                                have "Arr (map Λ.un_App1 (u # U))"
                                  using *** u Std Arr_map_un_App1
                                  by (metis Std_imp_Arr insert_subset list.discI list.simps(15)
                                      mem_Collect_eq)
                                moreover have "¬ Ide (map Λ.un_App1 (u # U))"
                                  using *
                                  by (metis Collect_cong Λ.ide_char list.set_map
                                      set_Ide_subset_ide)
                                ultimately show ?thesis
                                  using *** u MN N cong_filter_notIde cong_map_App2
                                  by (meson Λ.Ide_Src)
                              qed
                            qed
                            also have "[M ❙∘ N] @ map (λX. X ❙∘ N) (map Λ.un_App1 (u # U)) ⇧*∼⇧*
                                       [M ❙∘ N] @ u # U"
                            proof -
                              have "map (λX. X ❙∘ N) (map Λ.un_App1 (u # U)) ⇧*∼⇧* u # U"
                              proof -
                                have "map (λX. X ❙∘ N) (map Λ.un_App1 (u # U)) = u # U"
                                proof (intro map_App_map_un_App1)
                                  show "Arr (u # U)"
                                    using Std Std_imp_Arr by simp
                                  show "set (u # U) ⊆ Collect Λ.is_App"
                                    using *** u by auto
                                  show "Λ.Ide N"
                                    using N by simp
                                  show "Λ.un_App2 ` set (u # U) ⊆ {N}"
                                  proof -
                                    have "Λ.Src (Λ.un_App2 u) = Λ.Trg N"
                                      using ** seq u seq_char N
                                      apply (cases u)
                                          apply simp_all
                                      by (metis Trg_last_Src_hd_eqI Λ.Src.simps(4) Λ.Trg.simps(3)
                                          Λ.lambda.inject(3) last_ConsL list.sel(1) seq)
                                    moreover have "Λ.Ide (Λ.un_App2 u) ∧ Λ.Ide N"
                                      using ** N by simp
                                    moreover have "Ide (map Λ.un_App2 (u # U))"
                                      using ** Std Std_imp_Arr Arr_map_un_App2
                                      by (metis Collect_cong Ide_char
                                          ‹Arr (u # U)› ‹set (u # U) ⊆ Collect Λ.is_App›
                                          Λ.ide_char list.set_map)
                                    ultimately show ?thesis
                                      by (metis hd_map Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self
                                          Λ.Ide_implies_Arr list.discI list.sel(1)
                                          list.set_map set_Ide_subset_single_hd)
                                  qed
                                qed
                                thus ?thesis
                                  by (simp add: Resid_Arr_self Std ide_char)
                              qed
                              thus ?thesis
                                using MN cong_append
                                by (metis (no_types, lifting) 1 cong_standard_development
                                    cong_transitive Λ.Arr.simps(4) seq)
                            qed
                            also have "[M ❙∘ N] @ (u # U) = (M ❙∘ N) # u # U"
                              by simp
                            finally show ?thesis by blast
                            next
                            assume N: "¬ Λ.Ide N"
                            have "stdz_insert (M ❙∘ N) (u # U) =
                                  map (λX. X ❙∘ Λ.Src N)
                                      (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) @
                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (standard_development N)"
                              using 4 by simp
                            also have "... ⇧*∼⇧* map (λX. X ❙∘ Λ.Src N)
                                                   (M # filter notIde (map Λ.un_App1 (u # U))) @
                                                     map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]"
                            proof (intro cong_append)
                              show 23: "map (λX. X ❙∘ Λ.Src N)
                                            (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) ⇧*∼⇧*
                                        map (λX. X ❙∘ Λ.Src N)
                                            (M # filter notIde (map Λ.un_App1 (u # U)))"
                                using * A MN Λ.Ide_Src cong_map_App2 by blast
                              show 22: "map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                            (standard_development N) ⇧*∼⇧*
                                        map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]"
                                using 6 *** u Std Std_imp_Arr MN N cong_standard_development
                                      cong_map_App1
                                by presburger
                              show "seq (map (λX. X ❙∘ Λ.Src N)
                                             (stdz_insert M (filter notIde
                                                            (map Λ.un_App1 (u # U)))))
                                        (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                             (standard_development N))"
                              proof -
                                have "seq (map (λX. X ❙∘ Λ.Src N)
                                               (M # filter notIde
                                                           (map Λ.un_App1 (u # U))))
                                          (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N])"
                                proof
                                  show 26: "Arr (map (λX. X ❙∘ Λ.Src N)
                                                 (M # filter notIde
                                                             (map Λ.un_App1 (u # U))))"
                                    by (metis 23 Con_implies_Arr(2) Ide.simps(1) ide_char)
                                  show "Arr (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N])"
                                    by (meson 22 arr_char con_implies_arr(2) prfx_implies_con)   
                                  show "Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                         (M # filter notIde
                                                                     (map Λ.un_App1 (u # U))))) =
                                        Λ.Src (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                       [N]))"
                                  proof -
                                    have "Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                           (M # map Λ.un_App1 (u # U))))
                                           ∼
                                          Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                                    (M # filter notIde
                                                                           (map Λ.un_App1 (u # U)))))"
                                    proof -
                                      have "targets (map (λX. X ❙∘ Λ.Src N)
                                                         (M # filter notIde
                                                                     (map Λ.un_App1 (u # U)))) =
                                            targets (map (λX. X ❙∘ Λ.Src N)
                                                         (M # map Λ.un_App1 (u # U)))"
                                      proof -
                                        have "map (λX. X ❙∘ Λ.Src N)
                                                  (M # filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                                              map (λX. X ❙∘ Λ.Src N)
                                                  (M # map Λ.un_App1 (u # U))"
                                        proof -
                                          have "map (λX. X ❙∘ Λ.Src N)
                                                    (M # map Λ.un_App1 (u # U)) =
                                                map (λX. X ❙∘ Λ.Src N)
                                                    ([M] @ map Λ.un_App1 (u # U))"
                                            by simp
                                          also have "cong ... (map (λX. X ❙∘ Λ.Src N)
                                                                   ([M] @ filter notIde
                                                                           (map Λ.un_App1 (u # U))))"
                                          proof -
                                            have "[M] @ map Λ.un_App1 (u # U) ⇧*∼⇧*
                                                  [M] @ filter notIde
                                                               (map Λ.un_App1 (u # U))"
                                            proof (intro cong_append)
                                              show "cong [M] [M]"
                                                using MN
                                                by (meson head_redex_decomp prfx_transitive)
                                              show "seq [M] (map Λ.un_App1 (u # U))"
                                              proof
                                                show "Arr [M]"
                                                  using MN by simp
                                                show "Arr (map Λ.un_App1 (u # U))"
                                                  using *** u Std Arr_map_un_App1
                                                  by (metis Std_imp_Arr insert_subset list.discI
                                                      list.simps(15) mem_Collect_eq)
                                                show "Λ.Trg (last [M]) =
                                                      Λ.Src (hd (map Λ.un_App1 (u # U)))"
                                                  using MN u seq seq_char Srcs_simp⇩Λ⇩P by auto
                                              qed
                                              show "cong (map Λ.un_App1 (u # U))
                                                         (filter notIde
                                                                 (map Λ.un_App1 (u # U)))"
                                              proof -
                                                have "Arr (map Λ.un_App1 (u # U))"
                                                  by (metis *** Arr_map_un_App1 Std Std_imp_Arr
                                                      insert_subset list.discI list.simps(15)
                                                      mem_Collect_eq u)
                                                moreover have "¬ Ide (map Λ.un_App1 (u # U))"
                                                  using * set_Ide_subset_ide by fastforce
                                                ultimately show ?thesis
                                                  using cong_filter_notIde by blast
                                              qed
                                            qed
                                            thus "map (λX. X ❙∘ Λ.Src N)
                                                      ([M] @ map Λ.un_App1 (u # U)) ⇧*∼⇧*
                                                  map (λX. X ❙∘ Λ.Src N)
                                                      ([M] @ filter notIde (map Λ.un_App1 (u # U)))"
                                              using MN cong_map_App2 Λ.Ide_Src by presburger
                                          qed
                                          finally show ?thesis by simp
                                        qed
                                        thus ?thesis
                                          using cong_implies_coterminal by blast
                                      qed
                                      moreover have "[Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                                       (M # map Λ.un_App1 (u # U))))] ∈
                                                     targets (map (λX. X ❙∘ Λ.Src N)
                                                                  (M # map Λ.un_App1 (u # U)))"
                                        by (metis (no_types, lifting) 26 calculation mem_Collect_eq
                                            single_Trg_last_in_targets targets_char⇩Λ⇩P)
                                      moreover have "[Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                                  (M # filter notIde
                                                                         (map Λ.un_App1 (u # U)))))] ∈
                                                     targets (map (λX. X ❙∘ Λ.Src N)
                                                             (M # filter notIde
                                                                         (map Λ.un_App1 (u # U))))"
                                        using 26 single_Trg_last_in_targets by blast
                                      ultimately show ?thesis
                                        by (metis (no_types, lifting) 26 Ide.simps(1-2) Resid_rec(1)
                                            in_targets_iff ide_char)
                                    qed
                                    moreover have "Λ.Ide (Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                                            (M # map Λ.un_App1 (u # U)))))"
                                      by (metis 6 MN Λ.Ide.simps(4) Λ.Ide_Src Λ.Trg.simps(3)
                                          Λ.Trg_Src last_ConsR last_map list.distinct(1)
                                          list.simps(9))
                                    moreover have "Λ.Ide (Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                                            (M # filter notIde
                                                                                   (map Λ.un_App1 (u # U))))))"
                                      using Λ.ide_backward_stable calculation(1-2) by fast
                                    ultimately show ?thesis
                                      by (metis (no_types, lifting) 6 MN hd_map
                                          Λ.Ide_iff_Src_self Λ.Ide_implies_Arr Λ.Src.simps(4)
                                          Λ.Trg.simps(3) Λ.Trg_Src Λ.cong_Ide_are_eq
                                          last.simps last_map list.distinct(1) list.map_disc_iff
                                          list.sel(1))
                                  qed
                                qed
                                thus ?thesis
                                  using 22 23 cong_respects_seq⇩P by presburger
                              qed
                            qed
                            also have "map (λX. X ❙∘ Λ.Src N)
                                           (M # filter notIde (map Λ.un_App1 (u # U))) @
                                         map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N] =
                                       [M ❙∘ Λ.Src N] @
                                          map (λX. X ❙∘ Λ.Src N)
                                              (filter notIde (map Λ.un_App1 (u # U))) @
                                           [Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))) N]"
                              by simp
                            also have 1: "[M ❙∘ Λ.Src N] @
                                            map (λX. X ❙∘ Λ.Src N)
                                                (filter notIde (map Λ.un_App1 (u # U))) @
                                             [Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))) N] ⇧*∼⇧*
                                          [M ❙∘ Λ.Src N] @
                                            map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                              [Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))) N]"
                            proof (intro cong_append)
                              show "[M ❙∘ Λ.Src N] ⇧*∼⇧* [M ❙∘ Λ.Src N]"
                                using MN
                                by (meson head_redex_decomp lambda_calculus.Arr.simps(4)
                                    lambda_calculus.Arr_Src prfx_transitive)
                              show 21: "map (λX. X ❙∘ Λ.Src N)
                                            (filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                                        map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U))"
                              proof -
                                have "filter notIde (map Λ.un_App1 (u # U)) ⇧*∼⇧*
                                      map Λ.un_App1 (u # U)"
                                proof -
                                  have "¬ Ide (map Λ.un_App1 (u # U))"
                                    using *
                                    by (metis Collect_cong Λ.ide_char list.set_map
                                        set_Ide_subset_ide)
                                  thus ?thesis
                                    using *** u Std Std_imp_Arr Arr_map_un_App1
                                          cong_filter_notIde
                                    by (metis ‹¬ Ide (map Λ.un_App1 (u # U))›
                                        list.distinct(1) mem_Collect_eq set_ConsD
                                        subset_code(1))
                                qed
                                thus ?thesis
                                  using MN cong_map_App2 [of "Λ.Src N"] Λ.Ide_Src by presburger
                              qed
                              show "[Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] ⇧*∼⇧*
                                    [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]"
                                by (metis "6" Con_implies_Arr(1) MN Λ.Ide_implies_Arr arr_char
                                    cong_reflexive Λ.Ide_iff_Src_self neq_Nil_conv
                                    orthogonal_App_single_single(1))
                              show "seq (map (λX. X ❙∘ Λ.Src N)
                                             (filter notIde (map Λ.un_App1 (u # U))))
                                        [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]"
                              proof
                                show "Arr (map (λX. X ❙∘ Λ.Src N)
                                               (filter notIde (map Λ.un_App1 (u # U))))"
                                  by (metis 21 Con_implies_Arr(2) Ide.simps(1) ide_char)
                                show "Arr [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]"
                                  by (metis Con_implies_Arr(2) Ide.simps(1)
                                      ‹[Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] ⇧*∼⇧*
                                       [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]›
                                      ide_char)
                                show "Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                  (filter notIde
                                                          (map Λ.un_App1 (u # U))))) =
                                      Λ.Src (hd [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N])"
                                  by (metis (no_types, lifting) 6 21 MN Trg_last_eqI
                                      Λ.Ide_iff_Src_self Λ.Ide_implies_Arr Λ.Src.simps(4)
                                      Λ.Trg.simps(3) Λ.Trg_Src last_map list.distinct(1)
                                      list.map_disc_iff list.sel(1))
                              qed
                              show "seq [M ❙∘ Λ.Src N]
                                        (map (λX. X ❙∘ Λ.Src N)
                                             (filter notIde (map Λ.un_App1 (u # U))) @
                                          [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N])"
                              proof
                                show "Arr [M ❙∘ Λ.Src N]"
                                  using MN by simp
                                show "Arr (map (λX. X ❙∘ Λ.Src N)
                                               (filter notIde (map Λ.un_App1 (u # U))) @
                                             [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N])"
                                  apply (intro Arr_appendI⇩P)
                                    apply (metis 21 Con_implies_Arr(2) Ide.simps(1) ide_char)
                                   apply (metis Con_implies_Arr(1) Ide.simps(1)
                                      ‹[Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] ⇧*∼⇧*
                                       [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]› ide_char)
                                  by (metis (no_types, lifting) "21" Arr.simps(1)
                                      Arr_append_iff⇩P Con_implies_Arr(2) Ide.simps(1)
                                      append_is_Nil_conv calculation ide_char not_Cons_self2)
                                show "Λ.Trg (last [M ❙∘ Λ.Src N]) =
                                      Λ.Src (hd (map (λX. X ❙∘ Λ.Src N)
                                                     (filter notIde
                                                             (map Λ.un_App1 (u # U))) @
                                                        [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]))"
                                  by (metis (no_types, lifting) Con_implies_Arr(2) Ide.simps(1)
                                      Trg_last_Src_hd_eqI append_is_Nil_conv arr_append_imp_seq
                                      arr_char calculation ide_char not_Cons_self2)
                               qed
                            qed
                            also have "[M ❙∘ Λ.Src N] @
                                         map (λX. X ❙∘ Λ.Src N)(map Λ.un_App1 (u # U)) @
                                           [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] ⇧*∼⇧*
                                       [M ❙∘ Λ.Src N] @
                                         [Λ.Trg M ❙∘ N] @
                                           map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))"
                            proof (intro cong_append [of "[Λ.App M (Λ.Src N)]"])
                              show "seq [M ❙∘ Λ.Src N]
                                        (map (λX. X ❙∘ Λ.Src N)
                                             (map Λ.un_App1 (u # U)) @
                                                [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N])"
                              proof
                                show "Arr [M ❙∘ Λ.Src N]"
                                  using MN by simp
                                show "Arr (map (λX. X ❙∘ Λ.Src N)
                                               (map Λ.un_App1 (u # U)) @ 
                                                  [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N])"
                                  by (metis (no_types, lifting) 1 Con_append(2) Con_implies_Arr(2)
                                      Ide.simps(1) append_is_Nil_conv ide_char not_Cons_self2)
                                show "Λ.Trg (last [M ❙∘ Λ.Src N]) =
                                      Λ.Src (hd (map (λX. X ❙∘ Λ.Src N)
                                                     (map Λ.un_App1 (u # U)) @
                                                   [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N]))"
                                proof -
                                  have "Λ.Trg M = Λ.Src (Λ.un_App1 u)"
                                    using u seq
                                    by (metis Trg_last_Src_hd_eqI Λ.Src.simps(4) Λ.Trg.simps(3)
                                        Λ.lambda.collapse(3) Λ.lambda.inject(3) last_ConsL
                                        list.sel(1))
                                  thus ?thesis
                                    using MN by auto
                                qed
                              qed
                              show "[M ❙∘ Λ.Src N] ⇧*∼⇧* [M ❙∘ Λ.Src N]"
                                using MN
                                by (metis head_redex_decomp Λ.Arr.simps(4) Λ.Arr_Src
                                    prfx_transitive)
                              show "map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                      [Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] ⇧*∼⇧*
                                    [Λ.Trg M ❙∘ N] @
                                      map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))"
                              proof -
                                have "map (λX. X ❙∘ Λ.Src (hd [N])) (map Λ.un_App1 (u # U)) @
                                        map (Λ.App (Λ.Trg (last (map Λ.un_App1 (u # U))))) [N] ⇧*∼⇧*
                                      map (Λ.App (Λ.Src (hd (map Λ.un_App1 (u # U))))) [N] @
                                        map  (λX. X ❙∘ Λ.Trg (last [N])) (map Λ.un_App1 (u # U))"
                                proof -
                                  have "Arr (map Λ.un_App1 (u # U))"
                                    using Std *** u Arr_map_un_App1
                                    by (metis Std_imp_Arr insert_subset list.discI list.simps(15)
                                        mem_Collect_eq)
                                  moreover have "Arr [N]"
                                    using MN by simp
                                  ultimately show ?thesis
                                    using orthogonal_App_cong by blast
                                qed
                                moreover
                                have "map (Λ.App (Λ.Src (hd (map Λ.un_App1 (u # U))))) [N] =
                                      [Λ.Trg M ❙∘ N]"
                                  by (metis Trg_last_Src_hd_eqI lambda_calculus.Src.simps(4)
                                      Λ.Trg.simps(3) Λ.lambda.collapse(3) Λ.lambda.sel(3)
                                      last_ConsL list.sel(1) list.simps(8) list.simps(9) seq u)
                                moreover have "[Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] =
                                               map (Λ.App (Λ.Trg (last (map Λ.un_App1 (u # U))))) [N]"
                                  by (simp add: last_map)
                                ultimately show ?thesis
                                  using last_map by auto
                              qed
                            qed
                            also have "[M ❙∘ Λ.Src N] @
                                         [Λ.Trg M ❙∘ N] @
                                           map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)) =
                                       ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N]) @
                                          map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))"
                              by simp
                            also have "... ⇧*∼⇧* [M ❙∘ N] @ (u # U)"
                            proof (intro cong_append)
                              show "[M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N] ⇧*∼⇧* [M ❙∘ N]"
                                using MN Λ.resid_Arr_self Λ.Arr_not_Nil Λ.Ide_Trg ide_char
                                by auto
                              show 1: "map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)) ⇧*∼⇧* u # U"
                              proof -
                                have "map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)) = u # U"
                                proof (intro map_App_map_un_App1)
                                  show "Arr (u # U)"
                                    using Std Std_imp_Arr by simp
                                  show "set (u # U) ⊆ Collect Λ.is_App"
                                    using "***" u by auto
                                  show "Λ.Ide (Λ.Trg N)"
                                    using MN Λ.Ide_Trg by simp
                                  show "Λ.un_App2 ` set (u # U) ⊆ {Λ.Trg N}"
                                  proof -
                                    have "Λ.Src (Λ.un_App2 u) = Λ.Trg N"
                                      using u seq seq_char
                                      apply (cases u)
                                          apply simp_all
                                      by (metis Trg_last_Src_hd_eqI Λ.Src.simps(4) Λ.Trg.simps(3)
                                          Λ.lambda.inject(3) last_ConsL list.sel(1) seq)
                                    moreover have "Λ.Ide (Λ.un_App2 u)"
                                      using ** by simp
                                    moreover have "Ide (map Λ.un_App2 (u # U))"
                                      using ** Std Std_imp_Arr Arr_map_un_App2
                                      by (metis Collect_cong Ide_char
                                          ‹Arr (u # U)› ‹set (u # U) ⊆ Collect Λ.is_App›
                                          Λ.ide_char list.set_map)
                                    ultimately show ?thesis
                                      by (metis Λ.Ide_iff_Src_self Λ.Ide_implies_Arr list.sel(1)
                                          list.set_map list.simps(9) set_Ide_subset_single_hd
                                          singleton_insert_inj_eq)
                                  qed
                                qed
                                thus ?thesis
                                  by (simp add: Resid_Arr_self Std ide_char)
                              qed
                              show "seq ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])
                                        (map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)))"
                              proof
                                show "Arr ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])"
                                  using MN by simp
                                show "Arr (map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)))"
                                  using MN Std Std_imp_Arr Arr_map_un_App1 Arr_map_App1
                                  by (metis 1 Con_implies_Arr(1) Ide.simps(1) ide_char)
                                show "Λ.Trg (last ([M ❙∘ Λ.Src N] @ [Λ.Trg M ❙∘ N])) =
                                      Λ.Src (hd (map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))))"
                                  using MN Std Std_imp_Arr Arr_map_un_App1 Arr_map_App1
                                        seq seq_char u Srcs_simp⇩Λ⇩P by auto
                              qed
                            qed
                            also have "[M ❙∘ N] @ (u # U) = (M ❙∘ N) # u # U"
                              by simp
                            finally show ?thesis by blast
                          qed
                        qed
                      qed
                    qed
                    show "⟦¬ Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide;
                           ¬ Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide⟧
                             ⟹ ?thesis"
                    proof -
                      assume *: "¬ Λ.un_App1 ` set (u # U) ⊆ Collect Λ.Ide"
                      assume **: "¬ Λ.un_App2 ` set (u # U) ⊆ Collect Λ.Ide"
                      show ?thesis
                      proof (intro conjI)
                        show "Std (stdz_insert (M ❙∘ N) (u # U))"
                        proof -
                          have "Std (map (λX. X ❙∘ Λ.Src N)
                                         (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) @
                                     map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                         (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))))"
                          proof (intro Std_append)
                            show "Std (map (λX. X ❙∘ Λ.Src N)
                                      (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))))"
                              using * A Λ.Ide_Src MN Std_map_App1 by presburger
                            show "Std (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))))"
                            proof - 
                              have "Λ.Arr (Λ.un_App1 (last (u # U)))"
                                by (metis *** Λ.Arr.simps(4) Std Std_imp_Arr Arr.simps(2)
                                    Arr_append_iff⇩P append_butlast_last_id append_self_conv2
                                    Λ.arr_char Λ.lambda.collapse(3) last.simps last_in_set
                                    list.discI mem_Collect_eq subset_code(1) u)
                              thus ?thesis
                                using ** B Λ.Ide_Trg MN Std_map_App2 by presburger
                            qed
                            show "map (λX. X ❙∘ Λ.Src N)
                                      (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) = [] ∨
                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))) = [] ∨
                                  Λ.sseq (last (map (λX. X ❙∘ Λ.Src N)
                                               (stdz_insert M (filter notIde (map Λ.un_App1 (u # U))))))
                                         (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                  (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))))"
                            proof -
                              have "Λ.sseq (last (map (λX. X ❙∘ Λ.Src N)
                                                 (stdz_insert M (filter notIde (map Λ.un_App1 (u # U))))))
                                           (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                               (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))))"
                              proof -
                                let ?M = "Λ.un_App1 (last (map (λX. X ❙∘ Λ.Src N)
                                                          (stdz_insert M
                                                            (filter notIde
                                                                    (map Λ.un_App1 (u # U))))))"
                                let ?M' = "Λ.Trg (Λ.un_App1 (last (u # U)))"
                                let ?N = "Λ.Src N"
                                let ?N' = "Λ.un_App2
                                             (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                      (stdz_insert N
                                                        (filter notIde
                                                                (map Λ.un_App2 (u # U))))))"
                                have M: "?M = last (stdz_insert M
                                                     (filter notIde (map Λ.un_App1 (u # U))))"
                                  by (metis * A Ide.simps(1) Resid.simps(1) ide_char
                                      Λ.lambda.sel(3) last_map)
                                have N': "?N' = hd (stdz_insert N
                                                     (filter notIde (map Λ.un_App2 (u # U))))"
                                  by (metis ** B Ide.simps(1) Resid.simps(2) ide_char
                                      Λ.lambda.sel(4) hd_map)
                                have AppMN: "last (map (λX. X ❙∘ Λ.Src N)
                                                  (stdz_insert M
                                                    (filter notIde (map Λ.un_App1 (u # U))))) =
                                             ?M ❙∘ ?N"
                                  by (metis * A Ide.simps(1) M Resid.simps(2) ide_char last_map)
                                moreover
                                have 4: "hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                 (stdz_insert N
                                                   (filter notIde (map Λ.un_App2 (u # U))))) =
                                         ?M' ❙∘ ?N'"
                                  by (metis (no_types, lifting) ** B Resid.simps(2) con_char
                                      prfx_implies_con Λ.lambda.collapse(3) Λ.lambda.discI(3)
                                      Λ.lambda.inject(3) list.map_sel(1))
                                moreover have MM: "Λ.elementary_reduction ?M"
                                  by (metis * A Arr.simps(1) Con_implies_Arr(2) Ide.simps(1)
                                      M ide_char in_mono last_in_set mem_Collect_eq)
                                moreover have NN': "Λ.elementary_reduction ?N'"
                                  using ** B N'
                                  by (metis Arr.simps(1) Con_implies_Arr(2) Ide.simps(1)
                                      ide_char in_mono list.set_sel(1) mem_Collect_eq)
                                moreover have "Λ.Trg ?M = ?M'"
                                proof -
                                  have 1: "[Λ.Trg ?M] ⇧*∼⇧* [?M']"
                                  proof -
                                    have "[Λ.Trg ?M] ⇧*∼⇧*
                                          [Λ.Trg (last (M # filter notIde (map Λ.un_App1 (u # U))))]"
                                    proof -
                                      have "targets (stdz_insert M
                                                      (filter notIde (map Λ.un_App1 (u # U)))) =
                                            targets (M # filter notIde (map Λ.un_App1 (u # U)))"
                                        using * A cong_implies_coterminal by blast
                                      moreover
                                      have "[Λ.Trg (last (M # filter notIde (map Λ.un_App1 (u # U))))]
                                              ∈ targets (M # filter notIde (map Λ.un_App1 (u # U)))"
                                        by (metis (no_types, lifting) * A Λ.Arr_Trg Λ.Ide_Trg
                                            Arr.simps(2) Arr_append_iff⇩P Arr_iff_Con_self
                                            Con_implies_Arr(2) Ide.simps(1) Ide.simps(2)
                                            Resid_Arr_Ide_ind ide_char append_butlast_last_id
                                            append_self_conv2 Λ.arr_char in_targets_iff Λ.ide_char
                                            list.discI)
                                      ultimately show ?thesis
                                        using * A M in_targets_iff
                                        by (metis (no_types, lifting) Con_implies_Arr(1)
                                            con_char prfx_implies_con in_targets_iff)
                                    qed
                                    also have 2: "[Λ.Trg (last (M # filter notIde
                                                                      (map Λ.un_App1 (u # U))))] ⇧*∼⇧*
                                                  [Λ.Trg (last (filter notIde
                                                                  (map Λ.un_App1 (u # U))))]"
                                      by (metis (no_types, lifting) * prfx_transitive
                                          calculation empty_filter_conv last_ConsR list.set_map
                                          mem_Collect_eq subsetI)
                                    also have "[Λ.Trg (last (filter notIde
                                                               (map Λ.un_App1 (u # U))))] ⇧*∼⇧*
                                               [Λ.Trg (last (map Λ.un_App1 (u # U)))]"
                                    proof -
                                      have "map Λ.un_App1 (u # U) ⇧*∼⇧*
                                            filter notIde (map Λ.un_App1 (u # U))"
                                        by (metis (mono_tags, lifting) * *** Arr_map_un_App1
                                            Std Std_imp_Arr cong_filter_notIde empty_filter_conv
                                            filter_notIde_Ide insert_subset list.discI list.set_map
                                            list.simps(15) mem_Collect_eq subsetI u)
                                      thus ?thesis
                                        by (metis 2 Trg_last_eqI prfx_transitive)
                                    qed
                                    also have "[Λ.Trg (last (map Λ.un_App1 (u # U)))] = [?M']"
                                      by (simp add: last_map)
                                    finally show ?thesis by blast
                                  qed
                                  have 3: "Λ.Trg ?M = Λ.Trg ?M \\ ?M'"
                                    by (metis (no_types, lifting) 1 * A M Con_implies_Arr(2)
                                        Ide.simps(1) Resid_Arr_Ide_ind Resid_rec(1)
                                        ide_char target_is_ide in_targets_iff list.inject)
                                  also have "... = ?M'"
                                    by (metis (no_types, lifting) 1 4 Arr.simps(2) Con_implies_Arr(2)
                                        Ide.simps(1) Ide.simps(2) MM NN' Resid_Arr_Ide_ind
                                        Resid_rec(1) Src_hd_eqI calculation ide_char
                                        Λ.Ide_iff_Src_self Λ.Src_Trg Λ.arr_char
                                        Λ.elementary_reduction.simps(4)
                                        Λ.elementary_reduction_App_iff Λ.elementary_reduction_is_arr
                                        Λ.elementary_reduction_not_ide Λ.lambda.discI(3)
                                        Λ.lambda.sel(3) list.sel(1))
                                  finally show ?thesis by blast
                                qed
                                moreover have "?N = Λ.Src ?N'"
                                proof -
                                  have 1: "[Λ.Src ?N'] ⇧*∼⇧* [?N]"
                                  proof -
                                    have "sources (stdz_insert N
                                                     (filter notIde (map Λ.un_App2 (u # U)))) =
                                          sources [N]"
                                      using ** B
                                      by (metis Con_implies_Arr(2) Ide.simps(1) coinitialE
                                          cong_implies_coinitial ide_char sources_cons)
                                    thus ?thesis
                                      by (metis (no_types, lifting) AppMN ** B Λ.Ide_Src
                                          MM MN N' NN' Λ.Trg_Src Arr.simps(1) Arr.simps(2)
                                          Con_implies_Arr(1) Ide.simps(2) con_char ideE ide_char
                                          sources_cons Λ.arr_char in_targets_iff
                                          Λ.elementary_reduction.simps(4) Λ.elementary_reduction_App_iff
                                          Λ.elementary_reduction_is_arr Λ.elementary_reduction_not_ide
                                          Λ.lambda.disc(14) Λ.lambda.sel(4) last_ConsL list.exhaust_sel
                                          targets_single_Src)
                                  qed
                                  have "Λ.Src ?N' = Λ.Src ?N' \\ ?N"
                                    by (metis (no_types, lifting) 1 MN Λ.Coinitial_iff_Con
                                        Λ.Ide_Src Arr.simps(2) Ide.simps(1) Ide_implies_Arr
                                        Resid_rec(1) ide_char Λ.not_arr_null Λ.null_char
                                        Λ.resid_Arr_Ide)
                                  also have "... = ?N"
                                    by (metis 1 MN NN' Src_hd_eqI calculation Λ.Src_Src Λ.arr_char
                                        Λ.elementary_reduction_is_arr list.sel(1))
                                  finally show ?thesis by simp
                                qed
                                ultimately show ?thesis
                                  using u Λ.sseq.simps(4)
                                  by (metis (mono_tags, lifting))
                              qed
                              thus ?thesis by blast
                            qed
                          qed
                          thus ?thesis
                            using 4 by presburger
                        qed
                        show "¬ Ide ((M ❙∘ N) # u # U) ⟶
                                  stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                        proof
                          have "stdz_insert (M ❙∘ N) (u # U) =
                                map (λX. X ❙∘ Λ.Src N)
                                    (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) @
                                map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                   (stdz_insert N (filter notIde (map Λ.un_App2 (u # U))))"
                            using 4 by simp
                          also have "... ⇧*∼⇧* map (λX. X ❙∘ Λ.Src N)
                                                 (M # map Λ.un_App1 (u # U)) @
                                                 map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                     (N # map Λ.un_App2 (u # U))"
                          proof (intro cong_append)
                            have X: "stdz_insert M (filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                                     M # map Λ.un_App1 (u # U)"
                            proof -
                              have "stdz_insert M (filter notIde (map Λ.un_App1 (u # U))) ⇧*∼⇧*
                                    [M] @ filter notIde (map Λ.un_App1 (u # U))"
                                using * A by simp
                              also have "[M] @ filter notIde (map Λ.un_App1 (u # U)) ⇧*∼⇧*
                                         [M] @ map Λ.un_App1 (u # U)"
                              proof -
                                have "filter notIde (map Λ.un_App1 (u # U)) ⇧*∼⇧*
                                      map Λ.un_App1 (u # U)"
                                  using * cong_filter_notIde
                                  by (metis (mono_tags, lifting) *** Arr_map_un_App1 Std
                                      Std_imp_Arr empty_filter_conv filter_notIde_Ide insert_subset
                                      list.discI list.set_map list.simps(15) mem_Collect_eq subsetI u)
                                moreover have "seq [M] (filter notIde (map Λ.un_App1 (u # U)))"
                                  by (metis * A Arr.simps(1) Con_implies_Arr(1) append_Cons
                                      append_Nil arr_append_imp_seq arr_char calculation
                                      ide_implies_arr list.discI)
                                ultimately show ?thesis
                                  using cong_append cong_reflexive by blast
                              qed
                              also have "[M] @ map Λ.un_App1 (u # U) =
                                         M # map Λ.un_App1 (u # U)"
                                by simp
                              finally show ?thesis by blast
                            qed
                            have Y: "stdz_insert N (filter notIde (map Λ.un_App2 (u # U))) ⇧*∼⇧*
                                     N # map Λ.un_App2 (u # U)"
                            proof -
                              have 5: "stdz_insert N (filter notIde (map Λ.un_App2 (u # U))) ⇧*∼⇧*
                                       [N] @ filter notIde (map Λ.un_App2 (u # U))"
                                using ** B by simp
                              also have "[N] @ filter notIde (map Λ.un_App2 (u # U)) ⇧*∼⇧*
                                         [N] @ map Λ.un_App2 (u # U)"
                              proof -
                                have "filter notIde (map Λ.un_App2 (u # U)) ⇧*∼⇧*
                                      map Λ.un_App2 (u # U)"
                                  using ** cong_filter_notIde
                                  by (metis (mono_tags, lifting) *** Arr_map_un_App2 Std
                                      Std_imp_Arr empty_filter_conv filter_notIde_Ide insert_subset
                                      list.discI list.set_map list.simps(15) mem_Collect_eq subsetI u)
                                moreover have "seq [N] (filter notIde (map Λ.un_App2 (u # U)))"
                                  by (metis 5 Arr.simps(1) Con_implies_Arr(2) Ide.simps(1)
                                      arr_append_imp_seq arr_char calculation ide_char not_Cons_self2)
                                ultimately show ?thesis
                                  using cong_append cong_reflexive by blast
                              qed
                              also have "[N] @ map Λ.un_App2 (u # U) =
                                         N # map Λ.un_App2 (u # U)"
                                by simp
                              finally show ?thesis by blast
                            qed
                            show "seq (map (λX. X ❙∘ Λ.Src N)
                                           (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))))
                                      (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))))"
                              by (metis 4 * ** A B Ide.simps(1) Nil_is_append_conv Nil_is_map_conv
                                  Resid.simps(1) Std_imp_Arr ‹Std (stdz_insert (M ❙∘ N) (u # U))›
                                  arr_append_imp_seq arr_char ide_char)
                            show "map (λX. X ❙∘ Λ.Src N)
                                      (stdz_insert M (filter notIde (map Λ.un_App1 (u # U)))) ⇧*∼⇧*
                                  map (λX. X ❙∘ Λ.Src N) (M # map Λ.un_App1 (u # U))"
                              using X cong_map_App2 MN lambda_calculus.Ide_Src by presburger
                            show "map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (stdz_insert N (filter notIde (map Λ.un_App2 (u # U)))) ⇧*∼⇧*
                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                      (N # map Λ.un_App2 (u # U))"
                            proof -
                              have "set U ⊆ Collect Λ.Arr ∩ Collect Λ.is_App"
                                using *** Std Std_implies_set_subset_elementary_reduction
                                      Λ.elementary_reduction_is_arr
                                by blast
                              hence "Λ.Ide (Λ.Trg (Λ.un_App1 (last (u # U))))"
                                by (metis inf.boundedE Λ.Arr.simps(4) Λ.Ide_Trg
                                    Λ.lambda.collapse(3) last.simps last_in_set mem_Collect_eq
                                    subset_eq u)
                              thus ?thesis
                                using Y cong_map_App1 by blast
                            qed
                          qed
                          also have "map (λX. X ❙∘ Λ.Src N) (M # map Λ.un_App1 (u # U)) @
                                       map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                           (N # map Λ.un_App2 (u # U)) ⇧*∼⇧* 
                                     [M ❙∘ N] @ [u] @ U"
                          proof -
                            have "(map (λX. X ❙∘ Λ.Src N) (M # map Λ.un_App1 (u # U)) @
                                   map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                       (N # map Λ.un_App2 (u # U))) =
                                  ([M ❙∘ Λ.Src N] @
                                     map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U))) @
                                  ([Λ.Trg (Λ.un_App1 (last (u # U))) ❙∘ N] @
                                     map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                         (map Λ.un_App2 (u # U)))"
                              by simp
                            also have "... = [M ❙∘ Λ.Src N] @
                                                (map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                                 map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]) @
                                                map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                    (map Λ.un_App2 (u # U))"
                              by auto
                            also have "... ⇧*∼⇧* [M ❙∘ Λ.Src N] @
                                                 (map (Λ.App (Λ.Src (Λ.un_App1 u))) [N] @
                                                   map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))) @
                                                   map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                       (map Λ.un_App2 (u # U))"
                            proof -
                              (*
                               * TODO: (intro congI) does not work because it breaks the expression
                               * down too far, resulting in a false subgoal.
                               *)
                              have "(map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                       map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]) @
                                      map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                          (map Λ.un_App2 (u # U)) ⇧*∼⇧*
                                    (map (Λ.App (Λ.Src (Λ.un_App1 u))) [N] @
                                       map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))) @
                                       map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                   (map Λ.un_App2 (u # U))"
                              proof -
                                have 1: "Arr (map Λ.un_App1 (u # U))"
                                  using u ***
                                  by (metis Arr_map_un_App1 Std Std_imp_Arr list.discI
                                     mem_Collect_eq set_ConsD subset_code(1))
                                have "map (λX. Λ.App X (Λ.Src N)) (map Λ.un_App1 (u # U)) @
                                          map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N] ⇧*∼⇧*
                                        map (Λ.App (Λ.Src (Λ.un_App1 u))) [N] @
                                          map (λX. Λ.App X (Λ.Trg N)) (map Λ.un_App1 (u # U))"
                                proof -
                                  have "Arr [N]"
                                      using MN by simp
                                  moreover have "Λ.Trg (last (map Λ.un_App1 (u # U))) =
                                                 Λ.Trg (Λ.un_App1 (last (u # U)))"
                                    by (simp add: last_map)
                                  ultimately show ?thesis
                                      using 1 orthogonal_App_cong [of "map Λ.un_App1 (u # U)" "[N]"]
                                      by simp
                                qed
                                moreover have "seq (map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                                    map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N])
                                                    (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                         (map Λ.un_App2 (u # U)))"
                                proof
                                  show "Arr (map (λX. X ❙∘ Λ.Src N)
                                                 (map Λ.un_App1 (u # U)) @
                                             map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N])"
                                    by (metis Con_implies_Arr(1) Ide.simps(1) calculation ide_char)
                                  show "Arr (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                 (map Λ.un_App2 (u # U)))"
                                    using u ***
                                    by (metis 1 Arr_imp_arr_last Arr_map_App2 Arr_map_un_App2
                                        Std Std_imp_Arr Λ.Ide_Trg Λ.arr_char last_map list.discI
                                        mem_Collect_eq set_ConsD subset_code(1))
                                  show "Λ.Trg (last (map (λX. X ❙∘ Λ.Src N)
                                                         (map Λ.un_App1 (u # U)) @
                                                     map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                         [N])) =
                                        Λ.Src (hd (map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                       (map Λ.un_App2 (u # U))))"
                                  proof -
                                    have 1: "Λ.Arr (Λ.un_App1 u)"
                                      using u Λ.is_App_def by force
                                    have 2: "U ≠ [] ⟹ Λ.Arr (Λ.un_App1 (last U))"
                                      by (metis *** Arr_imp_arr_last Arr_map_un_App1
                                          ‹U ≠ [] ⟹ Arr U› Λ.arr_char last_map)
                                    have 3: "Λ.Trg N = Λ.Src (Λ.un_App2 u)"
                                      by (metis Trg_last_Src_hd_eqI Λ.Src.simps(4) Λ.Trg.simps(3)
                                          Λ.lambda.collapse(3) Λ.lambda.inject(3) last_ConsL
                                          list.sel(1) seq u)
                                    show ?thesis
                                      using u *** seq 1 2 3
                                      by (cases "U = []") auto
                                  qed
                                qed
                                moreover have "map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                   (map Λ.un_App2 (u # U)) ⇧*∼⇧*
                                               map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                   (map Λ.un_App2 (u # U))"
                                  using calculation(2) cong_reflexive by blast
                                ultimately show ?thesis
                                  using cong_append by blast
                              qed
                              moreover have "seq [M ❙∘ Λ.Src N]
                                                 ((map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                                   map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]) @
                                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                      (map Λ.un_App2 (u # U)))"
                              proof
                                show "Arr [M ❙∘ Λ.Src N]"
                                    using MN by simp
                                show "Arr ((map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                              map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]) @
                                              map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                              (map Λ.un_App2 (u # U)))"
                                    using MN u seq
                                    by (metis Con_implies_Arr(1) Ide.simps(1) calculation ide_char)
                                show "Λ.Trg (last [M ❙∘ Λ.Src N]) =
                                      Λ.Src (hd ((map (λX. X ❙∘ Λ.Src N) (map Λ.un_App1 (u # U)) @
                                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U))))) [N]) @
                                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                      (map Λ.un_App2 (u # U))))"
                                  using MN u seq seq_char Srcs_simp⇩Λ⇩P
                                  by (cases u) auto
                              qed
                              ultimately show ?thesis
                                using cong_append
                                by (meson Resid_Arr_self ide_char seq_char)
                            qed
                            also have "[M ❙∘ Λ.Src N] @
                                         (map (Λ.App (Λ.Src (Λ.un_App1 u))) [N] @
                                           map (λX. Λ.App X (Λ.Trg N)) (map Λ.un_App1 (u # U))) @
                                           map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                               (map Λ.un_App2 (u # U)) =
                                       ([M ❙∘ Λ.Src N] @ [Λ.Src (Λ.un_App1 u) ❙∘ N]) @
                                         (map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U))) @
                                            map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                (map Λ.un_App2 (u # U))"
                              by simp
                            also have "... ⇧*∼⇧* ([M ❙∘ N] @ [u] @ U)"
                            proof -
                              have "[M ❙∘ Λ.Src N] @ [Λ.Src (Λ.un_App1 u) ❙∘ N] ⇧*∼⇧* [M ❙∘ N]"
                              proof -
                                have "Λ.Src (Λ.un_App1 u) = Λ.Trg M"
                                  by (metis Trg_last_Src_hd_eqI Λ.Src.simps(4) Λ.Trg.simps(3)
                                      Λ.lambda.collapse(3) Λ.lambda.inject(3) last.simps
                                      list.sel(1) seq u)
                                thus ?thesis
                                  using MN u seq seq_char Λ.Arr_not_Nil Λ.resid_Arr_self ide_char
                                        Λ.Ide_Trg
                                  by simp
                              qed
                              moreover have "map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)) @
                                               map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                   (map Λ.un_App2 (u # U)) ⇧*∼⇧*
                                             [u] @ U"
                              proof -
                                have "Arr ([u] @ U)"
                                  by (simp add: Std)
                                moreover have "set ([u] @ U) ⊆ Collect Λ.is_App"
                                  using *** u by auto
                                moreover have "Λ.Src (Λ.un_App2 (hd ([u] @ U))) = Λ.Trg N"
                                proof -
                                  have "Λ.Ide (Λ.Trg N)"
                                    using MN lambda_calculus.Ide_Trg by presburger
                                  moreover have "Λ.Ide (Λ.Src (Λ.un_App2 (hd ([u] @ U))))"
                                    by (metis Std Std_implies_set_subset_elementary_reduction
                                        Λ.Ide_Src Λ.arr_iff_has_source Λ.ide_implies_arr
                                        ‹set ([u] @ U) ⊆ Collect Λ.is_App› append_Cons
                                        Λ.elementary_reduction_App_iff Λ.elementary_reduction_is_arr
                                        Λ.sources_char⇩Λ list.sel(1) list.set_intros(1)
                                        mem_Collect_eq subset_code(1))
                                  moreover have "Λ.Src (Λ.Trg N) =
                                                 Λ.Src (Λ.Src (Λ.un_App2 (hd ([u] @ U))))"
                                  proof -
                                    have "Λ.Src (Λ.Trg N) = Λ.Trg N"
                                      using MN by simp
                                    also have "... = Λ.Src (Λ.un_App2 u)"
                                      using u seq seq_char Srcs_simp⇩Λ⇩P
                                      by (cases u) auto
                                    also have "... = Λ.Src (Λ.Src (Λ.un_App2 (hd ([u] @ U))))"
                                      by (metis Λ.Ide_iff_Src_self Λ.Ide_implies_Arr
                                          ‹Λ.Ide (Λ.Src (Λ.un_App2 (hd ([u] @ U))))›
                                          append_Cons list.sel(1))
                                    finally show ?thesis by blast
                                  qed
                                  ultimately show ?thesis
                                    by (metis Λ.Ide_iff_Src_self Λ.Ide_implies_Arr)
                                qed           
                                ultimately show ?thesis
                                  using map_App_decomp
                                  by (metis append_Cons append_Nil)
                              qed
                              moreover have "seq ([M ❙∘ Λ.Src N] @ [Λ.Src (Λ.un_App1 u) ❙∘ N])
                                                 (map (λX. X ❙∘ Λ.Trg N) (map Λ.un_App1 (u # U)) @
                                                  map (Λ.App (Λ.Trg (Λ.un_App1 (last (u # U)))))
                                                      (map Λ.un_App2 (u # U)))"
                                using calculation(1-2) cong_respects_seq⇩P seq by auto
                              ultimately show ?thesis
                                using cong_append by presburger
                            qed
                            finally show ?thesis by blast
                          qed
                          also have "[M ❙∘ N] @ [u] @ U = (M ❙∘ N) # u # U"
                            by simp
                          finally show "stdz_insert (M ❙∘ N) (u # U) ⇧*∼⇧* (M ❙∘ N) # u # U"
                            by blast
                        qed
                      qed
                    qed
                  qed
                qed
              qed
            qed
          qed
        qed
      qed
      text ‹
        The eight remaining subgoals are now trivial consequences of fact ‹*›.
        Unfortunately, I haven't found a way to discharge them without having to state each
        one of them explicitly.
      ›
      show "⋀N u U. ⟦Λ.Ide (❙♯ ❙∘ N) ⟹ ?P (hd (u # U)) (tl (u # U));
                      ⟦¬ Λ.Ide (❙♯ ❙∘ N); Λ.seq (❙♯ ❙∘ N) (hd (u # U));
                       Λ.contains_head_reduction (❙♯ ❙∘ N);
                       Λ.Ide ((❙♯ ❙∘ N) \\ Λ.head_redex (❙♯ ❙∘ N))⟧
                         ⟹ ?P (hd (u # U)) (tl (u # U));
                      ⟦¬ Λ.Ide (❙♯ ❙∘ N); Λ.seq (❙♯ ❙∘ N) (hd (u # U));
                       Λ.contains_head_reduction (❙♯ ❙∘ N);
                       ¬ Λ.Ide ((❙♯ ❙∘ N) \\ Λ.head_redex (❙♯ ❙∘ N))⟧
                         ⟹ ?P ((❙♯ ❙∘ N) \\ Λ.head_redex (❙♯ ❙∘ N)) (u # U);
                      ⟦¬ Λ.Ide (❙♯ ❙∘ N); Λ.seq (❙♯ ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (❙♯ ❙∘ N);
                       Λ.contains_head_reduction (hd (u # U));
                       Λ.Ide ((❙♯ ❙∘ N) \\ Λ.head_strategy (❙♯ ❙∘ N))⟧
                         ⟹ ?P (Λ.head_strategy (❙♯ ❙∘ N)) (tl (u # U));
                      ⟦¬ Λ.Ide (❙♯ ❙∘ N); Λ.seq (❙♯ ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (❙♯ ❙∘ N);
                       Λ.contains_head_reduction (hd (u # U));
                       ¬ Λ.Ide ((❙♯ ❙∘ N) \\ Λ.head_strategy (❙♯ ❙∘ N))⟧
                         ⟹ ?P (Λ.resid (❙♯ ❙∘ N) (Λ.head_strategy (❙♯ ❙∘ N))) (tl (u # U));
                      ⟦¬ Λ.Ide (❙♯ ❙∘ N); Λ.seq (❙♯ ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (❙♯ ❙∘ N);
                       ¬ Λ.contains_head_reduction (hd (u # U))⟧
                         ⟹ ?P ❙♯ (filter notIde (map Λ.un_App1 (u # U)));
                      ⟦¬ Λ.Ide (❙♯ ❙∘ N); Λ.seq (❙♯ ❙∘ N) (hd (u # U));
                       ¬ Λ.contains_head_reduction (❙♯ ❙∘ N);
                     ¬ Λ.contains_head_reduction (hd (u # U))⟧
                         ⟹ ?P N (filter notIde (map Λ.un_App2 (u # U)))⟧
                    ⟹ ?P (❙♯ ❙∘ N) (u # U)"
        using * Λ.lambda.disc(6) by presburger
      show "⋀x N u U. ⟦Λ.Ide (❙«x❙» ❙∘ N) ⟹ ?P (hd (u # U)) (tl (u # U));
                        ⟦¬ Λ.Ide (❙«x❙» ❙∘ N); Λ.seq (❙«x❙» ❙∘ N) (hd (u # U));
                         Λ.contains_head_reduction (❙«x❙» ❙∘ N);
                         Λ.Ide ((❙«x❙» ❙∘ N) \\ Λ.head_redex (❙«x❙» ❙∘ N))⟧
                           ⟹ ?P (hd (u # U)) (tl (u # U));
                        ⟦¬ Λ.Ide (❙«x❙» ❙∘ N); Λ.seq (❙«x❙» ❙∘ N) (hd (u # U));
                         Λ.contains_head_reduction (❙«x❙» ❙∘ N);
                         ¬ Λ.Ide ((❙«x❙» ❙∘ N) \\ Λ.head_redex (❙«x❙» ❙∘ N))⟧
                           ⟹ ?P ((❙«x❙» ❙∘ N) \\ Λ.head_redex (❙«x❙» ❙∘ N)) (u # U);
                        ⟦¬ Λ.Ide (❙«x❙» ❙∘ N); Λ.seq (❙«x❙» ❙∘ N) (hd (u # U));
                         ¬ Λ.contains_head_reduction (❙«x❙» ❙∘ N);
                         Λ.contains_head_reduction (hd (u # U));
                         Λ.Ide ((❙«x❙» ❙∘ N) \\ Λ.head_strategy (❙«x❙» ❙∘ N))⟧
                           ⟹ ?P (Λ.head_strategy (❙«x❙» ❙∘ N)) (tl (u # U));
                        ⟦¬ Λ.Ide (❙«x❙» ❙∘ N); Λ.seq (❙«x❙» ❙∘ N) (hd (u # U));
                         ¬ Λ.contains_head_reduction (❙«x❙» ❙∘ N);
                         Λ.contains_head_reduction (hd (u # U));
                         ¬ Λ.Ide ((❙«x❙» ❙∘ N) \\ Λ.head_strategy (❙«x❙» ❙∘ N))⟧
                           ⟹ ?P ((❙«x❙» ❙∘ N) \\ Λ.head_strategy (❙«x❙» ❙∘ N)) (tl (u # U));
                        ⟦¬ Λ.Ide (❙«x❙» ❙∘ N); Λ.seq (❙«x❙» ❙∘ N) (hd (u # U));
                         ¬ Λ.contains_head_reduction (❙«x❙» ❙∘ N);
                         ¬ Λ.contains_head_reduction (hd (u # U))⟧
                           ⟹ ?P ❙«x❙» (filter notIde (map Λ.un_App1 (u # U)));
                        ⟦¬ Λ.Ide (❙«x❙» ❙∘ N); Λ.seq (❙«x❙» ❙∘ N) (hd (u # U));
                         ¬ Λ.contains_head_reduction (❙«x❙» ❙∘ N);
                         ¬ Λ.contains_head_reduction (hd (u # U))⟧
                           ⟹ ?P N (filter notIde (map Λ.un_App2 (u # U)))⟧
                    ⟹ ?P (❙«x❙» ❙∘ N) (u # U)"
        using * Λ.lambda.disc(7) by presburger
      show "⋀M1 M2 N u U. ⟦Λ.Ide (M1 ❙∘ M2 ❙∘ N) ⟹ ?P (hd (u # U)) (tl (u # U));
                           ⟦¬ Λ.Ide (M1 ❙∘ M2 ❙∘ N); Λ.seq (M1 ❙∘ M2 ❙∘ N) (hd (u # U));
                            Λ.contains_head_reduction (M1 ❙∘ M2 ❙∘ N);
                            Λ.Ide ((M1 ❙∘ M2 ❙∘ N) \\ Λ.head_redex (M1 ❙∘ M2 ❙∘ N))⟧
                              ⟹ ?P (hd (u # U)) (tl (u # U));
                           ⟦¬ Λ.Ide (M1 ❙∘ M2 ❙∘ N); Λ.seq (M1 ❙∘ M2 ❙∘ N) (hd (u # U));
                            Λ.contains_head_reduction (M1 ❙∘ M2 ❙∘ N);
                            ¬ Λ.Ide ((M1 ❙∘ M2 ❙∘ N) \\ Λ.head_redex (M1 ❙∘ M2 ❙∘ N))⟧
                              ⟹ ?P ((M1 ❙∘ M2 ❙∘ N) \\ Λ.head_redex (M1 ❙∘ M2 ❙∘ N)) (u # U);
                           ⟦¬ Λ.Ide (M1 ❙∘ M2 ❙∘ N); Λ.seq (M1 ❙∘ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (M1 ❙∘ M2 ❙∘ N);
                            Λ.contains_head_reduction (hd (u # U));
                            Λ.Ide ((M1 ❙∘ M2 ❙∘ N) \\ Λ.head_strategy (M1 ❙∘ M2 ❙∘ N))⟧
                              ⟹ ?P (Λ.head_strategy (M1 ❙∘ M2 ❙∘ N)) (tl (u # U));
                           ⟦¬ Λ.Ide (M1 ❙∘ M2 ❙∘ N); Λ.seq (M1 ❙∘ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (M1 ❙∘ M2 ❙∘ N);
                            Λ.contains_head_reduction (hd (u # U));
                            ¬ Λ.Ide ((M1 ❙∘ M2 ❙∘ N) \\ Λ.head_strategy (M1 ❙∘ M2 ❙∘ N))⟧
                              ⟹ ?P ((M1 ❙∘ M2 ❙∘ N) \\ Λ.head_strategy (M1 ❙∘ M2 ❙∘ N)) (tl (u # U));
                           ⟦¬ Λ.Ide (M1 ❙∘ M2 ❙∘ N); Λ.seq (M1 ❙∘ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (M1 ❙∘ M2 ❙∘ N);
                            ¬ Λ.contains_head_reduction (hd (u # U))⟧
                              ⟹ ?P (M1 ❙∘ M2) (filter notIde (map Λ.un_App1 (u # U)));
                           ⟦¬ Λ.Ide (M1 ❙∘ M2 ❙∘ N); Λ.seq (M1 ❙∘ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (M1 ❙∘ M2 ❙∘ N);
                            ¬ Λ.contains_head_reduction (hd (u # U))⟧
                              ⟹ ?P N (filter notIde (map Λ.un_App2 (u # U)))⟧
                    ⟹ ?P (M1 ❙∘ M2 ❙∘ N) (u # U)"
         using * Λ.lambda.disc(9) by presburger
      show "⋀M1 M2 N u U. ⟦Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) ⟹ ?P (hd (u # U)) (tl (u # U));
                           ⟦¬ Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N); Λ.seq (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (hd (u # U));
                            Λ.contains_head_reduction (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N);
                            Λ.Ide ((❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) \\ (Λ.head_redex (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N)))⟧
                              ⟹ ?P (hd (u # U)) (tl (u # U));
                           ⟦¬ Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N); Λ.seq (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (hd (u # U));
                            Λ.contains_head_reduction (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N);
                            ¬ Λ.Ide ((❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) \\ (Λ.head_redex (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N)))⟧
                              ⟹ ?P (Λ.resid (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (Λ.head_redex (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N)))
                                     (u # U);
                           ⟦¬ Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N); Λ.seq (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N);
                            Λ.contains_head_reduction (hd (u # U));
                            Λ.Ide ((❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) \\ Λ.head_strategy (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N))⟧
                              ⟹ ?P (Λ.head_strategy (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N)) (tl (u # U));
                           ⟦¬ Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N); Λ.seq (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N);
                            Λ.contains_head_reduction (hd (u # U));
                            ¬ Λ.Ide ((❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) \\ Λ.head_strategy (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N))⟧
                              ⟹ ?P ((❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) \\ Λ.head_strategy (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N))
                                     (tl (u # U));
                           ⟦¬ Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N); Λ.seq (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N);
                            ¬ Λ.contains_head_reduction (hd (u # U))⟧
                              ⟹ ?P (❙λ❙[M1❙] ❙⦁ M2) (filter notIde (map Λ.un_App1 (u # U)));
                           ⟦¬ Λ.Ide (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N); Λ.seq (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (hd (u # U));
                            ¬ Λ.contains_head_reduction (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N);
                            ¬ Λ.contains_head_reduction (hd (u # U))⟧
                              ⟹ ?P N (filter notIde (map Λ.un_App2 (u # U)))⟧
                    ⟹ ?P (❙λ❙[M1❙] ❙⦁ M2 ❙∘ N) (u # U)"
         using * Λ.lambda.disc(10) by presburger
      show "⋀M N U. ⟦Λ.Ide (M ❙∘ N) ⟹ ?P (hd (❙♯ # U)) (tl (❙♯ # U));
                     ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙♯ # U));
                      Λ.contains_head_reduction (M ❙∘ N);
                      Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                        ⟹ ?P (hd (❙♯ # U)) (tl (❙♯ # U));
                     ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙♯ # U));
                      Λ.contains_head_reduction (M ❙∘ N);
                      ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                        ⟹ ?P ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (❙♯ # U);
                     ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙♯ # U));
                      ¬ Λ.contains_head_reduction (M ❙∘ N);
                      Λ.contains_head_reduction (hd (❙♯ # U));
                      Λ.Ide (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N)))⟧
                        ⟹ ?P (Λ.head_strategy (M ❙∘ N)) (tl (❙♯ # U));
                     ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙♯ # U));
                      ¬ Λ.contains_head_reduction (M ❙∘ N);
                      Λ.contains_head_reduction (hd (❙♯ # U));
                      ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                        ⟹ ?P ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) (tl (❙♯ # U));
                     ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙♯ # U));
                      ¬ Λ.contains_head_reduction (M ❙∘ N);
                      ¬ Λ.contains_head_reduction (hd (❙♯ # U))⟧
                        ⟹ ?P M (filter notIde (map Λ.un_App1 (❙♯ # U)));
                     ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙♯ # U));
                      ¬ Λ.contains_head_reduction (M ❙∘ N);
                      ¬ Λ.contains_head_reduction (hd (❙♯ # U))⟧
                        ⟹ ?P N (filter notIde (map Λ.un_App2 (❙♯ # U)))⟧
                   ⟹ ?P (M ❙∘ N) (❙♯ # U)"
        using * Λ.lambda.disc(16) by presburger
      show "⋀M N x U. ⟦Λ.Ide (M ❙∘ N) ⟹ ?P (hd (❙«x❙» # U)) (tl (❙«x❙» # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙«x❙» # U));
                         Λ.contains_head_reduction (M ❙∘ N);
                         Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                           ⟹ ?P (hd (❙«x❙» # U)) (tl (❙«x❙» # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙«x❙» # U));
                         Λ.contains_head_reduction (M ❙∘ N);
                         ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                           ⟹ ?P ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (❙«x❙» # U);
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙«x❙» # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         Λ.contains_head_reduction (hd (❙«x❙» # U));
                         Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                           ⟹ ?P (Λ.head_strategy (M ❙∘ N)) (tl (❙«x❙» # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙«x❙» # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         Λ.contains_head_reduction (hd (❙«x❙» # U));
                         ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                           ⟹ ?P ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) (tl (❙«x❙» # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙«x❙» # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         ¬ Λ.contains_head_reduction (hd (❙«x❙» # U))⟧
                           ⟹ ?P M (filter notIde (map Λ.un_App1 (❙«x❙» # U)));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙«x❙» # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         ¬ Λ.contains_head_reduction (hd (❙«x❙» # U))⟧
                           ⟹ ?P N (filter notIde (map Λ.un_App2 (❙«x❙» # U)))⟧
                   ⟹ ?P (M ❙∘ N) (❙«x❙» # U)"
        using * Λ.lambda.disc(17) by presburger
      show "⋀M N P U. ⟦Λ.Ide (M ❙∘ N) ⟹ ?P (hd (❙λ❙[P❙] # U)) (tl (❙λ❙[P❙] # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙λ❙[P❙] # U));
                         Λ.contains_head_reduction (M ❙∘ N);
                         Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                           ⟹ ?P (hd (❙λ❙[P❙] # U)) (tl (❙λ❙[P❙] # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙λ❙[P❙] # U));
                         Λ.contains_head_reduction (M ❙∘ N);
                         ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                           ⟹ ?P ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) (❙λ❙[P❙] # U);
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙λ❙[P❙] # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         Λ.contains_head_reduction (hd (❙λ❙[P❙] # U));
                         Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                            ⟹ ?P (Λ.head_strategy (M ❙∘ N)) (tl (❙λ❙[P❙] # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙λ❙[P❙] # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         Λ.contains_head_reduction (hd (❙λ❙[P❙] # U));
                         ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                            ⟹ ?P (Λ.resid (M ❙∘ N) (Λ.head_strategy (M ❙∘ N))) (tl (❙λ❙[P❙] # U));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙λ❙[P❙] # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         ¬ Λ.contains_head_reduction (hd (❙λ❙[P❙] # U))⟧
                            ⟹ ?P M (filter notIde (map Λ.un_App1 (❙λ❙[P❙] # U)));
                        ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd (❙λ❙[P❙] # U));
                         ¬ Λ.contains_head_reduction (M ❙∘ N);
                         ¬ Λ.contains_head_reduction (hd (❙λ❙[P❙] # U))⟧
                            ⟹ ?P N (filter notIde (map Λ.un_App2 (❙λ❙[P❙] # U)))⟧
                  ⟹ ?P (M ❙∘ N) (❙λ❙[P❙] # U)"
        using * Λ.lambda.disc(18) by presburger
      show "⋀M N P1 P2 U. ⟦Λ.Ide (M ❙∘ N)
                             ⟹ ?P (hd ((P1 ❙∘ P2) # U)) (tl ((P1 ❙∘ P2) # U));
                           ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd ((P1 ❙∘ P2) # U));
                            Λ.contains_head_reduction (M ❙∘ N);
                            Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                              ⟹ ?P (hd ((P1 ❙∘ P2) # U)) (tl((P1 ❙∘ P2) # U));
                           ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd ((P1 ❙∘ P2) # U));
                            Λ.contains_head_reduction (M ❙∘ N);
                            ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N))⟧
                              ⟹ ?P ((M ❙∘ N) \\ Λ.head_redex (M ❙∘ N)) ((P1 ❙∘ P2) # U);
                           ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd ((P1 ❙∘ P2) # U));
                            ¬ Λ.contains_head_reduction (M ❙∘ N);
                            Λ.contains_head_reduction (hd ((P1 ❙∘ P2) # U));
                            Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                              ⟹ ?P (Λ.head_strategy (M ❙∘ N)) (tl ((P1 ❙∘ P2) # U));
                           ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd ((P1 ❙∘ P2) # U));
                            ¬ Λ.contains_head_reduction (M ❙∘ N);
                            Λ.contains_head_reduction (hd ((P1 ❙∘ P2) # U));
                            ¬ Λ.Ide ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N))⟧
                              ⟹ ?P ((M ❙∘ N) \\ Λ.head_strategy (M ❙∘ N)) (tl ((P1 ❙∘ P2) # U));
                           ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd ((P1 ❙∘ P2) # U));
                            ¬ Λ.contains_head_reduction (M ❙∘ N);
                            ¬ Λ.contains_head_reduction (hd ((P1 ❙∘ P2) # U))⟧
                              ⟹ ?P M (filter notIde (map Λ.un_App1 ((P1 ❙∘ P2) # U)));
                           ⟦¬ Λ.Ide (M ❙∘ N); Λ.seq (M ❙∘ N) (hd ((P1 ❙∘ P2) # U));
                            ¬ Λ.contains_head_reduction (M ❙∘ N);
                            ¬ Λ.contains_head_reduction (hd ((P1 ❙∘ P2) # U))⟧
                              ⟹ ?P N (filter notIde (map Λ.un_App2 ((P1 ❙∘ P2) # U)))⟧
                  ⟹ ?P (M ❙∘ N) ((P1 ❙∘ P2) # U)"
        using * Λ.lambda.disc(19) by presburger
    qed

    subsubsection "The Standardization Theorem"

    text ‹
      Using the function ‹standardize›, we can now prove the Standardization Theorem.
      There is still a little bit more work to do, because we have to deal with various
      cases in which the reduction path to be standardized is empty or consists
      entirely of identities.
    ›

    theorem standardization_theorem:
    shows "Arr T ⟹ Std (standardize T) ∧ (Ide T ⟶ standardize T = []) ∧
                     (¬ Ide T ⟶ cong (standardize T) T)"
    proof (induct T)
      show "Arr [] ⟹ Std (standardize []) ∧ (Ide [] ⟶ standardize [] = []) ∧
                       (¬ Ide [] ⟶ cong (standardize []) [])"
        by simp
      fix t T
      assume ind: "Arr T ⟹ Std (standardize T) ∧ (Ide T ⟶ standardize T = []) ∧
                             (¬ Ide T ⟶ cong (standardize T) T)"
      assume tT: "Arr (t # T)"
      have t: "Λ.Arr t"
        using tT Arr_imp_arr_hd by force
      show "Std (standardize (t # T)) ∧ (Ide (t # T) ⟶ standardize (t # T) = []) ∧
            (¬ Ide (t # T) ⟶ cong (standardize (t # T)) (t # T))"
      proof (cases "T = []")
        show "T = [] ⟹ ?thesis"
          using t tT Ide_iff_standard_development_empty Std_standard_development
                cong_standard_development
          by simp
        assume 0: "T ≠ []"
        hence T: "Arr T"
          using tT
          by (metis Arr_imp_Arr_tl list.sel(3))
        show ?thesis
        proof (intro conjI)
          show "Std (standardize (t # T))"
          proof -
            have 1: "¬ Ide T ⟹ seq [t] (standardize T)"
              using t T ind 0 ide_char Con_implies_Arr(1)
              apply (intro seqI⇩Λ⇩P)
                apply simp
               apply (metis Con_implies_Arr(1) Ide.simps(1) ide_char)
              by (metis Src_hd_eqI Trg_last_Src_hd_eqI ‹T ≠ []› append_Cons arrI⇩P
                        arr_append_imp_seq list.distinct(1) self_append_conv2 tT)
            show ?thesis
              using T 1 ind Std_standard_development stdz_insert_correctness by auto
          qed
          show "Ide (t # T) ⟶ standardize (t # T) = []"
            using Ide_consE Ide_iff_standard_development_empty Ide_implies_Arr ind
                  Λ.Ide_implies_Arr Λ.ide_char
            by (metis list.sel(1,3) standardize.simps(1-2) stdz_insert.simps(1))
          show "¬ Ide (t # T) ⟶ standardize (t # T) ⇧*∼⇧* t # T"
          proof
            assume 1: "¬ Ide (t # T)"
            show "standardize (t # T) ⇧*∼⇧* t # T"
            proof (cases "Λ.Ide t")
              assume t: "Λ.Ide t"
              have 2: "¬ Ide T"
                using 1 t tT by fastforce
              have "standardize (t # T) = stdz_insert t (standardize T)"
                by simp
              also have "... ⇧*∼⇧* t # T"
              proof -
                have 3: "Std (standardize T) ∧ standardize T ⇧*∼⇧* T"
                  using T 2 ind by blast
                have "stdz_insert t (standardize T) =
                       stdz_insert (hd (standardize T)) (tl (standardize T))"
                proof -
                  have "seq [t] (standardize T)"
                    using 0 2 tT ind
                    by (metis Arr.elims(2) Con_imp_eq_Srcs Con_implies_Arr(1) Ide.simps(1-2)
                        Ide_implies_Arr Trgs.simps(2) ide_char Λ.ide_char list.inject
                        seq_char seq_implies_Trgs_eq_Srcs t)
                  thus ?thesis
                    using t 3 stdz_insert_Ide_Std by blast
                qed
                also have "...  ⇧*∼⇧* hd (standardize T) # tl (standardize T)"
                proof -
                  have "¬ Ide (standardize T)"
                    using 2 3 ide_backward_stable ide_char by blast
                  moreover have "tl (standardize T) ≠ [] ⟹
                                   seq [hd (standardize T)] (tl (standardize T)) ∧
                                   Std (tl (standardize T))"
                    by (metis 3 Std_consE Std_imp_Arr append.left_neutral append_Cons
                        arr_append_imp_seq arr_char hd_Cons_tl list.discI tl_Nil)
                  ultimately show ?thesis
                    by (metis "2" Ide.simps(2) Resid.simps(1) Std_consE T cong_standard_development
                        ide_char ind Λ.ide_char list.exhaust_sel stdz_insert.simps(1)
                        stdz_insert_correctness)
                qed
                also have "hd (standardize T) # tl (standardize T) = standardize T"
                  by (metis 3 Arr.simps(1) Con_implies_Arr(2) Ide.simps(1) ide_char
                      list.exhaust_sel)
                also have "standardize T ⇧*∼⇧* T"
                  using 3 by simp
                also have "T ⇧*∼⇧* t # T"
                  using 0 t tT arr_append_imp_seq arr_char cong_cons_ideI(2) by simp
                finally show ?thesis by blast
              qed
              thus ?thesis by auto
              next
              assume t: "¬ Λ.Ide t"
              show ?thesis
              proof (cases "Ide T")
                assume T: "Ide T"
                have "standardize (t # T) = standard_development t"
                  using t T Ide_implies_Arr ind by simp
                also have "... ⇧*∼⇧* [t]"
                  using t T tT cong_standard_development [of t] by blast
                also have "[t] ⇧*∼⇧* [t] @ T"
                  using t T tT cong_append_ideI(4) [of "[t]" T]
                  by (simp add: 0 arrI⇩P arr_append_imp_seq ide_char)
                finally show ?thesis by auto
                next
                assume T: "¬ Ide T"
                have 1: "Std (standardize T) ∧ standardize T ⇧*∼⇧* T"
                  using T ‹Arr T› ind by blast
                have 2: "seq [t] (standardize T)"
                  by (metis 0 Arr.simps(2) Arr.simps(3) Con_imp_eq_Srcs Con_implies_Arr(2)
                      Ide.elims(3) Ide.simps(1) T Trgs.simps(2) ide_char ind
                      seq_char seq_implies_Trgs_eq_Srcs tT)
                have "stdz_insert t (standardize T) ⇧*∼⇧* t # standardize T"
                  using t 1 2 stdz_insert_correctness [of t "standardize T"] by blast
                also have "t # standardize T ⇧*∼⇧* t # T"
                  using 1 2
                  by (meson Arr.simps(2) Λ.prfx_reflexive cong_cons seq_char)
                finally show ?thesis by auto
              qed
            qed
          qed
        qed
      qed
    qed

    subsubsection "The Leftmost Reduction Theorem"

    text ‹
      In this section we prove the Leftmost Reduction Theorem, which states that
      leftmost reduction is a normalizing strategy.

      We first show that if a standard reduction path reaches a normal form,
      then the path must be the one produced by following the leftmost reduction strategy.
      This is because, in a standard reduction path, once a leftmost redex is skipped,
      all subsequent reductions occur ``to the right of it'', hence they are all non-leftmost
      reductions that do not contract the skipped redex, which remains in the leftmost position.

      The Leftmost Reduction Theorem then follows from the Standardization Theorem.
      If a term is normalizable, there is a reduction path from that term to a normal form.
      By the Standardization Theorem we may as well assume that path is standard.
      But a standard reduction path to a normal form is the path generated by following
      the leftmost reduction strategy, hence leftmost reduction reaches a normal form after
      a finite number of steps.
    ›

    lemma sseq_reflects_leftmost_reduction:
    assumes "Λ.sseq t u" and "Λ.is_leftmost_reduction u"
    shows "Λ.is_leftmost_reduction t"
    proof -
      have *: "⋀u. u = Λ.leftmost_strategy (Λ.Src t) \\ t ⟹ ¬ Λ.sseq t u" for t
      proof (induct t)
        show "⋀u. ¬ Λ.sseq ❙♯ u"
          using Λ.sseq_imp_seq by blast
        show "⋀x u. ¬ Λ.sseq ❙«x❙» u"
          using Λ.elementary_reduction.simps(2) Λ.sseq_imp_elementary_reduction1 by blast
        show "⋀t u. ⟦⋀u. u = Λ.leftmost_strategy (Λ.Src t) \\ t ⟹ ¬ Λ.sseq t u;
                      u = Λ.leftmost_strategy (Λ.Src ❙λ❙[t❙]) \\ ❙λ❙[t❙]⟧
                        ⟹ ¬ Λ.sseq ❙λ❙[t❙] u"
          by auto
        show "⋀t1 t2 u. ⟦⋀u. u = Λ.leftmost_strategy (Λ.Src t1) \\ t1 ⟹ ¬ Λ.sseq t1 u;
                         ⋀u. u = Λ.leftmost_strategy (Λ.Src t2) \\ t2 ⟹ ¬ Λ.sseq t2 u;
                         u = Λ.leftmost_strategy (Λ.Src (❙λ❙[t1❙] ❙⦁ t2)) \\ (❙λ❙[t1❙] ❙⦁ t2)⟧
                           ⟹ ¬ Λ.sseq (❙λ❙[t1❙] ❙⦁ t2) u"
          apply simp
          by (metis Λ.sseq_imp_elementary_reduction2 Λ.Coinitial_iff_Con Λ.Ide_Src
              Λ.Ide_Subst Λ.elementary_reduction_not_ide Λ.ide_char Λ.resid_Ide_Arr)
        show "⋀t1 t2. ⟦⋀u. u = Λ.leftmost_strategy (Λ.Src t1) \\ t1 ⟹ ¬ Λ.sseq t1 u;
                       ⋀u. u = Λ.leftmost_strategy (Λ.Src t2) \\ t2 ⟹ ¬ Λ.sseq t2 u;
                       u = Λ.leftmost_strategy (Λ.Src (Λ.App t1 t2)) \\ Λ.App t1 t2⟧
                         ⟹ ¬ Λ.sseq (Λ.App t1 t2) u" for u
          apply (cases u)
              apply simp_all
             apply (metis Λ.elementary_reduction.simps(2) Λ.sseq_imp_elementary_reduction2)
            apply (metis Λ.Src.simps(3) Λ.Src_resid Λ.Trg.simps(3) Λ.lambda.distinct(15)
                         Λ.lambda.distinct(3))
        proof -
          show "⋀t1 t2 u1 u2.
                  ⟦¬ Λ.sseq t1 (Λ.leftmost_strategy (Λ.Src t1) \\ t1);
                   ¬ Λ.sseq t2 (Λ.leftmost_strategy (Λ.Src t2) \\ t2);
                   ❙λ❙[u1❙] ❙⦁ u2 = Λ.leftmost_strategy (Λ.App (Λ.Src t1) (Λ.Src t2)) \\ Λ.App t1 t2;
                   u = Λ.leftmost_strategy (Λ.App (Λ.Src t1) (Λ.Src t2)) \\ Λ.App t1 t2⟧
                     ⟹ ¬ Λ.sseq (Λ.App t1 t2)
                                  (Λ.leftmost_strategy (Λ.App (Λ.Src t1) (Λ.Src t2)) \\ Λ.App t1 t2)"
            by (metis Λ.sseq_imp_elementary_reduction1 Λ.Arr.simps(5) Λ.Arr_resid
                      Λ.Coinitial_iff_Con Λ.Ide.simps(5) Λ.Ide_iff_Src_self Λ.Src.simps(4)
                      Λ.Src_resid Λ.contains_head_reduction.simps(8) Λ.is_head_reduction_if
                      Λ.lambda.discI(3) Λ.lambda.distinct(7)
                      Λ.leftmost_strategy_selects_head_reduction Λ.resid_Arr_self
                      Λ.sseq_preserves_App_and_no_head_reduction)
          show "⋀u1 u2.
                  ⟦¬ Λ.sseq t1 (Λ.leftmost_strategy (Λ.Src t1) \\ t1);
                   ¬ Λ.sseq t2 (Λ.leftmost_strategy (Λ.Src t2) \\ t2);
                   Λ.App u1 u2 = Λ.leftmost_strategy (Λ.App (Λ.Src t1) (Λ.Src t2)) \\ Λ.App t1 t2;
                   u = Λ.leftmost_strategy (Λ.App (Λ.Src t1) (Λ.Src t2)) \\ Λ.App t1 t2⟧
                     ⟹ ¬ Λ.sseq (Λ.App t1 t2)
                                  (Λ.leftmost_strategy (Λ.App (Λ.Src t1) (Λ.Src t2)) \\ Λ.App t1 t2)"
           for t1 t2
            apply (cases "¬ Λ.Arr t1")
             apply simp_all
             apply (meson Λ.Arr.simps(4) Λ.seq_char Λ.sseq_imp_seq)
            apply (cases "¬ Λ.Arr t2")
             apply simp_all
             apply (meson Λ.Arr.simps(4) Λ.seq_char Λ.sseq_imp_seq)
            using Λ.Arr_not_Nil
            apply (cases t1)
                apply simp_all
            using Λ.NF_iff_has_no_redex Λ.has_redex_iff_not_Ide_leftmost_strategy
                  Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self
                  Λ.NF_def Λ.elementary_reduction_not_ide Λ.eq_Ide_are_cong
                  Λ.leftmost_strategy_is_reduction_strategy Λ.reduction_strategy_def
                  Λ.resid_Arr_Src
             apply simp
             apply (metis Λ.Arr.simps(4) Λ.Ide.simps(4) Λ.Ide_Trg Λ.Src.simps(4)
                          Λ.sseq_imp_elementary_reduction2)
            by (metis Λ.Ide_Trg Λ.elementary_reduction_not_ide Λ.ide_char)
        qed
      qed
      have "t ≠ Λ.leftmost_strategy (Λ.Src t) ⟹ False"
      proof -
        assume 1: "t ≠ Λ.leftmost_strategy (Λ.Src t)"
        have 2: "¬ Λ.Ide (Λ.leftmost_strategy (Λ.Src t))"
          by (meson assms(1) Λ.NF_def Λ.NF_iff_has_no_redex Λ.arr_char
              Λ.elementary_reduction_is_arr Λ.elementary_reduction_not_ide
              Λ.has_redex_iff_not_Ide_leftmost_strategy Λ.ide_char
              Λ.sseq_imp_elementary_reduction1)
        have "Λ.is_leftmost_reduction (Λ.leftmost_strategy (Λ.Src t) \\ t)"
        proof -
          have "Λ.is_leftmost_reduction (Λ.leftmost_strategy (Λ.Src t))"
            by (metis assms(1) 2 Λ.Ide_Src Λ.Ide_iff_Src_self Λ.arr_char
                Λ.elementary_reduction_is_arr Λ.elementary_reduction_leftmost_strategy
                Λ.is_leftmost_reduction_def Λ.leftmost_strategy_is_reduction_strategy
                Λ.reduction_strategy_def Λ.sseq_imp_elementary_reduction1)
          moreover have 3: "Λ.elementary_reduction t"
            using assms Λ.sseq_imp_elementary_reduction1 by simp
          moreover have "¬ Λ.is_leftmost_reduction t"
            using 1 Λ.is_leftmost_reduction_def by auto
          moreover have "Λ.coinitial (Λ.leftmost_strategy (Λ.Src t)) t"
            using 3 Λ.leftmost_strategy_is_reduction_strategy Λ.reduction_strategy_def
                  Λ.Ide_Src Λ.elementary_reduction_is_arr
            by force
          ultimately show ?thesis
            using 1 Λ.leftmost_reduction_preservation by blast
        qed
        moreover have "Λ.coinitial (Λ.leftmost_strategy (Λ.Src t) \\ t) u"
          using assms(1) calculation Λ.Arr_not_Nil Λ.Src_resid Λ.elementary_reduction_is_arr
                Λ.is_leftmost_reduction_def Λ.seq_char Λ.sseq_imp_seq
          by force
        moreover have "⋀v. ⟦Λ.is_leftmost_reduction v; Λ.coinitial v u⟧ ⟹ v = u"
          by (metis Λ.arr_iff_has_source Λ.arr_resid_iff_con Λ.confluence assms(2)
              Λ.Arr_not_Nil Λ.Coinitial_iff_Con Λ.is_leftmost_reduction_def Λ.sources_char⇩Λ)
        ultimately have "Λ.leftmost_strategy (Λ.Src t) \\ t = u"
          by blast
        thus ?thesis
          using assms(1) * by blast
      qed
      thus ?thesis
        using assms(1) Λ.is_leftmost_reduction_def Λ.sseq_imp_elementary_reduction1 by force
    qed

    lemma elementary_reduction_to_NF_is_leftmost:
    shows "⟦Λ.elementary_reduction t; Λ.NF (Trg [t])⟧ ⟹ Λ.leftmost_strategy (Λ.Src t) = t"
    proof (induct t)
      show "Λ.leftmost_strategy (Λ.Src ❙♯) = ❙♯"
        by simp
      show "⋀x. ⟦Λ.elementary_reduction ❙«x❙»; Λ.NF (Trg [❙«x❙»])⟧
                   ⟹ Λ.leftmost_strategy (Λ.Src ❙«x❙») = ❙«x❙»"
        by auto
      show "⋀t. ⟦⟦Λ.elementary_reduction t; Λ.NF (Trg [t])⟧
                    ⟹ Λ.leftmost_strategy (Λ.Src t) = t;
                  Λ.elementary_reduction ❙λ❙[t❙]; Λ.NF (Trg [❙λ❙[t❙]])⟧
                   ⟹ Λ.leftmost_strategy (Λ.Src ❙λ❙[t❙]) = ❙λ❙[t❙]"
        using lambda_calculus.NF_Lam_iff lambda_calculus.elementary_reduction_is_arr by force
      show "⋀t1 t2. ⟦⟦Λ.elementary_reduction t1; Λ.NF (Trg [t1])⟧
                        ⟹ Λ.leftmost_strategy (Λ.Src t1) = t1;
                     ⟦Λ.elementary_reduction t2; Λ.NF (Trg [t2])⟧
                        ⟹ Λ.leftmost_strategy (Λ.Src t2) = t2;
                      Λ.elementary_reduction (❙λ❙[t1❙] ❙⦁ t2); Λ.NF (Trg [❙λ❙[t1❙] ❙⦁ t2])⟧
                        ⟹ Λ.leftmost_strategy (Λ.Src (❙λ❙[t1❙] ❙⦁ t2)) = ❙λ❙[t1❙] ❙⦁ t2"
        apply simp
        by (metis Λ.Ide_iff_Src_self Λ.Ide_implies_Arr)
      fix t1 t2
      assume ind1: "⟦Λ.elementary_reduction t1; Λ.NF (Trg [t1])⟧
                        ⟹ Λ.leftmost_strategy (Λ.Src t1) = t1"
      assume ind2: "⟦Λ.elementary_reduction t2; Λ.NF (Trg [t2])⟧
                        ⟹ Λ.leftmost_strategy (Λ.Src t2) = t2"
      assume t: "Λ.elementary_reduction (Λ.App t1 t2)"
      have t1: "Λ.Arr t1"
        using t Λ.Arr.simps(4) Λ.elementary_reduction_is_arr by blast
      have t2: "Λ.Arr t2"
        using t Λ.Arr.simps(4) Λ.elementary_reduction_is_arr by blast
      assume NF: "Λ.NF (Trg [Λ.App t1 t2])"
      have 1: "¬ Λ.is_Lam t1"
        using NF Λ.NF_def
        apply (cases t1)
            apply simp_all
        by (metis (mono_tags) Λ.Ide.simps(1) Λ.NF_App_iff Λ.Trg.simps(2-3) Λ.lambda.discI(2))
      have 2: "Λ.NF (Λ.Trg t1) ∧ Λ.NF (Λ.Trg t2)"
        using NF t1 t2 1 Λ.NF_App_iff by simp
      show "Λ.leftmost_strategy (Λ.Src (Λ.App t1 t2)) = Λ.App t1 t2"
        using t t1 t2 1 2 ind1 ind2
        apply (cases t1)
            apply simp_all
         apply (metis Λ.Ide.simps(4) Λ.Ide_iff_Src_self Λ.Ide_iff_Trg_self
            Λ.NF_iff_has_no_redex Λ.elementary_reduction_not_ide Λ.eq_Ide_are_cong
            Λ.has_redex_iff_not_Ide_leftmost_strategy Λ.resid_Arr_Src t1)
        using Λ.Ide_iff_Src_self by blast
    qed

    lemma Std_path_to_NF_is_leftmost:
    shows "⟦Std T; Λ.NF (Trg T)⟧ ⟹ set T ⊆ Collect Λ.is_leftmost_reduction"
    proof -
      have 1: "⋀t. ⟦Std (t # T); Λ.NF (Trg (t # T))⟧ ⟹ Λ.is_leftmost_reduction t" for T
      proof (induct T)
        show "⋀t. ⟦Std [t]; Λ.NF (Trg [t])⟧ ⟹ Λ.is_leftmost_reduction t"
          using elementary_reduction_to_NF_is_leftmost Λ.is_leftmost_reduction_def by simp
        fix t u T
        assume ind: "⋀t. ⟦Std (t # T); Λ.NF (Trg (t # T))⟧ ⟹ Λ.is_leftmost_reduction t"
        assume Std: "Std (t # u # T)"
        assume "Λ.NF (Trg (t # u # T))"
        show "Λ.is_leftmost_reduction t"
          using Std ‹Λ.NF (Trg (t # u # T))› ind sseq_reflects_leftmost_reduction by auto
      qed
      show "⟦Std T; Λ.NF (Trg T)⟧ ⟹ set T ⊆ Collect Λ.is_leftmost_reduction"
      proof (induct T)
        show 2: "set [] ⊆ Collect Λ.is_leftmost_reduction"
          by simp
        fix t T
        assume ind: "⟦Std T; Λ.NF (Trg T)⟧ ⟹ set T ⊆ Collect Λ.is_leftmost_reduction"
        assume Std: "Std (t # T)" and NF: "Λ.NF (Trg (t # T))"
        show "set (t # T) ⊆ Collect Λ.is_leftmost_reduction"
          by (metis 1 2 NF Std Std_consE Trg.elims ind insert_subset list.inject list.simps(15)
                    mem_Collect_eq)
      qed
    qed

    theorem leftmost_reduction_theorem:
    shows "Λ.normalizing_strategy Λ.leftmost_strategy"
    proof (unfold Λ.normalizing_strategy_def, intro allI impI)
      fix a
      assume a: "Λ.normalizable a"
      show "∃n. Λ.NF (Λ.reduce Λ.leftmost_strategy a n)"
      proof (cases "Λ.NF a")
        show "Λ.NF a ⟹ ?thesis"
          by (metis lambda_calculus.reduce.simps(1))
        assume 1: "¬ Λ.NF a"
        obtain T where T: "Arr T ∧ Src T = a ∧ Λ.NF (Trg T)"
          using a Λ.normalizable_def red_iff by auto
        have 2: "¬ Ide T"
          using T 1 Ide_imp_Src_eq_Trg by fastforce
        obtain U where U: "Std U ∧ cong T U"
          using T 2 standardization_theorem by blast
        have 3: "set U ⊆ Collect Λ.is_leftmost_reduction"
          using 1 U Std_path_to_NF_is_leftmost
          by (metis Con_Arr_self Resid_parallel Src_resid T cong_implies_coinitial)
        have "⋀U. ⟦Arr U; length U = n; set U ⊆ Collect Λ.is_leftmost_reduction⟧ ⟹
                   U = apply_strategy Λ.leftmost_strategy (Src U) (length U)" for n
        proof (induct n)
          show "⋀U. ⟦Arr U; length U = 0; set U ⊆ Collect Λ.is_leftmost_reduction⟧
                       ⟹ U = apply_strategy Λ.leftmost_strategy (Src U) (length U)"
            by simp
          fix n U
          assume ind: "⋀U. ⟦Arr U; length U = n; set U ⊆ Collect Λ.is_leftmost_reduction⟧
                              ⟹ U = apply_strategy Λ.leftmost_strategy (Src U) (length U)"
          assume U: "Arr U"
          assume n: "length U = Suc n"
          assume set: "set U ⊆ Collect Λ.is_leftmost_reduction"
          show "U = apply_strategy Λ.leftmost_strategy (Src U) (length U)"
          proof (cases "n = 0")
            show "n = 0 ⟹ ?thesis"
              using U n 1 set Λ.is_leftmost_reduction_def
              by (cases U) auto
            assume 5: "n ≠ 0"
            have 4: "hd U = Λ.leftmost_strategy (Src U)"
              using n U set Λ.is_leftmost_reduction_def
              by (cases U) auto
            have 6: "tl U ≠ []"
              using 4 5 n U
              by (metis Suc_length_conv list.sel(3) list.size(3))
            show ?thesis
              using 4 5 6 n U set ind [of "tl U"]
              apply (cases n)
               apply simp_all
              by (metis (no_types, lifting) Arr_consE Nil_tl Nitpick.size_list_simp(2)
                  ind [of "tl U"] Λ.arr_char Λ.trg_char list.collapse list.set_sel(2)
                  old.nat.inject reduction_paths.apply_strategy.simps(2) subset_code(1))
          qed
        qed
        hence "U = apply_strategy Λ.leftmost_strategy (Src U) (length U)"
          by (metis 3 Con_implies_Arr(1) Ide.simps(1) U ide_char)
        moreover have "Src U = a"
          using T U cong_implies_coinitial
          by (metis Con_imp_eq_Srcs Con_implies_Arr(2) Ide.simps(1) Srcs_simp⇩P⇩W⇩E empty_set
              ex_un_Src ide_char list.set_intros(1) list.simps(15))
        ultimately have "Trg U = Λ.reduce Λ.leftmost_strategy a (length U)"
          using reduce_eq_Trg_apply_strategy
          by (metis Arr.simps(1) Con_implies_Arr(1) Ide.simps(1) U a ide_char
              Λ.leftmost_strategy_is_reduction_strategy Λ.normalizable_def length_greater_0_conv)
        thus ?thesis
          by (metis Ide.simps(1) Ide_imp_Src_eq_Trg Src_resid T Trg_resid_sym U ide_char)
      qed
    qed

  end

end