section {*\isaheader{Verified BFS Implementation in ML}*}
theory Bfs_Impl
imports
  "../../../Refine_Monadic/examples/Breadth_First_Search"
  "../../Refine_Dflt_Only_ICF"
begin
  text {*
    Originally, this was part of our submission to the
    VSTTE 2010 Verification Competition. Some slight changes have been applied
    since the submitted version.
    *}

  text {*
    In the @{text "Breadth_First_Search"}-theory, we verified an abstract
    version of the algorithm. This abstract version tried to reflect the
    given pseudocode specification as precisely as possible.

    However, it was not executable, as it was nondeterministic. Hence,
    we now refine our algorithm to an executable specification, and use
    Isabelle/HOLs code generator to generate ML-code.

    The implementation uses the Isabelle Collection Framework (ICF)
    (Available at @{url "http://afp.sourceforge.net/entries/Collections.shtml"}),
    to provide efficient set implementations. We choose a hashset
    (backed by a Red Black Tree) for the visited set, and lists for
    all other sets. Moreover, we fix the node type to natural numbers.
    *}

  text {*
    The following algorithm is a straightforward rewriting of the
    original algorithm. We only exchanged the abstract set operations by
    concrete operations on the data structures provided by the ICF.

    The operations of the list-set implementation are named
    @{text "ls_xxx"}, the ones of the hashset are named @{text "hs_xxx"}.
    *}

  definition bfs_impl :: "(nat \<Rightarrow> nat ls) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat option nres)"
    where "bfs_impl succ src dst \<equiv> do {
    (f,_,_,_,d) \<leftarrow> WHILE
      (\<lambda>(f,V,C,N,d). f=False \<and> \<not> ls.isEmpty C)
      (\<lambda>(f,V,C,N,d). do {
        v \<leftarrow> RETURN (the (ls.sel C (\<lambda>_. True))); let C = ls.delete v C;
        if v=dst then RETURN (True,hs.empty (),ls.empty (),ls.empty (),d)
        else do {
          (V,N) \<leftarrow> FOREACH (ls.\<alpha> (succ v)) (\<lambda>w (V,N).
            if (\<not> hs.memb w V) then
               RETURN (hs.ins w V, ls.ins_dj w N)
            else RETURN (V,N)
          ) (V,N);
          if (ls.isEmpty C) then do {
            let C=N;
            let N=ls.empty ();
            let d=d+1;
            RETURN (f,V,C,N,d)
          } else RETURN (f,V,C,N,d)
        }
      })
      (False,hs.sng src,ls.sng src, ls.empty (),0::nat);
    if f then RETURN (Some d) else RETURN None
    }"

  text {* Auxilliary lemma to initialize the refinement prover. *}
  (*lemma [refine]: "(ls.\<alpha> \<circ> succ) v = ls.\<alpha> (succ v)"
    by auto*)

  (* TODO/FIXME:
    There is too much redundancy in the xx_correct - lemmas.
    They do not include the automtically instantiated generic algorithms,
    and they are independent of adding new operations to the interface or to
    the rb-interface
    *)

  text {*
    It is quite easy to show that the implementation respects the
    specification, as most work is done by the refinement framework. *}
  theorem bfs_impl_correct:
    shows "bfs_impl succ src dst \<le> Graph.bfs_spec (ls.\<alpha>\<circ>succ) src dst"
  proof -
    txt {* As list-sets are always finite, our setting satisfies the
      finitely-branching assumption made about graphs *}
    interpret Graph "ls.\<alpha>\<circ>succ"
      by unfold_locales simp

    txt {* The refinement framework can prove automatically that
      the implementation refines the abstract algorithm.

      The notation @{text "S \<le> \<Down>R S'"} means, that the program @{text "S"}
      refines the program @{text "S'"} w.r.t.\ the refinement relation
      (also called coupling invariant occasionally) @{text "R"}.

      In our case, the refinement relation is the identity, as
      the result type was not refined.
      *}

    have "bfs_impl succ src dst \<le> \<Down>Id (Graph.bfs (ls.\<alpha>\<circ>succ) src dst)"
      unfolding bfs_impl_def bfs_def

      apply (refine_rcg)
      apply (refine_dref_type)

      apply (simp_all add: refine_hsimp refine_rel_defs
        hs.correct hs.sng_correct ls.correct ls.sng_correct
        split: prod.split prod.split_asm)
      apply (rule inj_on_id)
      apply (simp_all add: refine_hsimp refine_rel_defs
        hs.correct hs.sng_correct ls.correct ls.sng_correct
        split: prod.split prod.split_asm)
      done
    txt {* The result then follows due to transitivity of refinement. *}
    also have "\<dots> \<le> bfs_spec src dst"
      by (simp add: bfs_correct)
    finally show ?thesis .
  qed

  text {* The last step is to actually generate executable ML-code.
    *}

  text {*
    We first use the partial-correctness code generator of our framework
    to automatically turn the algorithm described in our framework into
    a function that is independent from our framework. This step also
    removes the last nondeterminism, that has remained in the iteration order
    of the inner loop.

    The result of the function is an option type, returning @{text "None"}
    for nontermination. Inside this option-type, there is the option type
    that encodes whether we return with failure or a distance.
    *}
  schematic_goal bfs_code_refine_aux:
    "nres_of ?bfs_code \<le> bfs_impl succ src dst"
    unfolding bfs_impl_def
    apply (refine_transfer)
    done

  concrete_definition bfs_code for succ src dst uses bfs_code_refine_aux

  text {*
    As a last step, we make the correctness property independent of our
    refinement framework. This step drastically decreases the trusted code
    base, as it completely eliminates the specifications made in the
    refinement framework from the trusted code base.

    The following theorem solves both verification tasks, without depending
    on any concepts of the refinement framework, except the deterministic result
    monad.
    *}
  theorem bfs_code_correct:
    "bfs_code succ src dst = dRETURN None
      \<Longrightarrow> \<not>(Graph.conn (ls.\<alpha> \<circ> succ) src dst)"
    "bfs_code succ src dst = dRETURN (Some d)
      \<Longrightarrow> Graph.conn (ls.\<alpha> \<circ> succ) src dst
          \<and> Graph.min_dist (ls.\<alpha> \<circ> succ) src dst = d"
    "bfs_code succ src dst \<noteq> dFAIL"
  proof -
    interpret Graph "ls.\<alpha>\<circ>succ"
      by unfold_locales simp

    from order_trans[OF bfs_code.refine bfs_impl_correct, of succ src dst]
    show "bfs_code succ src dst = dRETURN None
      \<Longrightarrow> \<not>(Graph.conn (ls.\<alpha> \<circ> succ) src dst)"
      "bfs_code succ src dst = dRETURN (Some d)
      \<Longrightarrow> Graph.conn (ls.\<alpha> \<circ> succ) src dst
          \<and> Graph.min_dist (ls.\<alpha> \<circ> succ) src dst = d"
      "bfs_code succ src dst \<noteq> dFAIL"
      apply (unfold bfs_spec_def)
      apply (auto split: option.split_asm)
      done
  qed

  text {* Now we can use the code-generator of Isabelle/HOL to generate
    code into various target languages: *}
  export_code bfs_code in SML
  export_code bfs_code in OCaml
  export_code bfs_code in Haskell
  export_code bfs_code in Scala

  text {* The generated code is most conveniently executed within
    Isabelle/HOL itself. We use a small test graph here: *}

  definition nat_list:: "nat list \<Rightarrow> _" where "nat_list \<equiv> dlist_of_list"
  ML_val {*
    fun il l = @{code nat_list} (map @{code nat_of_integer} l)
    fun bfs succ s d =
      @{code bfs_code} (succ o @{code integer_of_nat})
        (@{code nat_of_integer} s) (@{code nat_of_integer} d)

    (* Define a test graph. *)
    fun succ 1 = il [2,3]
        | succ 2 = il [4]
        | succ 4 = il [5]
        | succ 5 = il [2]
        | succ 3 = il [6]
        | succ _ = il [];

    (* Execute algorithm for some node pairs. *)
    bfs succ 1 1;
    bfs succ 1 2;
    bfs succ 1 5;
    bfs succ 1 7;
    *}

end


section \<open>FIFO Push Relabel Algorithm\<close>
theory Fifo_Push_Relabel
imports
  Flow_Networks.Refine_Add_Fofu
  Generic_Push_Relabel
begin
text \<open>The FIFO push-relabel algorithm maintains a first-in-first-out queue
  of active nodes. As long as the queue is not empty, it discharges the
  first node of the queue.

  Discharging repeatedly applied push operations from the node.
  If no more push operations are possible, and the node is still active,
  it is relabeled and enqueued.

  Moreover, we implement the gap heuristics, which may accelerate relabeling
  if there is a gap in the label values, i.e., a label value that is assigned
  to no node.
\<close>

subsection \<open>Implementing the Discharge Operation\<close>

context Network
begin

text \<open>
  First, we implement push and relabel operations that maintain
  a queue of all active nodes.
\<close>
(* TODO: Use push and relabel from Prpu_Common_Inst.thy ! *)
definition "fifo_push f l Q \<equiv> \<lambda>(u,v). do {
  assert (push_precond f l (u,v));
  assert (Labeling c s t f l);
  let Q = (if v\<noteq>s \<and> v\<noteq>t \<and> excess f v = 0 then Q@[v] else Q);
  return (push_effect f (u,v),Q)
}"

text \<open>For the relabel operation, we assume that
  only active nodes are relabeled, and enqueue the relabeled node.
\<close>
definition "fifo_gap_relabel f l Q u \<equiv> do {
  assert (u\<in>V-{s,t});
  assert (Height_Bounded_Labeling c s t f l);
  let Q = Q@[u];
  assert (relabel_precond f l u);
  assert (l u < 2*card V \<and> relabel_effect f l u u < 2*card V);
  let l = gap_relabel_effect f l u;
  return (l,Q)
}"

text \<open>The discharge operation iterates over the edges, and pushes
  flow, as long as then node is active. If the node is still active after all
  edges have been saturated, the node is relabeled.
\<close>
definition "fifo_discharge f\<^sub>0 l Q \<equiv> do {
  assert (Q\<noteq>[]);
  let u=hd Q; let Q=tl Q;
  assert (u\<in>V \<and> u\<noteq>s \<and> u\<noteq>t);

  (f,l,Q) \<leftarrow> FOREACHc {v . (u,v)\<in>cfE_of f\<^sub>0} (\<lambda>(f,l,Q). excess f u \<noteq> 0) (\<lambda>v (f,l,Q). do {
    if (l u = l v + 1) then do {
      (f',Q) \<leftarrow> fifo_push f l Q (u,v);
      assert (\<forall>v'. v'\<noteq>v \<longrightarrow> cf_of f' (u,v') = cf_of f (u,v'));
      return (f',l,Q)
    } else return (f,l,Q)
  }) (f\<^sub>0,l,Q);

  if excess f u \<noteq> 0 then do {
    (l,Q) \<leftarrow> fifo_gap_relabel f l Q u;
    return (f,l,Q)
  } else do {
    return (f,l,Q)
  }
}"

text \<open>
  We will show that the discharge operation maintains the invariant that the queue
  is disjoint and contains exactly the active nodes:
\<close>
definition "Q_invar f Q \<equiv> distinct Q \<and> set Q = { v\<in>V-{s,t}. excess f v \<noteq> 0 }"

text \<open>Inside the loop of the discharge operation, we will use the following
  version of the invariant:\<close>
definition "QD_invar u f Q \<equiv> u\<in>V-{s,t} \<and> distinct Q \<and> set Q = { v\<in>V-{s,t,u}. excess f v \<noteq> 0 }"

lemma Q_invar_when_discharged1: "\<lbrakk>QD_invar u f Q; excess f u = 0\<rbrakk> \<Longrightarrow> Q_invar f Q"
  unfolding Q_invar_def QD_invar_def by auto

lemma Q_invar_when_discharged2: "\<lbrakk>QD_invar u f Q; excess f u \<noteq> 0\<rbrakk> \<Longrightarrow> Q_invar f (Q@[u])"
  unfolding Q_invar_def QD_invar_def
  by auto

lemma (in Labeling) push_no_activate_pres_QD_invar:
  fixes v
  assumes INV: "QD_invar u f Q"
  assumes PRE: "push_precond f l (u,v)"
  assumes VC: "s=v \<or> t=v \<or> excess f v \<noteq> 0"
  shows "QD_invar u (push_effect f (u,v)) Q"
proof -
  interpret push_effect_locale c s t f l u v
    using PRE by unfold_locales

  from excess_non_negative \<Delta>_positive have "excess f v + \<Delta> \<noteq> 0" if "v\<notin>{s,t}"
    using that by force
  thus ?thesis
    using VC INV
    unfolding QD_invar_def
    by (auto simp: excess'_if split!: if_splits)
qed

lemma (in Labeling) push_activate_pres_QD_invar:
  fixes v
  assumes INV: "QD_invar u f Q"
  assumes PRE: "push_precond f l (u,v)"
  assumes VC: "s\<noteq>v" "t\<noteq>v" and [simp]: "excess f v = 0"
  shows "QD_invar u (push_effect f (u,v)) (Q@[v])"
proof -
  interpret push_effect_locale c s t f l u v
    using PRE by unfold_locales

  show ?thesis
    using VC INV \<Delta>_positive
    unfolding QD_invar_def
    by (auto simp: excess'_if split!: if_splits)
qed

text \<open>Main theorem for the discharge operation:
  It maintains a height bounded labeling, the invariant for the FIFO queue,
  and only performs valid steps due to the generic push-relabel algorithm with
  gap-heuristics.
\<close>
theorem fifo_discharge_correct[THEN order_trans, refine_vcg]:
  assumes DINV: "Height_Bounded_Labeling c s t f l"
  assumes QINV: "Q_invar f Q" and QNE: "Q\<noteq>[]"
  shows "fifo_discharge f l Q \<le> SPEC (\<lambda>(f',l',Q').
      Height_Bounded_Labeling c s t f' l'
    \<and> Q_invar f' Q'
    \<and> ((f',l'),(f,l))\<in>gap_algo_rel\<^sup>+
  )"
proof -
  from QNE obtain u Qr where [simp]: "Q=u#Qr" by (cases Q) auto

  from QINV have U: "u\<in>V-{s,t}" "QD_invar u f Qr" and XU_orig: "excess f u \<noteq> 0"
    by (auto simp: Q_invar_def QD_invar_def)

  have [simp, intro!]: "finite {v. (u, v) \<in> cfE_of f}"
    apply (rule finite_subset[where B=V])
    using cfE_of_ss_VxV
    by auto

  show ?thesis
    using U
    unfolding fifo_discharge_def fifo_push_def fifo_gap_relabel_def
    apply (simp only: split nres_monad_laws)
    apply (rewrite in "FOREACHc _ _ \<hole> _" vcg_intro_frame)
    apply (rewrite in "if excess _ _ \<noteq> 0 then \<hole> else _" vcg_intro_frame)
    apply (refine_vcg FOREACHc_rule[where
            I="\<lambda>it (f',l',Q').
                Height_Bounded_Labeling c s t f' l'
              \<and> QD_invar u f' Q'
              \<and> ((f',l'),(f,l))\<in>gap_algo_rel\<^sup>*
              \<and> it \<subseteq> {v. (u,v) \<in> cfE_of f' }
              \<and> (excess f' u\<noteq>0 \<longrightarrow> (\<forall>v\<in>{v. (u,v) \<in> cfE_of f' }-it. l' u \<noteq> l' v + 1)
            )
            "
          ])
    apply (vc_solve simp: DINV QINV it_step_insert_iff split del: if_split)
    subgoal for v it f' l' Q' proof -
      assume HBL: "Height_Bounded_Labeling c s t f' l'"
      then interpret l': Height_Bounded_Labeling c s t f' l' .

      assume X: "excess f' u \<noteq> 0" and UI: "u \<in> V" "u \<noteq> s" "u \<noteq> t"
        and QDI: "QD_invar u f' Q'"

      assume "v \<in> it" and ITSS: "it \<subseteq> {v. (u, v) \<in> l'.cf.E}"
      hence UVE: "(u,v) \<in> l'.cf.E" by auto

      assume REL: "((f', l'), f, l) \<in> gap_algo_rel\<^sup>*"

      assume SAT_EDGES: "\<forall>v\<in>{v. (u, v) \<in> cfE_of f'} - it. l' u \<noteq> Suc (l' v)"

      from X UI l'.excess_non_negative have X': "excess f' u > 0" by force

      have PP: "push_precond f' l' (u, v)" if "l' u = l' v + 1"
        unfolding push_precond_def using that UVE X' by auto

      show ?thesis
        apply (rule vcg_rem_frame)
        apply (rewrite in "if _ then (assert _ \<then> \<hole>) else _" vcg_intro_frame)
        apply refine_vcg
        apply (vc_solve simp: REL solve: PP l'.push_pres_height_bound HBL QDI split del: if_split)
        subgoal proof -
          assume [simp]: "l' u = Suc (l' v)"
          assume PRE: "push_precond f' l' (u, v)"
          then interpret pe: push_effect_locale c s t f' l' u v by unfold_locales

          have UVNE': "l'.cf (u, v) \<noteq> 0"
            using l'.resE_positive by fastforce

          show ?thesis
            apply (rule vcg_rem_frame)
            apply refine_vcg
            apply (vc_solve simp: l'.push_pres_height_bound[OF PRE])
            subgoal by unfold_locales
            subgoal by (auto simp: pe.cf'_alt augment_edge_cf_def)
            subgoal
              using l'.push_activate_pres_QD_invar[OF QDI PRE]
              using l'.push_no_activate_pres_QD_invar[OF QDI PRE]
              by auto
            subgoal
              by (meson gap_algo_rel.push REL PRE converse_rtrancl_into_rtrancl HBL)
            subgoal for x proof -
              assume "x\<in>it" "x\<noteq>v"
              with ITSS have "(u,x)\<in>l'.cf.E" by auto
              thus ?thesis
                using \<open>x\<noteq>v\<close>
                unfolding pe.f'_alt
                apply (simp add: augment_edge_cf')
                unfolding Graph.E_def
                by (auto)
            qed
            subgoal for v' proof -
              assume "excess f' u \<noteq> pe.\<Delta>"
              hence PED: "pe.\<Delta> = l'.cf (u,v)"
                unfolding pe.\<Delta>_def by auto
              hence E'SS: "pe.l'.cf.E \<subseteq> (l'.cf.E \<union> {(v,u)}) - {(u,v)}"
                unfolding pe.f'_alt
                apply (simp add: augment_edge_cf')
                unfolding Graph.E_def
                by auto

              assume "v' \<in> it \<longrightarrow> v' = v" and UV'E: "(u, v') \<in> pe.l'.cf.E" and LUSLV': "l' v = l' v'"
              with E'SS have "v'\<notin>it" by auto
              moreover from UV'E E'SS pe.uv_not_eq(2) have "(u,v')\<in>l'.cf.E" by auto
              ultimately have "l' u \<noteq> Suc (l' v')" using SAT_EDGES by auto
              with LUSLV' show False by simp
            qed
            done
        qed
        subgoal using ITSS by auto
        subgoal using SAT_EDGES by auto
        done
    qed
    subgoal premises prems for f' l' Q' proof -
      from prems interpret l': Height_Bounded_Labeling c s t f' l' by simp
      from prems have UI: "u\<in>V" "u\<noteq>s" "u\<noteq>t"
        and X: "excess f' u \<noteq> 0"
        and QDI: "QD_invar u f' Q'"
        and REL: "((f', l'), f, l) \<in> gap_algo_rel\<^sup>*"
        and NO_ADM: "\<forall>v. (u, v) \<in> l'.cf.E \<longrightarrow> l' u \<noteq> Suc (l' v)"
        by simp_all

      from X have X': "excess f' u > 0" using l'.excess_non_negative UI by force

      from X' UI NO_ADM have PRE: "relabel_precond f' l' u"
        unfolding relabel_precond_def by auto

      from l'.height_bound \<open>u\<in>V\<close> card_V_ge2 have [simp]: "l' u < 2*card V" by auto

      from l'.relabel_pres_height_bound[OF PRE]
      interpret l'': Height_Bounded_Labeling c s t f' "relabel_effect f' l' u" .

      from l''.height_bound \<open>u\<in>V\<close> card_V_ge2 have [simp]: "relabel_effect f' l' u u < 2*card V" by auto

      show ?thesis
        apply (rule vcg_rem_frame)
        apply refine_vcg
        apply (vc_solve
            simp: UI PRE
            simp: l'.gap_relabel_pres_hb_labeling[OF PRE]
            simp: Q_invar_when_discharged2[OF QDI X])
        subgoal by unfold_locales
        subgoal
          by (meson PRE REL gap_algo_rel.relabel l'.Height_Bounded_Labeling_axioms rtrancl_into_trancl2)
        done
    qed
    subgoal by (auto simp: Q_invar_when_discharged1 Q_invar_when_discharged2)
    subgoal using XU_orig by (metis Pair_inject rtranclD)
    subgoal by (auto simp: Q_invar_when_discharged1)
    subgoal using XU_orig by (metis Pair_inject rtranclD)
    done
qed

end \<comment> \<open>Network\<close>

subsection \<open>Main Algorithm\<close>

context Network
begin

text \<open>The main algorithm initializes the flow, labeling, and the queue,
  and then applies the discharge operation until the queue is empty:
\<close>

definition "fifo_push_relabel \<equiv> do {
  let f = pp_init_f;
  let l = pp_init_l;

  Q \<leftarrow> spec l. distinct l \<and> set l = {v\<in>V - {s,t}. excess f v \<noteq> 0}; \<comment> \<open>TODO: This is exactly \<open>E``{s} - {t}\<close>!\<close>

  (f,l,_) \<leftarrow> while\<^sub>T (\<lambda>(f,l,Q). Q \<noteq> []) (\<lambda>(f,l,Q). do {
    fifo_discharge f l Q
  }) (f,l,Q);

  assert (Height_Bounded_Labeling c s t f l);
  return f
}"

text \<open>Having proved correctness of the discharge operation, the correctness
  theorem of the main algorithm is straightforward:
  As the discharge operation implements the generic algorithm, the loop
  will terminate after finitely many steps.
  Upon termination, the queue that contains exactly the active nodes is empty.
  Thus, all nodes are inactive, and the resulting preflow is actually a maximal
  flow.
\<close>
theorem fifo_push_relabel_correct:
  "fifo_push_relabel \<le> SPEC isMaxFlow"
  unfolding fifo_push_relabel_def
  apply (refine_vcg
      WHILET_rule[where
            I="\<lambda>(f,l,Q). Height_Bounded_Labeling c s t f l \<and> Q_invar f Q"
        and R="inv_image (gap_algo_rel\<^sup>+) (\<lambda>(f,l,Q). ((f,l)))"
        ]
      )
  apply (vc_solve solve: pp_init_height_bound)
  subgoal by (blast intro: wf_lex_prod wf_trancl)
  subgoal unfolding Q_invar_def by auto
  subgoal for initQ f l proof -
    assume "Height_Bounded_Labeling c s t f l"
    then interpret Height_Bounded_Labeling c s t f l .
    assume "Q_invar f []"
    hence "\<forall>u\<in>V-{s,t}. excess f u = 0" unfolding Q_invar_def by auto
    thus "isMaxFlow f" by (rule no_excess_imp_maxflow)
  qed
  done

end \<comment> \<open>Network\<close>

end


(*
    File:        OccGraft.thy
    Time-stamp:  <2015-12-25T10:47:28Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory OccGraft imports SubOcc begin

definition lists_subtree :: "[i, i] => i" where
"lists_subtree(b, W) == {z. y: W, y = Cons(b, z)}"

definition Occ_Shift :: "[i, i] => i" where
"Occ_Shift(m, X) == {z. y: X, EX l T. z = <m@l, T> & y = <l, T>}"

definition Incomparable :: "i=>o" where
"Incomparable(W) == ALL l: W. ALL m: W.
           initseg(nat, l, m) | initseg(nat, m, l) --> l = m"

definition Occ_Graft1 :: "[i, i, i] => i" where
"Occ_Graft1(X, l, Y) == (X - {u: X. EX m T. u = <m, T> &
                                       initseg(nat, l, m)}) Un
                         Occ_Shift(l, Y)"

definition Occ_Graft :: "[i, i, i] => i" where
"Occ_Graft(X, W, Y)  == (X - (UN l: W. {u: X. EX m T. u = <m, T> &
                                                initseg(nat, l, m)}))
                       Un (UN l: W. Occ_Shift(l, Y))"

(** lists_subtree **)
lemma lists_subtreeI:
  "Cons(b, l): X ==> l: lists_subtree(b, X)"
apply (unfold lists_subtree_def)
apply (rule ReplaceI)
prefer 2 apply assumption
apply (rule refl)
apply simp
done

lemma lists_subtreeD:
  "l: lists_subtree(b, X) ==> Cons(b, l): X"
apply (unfold lists_subtree_def)
apply blast
done

lemma lists_subtreeE:
  "[| l: lists_subtree(b, X);
      Cons(b, l): X ==> R |] ==> R"
apply (unfold lists_subtree_def)
apply blast
done

lemma lists_subtree_domain_eq:
  "lists_subtree(b, domain(X)) = domain(Occ_subtree(b, X))"
apply (rule equalityI)
apply (blast intro: Occ_subtreeI lists_subtreeI
         elim!: Occ_subtreeE lists_subtreeE)+
done

lemma lists_subtree_mono:
  "X <= W ==> lists_subtree(b, X) <= lists_subtree(b, W)"
apply (blast intro: lists_subtreeI elim!: lists_subtreeE)
done

(** Occ_Shift **)
lemma Occ_ShiftI:
  "<l, T>: X ==> <m@l, T>: Occ_Shift(m, X)"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_ShiftD:
  "[| <m@l, T>: Occ_Shift(m, X); m: list(A) |] ==> <l, T>: X"
apply (unfold Occ_Shift_def)
apply (elim ReplaceE exE conjE)
apply simp
done

lemma Occ_ShiftE:
  "[| x: Occ_Shift(m, X);
      !!l T. [| x = <m@l, T>; <l, T>: X |] ==> R
   |]==> R"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_ShiftE2:
  "[| <n, T>: Occ_Shift(m, X);
      !!l. [| n = m@l; <l, T>: X |] ==> R
   |]==> R"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_Shift_0:
  "Occ_Shift(m, 0) = 0"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_Shift_Nil:
  "X <= A * B ==> Occ_Shift([], X) = X"
apply (unfold Occ_Shift_def)
apply simp
apply blast
done

lemma Occ_Shift_Cons:
  "Occ_Shift(Cons(a, l), X) = Occ_shift(a, Occ_Shift(l, X))"
apply (rule equalityI)
apply (safe elim!: Occ_shiftE Occ_ShiftE)
apply simp
apply (blast intro: Occ_shiftI Occ_ShiftI)
apply (simp del: app_Cons add: app_Cons [THEN sym])
apply (rule Occ_ShiftI)
apply assumption
done

lemma Occ_Shift_domain:
  "[| X <= list(A) * B; m: list(A) |] ==> Occ_Shift(m, X) <= list(A) * B"
apply (blast intro: app_type elim!: Occ_ShiftE)
done

lemma Occ_Shift_app:
  assumes prem1: "l: list(A)"
  and prem2: "m: list(B)"
  and prem3: "X <= list(B) * D"
  shows "Occ_Shift(l@m, X) = Occ_Shift(l, Occ_Shift(m, X))"
apply (rule prem3 [THEN rev_mp])
apply (rule_tac x="X" in spec)
apply (rule prem1 [THEN list.induct])
apply (intro impI allI)
apply (drule Occ_Shift_domain)
apply (rule prem2)
apply (simp_all add: Occ_Shift_Nil Occ_Shift_Cons)
done

(** Incomparable **)
lemma IncomparableI:
  "[| !!l m. [| l: W; m: W; initseg(nat, l, m) |] ==> l = m |]
     ==> Incomparable(W)"
apply (unfold Incomparable_def)
apply blast
done

lemma IncomparableD:
  "[| Incomparable(W);
      initseg(nat, l, m);
      l: W; m: W |] ==> l = m"
apply (unfold Incomparable_def)
apply blast
done

lemma Incomparable_lists_subtree:
  assumes major: "Incomparable(W)"
  and prem: "a: nat"
  shows "Incomparable(lists_subtree(a, W))"
apply (rule IncomparableI)
apply (elim lists_subtreeE)
apply (drule prem [THEN initseg_ConsI])
apply (drule major [THEN IncomparableD])
apply assumption+
apply simp
done

lemma Incomparable_subset:
  assumes major: "Incomparable(W)"
  and prem: "X <= W"
  shows "Incomparable(X)"
apply (rule IncomparableI)
apply (erule major [THEN IncomparableD])
apply (erule prem [THEN subsetD])+
done

lemma Incomparable_CorrectArity_0_lemma:
  assumes major: "initseg(nat, l, m)"
  and prem1: "<l, T>: X"
  and prem2: "<m, U>: X"
  and hierX: "DenseTree(X)"
  and corrT: "CorrectArity(X, T, 0)"
  and m_list: "m: list(nat)"
  shows "l = m"
apply (rule prem2 [THEN rev_mp])
apply (rule prem1 [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule_tac x="U" in spec)
apply (rule m_list [THEN list_append_induct])
apply (intro allI impI)
apply (erule initseg_NilE)
apply assumption
apply (intro allI impI)
apply (erule  initseg_right_appE)
apply assumption
apply (rule corrT [THEN CorrectArityD2, THEN notE])
apply assumption
apply (erule nat_into_Ord [THEN Ord_0_le])
apply (rule hierX [THEN DenseTreeE])
apply (rule_tac [2] initseg_appI1)
apply assumption+
apply (drule spec)
apply (drule mp, assumption)+
apply hypsubst
apply (erule exI)
apply (rename_tac m n)
apply (erule_tac a="m" in list.cases)
apply hypsubst
apply simp
apply (rule corrT [THEN CorrectArityD2, THEN notE])
apply (rule_tac [3] exI)
apply (erule_tac [2] nat_into_Ord [THEN Ord_0_le])
apply assumption
apply hypsubst
apply assumption
apply simp
done

lemma Incomparable_CorrectArity_0:
  assumes domX: "X <= list(nat)* B"
  and hierX: "DenseTree(X)"
  shows "Incomparable(domain({<l, T>: X. CorrectArity(X, T, 0)}))"
apply (rule IncomparableI)
apply (elim domainE CollectE)
apply simp
apply (erule Incomparable_CorrectArity_0_lemma)
apply (erule_tac [5] domX [THEN subsetD, THEN SigmaD1])
apply (assumption | rule hierX)+
done

(** Occ_Graft1 **)
lemma Occ_Graft1I1:
  "[| <l, T>: X; ~initseg(nat, m, l) |]
      ==> <l, T>: Occ_Graft1(X, m, Y)"
apply (unfold Occ_Graft1_def)
apply blast
done

lemma Occ_Graft1I2:
  "<l, T>: Occ_Shift(m, Y) ==> <l, T>: Occ_Graft1(X, m, Y)"
apply (unfold Occ_Graft1_def)
apply blast
done

lemma Occ_Graft1E:
  "[| x: Occ_Graft1(X, m, Y);
      X <= A * B;
      !! l T. [| x = <l, T>; <l, T>: X; l: A; T: B;
                ~initseg(nat, m, l) |] ==> R;
      x: Occ_Shift(m, Y) ==> R
   |] ==> R"
apply (unfold Occ_Graft1_def)
apply blast
done

lemma Occ_Graft1_domain:
  assumes domX: "X <= list(A) * B"
  and domY: "Y <= list(A) * B"
  and m_list: "m: list(A)"
  shows "Occ_Graft1(X, m, Y) <= list(A) * B"
apply (rule subsetI)
apply (erule Occ_Graft1E)
apply (rule domX)
apply (erule_tac [2] Occ_Shift_domain [OF domY m_list, THEN subsetD])
apply blast
done

lemma Occ_Graft1_Nil:
  assumes prem1: "X <= list(nat) * B"
  and prem2: "Y <= list(nat) * D"
  shows "Occ_Graft1(X, [], Y) = Y"
apply (rule equalityI)
apply (safe elim!: prem1 [THEN [2] Occ_Graft1E] Occ_ShiftE)
prefer 2 apply simp
apply (erule notE)
apply (erule initseg_NilI)
apply (frule prem2 [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (rule Occ_Graft1I2)
apply (rule_tac P="%x. <x, y>: Occ_Shift([], Y)"
        in app_Nil [THEN subst])
apply (erule Occ_ShiftI)
done

lemma Occ_Graft1_Occ_cons_Cons:
  "[| T: Tag; l: list(Pow(list(nat)*Tag)); m: list(nat);
      a: length(l) |] ==>
    Occ_Graft1(Occ_cons(T, l), Cons(a, m), Y) =
        Occ_cons(T, mapnth(%x r. if(a = x, Occ_Graft1(r, m, Y), r), l))"
apply (rule equalityI)
apply (safe elim!: Occ_cons_type [THEN [2] Occ_Graft1E]
           Occ_ShiftE Occ_consE)
apply assumption+
apply (rule Occ_consI1)
prefer 3
apply (rule Occ_Graft1I1)
apply (rule Occ_consI1)
apply (rule notI)
apply (erule initseg_NilE)
apply simp
apply (rule Occ_consI2)
apply (simp add: length_mapnth)
apply (simp add: nth_mapnth)
apply (rule impI)
apply hypsubst
apply (rule Occ_Graft1I1)
apply assumption
apply (rule notI)
apply (erule notE)
apply (rule initseg_ConsI)
apply (erule mem_nat_in_nat)
apply (erule length_type)
apply assumption
apply simp
apply (rule Occ_consI2)
apply (simp add: length_mapnth)
apply (simp add: nth_mapnth)
apply (rule Occ_Graft1I2)
apply (rule Occ_ShiftI)
apply assumption
apply (simp add: length_mapnth nth_mapnth)
apply (rename_tac b n U)
apply (case_tac "a = b")
apply simp_all
apply (safe elim!: Occ_Graft1E Occ_ShiftE)
apply (frule nth_type2)
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
apply (drule PowD)
apply (drule subsetD)
apply assumption+
apply (rule Occ_Graft1I1)
apply (rule Occ_consI2)
apply assumption+
apply (rule notI)
apply (erule notE)
apply (erule initseg_ConsE)
apply simp
apply simp
apply (rule Occ_Graft1I2)
apply (simp add: Occ_Shift_Cons)
apply (rule Occ_shiftI)
apply (erule Occ_ShiftI)
apply (rule Occ_Graft1I1)
apply (rule Occ_consI2)
apply assumption+
apply (rule notI)
apply (erule initseg_ConsE)
apply simp_all
done

(** Occ_Graft **)
lemma Occ_GraftI1:
  "[| <l, T>: X; ~(EX m: W. initseg(nat, m, l)) |]
      ==> <l, T>: Occ_Graft(X, W, Y)"
apply (unfold Occ_Graft_def)
apply blast
done

lemma Occ_GraftI2:
  "[| m: W; <l, T>: Occ_Shift(m, Y) |]
           ==> <l, T>: Occ_Graft(X, W, Y)"
apply (unfold Occ_Graft_def)
apply blast
done

lemma Occ_GraftE:
  assumes major: "x: Occ_Graft(X, W, Y)"
  and prem: "X <= A * B"
  and prem1:
     "!! l T. [| x = <l, T>; <l, T>: X; l: A; T: B;
                ~(EX m: W. initseg(nat, m, l)) |] ==> R"
  and prem2:
     "!! m. [| m: W; x: Occ_Shift(m, Y) |] ==> R"
  shows "R"
apply (rule major [unfolded Occ_Graft_def, THEN UnE])
apply (erule_tac [2] UN_E)
apply (rule_tac [2] prem2)
apply (erule DiffE)
apply (frule prem [THEN subsetD])
apply (erule SigmaE)
apply (rule prem1)
prefer 2 apply hypsubst
apply (rule_tac [5] notI)
apply (erule_tac [5] notE)
apply (erule_tac [5] bexE)
apply (assumption | rule UN_I CollectI exI conjI)+
done

lemma Occ_Graft_domain:
  assumes domX: "X <= list(A) * B"
  and domY: "Y <= list(A) * B"
  and domW: "W <= domain(X)"
  shows "Occ_Graft(X, W, Y) <= list(A) * B"
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule domX)
apply blast
apply (rule domY [THEN Occ_Shift_domain, THEN subsetD])
apply (drule domW [THEN subsetD])
apply (erule domainE)
apply (drule domX [THEN subsetD])
apply (erule SigmaD1)
apply assumption
done

lemma Occ_Graft_0:
  "Occ_Graft(X, 0, Y) = X"
apply (unfold Occ_Graft_def)
apply simp
done

lemma Occ_Graft_cons:
  assumes prem: "Incomparable(cons(a, W))"
  and domW: "cons(a, W) <= domain(X)"
  and domX: "X <= list(nat) * Tag"
  and domY: "Y <= list(nat) * Tag"
  shows "Occ_Graft(X, cons(a, W), Y) =
               Occ_Graft1(Occ_Graft(X, W - {a}, Y), a, Y)"
apply (rule equalityI)
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule domX)
apply (erule_tac [2] Occ_ShiftE)
apply (erule_tac [3] Occ_Graft1E)
apply (rule_tac [3] Occ_Graft_domain)
apply (rule_tac [5] domW [THEN [2] subset_trans])
prefer 3 apply (rule domX)
prefer 3 apply (rule domY)
prefer 3 apply blast
apply (erule_tac [3] Occ_GraftE)
apply (rule_tac [3] domX)
apply (erule_tac [5] Occ_ShiftE)
apply (erule_tac [4] Occ_ShiftE2)
prefer 5
apply hypsubst
apply (rule Occ_GraftI2)
prefer 2 apply (rule Occ_ShiftI)
apply assumption
apply (rule consI1)
prefer 4
apply hypsubst
apply (rule Occ_GraftI2)
prefer 2 apply (rule Occ_ShiftI)
apply assumption
apply blast
prefer 3
apply hypsubst
apply (rule Occ_GraftI1)
apply simp
apply blast
apply hypsubst
apply (rule Occ_Graft1I1)
apply (rule Occ_GraftI1)
apply assumption
apply blast
apply blast

apply (case_tac "m = a")
apply hypsubst
apply (rule Occ_Graft1I2)
apply (erule Occ_ShiftI)
apply hypsubst
apply (rule Occ_Graft1I1)
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply blast

apply assumption
apply (rule notI)
apply (erule initseg_right_appE)
apply (drule domW [THEN subsetD])
apply (erule domainE)
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (drule_tac [2] prem [THEN IncomparableD])
apply (drule_tac [1] prem [THEN IncomparableD])
defer 3
apply (assumption | rule consI1)+
apply blast+
done

lemma Occ_Graft_cons2:
  assumes prem: "Incomparable(cons(a, W))"
  and domW: "cons(a, W) <= domain(X)"
  and domX: "X <= list(nat) * Tag"
  and domY: "Y <= list(nat) * Tag"
  shows "Occ_Graft(X, cons(a, W), Y) =
               Occ_Graft(Occ_Graft1(X, a, Y), W - {a}, Y)"
apply (rule equalityI)
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule domX)
apply (erule_tac [2] Occ_ShiftE)
apply (erule_tac [3] Occ_GraftE)
apply (rule_tac [3] Occ_Graft1_domain)
apply (insert consI1 [THEN domW [THEN subsetD]])
apply (erule_tac [5] domainE)
apply (erule_tac [5] domX [THEN subsetD, THEN SigmaD1])
apply (rule_tac [3] domX domY)+
apply (erule_tac [3] Occ_Graft1E)
apply (rule_tac [3] domX)
apply (erule_tac [5] Occ_ShiftE)
apply (erule_tac [4]  Occ_ShiftE2)
apply (simp_all del: cons_iff)
apply (rule_tac [5] Occ_GraftI2)
apply (rule_tac [4] Occ_GraftI2)
apply (rule_tac [7] Occ_ShiftI)
apply (rule_tac [5] Occ_ShiftI)
prefer 7 apply assumption
prefer 6 apply (erule conjE, erule consI2)
prefer 5 apply assumption
prefer 4 apply (rule consI1)
apply (erule conjE)
apply (rule Occ_GraftI1)
apply (rule Occ_Graft1I1)
apply assumption+
apply blast
apply (case_tac "m = a")
apply hypsubst
apply (rule Occ_GraftI1)
apply (rule Occ_Graft1I2)
apply (erule Occ_ShiftI)
apply (rule notI)
apply clarify
apply (erule initseg_right_appE)
apply (rule consI1 [THEN domW [THEN subsetD], THEN domainE])
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (rule prem [THEN IncomparableD])
apply (assumption | (erule consI2) | (rule consI1))+
apply (rule prem [THEN IncomparableD, THEN sym])
apply (assumption | (erule consI2) | (rule consI1))+
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply blast
apply assumption
apply (rule Occ_GraftI1)
apply assumption
apply blast
done

lemma Occ_Graft_Nil:
  "[| X <= list(nat) * Tag; Y <= A * B |] ==>
      Occ_Graft(X, {[]}, Y) = Y"
apply (unfold Occ_Graft_def)
apply (rule equalityI)
apply safe
apply (erule notE)
apply (rule singletonI [THEN UN_I])
apply (blast intro: initseg_NilI)
apply (simp add: Occ_Shift_Nil)
apply (erule notE)
apply (rule singletonI [THEN UN_I])
apply (simp add: Occ_Shift_Nil)
apply (erule notE)
apply (rule singletonI [THEN UN_I])
apply (simp add: Occ_Shift_Nil)
done

lemma Incomparable_Nil_lemma:
  assumes major: "Incomparable(W)"
  and prem: "[]: W"
  and domW: "W <= list(nat)"
  shows "W = {[]}"
apply (insert prem)
apply (rule equalityI)
prefer 2 apply blast
apply (rule subsetI)
apply (rule_tac P="%x. x: {[]}" in
     major [THEN prem [THEN [3] IncomparableD], THEN subst])
apply (drule_tac c="x" in domW [THEN subsetD])
apply (assumption | rule initseg_NilI singletonI)+
done

lemma Occ_Graft_Occ_cons:
  assumes major: "W ~= {[]}"
  and prem: "Incomparable(W)"
  and domW: "W <= domain(Occ_cons(T, l))"
  and t_tag: "T: Tag"
  and l_list: "l: list(Pow(list(nat)*Tag))"
  and domY: "Y <= list(nat) * Tag"
  shows "Occ_Graft(Occ_cons(T, l), W, Y) =
          Occ_cons(T, mapnth(%z r. Occ_Graft(r, lists_subtree(z, W), Y), l))"
apply (insert t_tag l_list)
apply (subgoal_tac "W <= list(nat)")
prefer 2
apply (insert domW Occ_cons_type [OF t_tag l_list])
apply blast
apply (rule equalityI)
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule Occ_cons_type [OF t_tag l_list])
apply (erule_tac [3] Occ_consE)
apply (erule_tac [2] Occ_ShiftE)
apply hypsubst
apply (erule Occ_consE)
apply safe
apply (frule_tac [3] domW [THEN subsetD])
apply (safe elim!: Occ_consE)
apply (erule_tac [3]  prem [THEN Incomparable_Nil_lemma,
                       THEN major [THEN notE]])
prefer 3 apply assumption
prefer 3 apply simp
apply (rule Occ_consI2)
apply (simp add: nth_mapnth length_mapnth)
prefer 2 apply (rule Occ_consI1)
prefer 2 apply (rule Occ_consI2)
apply (simp_all add: nth_mapnth length_mapnth)
apply (rule Occ_GraftI1)
apply assumption
apply (rule notI)
apply (elim conjE bexE lists_subtreeE)
apply (drule bspec, assumption)
apply (erule notE)
apply (erule initseg_ConsI, assumption)
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply (erule lists_subtreeI)
apply assumption
apply (rule Occ_GraftI1)
apply (rule Occ_consI1)
apply (rule notI)
apply (erule bexE)
apply (erule initseg_NilE)
apply hypsubst
apply (erule prem [THEN Incomparable_Nil_lemma,
                   THEN major [THEN notE]])
apply assumption
apply (erule Occ_GraftE)
apply (rule nth_type2 [THEN PowD], assumption)
apply (erule nat_ltI)
apply (erule length_type)
apply (rule Occ_GraftI1)
apply (erule Occ_consI2)
apply simp
apply (rule notI)
apply (erule bexE)
apply (erule initseg_ConsE)
apply hypsubst
apply (erule prem [THEN Incomparable_Nil_lemma,
                   THEN major [THEN notE]])
apply assumption
apply simp
apply (blast intro: lists_subtreeI)
apply (safe elim!: Occ_ShiftE lists_subtreeE)
apply (simp del: app_Cons add: app_Cons [THEN sym])
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply assumption+
done

(** Occ_Graft1 in Occ_range **)
lemma Occ_Graft1_preserves_functionality:
  assumes funcX: "functional(X)"
  and funcY: "functional(Y)"
  and domX: "X <= list(nat)*B"
  and l_list: "l: list(nat)"
  shows "functional(Occ_Graft1(X, l, Y))"
apply (rule functionalI)
apply (erule Occ_Graft1E)
apply (rule domX)
apply (erule_tac [2] Occ_Graft1E)
apply (rule_tac [2] domX)
apply (erule_tac Occ_Graft1E)
apply (rule_tac domX)
apply (safe elim!: Occ_ShiftE)
prefer 4
apply (drule l_list [THEN app_right_inj_iff, THEN iffD1])
apply hypsubst
apply (erule funcY [THEN functionalD])
apply assumption
apply (erule funcX [THEN functionalD])
apply assumption
apply (erule notE)
apply (rule l_list [THEN initseg_appI1])
apply (erule l_list [THEN [2] app_typeD])
apply (erule notE)
apply (rule l_list [THEN initseg_appI1])
apply (erule l_list [THEN [2] app_typeD])
done

lemma Occ_Graft1_preserves_DenseTree:
  assumes hierX: "DenseTree(X)"
  and hierY: "DenseTree(Y)"
  and domX: "X <= list(nat)*B"
  and l_list: "l: domain(X)"
  shows "DenseTree(Occ_Graft1(X, l, Y))"
apply (rule DenseTreeI)
apply (safe elim!: Occ_Graft1E Occ_ShiftE)
apply (erule domX [THEN subsetD])
apply (rule hierX [THEN DenseTreeE])
apply assumption+
apply (rule exI)
apply (erule Occ_Graft1I1)
apply (rule notI)
apply (erule notE)
apply (erule initseg_trans, assumption)
apply (rule l_list [THEN domainE])
apply (erule initseg_right_appE)
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (rule hierX [THEN DenseTreeE])
apply assumption+
apply (case_tac "m = l")
prefer 2
apply (rule exI)
apply (rule Occ_Graft1I1)
apply assumption
apply (rule notI)
apply (drule initseg_antisym, assumption)
apply (erule notE, assumption)
apply hypsubst
apply (erule hierY [THEN DenseTreeE])
apply (erule initseg_NilI)
apply (rename_tac C)
apply (rule_tac x="C" in exI)
apply (rule_tac P="%x. <x, C>: Occ_Graft1(X, l, Y)" in
         app_right_Nil [THEN subst])
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])
apply hypsubst
apply (erule hierY [THEN DenseTreeE])
apply (erule initseg_appI1)
apply assumption
apply (rule exI)
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])
done

lemma Occ_Graft1_preserves_CorrectArity:
  assumes corrX: "CorrectArity(X, T, n)"
  and corrY: "CorrectArity(Y, T, n)"
  and domX: "X <= list(nat)*B"
  and l_list: "l: domain(X)"
  and domY: "Y <= list(nat)*B"
  and hierY: "DenseTree(Y)"
  and not_emptyY: "Y ~= 0"
  shows "CorrectArity(Occ_Graft1(X, l, Y), T, n)"
apply (subgoal_tac "l: list(nat)")
prefer 2
apply (rule l_list [THEN domainE])
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (rule CorrectArityI)
apply (erule_tac [2] Occ_Graft1E)
apply (rule_tac [2] domX)
apply (erule Occ_Graft1E)
apply (rule domX)
apply (safe elim!: Occ_ShiftE)
apply (rename_tac l' U)
apply (case_tac "l' @ [m] = l")

prefer 5
apply (frule corrY [THEN CorrectArityD2])
apply assumption
apply (erule notE)
apply (erule Occ_Graft1E)
apply (rule domX)
apply clarify
apply (erule notE)
apply (simp add: app_assoc)
apply (rule initseg_appI1)
apply assumption
apply (erule app_typeD)
apply assumption
apply (erule Occ_ShiftE2)
apply (simp only: app_assoc app_right_inj_iff)
apply (erule exI)

prefer 4
apply (erule Occ_Graft1E)
apply (rule domX)
prefer 2
apply (erule_tac [1] Occ_ShiftE2)
apply (rule_tac [1] app_appE_lemma [THEN bspec, THEN mp, THEN disjE])
prefer 3 apply assumption
apply assumption+
apply (rule l_list [THEN domainE])
apply (erule exE)
apply hypsubst
apply (simp only: app_assoc app_right_inj_iff)
apply (drule app_typeD)
apply assumption
apply (erule_tac a="z" in list.cases)
apply (erule notE)
apply simp
apply (erule initseg_refl)
apply hypsubst
apply simp
apply clarify
apply (erule corrX [THEN CorrectArityD2, THEN notE])
apply assumption
apply (erule exI)
apply (erule exE)
apply hypsubst
apply (erule notE)
apply (drule app_typeD)
apply assumption
apply (erule initseg_appI1)
apply assumption

apply clarify
apply (erule corrX [THEN CorrectArityD2, THEN notE])
apply assumption
apply (erule exI)

prefer 3
apply (erule corrY [THEN CorrectArityD1, THEN exE])
apply assumption
apply (rule exI)
apply (simp add: app_assoc)
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])

prefer 1
apply (rule not_emptyY [THEN not_emptyE])
apply (frule domY [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (erule hierY [THEN DenseTreeE])
apply (erule initseg_NilI)
apply (rename_tac C)
apply (rule_tac x="C" in exI)
apply (erule_tac P="%x. <x, C>: Occ_Graft1(X, l' @ [m], Y)"
        in app_right_Nil [THEN subst])
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])

apply (rule corrX [THEN CorrectArityD1, THEN exE])
apply assumption+
apply (rule exI)
apply (erule Occ_Graft1I1)
apply (rule notI)
apply (erule notE)
apply (erule initseg_right_appE)
apply assumption+
apply (rename_tac m' y)
apply (erule_tac a="m'" in list.cases)
apply simp
apply simp
done

lemma Occ_shift_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "b: nat"
  shows "Occ_shift(b, X) : fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_succI])
apply (rule_tac [2] prem1)
apply (insert prem1 [THEN fin_bnd_set_domain [THEN subsetD], THEN PowD])
apply (unfold Occ_fbs_op_def Occ_fbs_dom_def list_dom_def list_op_def)
apply (rule subsetI)
apply (erule Occ_shiftE)
apply hypsubst
apply (drule subsetD, assumption)
apply (erule SigmaE2)
apply (rule SigmaI)
prefer 2 apply assumption
apply (rule CollectI)
prefer 2 apply (rule disjI2)
apply (intro exI conjI)
apply (rule refl)
apply (rule prem2)
apply (erule domainI)
apply (unfold list.con_defs)
apply (erule prem2 [THEN A_subset_univ [THEN subsetD],
                    THEN Pair_in_univ, THEN Inr_in_univ])
done

lemma Occ_Shift_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "l: list(nat)"
  shows "Occ_Shift(l, X) : fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (unfold Occ_fbs_dom_def)
apply (rule prem2 [THEN list.induct])
apply (rule prem1 [unfolded Occ_fbs_dom_def,
                   THEN fin_bnd_set_domain [THEN subsetD],
                   THEN PowD, THEN Occ_Shift_Nil, THEN ssubst])
apply (rule prem1 [unfolded Occ_fbs_dom_def])
apply (simp add: Occ_Shift_Cons)
apply (fold Occ_fbs_dom_def)
apply (erule Occ_shift_in_fin_bnd_set)
apply assumption
done

lemma Occ_Graft1_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "Y: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and l_list: "l: list(nat)"
  shows "Occ_Graft1(X, l, Y):
                 fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (unfold Occ_Graft1_def)
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_UnI])
apply (rule fin_bnd_set_subsetI
        [OF Occ_fbs_op_bnd_mono Diff_subset prem1])
apply (rule Occ_Shift_in_fin_bnd_set [OF prem2 l_list])
done

lemma Occ_Graft1_not_empty:
  assumes domY: "Y <= list(nat) * B"
  and not_emptyY: "Y ~= 0"
  shows "Occ_Graft1(X, l, Y) ~= 0"
apply (rule not_emptyY [THEN not_emptyE])
apply (frule domY [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (rule not_emptyI)
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])
done

lemma Occ_Graft1_in_Occ_range:
  assumes domX: "X: Occ_range(Tag, Arity)"
  and domY: "Y: Occ_range(Tag, Arity)"
  and l_list: "l: domain(X)"
  shows "Occ_Graft1(X, l, Y): Occ_range(Tag, Arity)"
apply (subgoal_tac "X <= list(nat) * Tag"
                   "Y <= list(nat) * Tag" "l: list(nat)")
prefer 2
apply (rule l_list [THEN domainE])
apply (erule subsetD [THEN SigmaD1])
apply assumption
prefer 2
apply (rule domY [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)
prefer 2
apply (rule domX [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)

apply (rule domX [THEN Occ_rangeE])
apply (rule domY [THEN Occ_rangeE])
apply (insert l_list)
apply (rule Occ_rangeI)
apply (rule_tac [5] ballI)
apply (drule_tac [5] bspec)
apply (drule_tac [6] bspec)
apply (assumption
       | rule Occ_Graft1_in_fin_bnd_set
              Occ_Graft1_not_empty
              Occ_Graft1_preserves_functionality
              Occ_Graft1_preserves_DenseTree
              Occ_Graft1_preserves_CorrectArity)+
done

lemma Occ_Graft_in_Occ_range:
  assumes finW: "W: Fin(list(nat))"
  and prem: "Incomparable(W)"
  and domW: "W <= domain(X)"
  and domX: "X: Occ_range(Tag, Arity)"
  and domY: "Y: Occ_range(Tag, Arity)"
  shows "Occ_Graft(X, W, Y): Occ_range(Tag, Arity)"
apply (rule domW [THEN rev_mp])
apply (rule prem [THEN rev_mp])
apply (rule finW [THEN Fin_induct])
apply (intro impI)
apply (rule Occ_Graft_0 [THEN ssubst])
apply (rule domX)

apply (intro impI)
apply (rule Occ_Graft_cons [THEN ssubst])
prefer 5
apply (rule Occ_Graft1_in_Occ_range)
apply (subgoal_tac "x ~: y ==> y - {x} = y")
prefer 2 apply blast
apply simp
apply (erule mp)
apply (erule Incomparable_subset)
apply blast
apply (rule domY)

apply (erule cons_subsetE)
apply (erule domainE)
apply (rule domainI)
apply (rule Occ_GraftI1)
apply assumption
apply (rule notI)
apply (erule bexE)
apply (erule DiffE)
apply (drule IncomparableD)
apply assumption
apply (erule consI2)
apply (rule consI1)
apply hypsubst
apply (erule singletonI [THEN [2] notE])

apply assumption+
apply (rule domX [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)
apply (rule domY [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)
done

lemma Occ_Graft_in_Occ_range2:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "Incomparable(W)"
  and domW: "W <= domain(X)"
  and domX: "X: Occ_range(Tag, Arity)"
  and domY: "Y: Occ_range(Tag, Arity)"
  shows "Occ_Graft(X, W, Y): Occ_range(Tag, Arity)"
apply (rule Occ_Graft_in_Occ_range)
apply (rule domW [THEN Fin_subset])
apply (rule Fin_domainI)
apply (rule Occ_range_convert_lemma [OF hcons domX])
apply (erule hind [THEN Occ_ind_cond_Occ_FinI])
apply (assumption | rule prem domW domX domY)+
done

(** subst **)
lemma def_graft_type:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  shows
   "[|
        M: Terms; N: Terms;
        Incomparable(W); W <= domain(Occ(M))
    |] ==> graft(M, W, N): Terms"
apply (unfold hsubst)
apply (rule def_Occinv_type [OF hcons hind hinv])
apply (rule Occ_Graft_in_Occ_range2 [OF hcons hind])
apply (assumption | rule hind [THEN Occ_ind_cond_Occ_in_Occ_range])+
done

lemma def_graft_0:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  and prem: "M: Terms"
  shows "graft(M, 0, N) = M"
apply (unfold hsubst)
apply (insert prem)
apply (simp only: def_Occinv_Occ [OF hcons hind hinv] Occ_Graft_0)
done

lemma def_graft_Nil:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  shows
   "[| M: Terms; N: Terms
    |] ==> graft(M, {[]}, N) = N"
apply (unfold hsubst)
apply (subgoal_tac "Occ(M) <= list(nat) * Tag"
                   "Occ(N) <= list(nat) * Tag")
apply (simp only: def_Occinv_Occ [OF hcons hind hinv] Occ_Graft_Nil)
apply (assumption | rule hind [THEN Occ_ind_cond_Occ_domain])+
done

lemma def_graft:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  shows
   "[|
        Term_cons(T, l): Terms;
        T: Tag; l: list(Terms); Arity(T) = length(l); y: Terms;
        W ~= {[]}; Incomparable(W);
        W <= domain(Occ(Term_cons(T, l)))
    |] ==> graft(Term_cons(T, l), W, y) =
         Term_cons(T, mapnth(%z r. graft(r, lists_subtree(z, W), y), l))"
apply (unfold hsubst)
apply (subgoal_tac "map(Occ, l): list(Pow(list(nat) * Tag))"
                   "Arity(T) = length(map(Occ, l))"
                   "Occ(y) <= list(nat) * Tag"
                   "Occ_Graft(Occ(Term_cons(T, l)), W, Occ(y))
                       : Occ_range(Tag, Arity)")
apply (simp add: Occ_Term_cons [OF hind hinj]
           Occ_Graft_Occ_cons mapnth_map)
apply (rule def_Occinv2 [OF hcons hind hinv, THEN trans])
prefer 5 apply (simp add: map_mapnth)
prefer 4 apply (simp add: length_mapnth)
prefer 6 apply simp
prefer 3
apply (rule nth_convert_list_type)
apply (erule mapnth_type2)
apply (simp add: nth_mapnth length_mapnth)
apply (rule ballI)
apply (rule Occ_Graft_domain)
apply (rule hind [THEN Occ_ind_cond_Occ_domain])
apply simp
apply assumption

prefer 5 apply (erule hind [THEN Occ_ind_cond_Occ_domain])
prefer 3 apply assumption
prefer 4 apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])
prefer 3 apply (rule Occ_Graft_in_Occ_range2 [OF hcons hind])
apply assumption+
apply (erule hind [THEN Occ_ind_cond_Occ_in_Occ_range])+
prefer 2 apply simp

apply (rule_tac P="%x. lists_subtree(z, W) <= x" in subst)
apply (erule_tac [2] lists_subtree_mono)
apply (simp add: lists_subtree_domain_eq Occ_subtree_Occ_cons nth_map)
done

end


chapter \<open>Pseudo-Terms\<close>

(*<*)
theory Pseudo_Term
  imports Natural_Deduction
begin
(*>*)

text \<open>Pseudo-terms are formulas that satisfy the exists-unique property
on one of their variables.\<close>

section \<open>Basic Setting\<close>

context Generic_Syntax
begin

text \<open>We choose a specific variable, out, that will represent the
"output" of pseudo-terms, i.e., the variable on which the exists-unique property holds:\<close>
abbreviation "out \<equiv> Variable 0"
text \<open>Many facts will involve pseudo-terms with only one additional "input" variable, inp:\<close>
abbreviation "inp \<equiv> Variable (Suc 0)"

(* These facts can speed up simplification: *)
lemma out_inp_distinct[simp]:
"out \<noteq> inp" "inp \<noteq> out"
"out \<noteq> xx" "out \<noteq> yy" "yy \<noteq> out" "out \<noteq> zz" "zz \<noteq> out" "out \<noteq> xx'" "xx' \<noteq> out"
   "out \<noteq> yy'" "yy' \<noteq> out" "out \<noteq> zz'" "zz' \<noteq> out"
"inp \<noteq> xx" "inp \<noteq> yy" "yy \<noteq> inp" "inp \<noteq> zz" "zz \<noteq> inp" "inp \<noteq> xx'" "xx' \<noteq> inp"
   "inp \<noteq> yy'" "yy' \<noteq> inp" "inp \<noteq> zz'" "zz' \<noteq> inp"
by auto

end (* context Generic_Syntax *)

context Deduct_with_False_Disj_Rename
begin

text \<open>Pseudo-terms over the first $n+1$ variables, i.e.,
having $n$ input variables (Variable $1$ to Variable $n$), and an output variable, out (which is
an abbreviation for Variable $0$).\<close>
definition ptrm :: "nat \<Rightarrow> 'fmla set" where
"ptrm n \<equiv> {\<sigma> \<in> fmla . Fvars \<sigma> = Variable ` {0..n} \<and> prv (exu out \<sigma>)}"

lemma ptrm[intro,simp]: "\<sigma> \<in> ptrm n \<Longrightarrow> \<sigma> \<in> fmla"
  unfolding ptrm_def by auto

lemma ptrm_1_Fvars[simp]: "\<sigma> \<in> ptrm (Suc 0) \<Longrightarrow> Fvars \<sigma> = {out,inp}"
	unfolding ptrm_def by auto

lemma ptrm_prv_exu: "\<sigma> \<in> ptrm n \<Longrightarrow> prv (exu out \<sigma>)"
  unfolding ptrm_def by auto

lemma ptrm_prv_exi: "\<sigma> \<in> ptrm n \<Longrightarrow> prv (exi out \<sigma>)"
  by (simp add: ptrm_prv_exu prv_exu_exi)

lemma nprv_ptrmE_exi:
"\<sigma> \<in> ptrm n \<Longrightarrow> nprv (insert \<sigma> F) \<psi> \<Longrightarrow>
 F \<subseteq> fmla \<Longrightarrow> finite F \<Longrightarrow>
 \<psi> \<in> fmla \<Longrightarrow> out \<notin> Fvars \<psi> \<Longrightarrow> out \<notin> \<Union> (Fvars ` F) \<Longrightarrow> nprv F \<psi>"
  apply (frule ptrm_prv_exu, drule ptrm)
  apply(rule nprv_exuE_exi[of _ out \<sigma>])
  by (auto intro!: prv_nprvI)

lemma nprv_ptrmE_uni:
"\<sigma> \<in> ptrm n \<Longrightarrow> nprv F (subst \<sigma> t1 out) \<Longrightarrow> nprv F (subst \<sigma> t2 out) \<Longrightarrow>
 nprv (insert (eql t1 t2) F) \<psi> \<Longrightarrow>
 F \<subseteq> fmla \<Longrightarrow> finite F \<Longrightarrow> \<psi> \<in> fmla \<Longrightarrow> t1 \<in> trm \<Longrightarrow> t2 \<in> trm
 \<Longrightarrow> nprv F \<psi>"
  apply (frule ptrm_prv_exu, drule ptrm)
  apply(rule nprv_exuE_uni[of _ out \<sigma> t1 t2])
  by (auto intro!: prv_nprvI)

lemma nprv_ptrmE_uni0:
"\<sigma> \<in> ptrm n \<Longrightarrow> nprv F \<sigma> \<Longrightarrow> nprv F (subst \<sigma> t out) \<Longrightarrow>
 nprv (insert (eql (Var out) t) F) \<psi> \<Longrightarrow>
 F \<subseteq> fmla \<Longrightarrow> finite F \<Longrightarrow> \<psi> \<in> fmla \<Longrightarrow> t \<in> trm
 \<Longrightarrow> nprv F \<psi>"
   by (rule nprv_ptrmE_uni[of \<sigma> _ _ "Var out" t]) auto

lemma nprv_ptrmE0_uni0:
"\<sigma> \<in> ptrm n \<Longrightarrow> \<sigma> \<in> F \<Longrightarrow> nprv F (subst \<sigma> t out) \<Longrightarrow>
 nprv (insert (eql (Var out) t) F) \<psi> \<Longrightarrow>
 F \<subseteq> fmla \<Longrightarrow> finite F \<Longrightarrow> \<psi> \<in> fmla \<Longrightarrow> t \<in> trm
 \<Longrightarrow> nprv F \<psi>"
by (rule nprv_ptrmE_uni0[of \<sigma> n _ t]) auto

section \<open>The $\forall$-$\exists$ Equivalence\<close>

text \<open>There are two natural ways to state that (unique) "output" of a pseudo-term @{term \<sigma>}
satisfies a property @{term \<phi>}:
(1) using $\exists$: there exists an "out" such that @{term \<sigma>} and @{term \<phi>} hold for it;
(2) using $\forall$: for all "out" such that @{term \<sigma>} holds for it, @{term \<phi>} holds for it as well.

We prove the well-known fact that these two ways are equivalent. (Intuitionistic
logic suffice to prove that.)\<close>

lemma ptrm_nprv_exi:
assumes \<sigma>: "\<sigma> \<in> ptrm n" and [simp]: "\<phi> \<in> fmla"
shows "nprv {\<sigma>, exi out (cnj \<sigma> \<phi>)} \<phi>"
proof-
  have [simp]: "\<sigma> \<in> fmla" using \<sigma> by simp
  define z where "z \<equiv> getFr [out] [] [\<sigma>,\<phi>]"
  have z_facts[simp]: "z \<in> var" "z \<noteq> out" "z \<notin> Fvars \<sigma>" "z \<notin> Fvars \<phi>"
  using getFr_FvarsT_Fvars[of "[out]" "[]" "[\<sigma>,\<phi>]"] unfolding z_def[symmetric] by auto
  have 0: "exi out (cnj \<sigma> \<phi>) = exi z (subst (cnj \<sigma> \<phi>) (Var z) out)"
    by(rule exi_rename, auto)
  show ?thesis
    unfolding 0
    apply(nrule r: nprv_exiE0[of z "subst (cnj \<sigma> \<phi>) (Var z) out"])
    apply(nrule2 r: nprv_ptrmE0_uni0[OF \<sigma>, of _ "Var z"])
      subgoal by (nrule r: nprv_cnjE0)
      subgoal
        apply(nrule r: nprv_clear4_4)
        apply(nrule r: nprv_clear3_3)
        apply (nrule r: nprv_cnjE0)
        apply(nrule r: nprv_clear4_4)
        apply(nrule r: nprv_clear3_1)
        apply(nrule r: nprv_eql_substE012[of "Var out" "Var z" _ \<phi> out \<phi>]) . .
qed

lemma ptrm_nprv_exi_all:
  assumes \<sigma>: "\<sigma> \<in> ptrm n" and [simp]: "\<phi> \<in> fmla"
  shows "nprv {exi out (cnj \<sigma> \<phi>)} (all out (imp \<sigma> \<phi>))"
proof-
  have [simp]: "\<sigma> \<in> fmla" using \<sigma> by simp
  show ?thesis
  apply(nrule r: nprv_allI)
  apply(nrule r: nprv_impI)
  apply(nrule r: ptrm_nprv_exi[OF \<sigma>]) .
qed

lemma ptrm_prv_exi_imp_all:
  assumes \<sigma>: "\<sigma> \<in> ptrm n" and [simp]: "\<phi> \<in> fmla"
  shows "prv (imp (exi out (cnj \<sigma> \<phi>)) (all out (imp \<sigma> \<phi>)))"
proof-
  have [simp]: "\<sigma> \<in> fmla" using \<sigma> by simp
  show ?thesis
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_impI)
  apply(nrule r: ptrm_nprv_exi_all[OF \<sigma>]) .
qed

lemma ptrm_nprv_all_imp_exi:
  assumes \<sigma>: "\<sigma> \<in> ptrm n" and [simp]: "\<phi> \<in> fmla"
  shows "nprv {all out (imp \<sigma> \<phi>)} (exi out (cnj \<sigma> \<phi>))"
proof-
  have [simp]: "\<sigma> \<in> fmla" using \<sigma> by simp
  define z where "z \<equiv> getFr [out] [] [\<sigma>,\<phi>]"
  have z_facts[simp]: "z \<in> var" "z \<noteq> out" "z \<notin> Fvars \<sigma>" "z \<notin> Fvars \<phi>"
  using getFr_FvarsT_Fvars[of "[out]" "[]" "[\<sigma>,\<phi>]"] unfolding z_def[symmetric] by auto
  show ?thesis
    apply(nrule r: nprv_ptrmE_exi[OF \<sigma>])
    apply(nrule r: nprv_exiI[of _ "cnj \<sigma> \<phi>" "Var out" out])
    apply(nrule r: nprv_allE0[of out "imp \<sigma> \<phi>" _ "Var out"])
    apply(nrule r: nprv_clear3_3)
    apply(nrule r: nprv_cnjI)
    apply(nrule r: nprv_impE01) .
qed

lemma ptrm_prv_all_imp_exi:
  assumes \<sigma>: "\<sigma> \<in> ptrm n" and [simp]: "\<phi> \<in> fmla"
  shows "prv (imp (all out (imp \<sigma> \<phi>)) (exi out (cnj \<sigma> \<phi>)))"
proof-
  have [simp]: "\<sigma> \<in> fmla" using \<sigma> by simp
  define z where "z \<equiv> getFr [out] [] [\<sigma>,\<phi>]"
  have z_facts[simp]: "z \<in> var" "z \<noteq> out" "z \<notin> Fvars \<sigma>" "z \<notin> Fvars \<phi>"
  using getFr_FvarsT_Fvars[of "[out]" "[]" "[\<sigma>,\<phi>]"] unfolding z_def[symmetric] by auto
  show ?thesis
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_impI)
  apply(nrule r: ptrm_nprv_all_imp_exi[OF \<sigma>]) .
qed

end \<comment> \<open>context @{locale Deduct_with_False_Disj_Rename }\<close>

section \<open>Instantiation\<close>

text \<open>We define the notion of instantiating the "inp" variable of a formula
(in particular, of a pseudo-term):
-- first with a term);
-- then with a pseudo-term.
\<close>

subsection \<open>Instantiation with terms\<close>

text \<open>Instantiation with terms is straightforward using substitution.
In the name of the operator, the suffix "Inp" is a reminder that we instantiate @{term \<phi>}
on its variable "inp".\<close>

context Generic_Syntax
begin

definition instInp :: "'fmla \<Rightarrow> 'trm \<Rightarrow> 'fmla" where
"instInp \<phi> t \<equiv> subst \<phi> t inp"

lemma instInp_fmla[simp,intro]:
assumes "\<phi> \<in> fmla" and "t \<in> trm"
shows "instInp \<phi> t \<in> fmla"
using assms instInp_def by auto

lemma Fvars_instInp[simp,intro]:
assumes "\<phi> \<in> fmla" and "t \<in> trm" "Fvars \<phi> = {inp}"
shows "Fvars (instInp \<phi> t) = FvarsT t"
using assms instInp_def by auto

end \<comment> \<open>context @{locale Generic_Syntax }\<close>

context Deduct_with_False_Disj_Rename
begin

lemma instInp:
assumes \<tau>: "\<tau> \<in> ptrm (Suc 0)" and [simp]: "t \<in> trm"
and [simp]: "FvarsT t = Variable ` {(Suc 0)..n}"
shows "instInp \<tau> t \<in> ptrm n"
proof-
  note Let_def[simp]
  have [simp]: "\<tau> \<in> fmla" "Fvars \<tau> = {out,inp}"
    using assms unfolding ptrm_def by auto
  have [simp]: "Fvars (instInp \<tau> t) = insert out (FvarsT t)"
     using \<tau> by (subst Fvars_instInp_ptrm_1) auto
  have 0: "exu out (instInp \<tau> t) = subst (exu out \<tau>) t inp"
    unfolding instInp_def by (subst subst_exu) auto
  have 1: "prv (exu out \<tau>)" using \<tau> unfolding ptrm_def by auto
  have "prv (exu out (instInp \<tau> t))"
  unfolding 0 by (rule prv_subst[OF _ _ _ 1], auto)
  thus ?thesis using assms unfolding ptrm_def[of n] by auto
qed

lemma instInp_0:
assumes \<tau>: "\<tau> \<in> ptrm (Suc 0)" and "t \<in> trm" and "FvarsT t = {}"
shows "instInp \<tau> t \<in> ptrm 0"
using assms by (intro instInp) auto

lemma instInp_1:
assumes \<tau>: "\<tau> \<in> ptrm (Suc 0)" and "t \<in> trm" and "FvarsT t = {inp}"
shows "instInp \<tau> t \<in> ptrm (Suc 0)"
using assms by (intro instInp) auto

subsection \<open>Instantiation with pseudo-terms\<close>

text \<open>Instantiation of a formula @{term \<phi>} with a pseudo-term @{term \<tau>} yields a formula that
could be casually written @{term [source] "\<phi>(\<tau>)"}. It states the existence of an output @{term zz} of @{term \<tau>} on which @{term \<phi>} holds.
Instead of @{term [source] "\<phi>(\<tau>)"}, we write @{term "instInpP \<phi> n \<tau>"} where @{term n} is the number of input variables of @{term \<tau>}.
In the name @{term "instInpP"}, @{term "Inp"} is as before a reminder that we instantiate @{term \<phi>} on its variable
"inp" and the suffix "P" stands for "Pseudo".\<close>

definition instInpP :: "'fmla \<Rightarrow> nat \<Rightarrow> 'fmla \<Rightarrow> 'fmla" where
"instInpP \<phi> n \<tau> \<equiv> let zz = Variable (Suc (Suc n)) in
   exi zz (cnj (subst \<tau> (Var zz) out) (subst \<phi> (Var zz) inp))"

lemma instInpP_fmla[simp, intro]:
	assumes "\<phi> \<in> fmla" and "\<tau> \<in> fmla"
	shows "instInpP \<phi> n \<tau> \<in> fmla"
	using assms unfolding instInpP_def by (auto simp: Let_def)

lemma Fvars_instInpP[simp]:
assumes "\<phi> \<in> fmla" and \<tau>: "\<tau> \<in> ptrm n"  "Variable (Suc (Suc n)) \<notin> Fvars \<phi>"
shows "Fvars (instInpP \<phi> n \<tau>) = Fvars \<phi> - {inp} \<union> Variable ` {(Suc 0)..n}"
using assms unfolding instInpP_def Let_def ptrm_def by auto

lemma Fvars_instInpP2[simp]:
assumes "\<phi> \<in> fmla" and \<tau>: "\<tau> \<in> ptrm n" and "Fvars \<phi> \<subseteq> {inp}"
shows "Fvars (instInpP \<phi> n \<tau>) = Fvars \<phi> - {inp} \<union> Variable ` {(Suc 0)..n}"
using assms by (subst Fvars_instInpP) auto

subsection \<open>Closure and compositionality properties of instantiation\<close>

text \<open>Instantiating a 1-pseudo-term with an n-pseudo-term yields an n pseudo-term:\<close>
(* This could be generalized, of course. *)
lemma instInpP1[simp,intro]:
assumes \<sigma>: "\<sigma> \<in> ptrm (Suc 0)" and \<tau>: "\<tau> \<in> ptrm n"
shows "instInpP \<sigma> n \<tau> \<in> ptrm n"
proof-
  note Let_def[simp]
  have [simp]: "\<sigma> \<in> fmla" "\<tau> \<in> fmla" "Fvars \<sigma> = {out,inp}"
   "Fvars \<tau> = Variable ` {0..n}"
    using assms unfolding ptrm_def by auto
  define zz where "zz \<equiv> Variable (Suc (Suc n))"
  have zz_facts[simp]: "zz \<in> var" "\<And>i. i \<le> n \<Longrightarrow> Variable i \<noteq> zz \<and> zz \<noteq> Variable i"
    "out \<noteq> zz" "zz \<noteq> out" "inp \<noteq> zz" "zz \<noteq> inp"
   unfolding zz_def by auto

  define x where "x \<equiv> getFr [out,inp,zz] [] [\<sigma>,\<tau>]"
  have x_facts[simp]: "x \<in> var" "x \<noteq> out" "x \<noteq> inp"
  "x \<noteq> zz" "zz \<noteq> x" "x \<notin> Fvars \<sigma>" "x \<notin> Fvars \<tau>"
  using getFr_FvarsT_Fvars[of "[out,inp,zz]" "[]" "[\<sigma>,\<tau>]"] unfolding x_def[symmetric] by auto
  have [simp]: "x \<noteq> Variable (Suc (Suc n))"
  	using x_facts(4) zz_def by auto
  define z where "z \<equiv> getFr [out,inp,zz,x] [] [\<sigma>,\<tau>]"
  have z_facts[simp]: "z \<in> var" "z \<noteq> out" "z \<noteq> inp" "z \<noteq> x" "z \<noteq> zz" "z \<notin> Fvars \<sigma>" "z \<notin> Fvars \<tau>"
  using getFr_FvarsT_Fvars[of "[out,inp,zz,x]" "[]" "[\<sigma>,\<tau>]"] unfolding z_def[symmetric] by auto

  have [simp]: "\<And>i. z = Variable i \<Longrightarrow> \<not> i \<le> n"
   and [simp]: "\<And>i. x = Variable i \<Longrightarrow> \<not> i \<le> n"
   using \<open>Fvars \<tau> = Variable ` {0..n}\<close> atLeastAtMost_iff z_facts(7) x_facts(7)
  by blast+

  have [simp]: "Fvars (instInpP \<sigma> n \<tau>) = Variable ` {0..n}"
    unfolding instInpP_def by auto
  have tt: "exi out \<tau> = exi zz (subst \<tau> (Var zz) out)"
    by (rule exi_rename) auto

  have exi_\<sigma>: "prv (exi out \<sigma>)" and exi_\<tau>: "prv (exi zz (subst \<tau> (Var zz) out))"
  	using \<sigma> \<tau> ptrm_prv_exi tt by fastforce+
  have exi_\<sigma>: "prv (exi out (subst \<sigma> (Var zz) inp))"
    using prv_subst[OF _ _ _ exi_\<sigma>, of inp "Var zz"] by auto

  have exu_\<sigma>: "prv (exu out \<sigma>)"
  	using \<sigma> ptrm_prv_exu by blast
  have exu_\<sigma>: "prv (exu out (subst \<sigma> (Var zz) inp))"
    using prv_subst[OF _ _ _ exu_\<sigma>, of inp "Var zz"] by auto

  have zz_z: "exi zz (cnj (subst \<tau> (Var zz) out) (subst \<sigma> (Var zz) inp)) =
              exi z (cnj (subst \<tau> (Var z) out) (subst \<sigma> (Var z) inp))"
  by (variousSubsts2 auto s1: exi_rename[of _ zz z] s2: subst_subst)

  have 0: "prv (exu out (instInpP \<sigma> n \<tau>))"
  apply(nrule r: nprv_prvI)
  apply(nrule2 r: nprv_exuI_exi[of _ _ _ x])
  subgoal unfolding instInpP_def Let_def
    apply(nrule r: nprv_addImpLemmaI[OF prv_exi_commute])
    apply(nrule r: nprv_addLemmaE[OF exi_\<tau>])
    apply(nrule r: nprv_exiE[of _ zz "subst \<tau> (Var zz) out"])
    apply(nrule r: nprv_clear2_2)
    apply(nrule r: nprv_exiI[of _ _ "Var zz"])
    apply(nrule r: nprv_addLemmaE[OF exi_\<sigma>])
    apply(nrule r: nprv_exiE[of _ out "subst \<sigma> (Var zz) inp"])
    apply(nrule r: nprv_clear3_2)
    apply(nrule r: nprv_exiI[of _ _ "Var out"])
      apply(variousSubsts1 auto s1: subst_subst)
    apply(nrule r: nprv_cnjI) .
  subgoal
    unfolding instInpP_def Let_def zz_def[symmetric]
    apply(nrule r: nprv_exiE0[of zz])
    apply(nrule r: nprv_clear3_2)
    apply(nrule r: nprv_cnjE0)
    apply(nrule r: nprv_clear4_3)
    unfolding zz_z
    apply(nrule r: nprv_exiE0[of z])
    apply(nrule r: nprv_clear4_4)
    apply(nrule r: nprv_cnjE0)
    apply(nrule r: nprv_clear5_3)
    apply(nrule r: nprv_cut[of _ "eql (Var z) (Var zz)"])
    subgoal by (nprover3 r1: nprv_clear4_2 r2: nprv_clear3_3
                  r3: nprv_ptrmE_uni[OF \<tau>, of _ "Var z" "Var zz"])
    subgoal
      apply(nrule r: nprv_clear5_2)
      apply(nrule r: nprv_clear4_3)
      apply(nrule2 r: nprv_eql_substE[of _ "Var zz" "Var z" \<sigma> inp])
      subgoal by (nrule r: nprv_eql_symE01)
      subgoal
        apply(nrule r: nprv_clear4_2)
        apply(nrule r: nprv_clear3_2)
        apply(nrule r: nprv_addLemmaE[OF exu_\<sigma>])
        apply(nrule r: nprv_exuE_uni[of _ out "subst \<sigma> (Var zz) inp" "Var out" "Var x"])
        apply(nrule r: nprv_eql_symE01) . . . .
	show ?thesis using 0 unfolding ptrm_def instInpP_def Let_def by auto
qed

text \<open>Term and pseudo-term instantiation compose smoothly:\<close>
lemma instInp_instInpP:
assumes \<phi>: "\<phi> \<in> fmla" "Fvars \<phi> \<subseteq> {inp}" and \<tau>: "\<tau> \<in> ptrm (Suc 0)"
and "t \<in> trm" and "FvarsT t = {}"
shows "instInp (instInpP \<phi> (Suc 0) \<tau>) t = instInpP \<phi> 0 (instInp \<tau> t)"
proof-
  define x1 and x2 where
   x12: "x1 \<equiv> Variable (Suc (Suc 0))"
        "x2 \<equiv> Variable (Suc (Suc (Suc 0)))"
  have x_facts[simp]: "x1 \<in> var" "x2 \<in> var" "x1 \<noteq> inp" "x2 \<noteq> inp"
   "x1 \<noteq> out" "out \<noteq> x1" "x2 \<noteq> out" "out \<noteq> x2" "x1 \<noteq> x2" "x2 \<noteq> x1"
   unfolding x12 by auto
  show ?thesis
  using assms unfolding instInp_def instInpP_def Let_def x12[symmetric]

  apply(subst subst_exi)
  apply(TUF simp)

  apply(variousSubsts5 auto
   s1: subst_compose_same
   s2: subst_compose_diff
   s3: exi_rename[of _ x1 x2]
   s4: subst_comp
   s5: subst_notIn[of \<phi> _ x1]
  ) .
qed

text \<open>Pseudo-term instantiation also composes smoothly with itself:\<close>
lemma nprv_instInpP_compose:
assumes [simp]: "\<chi> \<in> fmla" "Fvars \<chi> = {inp}"
and \<sigma>[simp]: "\<sigma> \<in> ptrm (Suc 0)" and \<tau>[simp]: "\<tau> \<in> ptrm 0"
shows "nprv {instInpP (instInpP \<chi> (Suc 0) \<sigma>) 0 \<tau>}
            (instInpP \<chi> 0 (instInpP \<sigma> 0 \<tau>))" (is ?A)
and
      "nprv {instInpP \<chi> 0 (instInpP \<sigma> 0 \<tau>)}
            (instInpP (instInpP \<chi> (Suc 0) \<sigma>) 0 \<tau>)" (is ?B)
proof-
  define \<chi>\<sigma> and \<sigma>\<tau> where \<chi>\<sigma>_def: "\<chi>\<sigma> \<equiv> instInpP \<chi> (Suc 0) \<sigma>" and \<sigma>\<tau>_def: "\<sigma>\<tau> \<equiv> instInpP \<sigma> 0 \<tau>"

  have [simp]: "\<sigma> \<in> fmla" "Fvars \<sigma> = {out,inp}" "\<tau> \<in> fmla" "Fvars \<tau> = {out}"
    using \<sigma> \<tau> unfolding ptrm_def by auto
  have \<chi>\<sigma>[simp]: "\<chi>\<sigma> \<in> fmla" "Fvars \<chi>\<sigma> = {inp}"
    unfolding \<chi>\<sigma>_def by auto
  have \<sigma>\<tau>[simp]:  "\<sigma>\<tau> \<in> ptrm 0" "\<sigma>\<tau> \<in> fmla" "Fvars \<sigma>\<tau> = {out}" unfolding \<sigma>\<tau>_def
    by auto
  define z where "z \<equiv> Variable (Suc (Suc 0))"
  have z_facts[simp]: "z \<in> var"
    "out \<noteq> z \<and> z \<noteq> out" "inp \<noteq> z \<and> z \<noteq> inp" "z \<notin> Fvars \<chi>" "z \<notin> Fvars \<sigma>" "z \<notin> Fvars \<tau>"
   unfolding z_def by auto
  define zz where "zz \<equiv> Variable (Suc (Suc (Suc 0)))"
  have zz_facts[simp]: "zz \<in> var"
    "out \<noteq> zz \<and> zz \<noteq> out" "inp \<noteq> zz \<and> zz \<noteq> inp" "z \<noteq> zz \<and> zz \<noteq> z"
    "zz \<notin> Fvars \<chi>" "zz \<notin> Fvars \<sigma>" "zz \<notin> Fvars \<tau>"
   unfolding zz_def z_def by auto
  define z' where "z' \<equiv> getFr [out,inp,z,zz] [] [\<chi>,\<sigma>,\<tau>]"
  have z'_facts[simp]: "z' \<in> var" "z' \<noteq> out" "z' \<noteq> inp" "z' \<noteq> z" "z \<noteq> z'" "z' \<noteq> zz" "zz \<noteq> z'"
   "z' \<notin> Fvars \<chi>""z' \<notin> Fvars \<sigma>" "z' \<notin> Fvars \<tau>"
  using getFr_FvarsT_Fvars[of "[out,inp,z,zz]" "[]" "[\<chi>,\<sigma>,\<tau>]"] unfolding z'_def[symmetric] by auto

  have \<chi>\<sigma>': "instInpP \<chi>\<sigma> 0 \<tau> = exi z' (cnj (subst \<tau> (Var z') out) (subst \<chi>\<sigma> (Var z') inp))"
    unfolding instInpP_def Let_def z_def[symmetric]
    by (auto simp: exi_rename[of _ z z'])
  have \<chi>\<sigma>z': "subst \<chi>\<sigma> (Var z') inp =
    exi zz (cnj (subst (subst \<sigma> (Var zz) out) (Var z') inp) (subst \<chi> (Var zz) inp))"
  unfolding \<chi>\<sigma>_def instInpP_def Let_def zz_def[symmetric]
  by (auto simp: subst_compose_same)
  have \<sigma>\<tau>zz: "subst \<sigma>\<tau> (Var zz) out =
     exi z (cnj (subst \<tau> (Var z) out) (subst (subst \<sigma> (Var zz) out) (Var z) inp))"
  unfolding \<sigma>\<tau>_def instInpP_def Let_def z_def[symmetric]
  by (variousSubsts2 auto s1: subst_compose_same s2: subst_compose_diff)

  have "nprv {instInpP \<chi>\<sigma> 0 \<tau>} (instInpP \<chi> 0 \<sigma>\<tau>)"
  unfolding \<chi>\<sigma>'
  apply(nrule r: nprv_exiE0)
  apply(nrule r: nprv_clear2_2)
  apply(nrule r: nprv_cnjE0)
  apply(nrule r: nprv_clear3_3)
  unfolding \<chi>\<sigma>z'
  apply(nrule r: nprv_exiE0)
  apply(nrule r: nprv_clear3_3)
  apply(nrule r: nprv_cnjE0)
  apply(nrule r: nprv_clear4_3)
  unfolding instInpP_def Let_def z_def[symmetric]
  apply(nrule r: nprv_exiI[of _ _ "Var zz"])
  apply(nrule r: nprv_cnjI)
  apply(nrule r: nprv_clear3_2)
  unfolding \<sigma>\<tau>zz
  apply(nrule r: nprv_exiI[of _ _ "Var z'"])
  apply(nrule r: nprv_cnjI) .
  thus ?A unfolding \<chi>\<sigma>_def \<sigma>\<tau>_def .

  have \<chi>\<sigma>\<tau>: "instInpP \<chi> 0 \<sigma>\<tau> = exi z' (cnj (subst \<sigma>\<tau> (Var z') out) (subst \<chi> (Var z') inp))"
  unfolding instInpP_def Let_def z_def[symmetric]
  by (auto simp: exi_rename[of _ z z'])

  have \<sigma>\<tau>z': "subst \<sigma>\<tau> (Var z') out =
   exi z (cnj (subst \<tau> (Var z) out) (subst (subst \<sigma> (Var z) inp) (Var z') out))"
  unfolding \<sigma>\<tau>_def instInpP_def Let_def z_def[symmetric]
  by (auto simp: subst_compose_same)

  have \<chi>\<sigma>z: "subst \<chi>\<sigma> (Var z) inp =
    exi zz (cnj (subst (subst \<sigma> (Var z) inp) (Var zz) out) (subst \<chi> (Var zz) inp))"
  unfolding \<chi>\<sigma>_def instInpP_def Let_def zz_def[symmetric]
  by (variousSubsts2 auto s1: subst_compose_same s2: subst_compose_diff)

  have "nprv {instInpP \<chi> 0 \<sigma>\<tau>} (instInpP \<chi>\<sigma> 0 \<tau>)"
  unfolding \<chi>\<sigma>\<tau>
  apply(nrule r: nprv_exiE0)
  apply(nrule r: nprv_clear2_2)
  apply(nrule r: nprv_cnjE0)
  apply(nrule r: nprv_clear3_3)
  unfolding \<sigma>\<tau>z'
  apply(nrule r: nprv_exiE0)
  apply(nrule r: nprv_clear3_2)
  apply(nrule r: nprv_cnjE0)
  apply(nrule r: nprv_clear4_3)
  unfolding instInpP_def Let_def z_def[symmetric]
  apply(nrule r: nprv_exiI[of _ _ "Var z"])
  apply(nrule r: nprv_cnjI)
  unfolding \<chi>\<sigma>z
  apply(nrule r: nprv_exiI[of _ _ "Var z'"])
  apply(nrule r: nprv_cnjI) .
  thus ?B unfolding \<chi>\<sigma>_def \<sigma>\<tau>_def .
qed

lemma prv_instInpP_compose:
assumes [simp]: "\<chi> \<in> fmla" "Fvars \<chi> = {inp}"
and \<sigma>[simp]: "\<sigma> \<in> ptrm (Suc 0)" and \<tau>[simp]: "\<tau> \<in> ptrm 0"
shows "prv (imp (instInpP (instInpP \<chi> (Suc 0) \<sigma>) 0 \<tau>)
                (instInpP \<chi> 0 (instInpP \<sigma> 0 \<tau>)))" (is ?A)
and
      "prv (imp (instInpP \<chi> 0 (instInpP \<sigma> 0 \<tau>))
                (instInpP (instInpP \<chi> (Suc 0) \<sigma>) 0 \<tau>))" (is ?B)
and
      "prv (eqv (instInpP (instInpP \<chi> (Suc 0) \<sigma>) 0 \<tau>)
                (instInpP \<chi> 0 (instInpP \<sigma> 0 \<tau>)))" (is ?C)
proof-
  have [simp]: "\<sigma> \<in> fmla" "Fvars \<sigma> = {out,inp}" "\<tau> \<in> fmla" "Fvars \<tau> = {out}"
  using \<sigma> \<tau> unfolding ptrm_def by auto
  show ?A ?B by (intro nprv_prvI nprv_impI nprv_instInpP_compose, auto)+
  thus ?C by (intro prv_eqvI) auto
qed

section \<open>Equality between Pseudo-Terms and Terms\<close>

text \<open>Casually, the equality between a pseudo-term @{term \<tau>} and a term @{term t} can
be written as $\vdash\tau = t$. This is in fact the (provability of)
the instantiation of @{term \<tau>} with @{term t} on @{term \<tau>}'s output variable out. Indeed, this
formula says that the unique entity denoted by @{term \<tau>} is exactly @{term t}.\<close>

definition prveqlPT :: "'fmla \<Rightarrow> 'trm \<Rightarrow> bool" where
"prveqlPT \<tau> t \<equiv> prv (subst \<tau> t out)"

text \<open>We prove that term--pseudo-term equality indeed acts like an equality,
in that it satisfies the substitutivity principle (shown only in the
particular case of formula-input instantiation).\<close>

lemma prveqlPT_nprv_instInp_instInpP:
assumes[simp]: "\<phi> \<in> fmla" and f: "Fvars \<phi> \<subseteq> {inp}" and \<tau>: "\<tau> \<in> ptrm 0"
and [simp]: "t \<in> trm" "FvarsT t = {}"
and \<tau>t: "prveqlPT \<tau> t"
shows "nprv {instInpP \<phi> 0 \<tau>} (instInp \<phi> t)"
proof-
  have [simp]: "\<tau> \<in> fmla" "Fvars \<tau> = {out}" using \<tau> unfolding ptrm_def by auto
  define zz where "zz \<equiv> Variable (Suc (Suc 0))"
  have zz_facts[simp]: "zz \<in> var"
    "out \<noteq> zz \<and> zz \<noteq> out" "inp \<noteq> zz \<and> zz \<noteq> inp" "zz \<notin> Fvars \<tau>" "zz \<notin> Fvars \<phi>"
   unfolding zz_def using f by auto

  note lemma1 = nprv_addLemmaE[OF \<tau>t[unfolded prveqlPT_def]]

  show ?thesis unfolding instInpP_def Let_def zz_def[symmetric] instInp_def
  apply(nrule r: lemma1)
  apply(nrule r: nprv_exiE0[of zz])
  apply(nrule r: nprv_clear3_3)
  apply(nrule r: nprv_cnjE0)
  apply(nrule r: nprv_clear4_3)
  apply(nrule r: nprv_ptrmE_uni[OF \<tau>, of _ t "Var zz"])
  apply(nrule r: nprv_clear4_2)
  apply(nrule r: nprv_clear3_3)
  apply(nrule r: nprv_eql_substE012[of t "Var zz" _ \<phi> inp]) .
qed

lemma prveqlPT_prv_instInp_instInpP:
assumes"\<phi> \<in> fmla" and f: "Fvars \<phi> \<subseteq> {inp}" and \<tau>: "\<tau> \<in> ptrm 0"
and "t \<in> trm" "FvarsT t = {}"
and \<tau>t: "prveqlPT \<tau> t"
shows "prv (imp (instInpP \<phi> 0 \<tau>) (instInp \<phi> t))"
using assms by (intro nprv_prvI nprv_impI prveqlPT_nprv_instInp_instInpP) auto

lemma prveqlPT_nprv_instInpP_instInp:
assumes[simp]: "\<phi> \<in> fmla" and f: "Fvars \<phi> \<subseteq> {inp}" and \<tau>: "\<tau> \<in> ptrm 0"
and [simp]: "t \<in> trm" "FvarsT t = {}"
and \<tau>t: "prveqlPT \<tau> t"
shows "nprv {instInp \<phi> t} (instInpP \<phi> 0 \<tau>)"
proof-
  have [simp]: "\<tau> \<in> fmla" "Fvars \<tau> = {out}" using \<tau> unfolding ptrm_def by auto
  define zz where "zz \<equiv> Variable (Suc (Suc 0))"
  have zz_facts[simp]: "zz \<in> var"
    "out \<noteq> zz \<and> zz \<noteq> out" "inp \<noteq> zz \<and> zz \<noteq> inp" "zz \<notin> Fvars \<tau>" "zz \<notin> Fvars \<phi>"
   unfolding zz_def using f by auto

  note lemma1 = nprv_addLemmaE[OF \<tau>t[unfolded prveqlPT_def]]

  show ?thesis unfolding instInpP_def Let_def zz_def[symmetric] instInp_def
  by (nprover3 r1: lemma1 r2: nprv_exiI[of _ _ t] r3: nprv_cnjI)
qed

lemma prveqlPT_prv_instInpP_instInp:
assumes"\<phi> \<in> fmla" and f: "Fvars \<phi> \<subseteq> {inp}" and \<tau>: "\<tau> \<in> ptrm 0"
and "t \<in> trm" "FvarsT t = {}"
and \<tau>t: "prveqlPT \<tau> t"
shows "prv (imp (instInp \<phi> t) (instInpP \<phi> 0 \<tau>))"
using assms by (intro nprv_prvI nprv_impI prveqlPT_nprv_instInpP_instInp) auto

lemma prveqlPT_prv_instInp_eqv_instInpP:
assumes"\<phi> \<in> fmla" and f: "Fvars \<phi> \<subseteq> {inp}" and \<tau>: "\<tau> \<in> ptrm 0"
and "t \<in> trm" "FvarsT t = {}"
and \<tau>t: "prveqlPT \<tau> t"
shows "prv (eqv (instInpP \<phi> 0 \<tau>) (instInp \<phi> t))"
using assms prveqlPT_prv_instInp_instInpP prveqlPT_prv_instInpP_instInp
by (intro prv_eqvI) auto

end \<comment> \<open>context @{locale Deduct_with_False_Disj_Rename}\<close>

(*<*)
end
(*>*)


theory L1
  imports RTC
begin

section \<open>Syntax\<close>

type_synonym loc = nat

datatype type = Num | Bool | Unit

datatype type_loc = Numref

datatype binop = Plus (".+") | Geq (".\<ge>")

datatype exp = Number int ("#_" [1000] 999)
  | Boolean bool ("$_" [1000] 999)
  | Binop exp binop exp ("_ _. _" [64, 1000, 64] 62)
  | Cond exp exp exp ("if _ then _ else _ fi" [0, 0, 0] 62)
  | Assign loc exp ("l_ := _" [0, 65] 62)
  | Deref loc ("!l_" [1000] 999)
  | Skip ("skip")
  | Seq exp exp ("_; _" [61, 59] 60)
  | While exp exp ("while _ do _od" [0, 0] 62)

abbreviation true :: exp where "true \<equiv> $True"

abbreviation false :: exp where "false \<equiv> $False"

section \<open>Operational Semantics\<close>

fun is_value :: "exp \<Rightarrow> bool" where
  "is_value (Number _)  = True"
| "is_value (Boolean b) = True"
| "is_value Skip = True"
| "is_value _ = False"

type_synonym store = "loc \<Rightarrow> int option"

inductive sem :: "exp * store \<Rightarrow> exp * store \<Rightarrow> bool" (infix "\<Rightarrow>" 50) where
  plus:    "(#n1 .+. #n2, s) \<Rightarrow> (#(n1 + n2), s)"
| geq:     "(#n1 .\<ge>. #n2, s) \<Rightarrow> ($(n1 \<ge> n2), s)"
| op1:     "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (e1 bop. e2, s) \<Rightarrow> (e1' bop. e2, s')"
| op2:     "is_value v \<Longrightarrow> (e2, s) \<Rightarrow> (e2', s') \<Longrightarrow> (v bop. e2, s) \<Rightarrow> (v bop. e2', s')"
| deref:   "i \<in> dom s \<Longrightarrow> s i = Some n \<Longrightarrow> (!li, s) \<Rightarrow> (#n, s)"
| assign1: "i \<in> dom s \<Longrightarrow> (l(i) := #n, s) \<Rightarrow> (skip, s(i \<mapsto> n))"
| assign2: "(e, s) \<Rightarrow> (e', s') \<Longrightarrow> (l(i) := e, s) \<Rightarrow> (l(i) := e', s')"
| seq1:    "(skip; e2, s) \<Rightarrow> (e2, s)"
| seq2:    "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (e1; e2, s) \<Rightarrow> (e1'; e2, s')"
| if1:     "(if true then e2 else e3 fi, s) \<Rightarrow> (e2, s)"
| if2:     "(if false then e2 else e3 fi, s) \<Rightarrow> (e3, s)"
| if3:     "(e1, s) \<Rightarrow> (e1', s') \<Longrightarrow> (if e1 then e2 else e3 fi, s) \<Rightarrow> (if e1' then e2 else e3 fi, s')"
| while:   "(while e1 do e2 od, s) \<Rightarrow> (if e1 then (e2; while e1 do e2 od) else skip fi, s)"

declare sem.intros[simp, intro!]

inductive_cases sem_elims [elim!]:
  "(skip, s) \<Rightarrow> (e', s')"
  "(#n, s) \<Rightarrow> (e', s')"
  "($b, s) \<Rightarrow> (e', s')"
  "(e1 .+. e2, s) \<Rightarrow> (e', s')"
  "(e1 .\<ge>. e2, s) \<Rightarrow> (e', s')"
  "(e1 bop. e2, s) \<Rightarrow> (e', s')"
  "(!l(i), s) \<Rightarrow> (e', s')"
  "(l(i) := e, s) \<Rightarrow> (e', s')"
  "(e1; e2, s) \<Rightarrow> (e', s')"
  "(if e1 then e2 else e3 fi, s) \<Rightarrow> (e', s')"
  "(while e1 do e2 od, s) \<Rightarrow> (e', s')"

abbreviation sem_rtc :: "exp * store \<Rightarrow> exp * store \<Rightarrow> bool" (infix "\<Rightarrow>\<^sup>*" 50) where
  "x \<Rightarrow>\<^sup>* y \<equiv> rtc sem x y"

section \<open>Typing \<close>

type_synonym type_env = "nat \<Rightarrow> type_loc option"

inductive typing :: "type_env \<Rightarrow> exp \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ : _" [50, 50, 50] 50) where
  Tnum:     "\<Gamma> \<turnstile> #n : Num"
| Tbool:    "\<Gamma> \<turnstile> $b : Bool"
| Top_plus: "\<Gamma> \<turnstile> e1 : Num \<Longrightarrow> \<Gamma> \<turnstile> e2 : Num \<Longrightarrow> \<Gamma> \<turnstile> e1 .+. e2 : Num"
| Top_geq:  "\<Gamma> \<turnstile> e1 : Num \<Longrightarrow> \<Gamma> \<turnstile> e2 : Num \<Longrightarrow> \<Gamma> \<turnstile> e1 .\<ge>. e2 : Bool"
| Tif:      "\<Gamma> \<turnstile> e1 : Bool \<Longrightarrow> \<Gamma> \<turnstile> e2 : T \<Longrightarrow> \<Gamma> \<turnstile> e3 : T \<Longrightarrow> \<Gamma> \<turnstile> if e1 then e2 else e3 fi : T"
| Tassign:  "\<Gamma> i = Some Numref \<Longrightarrow> \<Gamma> \<turnstile> e : Num \<Longrightarrow> \<Gamma> \<turnstile> l(i) := e : Unit"
| Tderef:   "\<Gamma> i = Some Numref \<Longrightarrow> \<Gamma> \<turnstile> !l(i) : Num"
| Tskip:    "\<Gamma> \<turnstile> skip : Unit"
| Tseq:     "\<Gamma> \<turnstile> e1 : Unit \<Longrightarrow> \<Gamma> \<turnstile> e2 : T \<Longrightarrow> \<Gamma> \<turnstile> e1; e2 : T"
| Twhile:   "\<Gamma> \<turnstile> e1 : Bool \<Longrightarrow> \<Gamma> \<turnstile> e2 : Unit \<Longrightarrow> \<Gamma> \<turnstile> while e1 do e2 od : Unit"

declare typing.intros[simp, intro!]

inductive_cases type_elims[elim!]:
  "\<Gamma> \<turnstile> #n : T"
  "\<Gamma> \<turnstile> $b : T"
  "\<Gamma> \<turnstile> e1 .+. e2 : T"
  "\<Gamma> \<turnstile> e1 .\<ge>. e2 : T"
  "\<Gamma> \<turnstile> !l(i) : T"
  "\<Gamma> \<turnstile> l(i) := e : T"
  "\<Gamma> \<turnstile> e1; e2 : T"
  "\<Gamma> \<turnstile> skip : T"
  "\<Gamma> \<turnstile> if e1 then e2 else e3 fi : T"
  "\<Gamma> \<turnstile> while e1 do e2 od : T"

section \<open>Properties about L1\<close>

lemma [dest]: "is_value e \<Longrightarrow> \<forall>s. \<not> (\<exists>e' s'. (e, s) \<Rightarrow> (e', s'))"
  by (induct e, auto)

theorem determinacy:
  assumes "(e, s) \<Rightarrow> (e1, s1)" "(e, s) \<Rightarrow> (e2, s2)"
  shows "(e1, s1) = (e2, s2)"
  using assms by (induction arbitrary: e2 rule: sem.induct; (blast | clarsimp))

theorem preservation:
  assumes "\<Gamma> \<turnstile> e : T" "dom \<Gamma> \<subseteq> dom s" "(e, s) \<Rightarrow> (e', s')"
  shows   "\<Gamma> \<turnstile> e' : T \<and> dom \<Gamma> \<subseteq> dom s'"
  using assms by (induction arbitrary: e' rule: typing.induct) (blast | (erule sem_elims; force) | fastforce)+

corollary pres_rtc:
  assumes "(e, s) \<Rightarrow>\<^sup>* (e', s')" "\<Gamma> \<turnstile> e : T" "dom \<Gamma> \<subseteq> dom s"
  shows   "\<Gamma> \<turnstile> e' : T \<and> dom \<Gamma> \<subseteq> dom s'"
  using assms by (induction rule: rtc_induct, simp) (drule preservation, simp+)

lemma [dest]: "\<Gamma> \<turnstile> e : Num \<Longrightarrow> is_value e \<Longrightarrow> \<exists>n. e = #n"
  by (induction e) auto

lemma [dest]: "\<Gamma> \<turnstile> e : Bool \<Longrightarrow> is_value e \<Longrightarrow> \<exists>n. e = Boolean n"
  by (induction e) auto

lemma [dest]: "\<Gamma> \<turnstile> e : Unit \<Longrightarrow> is_value e \<Longrightarrow> e = skip"
  by (induction e) auto

lemma [dest]: "\<Gamma> \<turnstile> e1 : Bool \<Longrightarrow> is_value e1 \<Longrightarrow> \<exists>e' s'. (if e1 then e2 else e3 fi, s) \<Rightarrow> (e', s')"
  by (induct e1, auto) (case_tac x, auto)

theorem progress[intro]:
  assumes "\<Gamma> \<turnstile> e : T" "dom \<Gamma> \<subseteq> dom s"
  shows   "is_value e \<or> (\<exists>e' s'. (e, s) \<Rightarrow> (e', s'))"
  using assms by (induction rule: typing.induct; (blast | simp))

corollary safety:
  assumes "\<Gamma> \<turnstile> e : T" "dom \<Gamma> \<subseteq> dom s" "(e, s) \<Rightarrow>\<^sup>* (e', s')"
  shows   "is_value e' \<or> (\<exists>e'' s''. (e', s') \<Rightarrow> (e'', s''))"
  by (metis assms pres_rtc progress)

theorem uniqueness:
  assumes "\<Gamma> \<turnstile> e : T" "\<Gamma> \<turnstile> e : T'"
  shows   "T = T'"
  using assms by (induction rule: typing.induct) auto

end


(*  Title:      ZF/Resid/Redex.thy
    Author:     Ole Rasmussen, University of Cambridge
*)

theory Redex imports Main begin
consts
  redexes     :: i

datatype
  "redexes" = Var ("n \<in> nat")
            | Fun ("t \<in> redexes")
            | App ("b \<in> bool","f \<in> redexes", "a \<in> redexes")

consts
  Ssub  :: "i"
  Scomp :: "i"
  Sreg  :: "i"

abbreviation
  Ssub_rel  (infixl "<==" 70) where
  "a<==b == <a,b> \<in> Ssub"

abbreviation
  Scomp_rel  (infixl "~" 70) where
  "a ~ b == <a,b> \<in> Scomp"

abbreviation
  "regular(a) == a \<in> Sreg"

consts union_aux        :: "i=>i"
primrec (*explicit lambda is required because both arguments of "un" vary*)
  "union_aux(Var(n)) =
     (\<lambda>t \<in> redexes. redexes_case(%j. Var(n), %x. 0, %b x y.0, t))"

  "union_aux(Fun(u)) =
     (\<lambda>t \<in> redexes. redexes_case(%j. 0, %y. Fun(union_aux(u)`y),
                                  %b y z. 0, t))"

  "union_aux(App(b,f,a)) =
     (\<lambda>t \<in> redexes.
        redexes_case(%j. 0, %y. 0,
                     %c z u. App(b or c, union_aux(f)`z, union_aux(a)`u), t))"

definition
  union  (infixl "un" 70) where
  "u un v == union_aux(u)`v"

notation (xsymbols)
  union  (infixl "\<squnion>" 70) and
  Ssub_rel  (infixl "\<Longleftarrow>" 70) and
  Scomp_rel  (infixl "\<sim>" 70)

inductive
  domains       "Ssub" \<subseteq> "redexes*redexes"
  intros
    Sub_Var:     "n \<in> nat ==> Var(n)<== Var(n)"
    Sub_Fun:     "[|u<== v|]==> Fun(u)<== Fun(v)"
    Sub_App1:    "[|u1<== v1; u2<== v2; b \<in> bool|]==>
                     App(0,u1,u2)<== App(b,v1,v2)"
    Sub_App2:    "[|u1<== v1; u2<== v2|]==> App(1,u1,u2)<== App(1,v1,v2)"
  type_intros    redexes.intros bool_typechecks

inductive
  domains       "Scomp" \<subseteq> "redexes*redexes"
  intros
    Comp_Var:    "n \<in> nat ==> Var(n) ~ Var(n)"
    Comp_Fun:    "[|u ~ v|]==> Fun(u) ~ Fun(v)"
    Comp_App:    "[|u1 ~ v1; u2 ~ v2; b1 \<in> bool; b2 \<in> bool|]
                  ==> App(b1,u1,u2) ~ App(b2,v1,v2)"
  type_intros    redexes.intros bool_typechecks

inductive
  domains       "Sreg" \<subseteq> redexes
  intros
    Reg_Var:     "n \<in> nat ==> regular(Var(n))"
    Reg_Fun:     "[|regular(u)|]==> regular(Fun(u))"
    Reg_App1:    "[|regular(Fun(u)); regular(v) |]==>regular(App(1,Fun(u),v))"
    Reg_App2:    "[|regular(u); regular(v) |]==>regular(App(0,u,v))"
  type_intros    redexes.intros bool_typechecks

declare redexes.intros [simp]

(* ------------------------------------------------------------------------- *)
(*    Specialisation of comp-rules                                           *)
(* ------------------------------------------------------------------------- *)

lemmas compD1 [simp] = Scomp.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas compD2 [simp] = Scomp.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas regD [simp] = Sreg.dom_subset [THEN subsetD]

(* ------------------------------------------------------------------------- *)
(*    Equality rules for union                                               *)
(* ------------------------------------------------------------------------- *)

lemma union_Var [simp]: "n \<in> nat ==> Var(n) un Var(n)=Var(n)"
by (simp add: union_def)

lemma union_Fun [simp]: "v \<in> redexes ==> Fun(u) un Fun(v) = Fun(u un v)"
by (simp add: union_def)

lemma union_App [simp]:
     "[|b2 \<in> bool; u2 \<in> redexes; v2 \<in> redexes|]
      ==> App(b1,u1,v1) un App(b2,u2,v2)=App(b1 or b2,u1 un u2,v1 un v2)"
by (simp add: union_def)

lemma or_1_right [simp]: "a or 1 = 1"
by (simp add: or_def cond_def)

lemma or_0_right [simp]: "a \<in> bool \<Longrightarrow> a or 0 = a"
by (simp add: or_def cond_def bool_def, auto)

declare Ssub.intros [simp]
declare bool_typechecks [simp]
declare Sreg.intros [simp]
declare Scomp.intros [simp]

declare Scomp.intros [intro]

inductive_cases [elim!]:
  "regular(App(b,f,a))"
  "regular(Fun(b))"
  "regular(Var(b))"
  "Fun(u) ~ Fun(t)"
  "u ~ Fun(t)"
  "u ~ Var(n)"
  "u ~ App(b,t,a)"
  "Fun(t) ~ v"
  "App(b,f,a) ~ v"
  "Var(n) ~ u"

(* ------------------------------------------------------------------------- *)
(*    comp proofs                                                            *)
(* ------------------------------------------------------------------------- *)

lemma comp_refl [simp]: "u \<in> redexes ==> u ~ u"
by (erule redexes.induct, blast+)

lemma comp_sym: "u ~ v ==> v ~ u"
by (erule Scomp.induct, blast+)

lemma comp_sym_iff: "u ~ v \<longleftrightarrow> v ~ u"
by (blast intro: comp_sym)

lemma comp_trans [rule_format]: "u ~ v ==> \<forall>w. v ~ w\<longrightarrow>u ~ w"
by (erule Scomp.induct, blast+)

(* ------------------------------------------------------------------------- *)
(*   union proofs                                                            *)
(* ------------------------------------------------------------------------- *)

lemma union_l: "u ~ v ==> u <== (u un v)"
apply (erule Scomp.induct)
apply (erule_tac [3] boolE, simp_all)
done

lemma union_r: "u ~ v ==> v <== (u un v)"
apply (erule Scomp.induct)
apply (erule_tac [3] c = b2 in boolE, simp_all)
done

lemma union_sym: "u ~ v ==> u un v = v un u"
by (erule Scomp.induct, simp_all add: or_commute)

(* ------------------------------------------------------------------------- *)
(*      regular proofs                                                       *)
(* ------------------------------------------------------------------------- *)

lemma union_preserve_regular [rule_format]:
     "u ~ v ==> regular(u)\<longrightarrow>regular(v)\<longrightarrow>regular(u un v)"
  by (erule Scomp.induct, auto)

end