Require Export SpecializedCategory.
Require Import Common.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section DCategory.
  Variable O : Type.

  Local Ltac simpl_eq := subst_body; hnf in *; simpl in *; intros; destruct_type @inhabited; simpl in *;
    repeat constructor;
      repeat subst;
        auto;
          simpl_transitivity.

  Let DiscreteCategory_Morphism (s d : O) := s = d.

  Definition DiscreteCategory_Compose (s d d' : O) (m : DiscreteCategory_Morphism d d') (m' : DiscreteCategory_Morphism s d) :
    DiscreteCategory_Morphism s d'.
    simpl_eq.
  Defined.

  Definition DiscreteCategory_Identity o : DiscreteCategory_Morphism o o.
    simpl_eq.
  Defined.

  Global Arguments DiscreteCategory_Compose [s d d'] m m' /.
  Global Arguments DiscreteCategory_Identity o /.

  Definition DiscreteCategory : @SpecializedCategory O.
    refine (@Build_SpecializedCategory _
                                       DiscreteCategory_Morphism
                                       DiscreteCategory_Identity
                                       DiscreteCategory_Compose
                                       _
                                       _
                                       _);
    abstract (
        unfold DiscreteCategory_Compose, DiscreteCategory_Identity;
        simpl_eq
      ).
  Defined.
End DCategory.


(** * RIS.transducer : definition and properties of the binding transducer. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Export stacks words.

Section s.
  Context {atom : Set}{𝐀 : Atom atom}.
  Context {X : Set} {𝐗 : Alphabet 𝐀 X}.

(** * Transducer *)
(** ** Definition *)
(** The predicate [s ⊣ l1 | l2 ↦ s'] encodes the transition function of the transducer. It holds when there exists a transition in the transducer from state [s] to state [s'] labelled with letters [l1|l2]. *)
Definition step (s : stack) (l1 l2 : letter) (s' : stack) :=
  match (l1,l2) with
  | (⟨a,⟨b) => s' = (a,b)::s
  | (a⟩,b⟩) => (s ⊨ a ↦ b) /\ s' = s ⊖ (a,b)
  | (var x,var y) => s' = s /\ exists p, y = p∙x /\ forall a, a ∈ ⌊x⌋ -> s ⊨ a ↦ p∙a
  | _ => False
  end.
Notation " s ⊣ l1 | l2 ↦ s' " := (step s l1 l2 s') (at level 80).

(** The predicate [s ⊣ u | v ⤅ s'] encodes paths in the transducer. It holds when there exists a path in the transducer from state [s] to state [s'] labelled with the words [u|v]. *)
Reserved Notation " s ⊣ u | v ⤅ s' " (at level 80).
Inductive path : word -> word -> stack -> stack -> Prop :=
| pathϵ s : s ⊣ [] | [] ⤅ s
| pathl s2 u v l1 l2 s1 s3 :
    s1 ⊣ l1 | l2 ↦ s2 -> s2 ⊣ u | v ⤅ s3 -> s1 ⊣ l1::u | l2::v ⤅ s3
where " s ⊣ u | v ⤅ s' " := (path u v s s').
Hint Constructors path.

(** ** The function [δt]: computing a path in the transducer *)

(** [compatible s u v] returns [true] if and only if there exists [s'] such that [s⊣u|v⤅s'].*)
Fixpoint compatible s u v :=
  match (u,v) with
  | ([],[]) => true
  | ([],_) | (_,[]) => false
  | (⟨a::u,⟨b::v)=> compatible ((a,b)::s) u v
  | (a⟩::u,b⟩::v)=>
    if (pairedb s a b)
    then compatible (s⊖(a,b)) u v
    else false
  | (var x::u,var y::v)=>
    match var_perm' ⌊x⌋ s with
    | None => false
    | Some p => (p∙x =?= y)&&(compatible s u v)
    end
  | (_::_,_::_) => false
  end.

(** If [s⊣u|v⤅s'], then [δt s u v] returns [s']. Otherwise, [δt s u v] returns [[]]. This implies that there is at most one path from [s] labelled with [u|v]. *)
Fixpoint δt s u v :=
  match (u,v) with
  | ([],[]) => s
  | ([],_) | (_,[]) => []
  | (⟨a::u,⟨b::v)=> δt ((a,b)::s) u v
  | (a⟩::u,b⟩::v)=>
    if (pairedb s a b)
    then δt (s⊖(a,b)) u v
    else []
  | (var x::u,var y::v)=>
    match var_perm' ⌊x⌋ s with
    | None => []
    | Some p =>
      if (p∙x =?= y)
      then δt s u v
      else []
    end
  | (_::_,_::_) => []
  end.

Ltac case_var s x y :=
  let p := fresh "p" in
  let e := fresh "e" in
  case_eq (var_perm' ⌊x⌋ s);
  [intros p e;destruct_eqX (p∙x) y|intros e].

(** There is a path from [s1] to [s2] labelled with [u|v] if and only if [u,v] is compatible with [s1] and [s2] is [δt s1 u v]. *)
Theorem δt_compatible_spec s1 u v s2 :
  δt s1 u v = s2 /\ compatible s1 u v = true <-> s1 ⊣ u|v ⤅ s2.
Proof.
  revert v s1 s2;induction u as [|[a|a|x] u];intros [|[b|b|y] v] s1 s2;simpl;
    try (now split;intro h;inversion h;auto).
  - split.
    + intros (->&_);auto.
    + intro P;inversion P;split;reflexivity.
  - rewrite IHu;split;intro p.
    + eapply pathl;eauto;reflexivity.
    + inversion p;subst.
      unfold step in H5;subst;auto.
  - case_paired s1 a b.
    + rewrite IHu;split;intro P.
      * eapply pathl;eauto;split;auto.
      * inversion P;subst.
        destruct H5 as (h&->);auto.
    + split;[intros (_&F);discriminate|].
      intro P;inversion P;subst.
      destruct H5 as (F&_);tauto.
  - case_var s1 x y.
    + subst;simpl.
      rewrite IHu;split;intro P.
      * eapply pathl;eauto.
        split;[reflexivity|].
        exists p;split;auto.
        intros a Ia;apply (var_perm'_Some e Ia).
      * inversion P as [|? ? ? ? ? ? ? hs P'];subst.
         destruct hs as (->&_);tauto.
    + split;[intros (_&F);discriminate|].
      intro P;inversion P as [|? ? ? ? ? ? ? hs P'];subst;exfalso.
      destruct hs as (->&q&->&h).
      apply var_perm'_spec in h as (p'&e'&h).
      rewrite e in e';inversion e';subst;clear e'.
      apply N,support_eq_action_eq;intros a Ia;symmetry;apply h,Ia.
    + split;[intros (_&F);discriminate|].
      intro P;inversion P as [|? ? ? ? ? ? ? hs P'];subst;exfalso.
      destruct hs as (->&q&->&h).
      apply var_perm'_spec in h as (p'&e'&_).
      rewrite e in e';discriminate.
Qed.

Corollary δt_path s u v : compatible s u v = true <-> s ⊣ u|v ⤅ δt s u v.
Proof. rewrite <- δt_compatible_spec;tauto. Qed.

(** When [u,v] is not compatible with [s], we set [δt s u v] to be the empty list. This choice of a default value is arbitrary. *)
Lemma compatible_false s u v : compatible s u v = false -> δt s u v = [].
Proof.
  revert s v;induction u as [|[a|a|x] u];intros s [|[b|b|y] v];simpl;discriminate || auto.
  - destruct (pairedb s a b);auto.
  - case_var s x y;auto.
Qed.

(** ** Elementary properties *)
(** It is straightforward that a path of length one is exactly a step. *)
Remark path_single_letter s1 l1 l2 s2 :
  s1 ⊣ [l1] | [l2] ⤅ s2 <-> s1 ⊣ l1 | l2 ↦ s2.
Proof.
  split;intro P;[inversion P as [|? ? ? ? ? ? ? h1 h2];inversion h2;subst;apply h1
                |apply (pathl P),pathϵ].
Qed.

(** The transition predicate commutes with permutation actions. *)
Fact nom_step p s1 s2 l1 l2 :
  s1 ⊣ l1 | l2 ↦ s2 -> p ∙ s1 ⊣ p∙l1 | p∙l2 ↦ p∙s2.
Proof.
  destruct l1 as [a|a|x];destruct l2 as [b|b|y];unfold step;simpl;auto.
  - intros ->;reflexivity.
  - replace (p∙a,p∙b) with (p∙(a,b)) by reflexivity.
    intros (P&->);setoid_rewrite rmfst_perm.
    rewrite act_pinv_p;split;auto.
    apply paired_perm;setoid_rewrite act_pinv_p;auto.
  - intros (->&q&->&P);split;auto.
    exists (p++q++p∗);split.
    + repeat rewrite action_compose.
      rewrite app_ass,app_ass,perm_pinv_p_eq_nil,app_nil_r;auto.
    + intro a;rewrite support_action,In_act_lists.
      intro I;apply P in I;clear P.
      apply paired_perm.
      rewrite action_compose,<-app_ass,perm_pinv_p_eq_nil;simpl;rewrite <- action_compose;auto.
Qed.

Corollary nom_path p s1 s2 u v :
  s1 ⊣ u | v ⤅ s2 -> p ∙ s1 ⊣ p∙u | p∙v ⤅ p∙s2.
Proof.
  intro P;induction P;simpl;auto.
  apply nom_step with (p:=p) in H.
  pose proof (pathl H IHP) as IH;apply IH.
Qed.

Corollary nom_compatible p s u v :
  compatible s u v = compatible (p∙s) (p∙u) (p∙v).
Proof.
  apply eq_iff_eq_true.
  cut (forall p s u v, compatible s u v = true -> compatible (p ∙ s) (p ∙ u) (p ∙ v) = true).
  - intros h;split;auto.
    intro E;apply (h (p∗)) in E.
    repeat rewrite act_pinv_p in E;auto.
  - clear;intros p s u v E.
    apply δt_path in E;apply nom_path with (p:=p) in E.
    apply δt_compatible_spec in E;tauto.
Qed.

Corollary nom_δt p s u v :
  p∙(δt s u v) = δt (p∙s) (p∙u) (p∙v).
Proof.
  case_eq (compatible s u v).
  - rewrite δt_path;intro P.
    apply nom_path with (p:=p) in P.
    apply δt_compatible_spec in P as (P&_);auto.
  - intro h;rewrite (compatible_false h).
    rewrite nom_compatible with (p:=p) in h;rewrite (compatible_false h).
    reflexivity.
Qed.

(** If [s] is accepting, then for any word [u] there is an accepting stack [s'] such that [s ⊣ u | u ⤅ s']. *)
Lemma path_id_Accepting u : forall s, s ✓ -> (δt s u u) ✓.
Proof.
  induction u as [|[a|a|x]u];intros s A;simpl;auto.
  - apply IHu;simpl;rewrite A;auto.
  - destruct (pairedb s a a);auto.
    apply IHu,Accepting_rmfst,A.
  - case_var s x x;auto.
Qed.

Lemma path_id_compatible u : forall s, s ✓ -> compatible s u u = true.
Proof.
  induction u as [|[a|a|x]u];intros s A;simpl;auto.
  - apply IHu;simpl;rewrite A;reflexivity.
  - assert (E:a=a) by reflexivity.
    rewrite <-(paired_Accepting _ _ A),pairedb_spec in E;rewrite E.
    apply IHu,Accepting_rmfst,A.
  - case_var s x x.
    + apply IHu;auto.
    + exfalso.
      apply N,action_invariant,map_eq_id.
      cut (forall a, a ∈ ⌊x⌋ -> s ⊨ a ↦ [] ∙ a).
      * rewrite var_perm'_spec;intros (q&e'&h).
        rewrite e' in e;inversion e;subst;clear e.
        setoid_rewrite act_nil in h.
        intros a Ia;symmetry;apply h,Ia.
      * setoid_rewrite act_nil.
        intros a _;apply paired_Accepting;tauto.
    + exfalso;apply var_perm'_None in e as (a&Ia&F);apply (F a),paired_Accepting;tauto.
Qed.

Corollary path_id s u : s ✓ -> exists s', s'✓ /\ s ⊣ u | u ⤅ s'.
Proof.
  setoid_rewrite <- δt_compatible_spec;intro A;rewrite (path_id_compatible u A).
  exists (δt s u u);split;auto;apply path_id_Accepting,A.
Qed.

(** If there is a path from labelled with [u|v], then [u] and [v] have the same length. *)
Lemma path_length_word u v s1 s2 : s1 ⊣ u | v ⤅ s2 -> ⎢u⎥ = ⎢v⎥.
Proof. intro P;induction P;solve_length. Qed.

(** If [u1] and [v1] have the same length, then [u1++u2,v1++v2] is compatible with [s] if and only if [u1,v1] is compatible with [s] and [u2,v2] is compatible with [δt s u1 v1]. *)
Proposition compatible_app u1 u2 v1 v2 s :
  ⎢u1⎥ = ⎢v1⎥ ->
  compatible s (u1++u2) (v1++v2) = (compatible s u1 v1)
                                     && compatible (δt s u1 v1) u2 v2.
Proof.
  revert v1 s;induction u1 as [|[a|a|x] u1];intros [|[b|b|y]v1] s1 L;simpl in *;lia||auto.
  - case_paired s1 a b;simpl;auto.
  - case_var s1 x y;simpl;auto.
Qed.

(** If [u1,v1] is compatible with [s] then [δt s (u1++u2) (v1++v2)] may be computed as [δt (δt s u1 v1) u2 v2]. *)
Proposition δt_app u1 u2 v1 v2 s :
  compatible s u1 v1 = true -> δt s (u1++u2) (v1++v2) = δt (δt s u1 v1) u2 v2.
Proof.
  revert v1 s;induction u1 as [|[a|a|x] u1];intros [|[b|b|y]v1] s1 L;simpl in *;discriminate||auto.
  - revert L;case_paired s1 a b;simpl;discriminate||auto.
  - revert L;case_var s1 x y;simpl;discriminate||auto.
Qed.

(** If there is a path labelled with [u1++u2|v1++v2], and if [u1] and [v1] have the same length, then it can be factored as a path labelled with [u1|v1] followed by one with label [u2|v2]. *)
Corollary path_decompose_app u1 u2 v1 v2 s1 s2 :
  (s1 ⊣ u1++u2 | v1++v2 ⤅ s2) -> ⎢u1⎥ = ⎢v1⎥ ->
  exists s3, s1 ⊣ u1 | v1  ⤅ s3 /\ s3 ⊣ u2 | v2  ⤅ s2.
Proof.
  setoid_rewrite <- δt_compatible_spec.
  intros (<-&C) L;rewrite compatible_app,andb_true_iff in C;auto.
  exists (δt s1 u1 v1);rewrite δt_app;tauto.
Qed.

Corollary path_letter u l v s1 s2 :
  (s1 ⊣ u++[l] | v ⤅ s2) ->
  exists v' l' s3, v = v' ++ [l'] /\ s1 ⊣ u | v' ⤅ s3 /\ s3 ⊣ l | l' ↦ s2.
Proof.
  intro P;destruct (nil_or_last v) as [->|(l'&v'&->)].
  + inversion P;simpl_words.
  + apply path_decompose_app in P as (s3&P1&P2);[|apply path_length_word in P;solve_length].
    exists v',l',s3;simpl;repeat split;auto.
    inversion P2;inversion H6;subst;auto.
Qed.

(** If we know [s2] to be accepting, we may simplify [image (s1++s2) a], [var_perm x (s1++s2)], [pairedb (s1++s2) a b], [compatible (s1++s2) u v]. Also, [δt (s1++s2) u v] is accepting if and only if [δt s1 u v] is. *)
Proposition image_app_Accepting s1 s2 :
  s2 ✓ -> forall a, image (s1++s2) a = image s1 a.
Proof.
  induction s1 as [|(a,b)s1];intros Acc c;simpl;auto.
  - apply image_spec,paired_Accepting;auto.
  - destruct_eqX c a;auto.
Qed.

Corollary var_perm_app_Accepting s1 s2 x :
  s2 ✓ -> var_perm x (s1++s2) = var_perm x s1 .
Proof. unfold var_perm; intro Acc;rewrite (map_ext _ _ (image_app_Accepting _ Acc));auto. Qed.

Lemma pairedb_app_Accepting s1 s2 :
  s2 ✓ -> forall a b, pairedb (s1++s2) a b = pairedb s1 a b.
Proof.
  intros Acc a b;case_paired s1 a b;case_paired (s1++s2) a b;auto.
  - exfalso;apply hp0,paired_app.
    rewrite (paired_Accepting _ _ Acc).
    pose proof hp as [(->&A)|(?&?&->&_)];simpl_In;auto.
  - exfalso;apply hp;apply paired_app in hp0 as [(E&_)|(A&hp0)];auto.
    apply (paired_Accepting _ _ Acc) in hp0 as ->.
    left;split;auto.
Qed.

Proposition compatible_app_Accepting s1 s2 u v :
  s2 ✓ -> compatible (s1++s2) u v = compatible s1 u v.
Proof.
  revert v s1 s2;induction u as [|[a|a|x] u];intros [|[b|b|y]v] s1 s2 Acc;simpl in *;auto.
  - repeat rewrite app_comm_cons;apply IHu,Acc.
  - rewrite pairedb_app_Accepting;auto;case_paired s1 a b;auto.
    pose proof hp as hp';
      rewrite pairedb_spec,<-(pairedb_app_Accepting _ Acc),<-pairedb_spec in hp'.
    destruct (rmfst_app_dec_stacks hp') as [(t1&t2&->&h&->)|[(t1&t2&->&h&->)|(->&h&->)]].
    + rewrite rmfst_present,<-app_ass;auto.
    + apply absent_app in h as (h1&h2);rewrite (rmfst_absent h1);apply IHu.
      repeat rewrite map_app in *;simpl in *.
      apply length_app in Acc as (->&h);[|solve_length].
      inversion h;auto.
    + apply absent_app in h as (h1&h2);rewrite (rmfst_absent h1);apply IHu;auto.
  - rewrite IHu by tauto.
    case_var s1 x y;case_var (s1++s2) x y;try reflexivity;simpl;exfalso.
    + apply N;rewrite <- E;apply support_eq_action_eq.
      intros a Ia.
      pose proof (var_perm'_Some e Ia) as p1.
      pose proof (var_perm'_Some e0 Ia) as p2.
      rewrite pairedb_spec,(pairedb_app_Accepting _ Acc),<-pairedb_spec in p2.
      apply (paired_inj p2 p1);reflexivity.
    + apply var_perm'_None in e0 as (a&Ia&h).
      pose proof (var_perm'_Some e Ia) as p1.
      apply (h (p∙a)).
      rewrite pairedb_spec,(pairedb_app_Accepting _ Acc),<-pairedb_spec;tauto.
    + apply N;rewrite <- E;apply support_eq_action_eq.
      intros a Ia.
      pose proof (var_perm'_Some e Ia) as p1.
      pose proof (var_perm'_Some e0 Ia) as p2.
      rewrite pairedb_spec,(pairedb_app_Accepting _ Acc),<-pairedb_spec in p2.
      apply (paired_inj p1 p2);reflexivity.
    + apply var_perm'_None in e as (a&Ia&h).
      pose proof (var_perm'_Some e0 Ia) as p1.
      apply (h (p∙a)).
      rewrite pairedb_spec,<-(pairedb_app_Accepting _ Acc),<-pairedb_spec;tauto.
Qed.

Proposition δt_app_Accepting s1 s2 u v :
  s2 ✓ -> δt (s1++s2) u v ✓ <-> δt s1 u v ✓.
Proof.
  revert v s1 s2;induction u as [|[a|a|x] u];intros [|[b|b|y]v] s1 s2 Acc;simpl in *;try tauto.
  - rewrite Accepting_app,Acc;tauto.
  - repeat rewrite app_comm_cons;rewrite IHu;auto;tauto.
  - rewrite pairedb_app_Accepting;auto.
    case_paired s1 a b;simpl;[|tauto].
    pose proof hp as hp';rewrite pairedb_spec,<-(pairedb_app_Accepting _ Acc),<-pairedb_spec in hp'.
    destruct (rmfst_app_dec_stacks hp') as [(t1&t2&->&h&->)|[(t1&t2&->&h&->)|(->&h&->)]].
    + rewrite rmfst_present,<-app_ass;auto.
    + apply absent_app in h as (h1&h2);rewrite (rmfst_absent h1);apply IHu.
      repeat rewrite map_app in *;simpl in *.
      apply length_app in Acc as (->&h);[|solve_length].
      inversion h;auto.
    + apply absent_app in h as (h1&h2);rewrite (rmfst_absent h1);apply IHu;auto.
  - pose proof (compatible_app_Accepting s1 [var x] [var y] Acc) as e.
    revert e;simpl.
    case_var s1 x y;case_var (s1++s2) x y;try discriminate||reflexivity;simpl.
    intros _;apply IHu,Acc.
Qed.

Corollary path_app_Accepting s1 s2 u v s3 :
  s2 ✓ -> s1 ⊣ u | v ⤅ s3 -> exists s4, s1++s2 ⊣ u | v ⤅ s4 /\ (s3 ✓ -> s4 ✓).
Proof.
  setoid_rewrite <- δt_compatible_spec.
  intros A (<-&C);exists (δt (s1++s2) u v);split;[split|];auto.
  - rewrite compatible_app_Accepting,C;auto.
  - rewrite δt_app_Accepting;auto.
Qed.

(** We can flip a path with label [u|v] into a path with label [v|u]. *)
Lemma step_sym a b s1 s2 : s1 ⊣ a | b ↦ s2 -> s1` ⊣ b | a ↦ s2`.
Proof.
  intro h;destruct a as [a|a|x];destruct b as [b|b|y];unfold step in *;try tauto.
  + rewrite h;simpl;auto.
  + rewrite <- paired_flip,rmfst_flip.
    destruct h as (P&->);auto.
  + destruct h as (->&p&->&E).
    split;auto;exists (p∗);split.
    * rewrite action_compose,perm_pinv_p_eq_nil,act_nil;auto.
    * intros a I;rewrite <- paired_flip,<-(act_p_pinv p).
      apply E,In_act_lists,support_action,I.
Qed.

Corollary path_sym s u v s' : s ⊣ u | v ⤅ s' <-> (s`) ⊣ v | u ⤅ (s'`).
Proof.
  revert u v s s';cut (forall u s v s', s ⊣ u | v ⤅ s' -> (s`) ⊣ v | u ⤅ (s'`));
    [intros h u v s s';split;[apply h|intro p;apply h in p;repeat rewrite flip_involutive in p;auto]
    |intros u s v s' P].
  induction P;simpl;eauto.
  apply step_sym in H;eauto.
Qed.

Corollary compatible_flip s u v : compatible (s`) u v = compatible s v u.
Proof.
  case_eq (compatible s v u).
  - rewrite δt_path;intro P;apply path_sym,δt_compatible_spec in P;tauto.
  - intro h;case_eq (compatible (s`) u v);auto.
    rewrite δt_path;intro P;apply path_sym,δt_compatible_spec in P as (_&C).
    rewrite flip_involutive in C;rewrite C in h;discriminate.
Qed.

Corollary δt_flip s u v : δt (s`) u v = (δt s v u)`.
Proof.
  case_eq (compatible s v u).
  - rewrite δt_path;intro P;apply path_sym,δt_compatible_spec in P;tauto.
  - intro C;rewrite (compatible_false C);rewrite <- compatible_flip in C;rewrite (compatible_false C).
    reflexivity.
Qed.

(** We can compose a path with label [u|v] with a path with label [v|w] to get a path with label [u|w], if their starting points are compatible. *)
Lemma step_mix l1 l2 l3 s1 s2 s3 s4 :
  prj2 s1 = prj1 s3 -> s1 ⊣ l1 | l2 ↦ s2 -> s3 ⊣ l2 | l3 ↦ s4 ->
  (s1 ⋈ s3) ⊣ l1 | l3 ↦ (s2 ⋈ s4) /\ prj2 s2 = prj1 s4.
Proof.
  destruct l1 as [a|a|x];destruct l2 as [b|b|y];destruct l3 as [c|c|z];unfold step;try tauto.
  - intros E -> -> ;simpl;split;auto;f_equal;auto.
  - intros E1 (P1&E2) (P2&E3);pose proof (paired_mix E1 P1 P2) as (h1&h2&h3);subst;auto.
  - intros len (->&p&->&hp) (->&q&->&hq);repeat split;auto.
    exists (q++p);rewrite action_compose.
    split;auto;intros a I1.
    eapply paired_mix;auto.
    rewrite <- action_compose;apply hq.
    rewrite support_action,In_act_lists,inverse_comp_l;auto.
Qed.

Corollary path_mix u v w s1 s2 s3 s4 :
  prj2 s1 = prj1 s3 -> (s1 ⊣ u | v ⤅ s2) -> (s3 ⊣ v | w ⤅ s4) ->
  prj2 s2 = prj1 s4 /\ (s1 ⋈ s3) ⊣ u | w ⤅ (s2 ⋈ s4).
Proof.
  intros E P;revert w s3 s4 E;induction P;intros w' s1' s3' E1 P'.
  - inversion P';subst;auto.
  - inversion P';subst;auto;clear P'.
    pose proof (step_mix E1 H H2) as (S'&E2).
    pose proof (IHP _ _ _ E2 H6) as (->&P');eauto.
Qed.

(** Notice that paths are deterministic, in the sense that given a starting point [s] and a label [u|v], there is at most one stack [s'] such that [s⊣ u | v ⤅s']. *)
Remark step_det a b s s1 s2 : s ⊣ a | b ↦ s1 -> s ⊣ a | b ↦ s2 -> s1 = s2.
Proof. destruct a;destruct b;unfold step;try tauto|| intuition congruence. Qed.

Remark path_det u v s s1 s2 : s ⊣ u | v ⤅ s1 -> s ⊣ u | v ⤅ s2 -> s1 = s2.
Proof.
  intro P;revert s2;induction P;intros s' P';inversion P';subst;clear P';auto.
  apply (step_det H) in H6;subst;eauto.
Qed.

(** We can compose a path from [s1] to [s2] and one from [s2] to [s3] to get a path from [s1] to [s3]. *)
Lemma path_app u1 u2 v1 v2 s1 s2 s3 :
  s1 ⊣ u1 | v1 ⤅ s2 -> s2 ⊣ u2 | v2 ⤅ s3 -> s1 ⊣ u1++u2 | v1++v2 ⤅ s3.
Proof. intros P1 P2;induction P1;auto;apply IHP1 in P2;simpl;eauto. Qed.

(** ** Binding power *)
(** If [s ⊣ u | v ⤅ s'], we can relate the number of occurrences of atoms in [s] and [s'] with the binding power of [u] and [v] with respect to [a]. *)
Proposition stack_binding a u s s' :
  (s ⊣ u | u ⤅ s') ->
  nb a (prj1 s') = (nb a (prj1 s) - d_binding (𝗙 a u)) + c_binding (𝗙 a u).
Proof.
  intro P;assert (exists v, v = u /\ s ⊣ u | v ⤅ s') as (v&E0&P') by (exists u;split;auto).
  clear P;induction P';simpl in *;auto.
  - unfold 𝗙;simpl_binding; lia.
  - inversion E0 as [[E1 E]];apply IHP' in E as -> ;subst;clear E0 IHP';simpl_binding.
    generalize (𝗙 a u);clear u v P' s3;intros ((n,m),p);simpl_binding.
    destruct l1 as [b|b|x];unfold step in H;simpl.
    + subst;unfold_eqX;simpl;simpl_beq;simpl.
      * destruct n;lia.
      * lia.
    + destruct H as ([(_&A)|(t1&t2&->&A)]&->); [rewrite rmfst_absent|rewrite rmfst_present];auto;
        destruct A as (A&_);apply nb_not_In in A;unfold_eqX;simpl_binding;
          repeat rewrite map_app,filter_app,app_length;simpl;simpl_eqX;simpl;lia.
    + destruct H as (->&_);lia.
Qed.

Corollary stack_binding_both u v s s' :
  (s ⊣ u | v ⤅ s') ->
  forall a,
    nb a (prj1 s') = (nb a (prj1 s) - d_binding (𝗙 a u)) + c_binding (𝗙 a u)
    /\
    nb a (prj2 s') = (nb a (prj2 s) - d_binding (𝗙 a v)) + c_binding (𝗙 a v).
Proof.
  intros P a;pose proof P as P';apply path_sym in P';split.
  - apply (path_mix (eq_sym (@flip_proj1 _ _ s)) P) in P' as (E&P').
    apply stack_binding with (a:=a) in P'.
    rewrite mix_fst,mix_fst in P';auto.
    + unfold flip;rewrite map_length;auto.
    + unfold flip;rewrite map_length;auto.
  - apply (path_mix (@flip_proj2 _ _ s) P') in P as (E&P).
    apply stack_binding with (a:=a) in P.
    rewrite mix_fst,flip_proj1,mix_fst,flip_proj1 in P;auto.
    + unfold flip;rewrite map_length;auto.
    + unfold flip;rewrite map_length;auto.
Qed.

(** Using these, we can compute the size of the target stack from the c-binding power of [u]. *)
Lemma size_stack u v s :
  [] ⊣ u | v ⤅ s -> ⎢s⎥ = sum (fun a => c_binding (𝗙 a u)) {{⌊u⌋}}.
Proof.
  intro P.
  transitivity (sum (fun a => nb a [] - d_binding (𝗙 a u) + c_binding (𝗙 a u)) {{⌊ u ⌋}}).
  - transitivity (sum (fun a => nb a (prj1 s)) {{⌊u⌋}}).
    + rewrite <- length_sum_filter;auto.
      * symmetry;apply map_length.
      * revert v s P;induction u as [|l u] using rev_induction;simpl;intros v s P.
        -- inversion P;reflexivity.
        -- apply path_letter in P as (v'&l'&s'&->&P&hs).
           apply IHu in P;rewrite undup_equivalent,(support_list_app u [l]),
                          <-(undup_equivalent ⌊u⌋),<-P.
           unfold support,SupportList,support;simpl;rewrite app_nil_r,undup_equivalent.
           clear P IHu u;destruct l as [a|a|x];destruct l' as [b|b|y];unfold step in hs;simpl;
             try tauto.
           ++ subst;simpl;intro c;simpl_In;simpl;tauto.
           ++ destruct hs as ([(->&A)|(s1&s2&->&A)]&->).
              ** rewrite rmfst_absent;auto;intro;simpl_In;tauto.
              ** rewrite (rmfst_present _ A);repeat rewrite map_app;intro;simpl_In;simpl; tauto.
           ++ destruct hs as (->&_);intro;simpl_In;tauto.
      * apply NoDup_undup.
    + apply sum_ext;intro.
      apply (stack_binding_both P x).
  - apply sum_ext;simpl;auto.
Qed.

(** ** Applying permutations on one component *)
(** We introduce a new operation. [p ⧓ s] is the stack obtained by replacing every pair [(a,b)] in [s] with [(a,p∙b)]. *)
Definition mixp p s : stack:= (prj1 s) ⊗ (p∙prj2 s).
Infix "⧓" := mixp (at level 50).

Remark mixp_fst p l : prj1 (p ⧓ l) = prj1 l.
Proof. unfold mixp;induction l;simpl;auto;f_equal;auto. Qed.

Remark mixp_snd p l : prj2 (p ⧓ l) = prj2 (p∙l).
Proof. unfold mixp,act,act_lists;induction l;simpl;auto;f_equal;auto. Qed.

Remark mixp_snd_bis p l : prj2 (p ⧓ l) = p∙prj2 l.
Proof. unfold mixp,act,act_lists;induction l;simpl;auto;f_equal;auto. Qed.

Remark mixp_cons p a b l : p ⧓ ((a,b)::l) = (a,p∙b)::p ⧓ l.
Proof. reflexivity. Qed.

Remark mixp_app p l m : p ⧓ (l++m) = p ⧓ l ++ p ⧓ m.
Proof.
  unfold mixp;induction l as [|a l];simpl;auto.
  f_equal;auto.
Qed.

Remark mixp_absent p l a b : absent (p⧓l) a b <-> absent l a (p∗∙b).
Proof.
  unfold absent;rewrite mixp_fst,mixp_snd.
  replace (prj2 (p∙l)) with (p ∙ prj2 l)
    by (etransitivity;[|etransitivity];[apply map_map| |symmetry;apply map_map];simpl;auto).
  rewrite In_act_lists;tauto.
Qed.

(** [min_occ a u] is equal to [d_binding (𝗙 a u)] if the boolean component of [𝗙 a u] is [false], and [d_binding (𝗙 a u)+1] otherwise. *)
Definition min_occ a v :=
  match 𝗙 a v with (m,true,_) => S m | (m,_,_) => m end.

Remark min_occ_app a u v : min_occ a u <= min_occ a (u++v).
Proof.
  unfold min_occ;rewrite 𝗙_app.
  destruct (𝗙 a u) as ((n1&b1)&m1); destruct (𝗙 a v) as ((n2&b2)&m2).
  unfold prod_binding;destruct_ltb m1 n2;[destruct_ltb n2 m1|];destruct b1;destruct b2;simpl;lia.
Qed.

(** This is the technical lemma needed to prove that the law [αα] holds for stacks. More precisely, we want to show that if [b #α u] and [a #α u] then there is a path from the empty stack to some accepting stack labelled with [u | [(a,b)]∙u]. We generalise the statement by changing [a,b #α u] with a permutation [p] such that [forall a, ~ a #α u -> p ∙ a = a].

Intuitively, one might think that the following holds: [s ⊣ u | v ⤅ s' -> p ⧓ s ⊣ u | p∙v ⤅ p⧓s']. Unfortunately, this is not true in general, consider for instance [[] ⊣ a⟩ | a⟩ ⤅ []].

For this reason we need to require that [forall a, ~ a #α v -> p ∙ a = a]. However, while the statement becomes true in this case, it is not suitable for induction. Thus we assume the stronger condition
[forall a, p ∙ a <> a -> min_occ a v <= nb a (prj2 s)].
*)
Lemma perm_path_mixp p u v s s' :
  (forall a, p ∙ a <> a -> min_occ a v <= nb a (prj2 s)) -> (s ⊣ u | v ⤅ s') ->
  p ⧓ s ⊣ u | p∙v ⤅ p⧓s'.
Proof.
  revert v s';induction u as [|l u] using rev_induction;intros v' s' B P.
  - inversion P;subst;auto.
  - apply path_letter in P as (v&l'&s''&->&P&hs).
    setoid_rewrite act_lists_app;eapply path_app.
    + apply IHu;[|eauto];intros b N;etransitivity;[|apply B;auto];apply min_occ_app.
    + eapply pathl;auto using pathϵ;pose proof (stack_binding_both P) as B'.
      destruct l as [a|a|x];destruct l' as [b|b|y];unfold step in hs;try tauto.
      * subst;reflexivity.
      * destruct hs as ([(->&A)|(t1&t2&->&A)]&->);
          [rewrite (rmfst_absent A)|rewrite (rmfst_present _ A)].
        -- cut (p∙a=a).
           ++ intro Ea; split;[left;split;auto|rewrite Ea;rewrite rmfst_absent;auto];
                rewrite mixp_absent;rewrite <- Ea at 2;rewrite inverse_comp_l;auto.
           ++ destruct_eqX (p∙a) a;auto.
              exfalso;apply B in N.
              pose proof (B' a) as (_&E').
              destruct A as (_&A);rewrite nb_not_In in A.
              revert N;unfold min_occ;rewrite 𝗙_add;simpl;simpl_beq.
              destruct (𝗙 a v) as ((?,?),[|[]]);simpl in *;rewrite d_binding_simpl in E';
                destruct n;simpl in *;lia.
        -- repeat rewrite mixp_app;rewrite mixp_cons.
           split;[right;exists (p⧓t1),(p⧓t2); split|rewrite rmfst_present];auto;
           apply mixp_absent;rewrite inverse_comp_l;auto.
      * destruct hs as (->&q&->&S);split;auto.
        exists (p++q);rewrite action_compose;split;auto.
        intros a I;pose proof I as Ia.
        apply S in I as [(Ea&A)|(t1&t2&->&A)].
        -- left;cut (p∙a=a).
           ++ rewrite <-action_compose,Ea;intro Ea'; split;auto.
              rewrite mixp_absent;rewrite <- Ea' at 2;rewrite inverse_comp_l;auto.
           ++ destruct_eqX (p∙a) a;auto.
              exfalso;apply B in N.
              pose proof (B' a) as (_&E').
              destruct A as (_&A);rewrite nb_not_In in A.
              revert N;unfold min_occ;rewrite 𝗙_add;simpl.
              rewrite <- perm_bij with (p0:=q∗),inverse_comp_l in Ea.
              rewrite Ea, <-In_act_lists, <-support_action, <-inb_spec in Ia;rewrite Ia.
              destruct (𝗙 a v) as ((?,?),[]);simpl in *;rewrite d_binding_simpl in E';
                destruct n;destruct b;simpl;lia.
        -- right;exists (p⧓t1),(p⧓t2).
           rewrite mixp_app,mixp_cons,action_compose;split;auto.
           rewrite mixp_absent,action_compose, <-app_ass,perm_pinv_p_eq_nil;simpl;auto.
Qed.

Corollary αfresh_perm_path p u v s s' :
  (forall a, ~ a #α v -> p ∙ a = a) -> s ⊣ u | v ⤅ s' -> p ⧓ s ⊣ u | p∙v ⤅ p ⧓ s'.
Proof.
  intros h P;apply perm_path_mixp;auto.
  intros a h';cut (a#α v).
  - intro E; unfold min_occ;rewrite E in *;lia.
  - unfold fresh__α;destruct_eqX (𝗙 a v) ε;auto.
    apply h in N;tauto.
Qed.

Corollary αfresh_perm_path_nil p u :
  (forall a, ~ a #α u -> p ∙ a = a) -> exists s, [] ⊣ u | p∙u ⤅ s /\ s ✓.
Proof.
  intros h;pose proof (path_id u Accepting_nil) as (l&A&E).
  pose proof (αfresh_perm_path h E) as P;exists (p⧓l);split;auto.
  rewrite combine_split in *.
  rewrite mixp_fst,combine_fst;
    [|unfold mixp;repeat rewrite map_length||rewrite combine_length;solve_length].
  rewrite mixp_snd_bis,combine_snd,A;[|solve_length].
  symmetry;apply action_invariant,map_eq_id.
  intros a I;apply h.
  rewrite support_list_atoms, nb_In in I.
  apply (stack_binding a) in E;simpl in E.
  rewrite <- A,E in I.
  intros E';rewrite E' in I;simpl in I;lia.
Qed.

(** * Main result *)
(** ** Completeness *)
(** It is now fairly routine to check that whenever [u] and [v] are alpha-equivalent, there is a path labelled with [u|v] from the empty stack to some accepting stack. *)
Theorem αequiv_path u v : u ≡ v -> exists s, [] ⊣ u | v ⤅ s /\ s ✓.
Proof.
  intro E;induction E as [u v w E1 (s1&P1&A1) E2 (s2&P2&A2)
                         | | u v l E (s&P&A) | u v l E (s&P&A) | a b u F B ].
  - exists (s1 ⋈ s2); assert (E:prj2 (@nil (atom*atom)) = prj1 (@nil (atom*atom))) by reflexivity.
    pose proof (path_mix E P1 P2) as (E'&P);split;auto.
    rewrite mix_snd,mix_fst;auto using proj_length;congruence.
  - exists [];split;auto using pathϵ.
  - cut (exists s', s⊣l|l↦s' /\ s' ✓);
      [intros (s'&hs&A');exists s';split;auto;eapply (path_app P);eauto|clear P u v E].
    destruct (path_id [l] A) as (s'&Acc&P).
    inversion P as [|s1 ? ? ? ? s2 s3 h P'];subst;inversion P' as [|];subst;clear P P';eauto.
  - destruct l as [a|a|x].
    + revert P;setoid_rewrite <- δt_compatible_spec.
      intros (<-&C);eexists;split;[split;[eauto|]|];simpl.
      * rewrite <- compatible_app_Accepting with (s2:=[(a,a)]) in C;simpl;auto.
      * rewrite <- (app_nil_l [(a,a)]),δt_app_Accepting;auto.
    + exists s;split;auto.
      eapply pathl;[|apply P].
      split;[left|];repeat split;auto.
    + exists s;split;[eapply pathl;[|apply P]|tauto].
      apply path_single_letter.
      replace [] with (δt [] [var x] [var x]) at 2;[apply δt_path|];simpl;[rewrite andb_true_r|];
      rewrite act_nil; simpl_beq;reflexivity.
  - assert (E: forall c, ~ c #α (⟨a :: u ++ [a⟩]) -> [(a, b)] ∙ c = c).
    + intros c I;apply elements_inv_act_atom;simpl.
      intros [<-|[<-|?]];try tauto;apply I;clear I.
      * unfold fresh__α,balanced in *.
        rewrite 𝗙_cons,𝗙_add;simpl;simpl_beq.
        destruct (𝗙 a u) as (([],?),[]);simpl in *;rewrite d_binding_simpl in *;try lia.
        reflexivity.
      * unfold fresh__α;rewrite 𝗙_cons,𝗙_add,F;simpl.
        destruct_eqX b a;reflexivity.
    + assert (a#α (⟨a :: u ++ [a⟩]) /\ b #α (⟨a :: u ++ [a⟩])) as (Fa&Fb).
      * unfold fresh__α;destruct_eqX b a;simpl_binding;rewrite F;repeat split;simpl;
          try reflexivity.
        unfold balanced in B;destruct (𝗙 a u) as ((x&y)&z);simpl_binding in *.
        destruct B as (->&->);reflexivity.
      * pose proof (αfresh_perm_path_nil E) as (s&P&A);exists s;split;auto.
        setoid_rewrite (act_lists_cons _ ( ⟨a ) ) in P.
        rewrite act_lists_app in P.
        unfold act at 1 3 in P;simpl in P.
        unfold act at 3 in P;simpl in P.
        replace ([(a, b)] ∙ a) with b in P by (unfold act;simpl;destruct_eqX b a;auto).
        apply P.
Qed.

(** ** Soundness *)
(** To prove completeness, we will proceed by induction on the length of the path, focusing on the last step:
    - if [[]⊣[]|[]⤅[]], then [[]≡[]];
    - if [[] ⊣ u|v ⤅ s ⊣ l|l' ↦ s'] and [s'] is accepting, then the letters [l,l'] can be:
      - [⟨a,⟨b], but because [s'] is accepting we deduce that [a=b] and [s'] is accepting;
      - [var x,var y], with [s=s'], and because [s'] is accepting we deduce that [var x=var y];
      - [a⟩,b⟩].
      In the first two case, we have [l=l'] and by induction [u≡v], thus we deduce [u++l≡v++l'].

   The last case is more subtle: we need to show that if [a<>b] and if there is path for the empty stack to [s] labelled with [u++[a⟩] | v++[b⟩]], then we can decompose [u] and [v] as follows:
    - [u=u1++⟨a::u2] and [v=v1++⟨b::v2], where [u1] and [v1] have the same length;
    - [a ⋄ u2] and [b ⋄ v2].
    However, the statements [a ⋄ u2] and [b ⋄ v2] are not stable by prefixes, meaning that this statement is too weak to be provable by a direct induction. Therefore we start by proving the following technical lemma.
*)
Lemma path_stack_decompose_aux u v a b t1 t2 :
  ([] ⊣ u | v ⤅ t1++(a,b)::t2) ->
  exists u1 u2 v1 v2, u=u1++⟨a::u2
                 /\ v=v1++⟨b::v2
                 /\ ⎢u1⎥ = ⎢v1⎥
                 /\ nb a (prj1 t1) = c_binding (𝗙 a u2)
                 /\ nb b (prj2 t1) = c_binding (𝗙 b v2)
                 /\ nb a (prj1 t2) = c_binding (𝗙 a u1)
                 /\ nb b (prj2 t2) = c_binding (𝗙 b v1).
Proof.
  revert a b v t1 t2;induction u as [|l u] using rev_induction;intros a b v' t1 t2 P;
    [inversion P;simpl_words|].
  apply path_letter in P as (v&l'&s'&->&P&hs).
  destruct l as [c|c|x];destruct l' as [d|d|y];unfold step in hs;try tauto.
  - destruct t1;simpl in *;inversion hs;subst;clear hs.
    + exists u,[],v,[];simpl;repeat split;auto.
      * apply (path_length_word P).
      * apply (stack_binding_both P c).
      * apply (stack_binding_both P d).
    + apply IHu in P as (u1&u2&v1&v2&->&->&L&E1&E2&->&->).
      exists u1,(u2++[open c]),v1,(v2++[open d]);repeat rewrite app_ass;simpl;repeat split;auto.
      * destruct_eqX a c;simpl_binding; lia.
      * destruct_eqX b d;simpl_binding;lia.
  - destruct hs as ([(->&(A1&A2))|(m1&m2&->&(A1&A2))]&E).
    + setoid_rewrite rmfst_absent in E;[|split;auto];subst.
      rewrite map_app in *;simpl in *;simpl_In in *;simpl in *.
      apply IHu in P as (u1&u2&v1&v2&->&->&L&E1&E2&->&->).
      exists u1,(u2++[c⟩]),v1,(v2++[c⟩]);repeat rewrite app_ass.
      simpl_binding;repeat split;auto.
      * destruct_eqX a c;[tauto|simpl_binding;lia].
      * destruct_eqX b c;[tauto|simpl_binding;lia].
    + rewrite rmfst_present in E by (split;auto).
      apply Levi in E as (s&[(->&->)|(->&E)]);
        [|destruct s as [|x s];[rewrite app_nil_r in *;simpl in *;subst
                               |inversion E;subst;clear E]].
      * rewrite app_comm_cons,<- app_ass in P.
        apply IHu in P as (u1&u2&v1&v2&->&->&L&E).
        exists u1,(u2++[c⟩]),v1,(v2++[d⟩]);simpl_binding;repeat rewrite app_ass.
        destruct E as (<-&<-&<-&<-);repeat rewrite map_app,filter_app,app_length;simpl.
        repeat split;auto.
        -- destruct_eqX a c;simpl_binding;lia.
        -- destruct_eqX b d;simpl_binding;lia.
      * replace ((c,d)::(a,b)::t2) with ([(c,d)]++(a,b)::t2) in P by reflexivity.
        rewrite <- app_ass in P.
        apply IHu in P as (u1&u2&v1&v2&->&->&L&E).
        exists u1,(u2++[c⟩]),v1,(v2++[d⟩]);simpl_binding;repeat rewrite app_ass.
        destruct E as (<-&<-&<-&<-);repeat rewrite map_app,filter_app,app_length;simpl.
        repeat split;auto.
        -- destruct_eqX a c;simpl_binding;lia.
        -- destruct_eqX b d;simpl_binding;lia.
      * rewrite app_ass in P;simpl in P.
        apply IHu in P as (u1&u2&v1&v2&->&->&L&E).
        exists u1,(u2++[c⟩]),v1,(v2++[d⟩]);simpl_binding;repeat rewrite app_ass.
        destruct E as (<-&<-&<-&<-);repeat rewrite map_app,filter_app,app_length;simpl.
        assert (a<>c /\ b<>d) as (n1&n2)
            by (rewrite map_app in *;simpl in *;simpl_In in *;simpl in *;tauto).
        repeat simpl_beq;simpl_binding;repeat split;tauto||lia.
  - destruct hs as (<-&_).
    apply IHu in P as (u1&u2&v1&v2&->&->&L&->&->&->&->).
    repeat rewrite app_ass;simpl;exists u1,(u2++[var x]),v1,(v2++[var y]);simpl_binding;
      repeat split;auto;lia.
Qed.

Corollary path_stack_decompose u v a b s :
  ([] ⊣ u | v ⤅ s) ->
  a<>b ->
  (s ⊨ a ↦ b) ->
  exists u1 u2 v1 v2, u=u1++⟨a::u2
                 /\ v=v1++⟨b::v2
                 /\ ⎢u1⎥ = ⎢v1⎥
                 /\ a ⋄ u2
                 /\ b ⋄ v2.
Proof.
  intros P N [(->&_)|(t1&t2&->&A1&A2)];[tauto|].
  destruct (path_stack_decompose_aux P) as (u1&u2&v1&v2&->&->&L&E1&E2&L1&L2).
  exists u1,u2,v1,v2;split;[|split;[|split]];auto.
  apply nb_not_In in A1;apply nb_not_In in A2.
  pose proof (stack_binding_both P a) as (Ba&_).
  pose proof (stack_binding_both P b) as (_&Bb).
  revert Ba Bb;repeat rewrite map_app,filter_app,app_length;simpl.
  rewrite A1 in *;rewrite A2 in *;repeat simpl_beq;simpl.
  unfold balanced;simpl_binding;rewrite <- E1,<- E2;simpl_binding.
  destruct (d_binding (𝗙 a u2));[destruct (d_binding (𝗙 b v2));[auto|]|];simpl;lia.
Qed.

(** We may now prove the second direction of our main theorem: whenever we have an accepting path labelled with [u|v], [u] and [v] are alpha-equivalent.

Note that this proof relies on the fact that [Atom] is infinite. This is in fact the only place in the proof where we use this fact. Indeed, to prove that [⟨a;⟨b;a⟩;b⟩] is equivalent to [⟨b;⟨a;b⟩;a⟩], the transducer only uses names [a] and [b], but the derivation of [≡] will need to use a α-fresh name. *)
Theorem path_αequiv u v s : s ✓ -> [] ⊣ u | v ⤅ s -> u ≡ v.
Proof.
  intros A P;revert v s A P;induction u as [|l u IH]using len_rev_induction;intros v0 s0 A P.
  - inversion P;subst;reflexivity.
  - pose proof P as P0;apply path_letter in P as (v&l'&s'&->&P&hs).
    destruct l as [a|a|x];destruct l' as [b|b|y];unfold step in hs;try tauto.
    + subst; replace b with a in * by (rewrite Accepting_refl in A;apply A;now left).
      apply IH in P;auto;apply Accepting_cons_refl in A;auto.
      apply αr,P.
    + destruct_eqX a b.
      * symmetry in E;subst.
        eapply αr,IH;try apply P||lia.
        destruct hs as ([(_&A')|(s1&s2&->&A')]&->);[setoid_rewrite (rmfst_absent A') in A
                                                   |rewrite (rmfst_present _ A') in A];auto.
        rewrite Accepting_app in *;rewrite Accepting_cons_refl ;tauto.
      * destruct hs as (hs&->).
        destruct (path_stack_decompose P N hs) as (u1&u2&v1&v2&->&->&B1&B2&L).
        assert (exists c, ~ c ∈( ⌊u2⌋++⌊v2⌋)) as (c&Ic)
            by (apply exists_fresh).
        assert (E1:u1 ++ ⟨a :: u2 ++ [a⟩] ≡ u1 ++ ⟨c :: [(a,c)]∙ u2 ++ [c⟩] )
          by (apply αequiv_app_left,αα;auto;apply αfresh_support;simpl_In in Ic;tauto).
        assert (E2:v1 ++ ⟨b :: v2 ++ [b⟩] ≡ v1 ++ ⟨c :: [(b,c)]∙v2 ++ [c⟩] )
          by (apply αequiv_app_left,αα;auto;apply αfresh_support;simpl_In in Ic;tauto).
        repeat rewrite app_comm_cons,<-app_ass in *.
        repeat rewrite app_ass.
        symmetry in E1;apply αequiv_path in E1 as (s1&P1&A1);apply αequiv_path in E2 as (s2&P2&A2).
        assert (E0 : prj2 (@nil (atom*atom)) = prj1(@nil (atom*atom))) by reflexivity.
        assert (E1 : prj2 (@nil (atom*atom)) = prj1([]⋈@nil (atom*atom))) by reflexivity.
        pose proof (path_mix E0 P1 P0) as (E4&P4).
        pose proof (path_mix E1 P4 P2) as (E5&P3).
        unfold mix in P3 at 1;simpl in P3; clear E0 E1.
        apply path_letter in P3 as (?&?&s4&E&P3&P5);simpl_words;subst.
        simpl in *;simpl_In in *.
        transitivity  (u1 ++ ⟨c :: [(a, c)] ∙ u2 ++ [c⟩]);
          [|transitivity  (v1 ++ ⟨c :: [(b, c)] ∙ v2 ++ [c⟩])].
        -- apply αequiv_app_left.
           apply αα;auto.
           apply αfresh_support;tauto.
        -- repeat rewrite app_comm_cons,<- app_ass.
           apply αr;eapply IH;try apply P3.
           ++ repeat rewrite app_length;simpl.
              rewrite (act_lists_length [(a,c)] u2);lia.
           ++ revert A A1 A2 E4 E5 P5;clear.
              intros A0 A1 A2 E1;rewrite mix_snd;auto using proj_length;intro E2.
              cut (s1 = s'⊖(a,b) /\ s2 = s'⊖(a,b));[intros (->&->);clear A1 A2 E1 E2|].
              ** pose proof A0 as E;unfold mix;rewrite <- E.
                 rewrite combine_fst;auto.
                 intros ([(_&A)|(t1&t2&->&A)]&E3).
                 --- rewrite (rmfst_absent A) in E3;subst;apply Accepting_combine.
                 --- rewrite E in E3 at 2;rewrite <-combine_split,(rmfst_present _ A) in E3;
                       rewrite E3 in A0.
                     rewrite Accepting_app in *;rewrite Accepting_cons;simpl;tauto.
              ** rewrite (@combine_split _ _ s1),(@combine_split _ _ (s'⊖(a,b))),
                 (@combine_split _ _ s2).
                 split.
                 --- rewrite A1,E1,A0;auto.
                 --- rewrite A0,E2,A2;auto.
        -- apply αequiv_app_left.
           symmetry;apply αα;auto.
           apply αfresh_support;tauto.
    + destruct hs as (->&p&->&E).
      rewrite action_invariant.
      * eapply αr,IH,P;auto.
      * apply map_eq_id.
        intros a I;apply E in I.
        rewrite paired_Accepting in I;auto.
Qed.

Theorem completeness u v : u ≡ v <-> (exists s, [] ⊣ u | v ⤅ s /\ s ✓).
Proof.
  split.
  - apply αequiv_path.
  - intros (s&P&A);apply (path_αequiv A P).
Qed.

(** Using the equivalence between paths and alpha-equivalence, and lemma [αfresh_perm_path_nil], we can prove that the following rule is admissible. *)
Proposition αequiv_αfresh_transpose p u : (forall a, ~ a #α u -> p∙a = a) -> u ≡ p∙u.
Proof. rewrite completeness;apply αfresh_perm_path_nil. Qed.

End s.

(* begin hide *)
Ltac case_var s x y :=
  let p := fresh "p" in
  let e := fresh "e" in
  case_eq (var_perm' ⌊x⌋ s);
  [intros p e;destruct_eqX (p∙x) y|intros e].
Hint Constructors path.
Notation " s ⊣ l1 | l2 ↦ s' " := (step s l1 l2 s') (at level 80).
Notation " s ⊣ u | v ⤅ s' " := (path u v s s') (at level 80).
(* end hide *)


(** Infrastructure lemmas and tactic definitions for Bang.

    Authors: Steve Zdancewic and Karl Mazurak and Jianzhou Zhao.

    This file contains a number of definitions, tactics, and lemmas
    that are based only on the syntax of the language at hand.  While
    the exact statements of everything here would change for a
    different language, the general structure of this file (i.e., the
    sequence of definitions,tactics, and lemmas) would remain the
    same.

    Table of contents:
      - #Free variables#
      - #Substitution#
      - #The "pick fresh" tactic#
      - #The "pick fresh and apply" tactic#
      - #Properties of opening and substitution#
      - #Local closure is preserved under substitution#
      - #Automation# *)

Require Export Bang_Definitions.

(* ********************************************************************** *)
(** * ## Free variables *)

(** In this section, we define free variable functions.  The functions
    [fv_tt] and [fv_te] calculate the set of atoms used as free type
    variables in a type or expression, respectively.  The function
    [fv_ee] calculates the set of atoms used as free expression
    variables in an expression.  Cases involving binders are
    straightforward since bound variables are indices, not names, in
    locally nameless representation. *)

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_bvar J => {}
  | typ_fvar X => singleton X
  | typ_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_all T1 => (fv_tt T1)
  | typ_bang T1 => (fv_tt T1)
  | typ_with T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  end.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => {}
  | exp_abs V e1  => (fv_tt V) `union` (fv_te e1)
  | exp_app e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_tabs e1 => (fv_te e1)
  | exp_tapp e1 V => (fv_tt V) `union` (fv_te e1)
  | exp_bang e1 => (fv_te e1)
  | exp_let e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_apair e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_fst e1 => (fv_te e1)
  | exp_snd e1 => (fv_te e1)
  end.

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => singleton x
  | exp_abs V e1 => (fv_ee e1)
  | exp_app e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_tabs e1 => (fv_ee e1)
  | exp_tapp e1 V => (fv_ee e1)
  | exp_bang e1 => (fv_ee e1)
  | exp_let e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_apair e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_fst e1 => (fv_ee e1)
  | exp_snd e1 => (fv_ee e1)
  end.

Fixpoint fv_env (E : env) {struct E} : atoms :=
  match E with
  | nil => {}
  | (x, bind_kn) :: E' =>
      singleton x `union` fv_env E'
  | (x, bind_typ t) :: E' =>
      singleton x `union` (fv_tt t) `union` fv_env E'
  end.

Fixpoint fv_lenv (D : lenv) {struct D} : atoms :=
  match D with
  | nil => {}
  | cons (x, lbind_typ T) l =>
      singleton x `union` fv_tt T `union` fv_lenv l
  end.

(* ********************************************************************** *)
(** * ## Substitution *)

(** In this section, we define substitution for expression and type
    variables appearing in types, expressions, and environments.
    Substitution differs from opening because opening replaces indices
    whereas substitution replaces free variables.  The definitions
    below are relatively simple for two reasons.
      - We are using locally nameless representation, where bound
        variables are represented using indices.  Thus, there is no
        need to rename variables to avoid capture.
      - The definitions below assume that the term being substituted
        in, i.e., the second argument to each function, is locally
        closed.  Thus, there is no need to shift indices when passing
        under a binder. *)

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else T
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T1 => typ_all (subst_tt Z U T1)
  | typ_bang T1 => typ_bang (subst_tt Z U T1)
  | typ_with T1 T2 => typ_with (subst_tt Z U T1) (subst_tt Z U T2)
  end.

Fixpoint subst_te (Z : atom) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs (subst_tt Z U V)  (subst_te Z U e1)
  | exp_app e1 e2 => exp_app (subst_te Z U e1) (subst_te Z U e2)
  | exp_tabs e1 => exp_tabs (subst_te Z U e1)
  | exp_tapp e1 V => exp_tapp (subst_te Z U e1) (subst_tt Z U V)
  | exp_bang e1 => exp_bang  (subst_te Z U e1)
  | exp_let e1 e2 => exp_let (subst_te Z U e1) (subst_te Z U e2)
  | exp_apair e1 e2 => exp_apair  (subst_te Z U e1) (subst_te Z U e2)
  | exp_fst e1 => exp_fst  (subst_te Z U e1)
  | exp_snd e1 => exp_snd  (subst_te Z U e1)
  end.

Fixpoint subst_ee (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => if x == z then u else e
  | exp_abs V e1 => exp_abs V (subst_ee z u e1)
  | exp_app e1 e2 => exp_app (subst_ee z u e1) (subst_ee z u e2)
  | exp_tabs e1 => exp_tabs (subst_ee z u e1)
  | exp_tapp e1 V => exp_tapp (subst_ee z u e1) V
  | exp_bang e1 => exp_bang  (subst_ee z u e1)
  | exp_let e1 e2 => exp_let (subst_ee z u e1) (subst_ee z u e2)
  | exp_apair e1 e2 => exp_apair (subst_ee z u e1) (subst_ee z u e2)
  | exp_fst e1 => exp_fst (subst_ee z u e1)
  | exp_snd e1 => exp_snd (subst_ee z u e1)
  end.

Definition subst_tb (Z : atom) (P : typ) (b : binding) : binding :=
  match b with
  | bind_kn => bind_kn
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

Definition subst_tlb (Z : atom) (P : typ) (b : lbinding) : lbinding :=
  match b with
  | lbind_typ T => lbind_typ (subst_tt Z P T)
  end.

(* ********************************************************************** *)
(** * ## The "[pick fresh]" tactic *)

(** The "[pick fresh]" tactic introduces a fresh atom into the context.
    We define it in two steps.

    The first step is to define an auxiliary tactic [gather_atoms],
    meant to be used in the definition of other tactics, which returns
    a set of atoms in the current context.  The definition of
    [gather_atoms] follows a pattern based on repeated calls to
    [gather_atoms_with].  The one argument to this tactic is a
    function that takes an object of some particular type and returns
    a set of atoms that appear in that argument.  It is not necessary
    to understand exactly how [gather_atoms_with] works.  If we add a
    new inductive datatype, say for kinds, to our language, then we
    would need to modify [gather_atoms].  On the other hand, if we
    merely add a new type, say products, then there is no need to
    modify [gather_atoms]; the required changes would be made in
    [fv_tt]. *)

Ltac gather_atoms :=
  let A := ltac_map (fun x : atoms => x) in
  let B := ltac_map (fun x : atom => singleton x) in
  let C := ltac_map (fun x : exp => fv_te x) in
  let D := ltac_map (fun x : exp => fv_ee x) in
  let E := ltac_map (fun x : typ => fv_tt x) in
  let F := ltac_map (fun x : env => dom x) in
  let G := ltac_map (fun x : env => fv_env x) in
  let H := ltac_map (fun x : lenv => dom x) in
  let I := ltac_map (fun x : lenv => fv_lenv x) in
  simplify_list_of_atom_sets (A ++ B ++ C ++ D ++ E ++ F ++ G ++ H ++ I).

(** The second step in defining "[pick fresh]" is to define the tactic
    itself.  It is based on the [(pick fresh ... for ...)] tactic
    defined in the [Atom] library.  Here, we use [gather_atoms] to
    construct the set [L] rather than leaving it to the user to
    provide.  Thus, invoking [(pick fresh x)] introduces a new atom
    [x] into the current context that is fresh for "everything" in the
    context. *)

Tactic Notation "pick" "fresh" ident(x) :=
  let L := gather_atoms in (pick fresh x for L).

(* *********************************************************************** *)
(** * ## The "[pick fresh and apply]" tactic *)

(** This tactic is implementation specific only because of its
    reliance on [gather_atoms], which is itself implementation
    specific.  The definition below may be copied between developments
    without any changes, assuming that the other other developments
    define an appropriate [gather_atoms] tactic.  For documentation on
    the tactic on which the one below is based, see the
    [Metatheory] library. *)

Tactic Notation
      "pick" "fresh" ident(atom_name) "and" "apply" constr(lemma) :=
  let L := gather_atoms in
  pick fresh atom_name excluding L and apply lemma.

(* ********************************************************************** *)
(** * ## Properties of opening and substitution *)

(** The following lemmas provide useful structural properties of
    substitution and opening.  While the exact statements are language
    specific, we have found that similar properties are needed in a
    wide range of languages.

    Below, we indicate which lemmas depend on which other lemmas.
    Since [te] functions depend on their [tt] counterparts, a similar
    dependency can be found in the lemmas.

    The lemmas are split into three sections, one each for the [tt],
    [te], and [ee] functions.  The most important lemmas are the
    following:
      - Substitution and opening commute with each other, e.g.,
        [subst_tt_open_tt_var].
      - Opening a term is equivalent to opening the term with a fresh
        name and then substituting for that name, e.g.,
        [subst_tt_intro].

    We keep the sections as uniform in structure as possible.  In
    particular, we state explicitly strengthened induction hypotheses
    even when there are more concise ways of proving the lemmas of
    interest. *)

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

(** The next lemma is the strengthened induction hypothesis for the
    lemma that follows, which states that opening a locally closed
    term is the identity.  This lemma is not otherwise independently
    useful. *)

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with try solve [congruence | eauto].
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
  Case "typ_bvar".
    destruct (j == n)... destruct (i == n)...
Qed.

(** Opening a locally closed term is the identity.  This lemma depends
    on the immediately preceding lemma. *)

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with try solve [congruence | intuition].
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
  Case "typ_all".
    unfold open_tt in *.
    pick fresh X.
    apply (open_tt_rec_type_aux T1 0 (typ_fvar X))...
Qed.

(** If a name is fresh for a term, then substituting for it is the
    identity. *)

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with try solve [congruence | intuition].
  induction T; simpl; intro H; f_equal...
  Case "typ_fvar".
    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

(** Substitution commutes with opening under certain conditions.  This
    lemma depends on the fact that opening a locally closed term is
    the identity. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with try solve [congruence | intuition].
  intros T1 T2 X P k WP. revert k.
  induction T1; intros K; simpl; f_equal...
  Case "typ_bvar".
    destruct (K == n); subst...
  Case "typ_fvar".
    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero. *)

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---here, we're opening the term with a variable.  In
    practice, this lemma seems to be needed as a left-to-right rewrite
    rule, when stated in its current form. *)

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with try solve [congruence | intuition].
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

(** The next lemma states that opening a term is equivalent to first
    opening the term with a fresh name and then substituting for the
    name.  This is actually the strengthened induction hypothesis for
    the version we use in practice. *)

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with try solve [congruence | intuition].
  induction T2; intros U K Fr; simpl in *; f_equal...
  Case "typ_bvar".
    destruct (K == n)... simpl. destruct (X == X)...
  Case "typ_fvar".
    destruct (a == X)... contradict Fr; fsetdec.
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero.  *)

Lemma subst_tt_intro : forall (X : atom) T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in expressions *)

(** This section follows the structure of the previous section.  The
    one notable difference is that we require two auxiliary lemmas to
    show that substituting a type in a locally-closed expression is
    the identity. *)

Lemma open_te_rec_expr_aux : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof with try solve [congruence | eauto].
  induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
  i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
  expr e ->
  e = open_te_rec k U e.
Proof with try solve [congruence | intuition].
  intros e U k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_tt_rec_type;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_te_rec_expr_aux with (j := 0) (u := exp_fvar x);
    try solve [congruence | intuition]
  | unfold open_te in *;
    pick fresh X;
    eapply open_te_rec_type_aux with (j := 0) (Q := typ_fvar X);
    try solve [congruence | intuition]
  ].
Qed.

Lemma subst_te_fresh : forall X U e,
  X `notin` fv_te e ->
  e = subst_te X U e.
Proof.
  induction e; simpl; intros; f_equal; auto using subst_tt_fresh.
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
  type U ->
  subst_te X U (open_te_rec k T e) =
    open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
  intros e T X U k WU. revert k.
  induction e; intros K; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te : forall e T X U,
  type U ->
  subst_te X U (open_te e T) = open_te (subst_te X U e) (subst_tt X U T).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_te.
  apply subst_te_open_te_rec...
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
  Y <> X ->
  type U ->
  open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with try solve [congruence | intuition].
  intros X Y U e Neq WU.
  unfold open_te.
  rewrite subst_te_open_te_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
  X `notin` fv_te e ->
  open_te_rec k U e = subst_te X U (open_te_rec k (typ_fvar X) e).
Proof.
  induction e; intros U K Fr; simpl in *; f_equal;
    auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall (X : atom) e U,
  X `notin` fv_te e ->
  open_te e U = subst_te X U (open_te e X).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_te.
  apply subst_te_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

(** This section follows the structure of the previous two sections. *)

Lemma open_ee_rec_expr_aux : forall e j v u i,
  i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof with try solve [congruence | eauto].
  induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
  Case "exp_bvar".
    destruct (j==n)... destruct (i==n)...
Qed.

Lemma open_ee_rec_type_aux : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; intros j V u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
  expr e ->
  e = open_ee_rec k u e.
Proof with try solve [congruence | intuition].
  intros u e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; try solve [congruence | intuition];
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ee_rec_expr_aux with (j := 0) (v := exp_fvar x);
    try solve [congruence | intuition]
  | unfold open_te in *;
    pick fresh X;
    eapply open_ee_rec_type_aux with (j := 0) (V := typ_fvar X);
    try solve [congruence | intuition]
  ].
Qed.

Lemma subst_ee_fresh : forall (x: atom) u e,
  x `notin` fv_ee e ->
  e = subst_ee x u e.
Proof with try solve [congruence | intuition].
  intros x u e; induction e; simpl; intro H; f_equal...
  Case "exp_fvar".
    destruct (a==x)...
    contradict H; fsetdec.
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
  expr u ->
  subst_ee x u (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with try solve [congruence | intuition].
  intros e1 e2 x u k WP. revert k.
  induction e1; intros K; simpl; f_equal...
  Case "exp_bvar".
    destruct (K == n); subst...
  Case "exp_fvar".
    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall (x y:atom) u e,
  y <> x ->
  expr u ->
  open_ee (subst_ee x u e) y = subst_ee x u (open_ee e y).
Proof with try solve [congruence | intuition].
  intros x y u e Neq Wu.
  unfold open_ee.
  rewrite subst_ee_open_ee_rec...
  simpl.
  destruct (y == x)...
Qed.

Lemma subst_te_open_ee_rec : forall e1 e2 Z P k,
  subst_te Z P (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_te Z P e2) (subst_te Z P e1).
Proof with try solve [congruence | intuition].
  induction e1; intros e2 Z P K; simpl; f_equal...
  Case "exp_bvar".
    destruct (K == n)...
Qed.

Lemma subst_te_open_ee : forall e1 e2 Z P,
  subst_te Z P (open_ee e1 e2) = open_ee (subst_te Z P e1) (subst_te Z P e2).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ee.
  apply subst_te_open_ee_rec...
Qed.

Lemma subst_te_open_ee_var : forall Z (x:atom) P e,
  open_ee (subst_te Z P e) x = subst_te Z P (open_ee e x).
Proof with try solve [congruence | intuition].
  intros.
  rewrite subst_te_open_ee...
Qed.

Lemma subst_ee_open_te_rec : forall e P z u k,
  expr u ->
  subst_ee z u (open_te_rec k P e) = open_te_rec k P (subst_ee z u e).
Proof with try solve [congruence | intuition].
  induction e; intros P z u K H; simpl; f_equal...
  Case "exp_fvar".
    destruct (a == z)... apply open_te_rec_expr...
Qed.

Lemma subst_ee_open_te : forall e P z u,
  expr u ->
  subst_ee z u (open_te e P) = open_te (subst_ee z u e) P.
Proof with try solve [congruence | intuition].
  intros.
  unfold open_te.
  apply subst_ee_open_te_rec...
Qed.

Lemma subst_ee_open_te_var : forall z (X:atom) u e,
  expr u ->
  open_te (subst_ee z u e) X = subst_ee z u (open_te e X).
Proof with try solve [congruence | intuition].
  intros z X u e H.
  rewrite subst_ee_open_te...
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
  x `notin` fv_ee e ->
  open_ee_rec k u e = subst_ee x u (open_ee_rec k (exp_fvar x) e).
Proof with try solve [congruence | intuition].
  induction e; intros u K Fr; simpl in *; f_equal...
  Case "exp_bvar".
    destruct (K == n)... simpl. destruct (x == x)...
  Case "exp_fvar".
    destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall (x : atom) e u,
  x `notin` fv_ee e ->
  open_ee e u = subst_ee x u (open_ee e x).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ee.
  apply subst_ee_intro_rec...
Qed.

(* *********************************************************************** *)
(** * ## Local closure is preserved under substitution *)

(** While these lemmas may be considered properties of substitution, we
    separate them out due to the lemmas that they depend on. *)

(** The following lemma depends on [subst_tt_open_tt_var]. *)

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  Case "type_fvar".
    destruct (X == Z)...
  Case "type_all".
    pick fresh Y and apply type_all...
    rewrite subst_tt_open_tt_var...
Qed.

(** The following lemma depends on [subst_tt_type] and
    [subst_te_open_ee_var]. *)

Lemma subst_te_expr : forall Z P e,
  expr e ->
  type P ->
  expr (subst_te Z P e).
Proof with eauto using subst_tt_type.
  intros Z P e He Hp.
  induction He; simpl; auto using subst_tt_type;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton Z);
    intros;
    try rewrite subst_te_open_ee_var;
    try rewrite subst_te_open_te_var;
    eauto using subst_tt_type
  ].
Qed.

(** The following lemma depends on [subst_ee_open_ee_var] and
    [subst_ee_open_te_var]. *)

Lemma subst_ee_expr : forall z e1 e2,
  expr e1 ->
  expr e2 ->
  expr (subst_ee z e2 e1).
Proof with auto.
  intros z e1 e2 He1 He2.
  induction He1; simpl; auto;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton z);
    intros;
    try rewrite subst_ee_open_ee_var;
    try rewrite subst_ee_open_te_var;
    auto
  ].
  Case "expr_var".
    destruct (x == z)...
Qed.

(* *********************************************************************** *)
(* more properties of fv *)

Lemma fv_in_open_ee:  forall x e1 e2 k,
   x `in` fv_ee e1 ->
   x `in` fv_ee (open_ee_rec k e2 e1).
Proof.
  intros x. induction e1; intros e2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHe1; auto].
  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.

  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ee_rec (S k1) e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.

  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.
Qed.

Lemma fv_in_open_te:  forall x e1 e2 k,
   x `in` fv_ee e1 ->
   x `in` fv_ee (open_te_rec k e2 e1).
Proof.
  intros x. induction e1; intros e2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHe1; auto].
  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (x `in` fv_ee (open_te_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_te_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.

  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (x `in` fv_ee (open_te_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_te_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.

  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H.
    fsetdec.
  destruct H as [H | H].
    assert (x `in` fv_ee (open_te_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_te_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.
Qed.

Lemma notin_open_tt_rec_fv : forall (Y X : atom) T n,
  X `notin` fv_tt T ->
  X <> Y ->
  X `notin` fv_tt (open_tt_rec n Y T).
Proof.
  intros.
  generalize dependent n. generalize dependent X.
  induction T; simpl; intros X Nin Neq n0; simpl; auto.
    destruct (n0 == n); simpl; auto.
Qed.

Lemma notin_open_tt_fv : forall (Y X : atom) T,
  X `notin` fv_tt T ->
  X <> Y ->
  X `notin` fv_tt (open_tt T Y).
Proof.
  intros. unfold open_tt.
  apply (notin_open_tt_rec_fv Y X T 0); auto.
Qed.

Lemma notin_fv_tt_open : forall (Y X : atom) T,
  X `notin` fv_tt (open_tt T Y) ->
  X `notin` fv_tt T.
Proof.
 intros Y X T. unfold open_tt.
 generalize 0.
 induction T; simpl; intros K Fr; destruct_notin; try apply notin_union; eauto.
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** We add as hints the fact that local closure is preserved under
    substitution.  This is part of our strategy for automatically
    discharging local-closure proof obligations. *)

Hint Resolve subst_tt_type subst_te_expr subst_ee_expr.

(** When reasoning about the [binds] relation and [map], we
    occasionally encounter situations where the binding is
    over-simplified.  The following hint undoes that simplification,
    thus enabling [Hint]s from the [Environment] library. *)

Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tb X U (F T)).

Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tlb X U (F T)).

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory") ***
*** End: ***
 *)


Require Export List.

Require Import term.
Require Import rpo.

Require Export utils.
Require Export coccinelle_utils.

(** Translation of the specification *)
Module Specif.

  Inductive symb : Set :=
  | id_0
  | id_S
  | id_true
  | id_false
  | id_C
  | id_Nil
  | id_Cons
  | id_PLAN_eq
  | id_OBJ_eq
  | id_nat_eq
  | id_plus
  | id_le
  | id_time
  | id_timel
  | id_er
  | id_erl
  | id_memberC
  | id_memberT
  | id_memberE
  | id_sortedT
  | id_sortedE
  | id_listUpTo
  | id_wind
  | id_maxEr
  | id_acr
  | id_insAt
  | id_insIn
  | id_progAt
  | id_timeAt
  | id_firstAt
  | id_listAt
  | id_prog
  | id_acr1
  .

  Definition arity (f:symb) :=
    match f with
    | id_0 => term_spec.Free 0
    | id_S => term_spec.Free 1
    | id_true => term_spec.Free 0
    | id_false => term_spec.Free 0
    | id_C => term_spec.Free 2
    | id_Nil => term_spec.Free 0
    | id_Cons => term_spec.Free 2
    | id_PLAN_eq => term_spec.Free 2
    | id_OBJ_eq => term_spec.Free 2
    | id_nat_eq => term_spec.Free 2
    | id_plus => term_spec.Free 2
    | id_le => term_spec.Free 2
    | id_time => term_spec.Free 1
    | id_timel => term_spec.Free 1
    | id_er => term_spec.Free 1
    | id_erl => term_spec.Free 1
    | id_memberC => term_spec.Free 2
    | id_memberT => term_spec.Free 2
    | id_memberE => term_spec.Free 2
    | id_sortedT => term_spec.Free 1
    | id_sortedE => term_spec.Free 1
    | id_listUpTo => term_spec.Free 2
    | id_wind => term_spec.Free 4
    | id_maxEr => term_spec.Free 1
    | id_acr => term_spec.Free 4
    | id_insAt => term_spec.Free 3
    | id_insIn => term_spec.Free 3
    | id_progAt => term_spec.Free 2
    | id_timeAt => term_spec.Free 2
    | id_firstAt => term_spec.Free 2
    | id_listAt => term_spec.Free 2
    | id_prog => term_spec.Free 3
    | id_acr1 => term_spec.Free 4
    end.

Definition status (f:symb) :=
     match f with
    | id_0 => rpo.Mul
    | id_S => rpo.Mul
    | id_true => rpo.Mul
    | id_false => rpo.Mul
    | id_C => rpo.Mul
    | id_Nil => rpo.Mul
    | id_Cons => rpo.Mul
    | id_PLAN_eq => rpo.Mul
    | id_OBJ_eq => rpo.Mul
    | id_nat_eq => rpo.Mul
    | id_plus => rpo.Mul
    | id_le => rpo.Mul
    | id_time => rpo.Mul
    | id_timel => rpo.Mul
    | id_er => rpo.Mul
    | id_erl => rpo.Mul
    | id_memberC => rpo.Mul
    | id_memberT => rpo.Mul
    | id_memberE => rpo.Mul
    | id_sortedT => rpo.Mul
    | id_sortedE => rpo.Mul
    | id_listUpTo => rpo.Mul
    | id_wind => rpo.Mul
    | id_maxEr => rpo.Mul
    | id_acr => rpo.Mul
    | id_insAt => rpo.Mul
    | id_insIn => rpo.Mul
    | id_progAt => rpo.Mul
    | id_timeAt => rpo.Mul
    | id_firstAt => rpo.Mul
    | id_listAt => rpo.Mul
    | id_prog => rpo.Mul
    | id_acr1 => rpo.Mul

    end.
  Definition index (f:symb) :=
     match f with
    | id_0 => 2
    | id_S => 3
    | id_true => 4
    | id_false => 5
    | id_C => 6
    | id_Nil => 7
    | id_Cons => 10
    | id_PLAN_eq => 17
    | id_OBJ_eq => 14
    | id_nat_eq => 11
    | id_plus => 12
    | id_le => 18
    | id_time => 8
    | id_timel => 13
    | id_er => 9
    | id_erl => 22
    | id_memberC => 19
    | id_memberT => 15
    | id_memberE => 16
    | id_sortedT => 27
    | id_sortedE => 32
    | id_listUpTo => 25
    | id_wind => 28
    | id_maxEr => 20
    | id_acr => 35
    | id_insAt => 26
    | id_insIn => 29
    | id_progAt => 30
    | id_timeAt => 23
    | id_firstAt => 24
    | id_listAt => 31
    | id_prog => 36
    | id_acr1 => 39
    end.

  Definition max_size := 100.

End Specif.

(* Nat and comparisons *)
Module Nat <: decidable_set.S.

  Definition A:=nat.
  Definition eq_bool := utils.beq_nat.
  Definition eq_bool_ok := utils.beq_nat_ok.

End Nat. (*: decidable_set.S*)

(** Initialisation of Coccinelle *)
Module Symbols <: term_spec.Signature.

  Module Symb <: decidable_set.S.

    Definition A:=Specif.symb.

    Theorem symb_eq_dec: forall x y:A, {x=y}+{x<>y}.
    Proof.
    decide equality.
    Defined.

    Definition eq_bool := utils.eq_bool A symb_eq_dec.
    Definition eq_bool_ok := utils.eq_bool_ok A symb_eq_dec.

  End Symb. (* Symb : decidable_set.S *)

  Definition arity := Specif.arity.

End Symbols. (* Symbols : term_spec.Signature *)

Module Terms <: term_spec.Term := term.Make' Symbols Nat.
Module Rpo := coccinelle_utils.Make Terms.

Export Specif.
Export Rpo.

Theorem prec_eq_status : forall f g, utils.prec_eq symb index f g -> status f = status g.
Proof.
intros f g; case f; case g; reflexivity.
Qed.

Definition P := rpo.Build_Precedence status
    (utils.prec_bool symb index) (utils.prec_bool_ok symb index)  (utils.prec_antisym symb index) (utils.prec_transitive symb index) (utils.prec_eq_bool symb index) (utils.prec_eq_transitive symb index) (utils.prec_eq_refl symb index) (utils.prec_eq_bool_ok symb index) (utils.prec_eq_prec1 symb index) (utils.prec_eq_prec2 symb index) (utils.prec_eq_sym symb index) (utils.prec_not_prec_eq symb index) (prec_eq_status).

Notation less := (rpo_mul P (bb (empty_rpo_infos P max_size))).

(* Coq version of the specification. *) (* TODO: should be in Spec module but model_* *)
  Inductive OBJ:Set := C: nat -> nat -> OBJ.
Inductive PLAN:Set := Nil | Cons: OBJ -> PLAN -> PLAN.

Fixpoint nat_eq (m n:nat) : bool :=
match m, n with
|0, 0 => true
|S_, 0 => false
|0, S_ => false
| S x, S y => nat_eq x y
end.

Definition OBJ_eq (m n: OBJ) : bool :=
match m, n with
| C t1 e1, C t2 e2 => andb (nat_eq t1 t2) (nat_eq e1 e2)
end.

Fixpoint PLAN_eq (m n: PLAN) : bool :=
match m, n with
| Nil, Nil => true
| Nil, Cons _ _ => false
| Cons _ _, Nil => false
| Cons o1 l1, Cons o2 l2 =>
 match OBJ_eq o1 o2 with
  | true => PLAN_eq l1 l2
  | false => false
 end
end.

Fixpoint le (m n:nat): bool :=
match m,n with
| 0,_ => true
| S_, 0 => false
| S x, S y => le x y
end.

Definition time (o:OBJ) : nat :=
match o with
| C t e => t
end.

Fixpoint memberC (o1:OBJ) (p1:PLAN): bool :=
match p1 with
|Nil => false
| Cons o2 p2 =>
  match OBJ_eq o1 o2 with
  |true => true
  |false => memberC o1 p2
 end
end.

Fixpoint memberT (t1:nat) (p1:PLAN): bool :=
match p1 with
|Nil => false
| Cons (C t2 e) p2 =>
  match nat_eq t1 t2 with
  |true => true
  |false => memberT t1 p2
 end
end.

Fixpoint memberE (e1:nat) (p1:PLAN): bool :=
match p1 with
|Nil => false
| Cons (C t e2) p2 =>
  match nat_eq e1 e2 with
  |true => true
  |false => memberE e1 p2
 end
end.

Definition timel (o:PLAN): nat :=
match o with
| Nil => 0
| Cons o p => time o
end.

Definition er (o:OBJ) : nat :=
match o with
| C t e => e
end.

Definition erl (p:PLAN) : nat :=
match p with
| Nil => 0
| Cons o p' => er o
end.

Fixpoint sortedT (p:PLAN) : bool :=
match p with
| Nil => true
| Cons (C t1 e1) p1 =>
  match p1 with
  | Nil => true
  | Cons (C t2 e2) p2 =>
     match le t2 t1 with
       | true => sortedT p1
       | false => false
     end
  end
end.

Fixpoint sortedE (p:PLAN) : bool :=
match p with
| Nil => true
| Cons (C t1 e1) p1 =>
  match p1 with
  | Nil => true
  | Cons (C t2 e2) p2 =>
     match le e2 e1 with
       | false => sortedE p1
       | true => false
     end
  end
end.

Fixpoint listUpTo (p:PLAN) (t:nat) : PLAN :=
match p with
|Nil =>  Nil
|Cons (C t1 e1) p1 =>
  match le t1 t with
   | true => Cons (C t1 e1) Nil
   | false => Cons (C t1 e1) (listUpTo p1 t)
 end
end.

Fixpoint wind (p':PLAN) (t t1 t2: nat) : PLAN :=
match p' with
|Nil => Nil
|Cons (C t' e') p =>
 match le (plus t' t2) t with
  | false => wind p t  t1 t2
  | true =>
    match le (plus t' t1) t with
       | true => Cons (C t' e') Nil
       | false => Cons (C t' e') (wind p t t1 t2)
   end
 end
end.

Fixpoint maxEr (p':PLAN) : nat :=
match p' with
|Nil => 0
|Cons (C t e) p =>
  match le (maxEr p) e with
  | true => e
  | false => maxEr p
 end
end.

Definition acr (p: PLAN) (t t2 t3: nat) : nat :=
   match sortedT p with
    | true => (match le t2 t3 with
                       |false =>maxEr (wind p t t2 t3)
                       |true =>  0
                     end)
    | false => 0
  end.

Fixpoint insAt (p:PLAN) (t e:nat) : PLAN :=
match p with
| Nil => Cons(C t e) Nil
| Cons o pg =>
  match le (time o) t with
  | true => Cons (C t e) (Cons o pg)
  | false => insAt pg t e
  end
end.

Fixpoint insIn  (p:PLAN) (t e:nat) : PLAN :=
match p with
| Nil => Cons(C t e) Nil
| Cons o pg =>
  match le (er o) e with
  | true => insIn pg (time o) e
  | false => Cons (C t e) (Cons o pg)
  end
end.

Hint Unfold er.
Hint Unfold time.

Fixpoint progAt (p:PLAN) (t:nat) : nat :=
match p with
| Nil => 0
| Cons o pg =>
  match le (time o) t with
  | true => er o
  | false => progAt pg t
  end
end.

Fixpoint timeAt (p: PLAN) (t:nat) : nat :=
match p with
|Nil => 0
|Cons o pg =>
  match le (time o) t with
   | true => time o
   | false => timeAt pg t
  end
end.

Fixpoint firstAt (p:PLAN) (t:nat) : OBJ :=
match p with
| Nil => C 0 0
| Cons o pg =>
  match le (time o) t with
    | true => o
    | false => firstAt pg t
  end
end.

Fixpoint listAt (p: PLAN) (t: nat) : PLAN :=
match p with
|Nil => Nil
|Cons o pg =>
  match le (time o) t with
    | true => Cons o pg
    | false => listAt pg t
  end
end.

Fixpoint prog (p:PLAN) (t2 t3:nat) : PLAN :=
match p with
| Nil => Nil
| Cons o p =>
  match le (progAt (prog p t2 t3) (plus (time o) t3)) (er o) with
  | true => insAt (prog p t2 t3) (plus (time o) t3) (er o)
  | false => insIn (prog p t2 t3) (plus (time o) t2) (er o)
  end
end.

Fixpoint model_nat (n:nat) : term :=
match n with
| 0 => Term id_0 nil
| S n' => Term id_S ((model_nat n')::nil)
end.

Definition model_bool (b:bool) : term :=
match b with
| true => Term id_true nil
| false => Term id_false nil
end.

Definition model_OBJ (o:OBJ) : term :=
match o with
| C x y => Term id_C ((model_nat x)::(model_nat y)::nil)
end.

Fixpoint model_PLAN (p:PLAN) : term :=
match p with
| Nil => Term id_Nil nil
| Cons o p => Term id_Cons ((model_OBJ o)::(model_PLAN p)::nil)
end.

Definition acr1 (p: PLAN) (t t2 t3: nat) : nat :=
   match sortedT p with
    | true => (match le t2 t3 with
                       |false => progAt (prog p t2 t3) t
                       |true =>  0
                     end)
    | false => 0
  end.

(** Initialisation of proof process *)
Lemma model_nat_0: model_nat 0 = (Term id_0 nil).
Proof.
auto.
Qed.

Lemma model_nat_S: forall (u1: nat), model_nat (S u1) = (Term id_S ((model_nat u1)::nil)).
Proof.
auto.
Qed.

Lemma model_bool_true: model_bool true = (Term id_true nil).
Proof.
auto.
Qed.

Lemma model_bool_false: model_bool false = (Term id_false nil).
Proof.
auto.
Qed.

Lemma model_OBJ_C: forall (u1: nat), forall (u2: nat), model_OBJ (C u1 u2) = (Term id_C ((model_nat u1):: (model_nat u2)::nil)).
Proof.
auto.
Qed.

Lemma model_PLAN_Nil: model_PLAN Nil = (Term id_Nil nil).
Proof.
auto.
Qed.

Lemma model_PLAN_Cons: forall (u1: OBJ), forall (u2: PLAN), model_PLAN (Cons u1 u2) = (Term id_Cons ((model_OBJ u1):: (model_PLAN u2)::nil)).
Proof.
auto.
Qed.

Hint Rewrite model_PLAN_Nil model_PLAN_Cons : model_PLAN.
Hint Rewrite model_bool_true model_bool_false : model_bool.
Hint Rewrite model_nat_0 model_nat_S : model_nat.
Hint Rewrite model_OBJ_C : model_OBJ.

Ltac rewrite_model := autorewrite with model_PLAN model_bool model_nat model_OBJ.