Require Import Metatheory.

Definition sym := atom.

Inductive typ : Set :=
| typ_nat
| typ_parr : typ -> typ -> typ.

Inductive exp : Set :=
| exp_blackhole : exp
| exp_sym  : atom -> exp
| exp_fvar : atom -> exp
| exp_bvar : nat -> exp
| exp_zero : exp
| exp_succ : exp -> exp
(* number -> zero branch -> non-zero branch -> exp *)
| exp_ifz  : exp -> exp -> exp -> exp
| exp_abs  : typ -> exp -> exp
| exp_app  : exp -> exp -> exp
| exp_fix  : typ -> exp -> exp.

Ltac solve_neq_contra :=
  match goal with
    H : ?a <> ?a
    |- _ => destruct H; reflexivity
  end.

Fixpoint fv (term : exp) : atoms :=
  match term with
  | exp_blackhole => empty
  | exp_sym  _ => empty
  | exp_fvar x => singleton x
  | exp_bvar _ => empty
  | exp_zero => empty
  | exp_succ e => fv e
  | exp_ifz num z_branch s_branch => fv num `union` fv z_branch `union` fv s_branch
  | exp_abs _ e => fv e
  | exp_app e1 e2 => fv e1 `union` fv e2
  | exp_fix _ e => fv e
  end.

Fixpoint subst (term : exp) (z : atom) (u : exp) : exp :=
  match term with
  | exp_blackhole => term
  | exp_sym  _ => term
  | exp_bvar _ => term
  | exp_fvar x => if x == z then u else term
  | exp_zero => term
  | exp_succ e => exp_succ (subst e z u)
  | exp_ifz num z_branch s_branch => exp_ifz (subst num z u)
                                            (subst z_branch z u)
                                            (subst s_branch z u)
  | exp_abs t exp => exp_abs t (subst exp z u)
  | exp_app e1 e2 => exp_app (subst e1 z u)
                            (subst e2 z u)
  | exp_fix t exp => exp_fix t (subst exp z u)
  end.

Fixpoint opening (term : exp) (x : exp) (k : nat) : exp :=
  match term with
  | exp_blackhole => term
  | exp_sym  _ => term
  | exp_fvar _ => term
  | exp_bvar k' => if k == k' then x else term
  | exp_zero => term
  | exp_succ exp => exp_succ (opening exp x k)
  | exp_ifz num z_branch s_branch => exp_ifz (opening num x k)
                                            (opening z_branch x k)
                                            (opening s_branch x (S k))
  | exp_abs t body => exp_abs t (opening body x (S k))
  | exp_app e1 e2 => exp_app (opening e1 x k) (opening e2 x k)
  | exp_fix t body => exp_fix t (opening body x (S k))
  end.

Definition open term x := opening term x 0.

Hint Unfold open.

Notation "{ k ~> u } t" := (opening t u k) (at level 67).
Notation "[ z ~> u ] e" := (subst e z u) (at level 68).

Ltac gather_atoms ::=
     let A := gather_atoms_with (fun x : atoms => x) in
     let B := gather_atoms_with (fun x : atom => singleton x) in
     let C := gather_atoms_with (fun x : list (atom * typ) => dom x) in
     let D := gather_atoms_with (fun x : exp => fv x) in
     let E := gather_atoms_with (fun x : list (atom * exp) => dom x) in
     constr:(A `union` B `union` C `union` D `union` E).

Lemma union_subset :
  forall s1 s2 s1' s2',
    s1 [<=] s1' -> s2 [<=] s2' -> (s1 \u s2) [<=] (s1' \u s2').
Proof.
  intros.
  Search "[<=]".
  apply KeySetProperties.union_subset_3; fsetdec.
Qed.

Lemma open_var_fv : forall e x,
    fv ({0 ~> exp_fvar x} e) [<=] fv e \u (singleton x).
Proof.
  intros e x.
  generalize dependent 0.
  induction e; intros; simpl in *; try fsetdec.
  - destruct (n0 == n).
    + simpl. fsetdec.
    + simpl. fsetdec.
  - apply IHe.
  - apply KeySetProperties.union_subset_3.
    assert (fv ({n ~> exp_fvar x} e1) [<=] union (fv e1) (singleton x)). {
      apply IHe1.
    }
    fsetdec.
    apply KeySetProperties.union_subset_3.
    assert (fv ({n ~> exp_fvar x} e2) [<=] union (fv e2) (singleton x)). {
      apply IHe2.
    }
    fsetdec.
    assert (fv ({S n ~> exp_fvar x} e3) [<=] union (fv e3) (singleton x)). {
      apply IHe3.
    }
    fsetdec.
  - assert (fv ({S n ~> exp_fvar x} e) [<=] union (fv e) (singleton x)). {
      apply IHe.
    }
    fsetdec.
  - apply KeySetProperties.union_subset_3.
    assert (fv ({n ~> exp_fvar x} e1) [<=] union (fv e1) (singleton x)). {
      apply IHe1.
    }
    fsetdec.
    assert (fv ({n ~> exp_fvar x} e2) [<=] union (fv e2) (singleton x)). {
      apply IHe2.
    }
    fsetdec.
  - assert (fv ({S n ~> exp_fvar x} e) [<=] union (fv e) (singleton x)). {
      apply IHe.
    }
    fsetdec.
Qed.

Lemma open_lc_core : forall e j v i u,
    i <> j
    -> {j ~> v} e = {i ~> u}({j ~> v} e)
    -> e = {i ~> u} e.
Proof.
  induction e; intros j v i u Hneq Hopen; simpl in *; try reflexivity.
  - Case "exp_bvar".
    destruct (i == n); destruct (j == n).
    + SCase "i <> j, j = i = n".
      rewrite e0 in Hneq. rewrite e in Hneq.
      solve_neq_contra.
    + SCase "i <> j, i = n, j <> n".
      subst.
      simpl in Hopen.
      destruct (n == n).
      * auto.
      * solve_neq_contra.
    + auto.
    + auto.
  - f_equal.
    eapply IHe; eauto.
    inversion Hopen.
    eassumption.
  - inversion Hopen; subst.
    f_equal.
    + eapply IHe1; eauto.
    + eapply IHe2; eauto.
    + assert (S i <> S j). {
        intros contra.
        inversion contra.
        subst.
        solve_neq_contra.
      }
      eapply IHe3; eauto.
  - inversion Hopen; subst.
    f_equal.
    assert (S i <> S j). {
      intros contra.
      inversion contra.
      subst.
      solve_neq_contra.
    }
    eapply IHe; eauto.
  - inversion Hopen; subst.
    f_equal.
    + eapply IHe1; eauto.
    + eapply IHe2; eauto.
  - inversion Hopen; subst.
    f_equal.
    assert (S i <> S j). {
      intros contra.
      inversion contra.
      subst.
      solve_neq_contra.
    }
    eapply IHe; eauto.
Qed.

Definition cost_annotated_relation (X : Type) := X -> X -> nat -> Prop.

Inductive multi {X : Type} (R : cost_annotated_relation X)
  : cost_annotated_relation X :=
| multi_refl : forall (x : X), multi R x x 0
| multi_step : forall (x y z : X) (k_xy k_yz : nat),
    R x y k_xy -> multi R y z k_yz -> multi R x z (k_xy + k_yz).

Module CallByValue.

Inductive lc : exp -> Prop :=
| lc_fvar : forall x, lc (exp_fvar x)
| lc_zero : lc exp_zero
| lc_succ : forall e, lc e -> lc (exp_succ e)
| lc_ifz : forall (L : atoms) (num z_branch s_branch : exp),
    lc num
    -> lc z_branch
    -> (forall x, x `notin` L -> lc (open s_branch (exp_fvar x)))
    -> lc (exp_ifz num z_branch s_branch)
| lc_abs : forall (L : atoms) t exp,
    (forall x, x `notin` L -> lc (open exp (exp_fvar x)))
    -> lc (exp_abs t exp)
| lc_app : forall e1 e2, lc e1
                    -> lc e2
                    -> lc (exp_app e1 e2)
| lc_fix : forall (L : atoms) t exp,
    (forall x, x `notin` L -> lc (open exp (exp_fvar x)))
    -> lc (exp_fix t exp).

Ltac solve_open_lc_main :=
  match goal with
    H : forall x : atom,
        x `notin` ?L
        -> forall k, open ?exp (exp_fvar x) = {k ~> ?u} open ?exp (exp_fvar x)
               |- _ => unfold open in H;
                     pick fresh x;
                     apply open_lc_core with (j := 0) (v := exp_fvar x);
                     try (apply H);
                     auto
end.

Lemma open_lc : forall k u e,
    lc e -> e = {k ~> u} e.
Proof.
  intros k u e Hlc.
  generalize dependent k.
  induction Hlc; try (simpl; reflexivity).
  - intros k.
    simpl.
    rewrite <- IHHlc.
    reflexivity.
  - intros k.
    simpl.
    rewrite <- IHHlc1.
    rewrite <- IHHlc2.
    f_equal.
    solve_open_lc_main.
  - intros k.
    simpl.
    f_equal.
    solve_open_lc_main.
  - intros k.
    simpl.
    rewrite <- IHHlc1.
    rewrite <- IHHlc2.
    reflexivity.
  - intros k.
    simpl.
    f_equal.
    solve_open_lc_main.
Qed.

Lemma subst_intro : forall x e u,
    x `notin` fv e
    -> {0 ~> u} e = [x ~> u] {0 ~> (exp_fvar x)} e.
Proof.
  intros x e u Hnotin.
  generalize dependent 0.
  induction e; try (simpl; reflexivity).
  - intros n.
    simpl.
    destruct (a == x).
    + rewrite e in Hnotin. simpl in Hnotin.
      fsetdec.
    + reflexivity.
  - intros n0.
    simpl in *.
    destruct (n0 == n).
    + simpl.
      destruct (x == x).
      * reflexivity.
      * solve_neq_contra.
    + simpl.
      reflexivity.
  - intros n.
    simpl in *.
    f_equal.
    apply IHe; auto.
  - intros n.
    simpl in *.
    f_equal.
    + apply IHe1; auto.
    + apply IHe2; auto.
    + apply IHe3; auto.
  - intros n.
    simpl in *.
    f_equal.
    apply IHe; auto.
  - intros n.
    simpl in *.
    f_equal.
    + apply IHe1; auto.
    + apply IHe2; auto.
  - intros n.
    simpl in *.
    f_equal.
    apply IHe; auto.
Qed.

Lemma subst_open : forall x u e v,
    lc u -> [x ~> u] ({0 ~> v} e) = {0 ~> ([x ~> u] v)}([x ~> u] e).
Proof.
  intros x u e v Hlc.
  generalize dependent 0.
  induction e.
  - intros n.
    simpl. reflexivity.
  - intros n.
    simpl. reflexivity.
  - intros n.
    simpl.
    destruct (a == x).
    + apply open_lc; auto.
    + simpl. auto.
  - intros n0.
    simpl.
    destruct (n0 == n).
    + reflexivity.
    + simpl. reflexivity.
  - auto.
  - intros n.
    simpl.
    f_equal.
    apply IHe.
  - intros n.
    simpl.
    f_equal.
    + apply IHe1.
    + apply IHe2.
    + apply IHe3.
  - intros n.
    simpl.
    f_equal.
    apply IHe.
  - intros n.
    simpl.
    f_equal.
    apply IHe1.
    apply IHe2.
  - intros n.
    simpl.
    f_equal.
    apply IHe.
Qed.

Notation env := (list (atom * typ)).

Inductive typing : env -> exp -> typ -> Prop :=
| typing_var : forall E (x : atom) T,
    uniq E
    -> binds x T E
    -> typing E (exp_fvar x) T
| typing_zero : forall E,
    uniq E
    -> typing E exp_zero typ_nat
| typing_succ : forall E e,
    typing E e typ_nat
    -> typing E (exp_succ e) typ_nat
| typing_ifz : forall (L : atoms) E num z_branch s_branch t,
    typing E num typ_nat
    -> typing E z_branch t
    -> (forall (x:atom), x `notin` L
                   -> typing ((x ~ typ_nat) ++ E) (open s_branch (exp_fvar x)) t)
    -> typing E (exp_ifz num z_branch s_branch) t
| typing_abs : forall (L : atoms) E exp t1 t2,
    (forall (x:atom), x `notin` L
                 -> typing ((x ~ t1) ++ E) (open exp (exp_fvar x)) t2)
    -> typing E (exp_abs t1 exp) (typ_parr t1 t2)
| typing_app : forall E e1 e2 t1 t2,
    typing E e1 (typ_parr t1 t2)
    -> typing E e2 t1
    -> typing E (exp_app e1 e2) t2
| typing_fix : forall (L : atoms) E exp t,
    (forall (x:atom), x `notin` L
                 -> typing ((x ~ t) ++ E) (open exp (exp_fvar x)) t)
    -> typing E (exp_fix t exp) t.

Lemma typing_uniq : forall E e T,
    typing E e T -> uniq E.
Proof.
  intros E e T H.
  induction H; auto.
  - pick fresh x;
      assert (uniq ((x ~ t1) ++ E)). {
      apply H0; auto.
    }
    solve_uniq.
  - pick fresh x;
      assert (uniq ((x ~ t) ++ E)). {
      apply H0; auto.
    }
    solve_uniq.
Qed.

Lemma subst_lc : forall x e u,
    lc e -> lc u -> lc ([x ~> u] e).
Proof.
  intros x e u Hlc.
  generalize dependent u.
  induction Hlc; intros u Hlcu.
  - simpl.
    destruct (x0 == x); try constructor; auto.
  - simpl. constructor.
  - simpl. constructor. apply IHHlc; auto.
  - simpl.
    pick fresh y and apply lc_ifz; auto.
    unfold open in *.
    replace (exp_fvar y) with ([x ~> u] exp_fvar y).
    rewrite <- subst_open; auto.
    simpl.
    destruct (y == x).
    + subst. fsetdec.
    + auto.
  - simpl.
    pick fresh y and apply lc_abs; auto.
    unfold open.
    replace (exp_fvar y) with ([x ~> u] exp_fvar y).
    rewrite <- subst_open; auto.
    apply H0; auto.
    simpl.
    destruct (y == x).
    + subst. fsetdec.
    + auto.
  - simpl.
    constructor; auto.
  - simpl.
    pick fresh y and apply lc_fix.
    unfold open.
    replace (exp_fvar y) with ([x ~> u] exp_fvar y).
    rewrite <- subst_open; auto.
    apply H0; auto.
    simpl.
    destruct (y == x).
    + subst. fsetdec.
    + auto.
Qed.

Lemma typing_weakening : forall (E F : env) e T,
    typing E e T ->
    uniq (F ++ E) ->
    typing (F ++ E) e T.
Proof.
Admitted.

Lemma typing_lc : forall E e T,
    typing E e T -> lc e.
Proof.
  intros E e T Htyping.
  induction Htyping.
  - constructor.
  - constructor.
  - constructor; auto.
  - pick fresh x and apply lc_ifz; auto.
  - pick fresh x and apply lc_abs; auto.
  - constructor; auto.
  - pick fresh x and apply lc_fix; auto.
Qed.

Lemma typing_subst_strengthened : forall F E e x u T1 T2,
    typing (F ++ (x ~ T1) ++ E) e T2
    -> typing E u T1
    -> typing (F ++ E) ([x ~> u] e) T2.
Proof.
  intros F E e x u T1 T2 Htyping1 Htyping2.
  remember (F ++ (x ~ T1) ++ E) as G.
  generalize dependent F.
  induction Htyping1.
  - intros F Heq. subst.
    simpl.
    destruct (x0 == x).
    + subst.
      assert (T = T1). {
        eapply binds_mid_eq; eauto.
      }
      subst.
      apply typing_weakening; auto.
      eapply uniq_remove_mid; eauto.
    + apply uniq_remove_mid in H.
      apply binds_remove_mid in H0; auto.
      constructor; auto.
  - intros F Heq. subst.
    simpl.
    apply uniq_remove_mid in H.
    constructor; auto.
  - intros F Heq. subst.
    simpl.
    constructor.
    apply IHHtyping1; auto.
  - intros F Heq. subst.
    simpl.
    pick fresh y and apply typing_ifz; auto.
    unfold open in *.
    replace (exp_fvar y) with ([x ~> u] exp_fvar y).
    rewrite <- subst_open; auto.
    apply H0 with (F0 := (y ~ typ_nat) ++ F); auto.
    eapply typing_lc; eauto.
    simpl.
    destruct (y == x).
    + subst.
      fsetdec.
    + auto.
  - intros F Heq. subst.
    simpl.
    pick fresh y and apply typing_abs.
    unfold open in *.
    replace (exp_fvar y) with ([x ~> u] exp_fvar y).
    rewrite <- subst_open.
    apply H0 with (F0 := (y ~ t1) ++ F); auto.
    eapply typing_lc; eauto.
    simpl.
    destruct (y == x).
    + subst. fsetdec.
    + auto.
  - intros F Heq. subst.
    simpl.
    apply typing_app with (t1 := t1); auto.
  - intros F Heq. subst.
    simpl.
    pick fresh y and apply typing_fix.
    unfold open in *.
    replace (exp_fvar y) with ([x ~> u] exp_fvar y).
    rewrite <- subst_open.
    apply H0 with (F0 := (y ~ t) ++ F); auto.
    eapply typing_lc; eauto.
    simpl.
    destruct (y == x).
    + subst. fsetdec.
    + auto.
Qed.

Lemma typing_subst : forall E e x u T1 T2,
    typing ((x ~ T1) ++ E) e T2
    -> typing E u T1
    -> typing E ([x ~> u] e) T2.
Proof.
  intros.
  rewrite_env (nil ++ E).
  rewrite_env (nil ++ (x ~ T1) ++ E) in H.
  eapply typing_subst_strengthened; eauto.
Qed.

(** A strict judgement on what are values *)
Inductive strict_is_val : exp -> Prop :=
| zero_is_val : strict_is_val exp_zero
| succ_is_val : forall e, strict_is_val e -> strict_is_val (exp_succ e)
| abs_is_val : forall t e, lc (exp_abs t e) -> strict_is_val (exp_abs t e).

Inductive strict_small_step : exp -> exp -> nat -> Prop :=
| succ_step : forall e1 e2 k,
    strict_small_step e1 e2 k
    -> strict_small_step (exp_succ e1) (exp_succ e2) k
| ifz_step_num : forall num num' z_branch s_branch k,
    lc (exp_ifz num z_branch s_branch)
    -> strict_small_step num num' k
    -> strict_small_step (exp_ifz num z_branch s_branch)
                        (exp_ifz num' z_branch s_branch)
                        k
| ifz_zero_step : forall z_branch s_branch,
    lc (exp_ifz exp_zero z_branch s_branch)
    -> strict_small_step (exp_ifz exp_zero z_branch s_branch)
                        z_branch 1
| ifz_succ_step : forall num z_branch s_branch,
    lc (exp_ifz (exp_succ num) z_branch s_branch)
    -> strict_is_val (exp_succ num)
    -> strict_small_step (exp_ifz (exp_succ num) z_branch s_branch)
                        (open s_branch num) 1
| app_step_l : forall e1 e1' e2 k,
    lc e2
    -> strict_small_step e1 e1' k
    -> strict_small_step (exp_app e1 e2) (exp_app e1' e2) k
| app_step_r : forall e1 e2 e2' k,
    strict_is_val e1
    -> strict_small_step e2 e2' k
    -> strict_small_step (exp_app e1 e2) (exp_app e1 e2') k
| beta_step : forall e t e2,
    lc (exp_abs t e)
    -> strict_is_val e2
    -> strict_small_step (exp_app (exp_abs t e) e2)
                        (open e e2) 1
| fix_step : forall t e,
    lc (exp_fix t e)
    -> strict_small_step (exp_fix t e)
                        (exp_fix t (open e (exp_fix t e))) 1.

Lemma val_lc : forall e,
    strict_is_val e -> lc e.
Proof.
  intros e Hval.
  induction Hval; try constructor; auto.
Qed.

Lemma beta_regular_left : forall e e' k,
    strict_small_step e e' k -> lc e.
Proof.
  intros e e' k Hstep.
  induction Hstep.
  - constructor; auto.
  - inversion H; subst.
    pick fresh x and apply lc_ifz; auto.
  - auto.
  - auto.
  - constructor; auto.
  - constructor; auto.
    apply val_lc in H; auto.
  - inversion H; subst.
    constructor; auto.
    apply val_lc in H0; auto.
  - auto.
Qed.

Lemma beta_regular_right : forall e e' k,
    strict_small_step e e' k -> lc e'.
Proof.
  intros e e' k Hstep.
  induction Hstep.
  - constructor; auto.
  - inversion H; subst.
    pick fresh x and apply lc_ifz; auto.
  - inversion H; subst; auto.
  - inversion H; subst; auto.
    unfold open in *.
    pick fresh x.
    rewrite subst_intro with (x := x); auto.
    apply subst_lc; auto.
    inversion H4; auto.
  - constructor; auto.
  - apply val_lc in H.
    constructor; auto.
  - inversion H; subst.
    unfold open in *.
    pick fresh x.
    rewrite subst_intro with (x := x); auto.
    apply subst_lc; auto.
    apply val_lc in H0; auto.
  - inversion H; subst.
    pick fresh x and apply lc_fix.
    unfold open in *.
    rewrite <- open_lc.
    + pick fresh y.
      rewrite subst_intro with (x := y); auto.
      apply subst_lc.
      apply H1; auto.
      auto.
    + pick fresh y.
      rewrite subst_intro with (x := y); auto.
      apply subst_lc.
      apply H1; auto.
      auto.
Qed.

Lemma beta_regular : forall e e' k,
    strict_small_step e e' k -> lc e /\ lc e'.
Proof.
  intros.
  split.
  eapply beta_regular_left; eauto.
  eapply beta_regular_right; eauto.
Qed.

Lemma canonical_form_abs : forall E e t1 t2,
    typing E e (typ_parr t1 t2)
    -> strict_is_val e
    -> exists e1, e = exp_abs t1 e1.
Proof.
  intros E e t1 t2 Htyping Hval.
  inversion Htyping; subst; try (inversion Hval; subst).
  exists exp0.
  reflexivity.
Qed.

Lemma progress : forall e T,
    typing nil e T
    -> strict_is_val e \/ exists e' k, strict_small_step e e' k.
Proof.
  intros e T.
  remember nil as E.
  intros Htyping.
  assert (lc e). {
    eapply typing_lc.
    apply Htyping.
  }
  induction Htyping.
  - subst. apply binds_nil_iff in H1.
    destruct H1.
  - left. constructor.
  - subst.
    destruct IHHtyping; auto.
    + inversion H; auto.
    + left. constructor; auto.
    + destruct H0 as [e' H'].
      destruct H' as [k H0].
      right.
      exists (exp_succ e').
      exists k.
      constructor; auto.
  - subst.
    right.
    destruct IHHtyping1; auto;
      destruct IHHtyping2; auto.
    + inversion H; auto.
    + inversion H; auto.
    + inversion H; auto.
    + inversion H; auto.
    + inversion H2; subst.
      * exists z_branch, 1.
        constructor; auto.
      * Print open.
        exists (open s_branch e), 1.
        constructor; auto.
      * inversion Htyping1; auto.
    + inversion H2; subst.
      * exists z_branch, 1.
        constructor; auto.
      * exists (open s_branch e), 1.
        constructor; auto.
      * inversion Htyping1.
    + inversion H; auto.
    + destruct H2 as [e' H2].
      destruct H2 as [k H2].
      exists (exp_ifz e' z_branch s_branch), k.
      constructor; auto.
    + destruct H2 as [e' H2].
      destruct H2 as [k H2].
      exists (exp_ifz e' z_branch s_branch), k.
      constructor; auto.
  - left.
    constructor; auto.
  - right.
    destruct IHHtyping1; auto;
      destruct IHHtyping2; auto.
    + inversion H; auto.
    + inversion H; auto.
    + inversion H; auto.
    + inversion H; auto.
    + assert (exists e10, e1 = exp_abs t1 e10). {
        eapply canonical_form_abs; eauto.
      }
      destruct H2 as [e10 H2].
      subst.
      exists (open e10 e2), 1.
      constructor.
      apply val_lc; auto.
      auto.
    + destruct H1 as [e' H1].
      destruct H1 as [k H1].
      exists (exp_app e1 e'), k.
      constructor; auto.
    + inversion H; auto.
    + destruct H0 as [e' H0].
      destruct H0 as [k H0].
      exists (exp_app e' e2), k.
      constructor; auto.
      inversion H; auto.
    + destruct H0 as [e' H0].
      destruct H0 as [k H0].
      exists (exp_app e' e2), k.
      constructor; auto.
      inversion H; auto.
  - right.
    exists (exp_fix t (open exp0 (exp_fix t exp0))), 1.
    constructor; auto.
Qed.

Lemma preservation : forall E e e' T k,
    typing E e T
    -> strict_small_step e e' k
    -> typing E e' T.
Proof.
  intros E e e' T k Htyping Hstep.
  generalize dependent E.
  generalize dependent T.
  induction Hstep.
  - intros T E Htyping.
    inversion Htyping; subst.
    constructor; auto.
  - intros T E Htyping.
    inversion Htyping; subst.
    pick fresh x and apply typing_ifz; auto.
  - intros T E Htyping.
    inversion Htyping; auto.
  - intros T E Htyping.
    inversion Htyping; subst.
    unfold open in *.
    pick fresh x.
    rewrite subst_intro with (x := x); auto.
    inversion H5; subst.
    apply typing_subst with (T1 := typ_nat); auto.
  - intros T E Htyping.
    inversion Htyping; subst.
    econstructor; eauto.
  - intros T E Htyping.
    inversion Htyping; subst.
    econstructor; eauto.
  - intros T E Htyping.
    inversion Htyping; subst.
    unfold open in *.
    inversion H4; subst.
    pick fresh x.
    rewrite subst_intro with (x := x); auto.
    eapply typing_subst; eauto.
  - intros T E Htyping.
    inversion Htyping; subst.
    assert (typing E (open e (exp_fix T e)) T). {
      pick fresh x.
      unfold open in *.
      rewrite subst_intro with (x := x); auto.
      apply typing_subst with (T1 := T).
      apply H4; auto.
      auto.
    }
    pick fresh x and apply typing_fix.
    unfold open in *.
    rewrite <- open_lc; auto.
    apply typing_weakening; auto.
    apply typing_uniq in Htyping.
    solve_uniq.
    apply typing_lc in H0; auto.
Qed.

End CallByValue.
Export CallByValue.

Module CallByNeed.

  Inductive lc : exp -> Prop :=
  | lc_sym  : forall x, lc (exp_sym x)
  | lc_blackhole : lc (exp_blackhole)
  | lc_fvar : forall x, lc (exp_fvar x)
  | lc_zero : lc exp_zero
  | lc_succ : forall e, lc e -> lc (exp_succ e)
  | lc_ifz : forall (L : atoms) (num z_branch s_branch : exp),
      lc num
      -> lc z_branch
      -> (forall x, x `notin` L -> lc (open s_branch (exp_fvar x)))
      -> lc (exp_ifz num z_branch s_branch)
  | lc_abs : forall (L : atoms) t exp,
      (forall x, x `notin` L -> lc (open exp (exp_fvar x)))
      -> lc (exp_abs t exp)
  | lc_app : forall e1 e2, lc e1
                      -> lc e2
                      -> lc (exp_app e1 e2)
  | lc_fix : forall (L : atoms) t exp,
      (forall x, x `notin` L -> lc (open exp (exp_fvar x)))
      -> lc (exp_fix t exp).

  Definition mu_table := list (atom * exp).
  Definition sig_table := list (atom * typ).

  Inductive lc_mu : mu_table -> Prop :=
  | lc_mu_safe : forall mu, uniq mu
                       -> (forall x e, binds x e mu
                                 -> lc e)
                       -> lc_mu mu.

  Definition lc_by_need (e : exp) (mu : mu_table) : Prop :=
    lc e /\ lc_mu mu.

  Inductive cbn_is_val : exp -> sig_table -> Prop :=
  | cbn_is_val_zero : forall Σ, uniq Σ -> cbn_is_val exp_zero Σ
  | cbn_is_val_succ : forall a Σ, uniq Σ ->
                             binds a typ_nat Σ ->
                             cbn_is_val (exp_succ (exp_sym a)) Σ
  | cbn_is_val_abs : forall t e Σ, uniq Σ -> cbn_is_val (exp_abs t e) Σ.

  Inductive typing : env -> sig_table -> exp -> typ -> Prop :=
  | typing_sym : forall E (a : atom) T Σ,
      uniq E
      -> uniq Σ
      -> binds a T Σ
      -> typing E Σ (exp_sym a) T
  | typing_var : forall E (x : atom) T Σ,
      uniq E
      -> binds x T E
      -> typing E Σ (exp_fvar x) T
  | typing_zero : forall E Σ,
      uniq E
      -> typing E Σ exp_zero typ_nat
  | typing_succ : forall E e Σ,
      typing E Σ e typ_nat
      -> typing E Σ (exp_succ e) typ_nat
  | typing_ifz : forall (L : atoms) E num z_branch s_branch t Σ,
      typing E Σ num typ_nat
      -> typing E Σ z_branch t
      -> (forall (x:atom), x `notin` L
                     -> typing ((x ~ typ_nat) ++ E) Σ (open s_branch (exp_fvar x)) t)
      -> typing E Σ (exp_ifz num z_branch s_branch) t
  | typing_abs : forall (L : atoms) E exp t1 t2 Σ,
      (forall (x:atom), x `notin` L
                   -> typing ((x ~ t1) ++ E) Σ (open exp (exp_fvar x)) t2)
      -> typing E Σ (exp_abs t1 exp) (typ_parr t1 t2)
  | typing_app : forall E e1 e2 t1 t2 Σ,
      typing E Σ e1 (typ_parr t1 t2)
      -> typing E Σ e2 t1
      -> typing E Σ (exp_app e1 e2) t2
  | typing_fix : forall (L : atoms) E exp t Σ,
      (forall (x:atom), x `notin` L
                   -> typing ((x ~ t) ++ E) Σ (open exp (exp_fvar x)) t)
      -> typing E Σ (exp_fix t exp) t.

  Lemma typing_not_blackhole : forall E Σ e T,
      typing E Σ e T -> e <> exp_blackhole.
  Proof.
    intros E Σ e T Htyping contra.
    induction Htyping; try inversion contra.
  Qed.

  Locate "`notin`".
  Locate "`in`".

  Inductive typing_mu : sig_table -> mu_table -> sig_table -> Prop :=
  | typing_mu_safe : forall Σ' Σ mu, uniq Σ'
                               -> uniq Σ
                               -> uniq mu
                               -> (forall a t, binds a t Σ
                                         -> exists e, binds a e mu
                                                /\ (e <> exp_blackhole
                                                   -> typing nil Σ' e t))
                               -> typing_mu Σ' mu Σ.

  Definition eval_state := (sig_table * exp * mu_table) % type.

  Inductive eval_state_ok : eval_state -> Prop :=
  | eval_state_safe : forall Σ e t mu, typing nil Σ e t
                                  -> typing_mu Σ mu Σ
                                  -> eval_state_ok (Σ, e, mu).

  Inductive cbn_smallstep : eval_state -> eval_state -> nat -> Prop :=
  | cbn_smallstep_lookup :
      forall e Σ a T mu,
        lc_by_need (exp_sym a) mu
        -> uniq Σ
        -> binds a T Σ
        -> uniq mu
        -> binds a e mu
        -> e <> exp_blackhole
        -> cbn_smallstep (Σ, (exp_sym a), mu) (Σ, e, mu) 1
  | cbn_smallstep_inplace :
      forall e e' Σ Σ' a T mu_l mu_r mu_l' mu_r' k,
        lc_by_need e (mu_l ++ mu_r)
        -> uniq (mu_l ++ (a ~ exp_blackhole) ++ mu_r)
        -> uniq Σ
        -> binds a T Σ
        -> binds a T Σ'
        -> cbn_smallstep (Σ, e, mu_l ++ (a ~ exp_blackhole) ++ mu_r)
                        (Σ', e', mu_l' ++ (a ~ exp_blackhole) ++ mu_r') k
        -> e <> exp_blackhole
        -> e' <> exp_blackhole
        -> cbn_smallstep (Σ, (exp_sym a), mu_l ++ (a ~ e) ++ mu_r)
                        (Σ', (exp_sym a), mu_l' ++ (a ~ e') ++ mu_r') k
  | cbn_smallstep_succ :
      forall e Σ_l Σ_r mu_l mu_r a,
        lc_by_need (exp_succ e) (mu_l ++ mu_r)
        -> e <> exp_blackhole
        -> uniq (Σ_l ++ (a ~ typ_nat) ++ Σ_r)
        -> uniq (mu_l ++ (a ~ e) ++ mu_r)
        -> cbn_smallstep (Σ_l ++ Σ_r,
                         exp_succ e,
                         mu_l ++ mu_r)
                        (Σ_l ++ (a ~ typ_nat) ++ Σ_r,
                         exp_succ (exp_sym a),
                         mu_l ++ (a ~ e) ++ mu_r) 1
  | cbn_smallstep_ifz_num :
      forall e e' Σ Σ' mu mu' z_branch s_branch k,
        lc_by_need (exp_ifz e z_branch s_branch) mu
        -> cbn_smallstep (Σ, e, mu)
                      (Σ', e', mu') k
        -> cbn_smallstep (Σ, exp_ifz e z_branch s_branch, mu)
                        (Σ', exp_ifz e' z_branch s_branch, mu') k
  | cbn_smallstep_ifz_zero :
      forall Σ mu z_branch s_branch,
        lc_by_need (exp_ifz exp_zero z_branch s_branch) mu
        -> uniq Σ
        -> uniq mu
        -> cbn_smallstep (Σ, exp_ifz exp_zero z_branch s_branch, mu) (Σ, z_branch, mu) 1
  | cbn_smallstep_ifz_succ :
      forall e a Σ z_branch s_branch mu,
        lc_by_need (exp_ifz (exp_succ (exp_sym a)) z_branch s_branch) mu
        -> binds a typ_nat Σ
        -> binds a e mu
        -> uniq Σ
        -> cbn_smallstep (Σ, exp_ifz (exp_succ (exp_sym a)) z_branch s_branch, mu)
                        (Σ, open s_branch (exp_sym a), mu) 1
  | cbn_smallstep_app_l :
      forall e1 e1' e2 Σ Σ' mu mu' k,
        lc_by_need (exp_app e1 e2) mu
        -> cbn_smallstep (Σ, e1, mu)
                        (Σ', e1', mu') k
        -> cbn_smallstep (Σ, exp_app e1 e2, mu)
                        (Σ', exp_app e1' e2, mu') k
  | cbn_smallstep_beta :
      forall Σ_l Σ_r t a e e2 mu_l mu_r,
        lc_by_need (exp_app (exp_abs t e) e2) (mu_l ++ mu_r)
        -> uniq (Σ_l ++ (a ~ t) ++ Σ_r)
        -> uniq (mu_l ++ (a ~ e2) ++ mu_r)
        -> e2 <> exp_blackhole
        -> cbn_smallstep (Σ_l ++ Σ_r, exp_app (exp_abs t e) e2, mu_l ++ mu_r)
                        (Σ_l ++ (a ~ t) ++ Σ_r, open e (exp_sym a), mu_l ++ (a ~ e2) ++ mu_r) 1
  | cbn_smallstep_fix :
      forall Σ_l Σ_r t e mu_l mu_r a,
        lc_by_need (exp_fix t e) (mu_l ++ mu_r)
        -> uniq (Σ_l ++ (a ~ t) ++ Σ_r)
        -> uniq (mu_l ++ (a ~ (open e (exp_sym a))) ++ mu_r)
        -> e <> exp_blackhole
        -> cbn_smallstep (Σ_l ++ Σ_r,
                         exp_fix t e,
                         mu_l ++ mu_r)
                        (Σ_l ++ (a ~ t) ++ Σ_r,
                         exp_sym a,
                         mu_l ++ (a ~ (open e (exp_sym a))) ++ mu_r) 1.

  Ltac solve_open_lc_main :=
    match goal with
      H : forall x : atom,
        x `notin` ?L
        -> forall k, open ?exp (exp_fvar x) = {k ~> ?u} open ?exp (exp_fvar x)
               |- _ => unfold open in H;
                     pick fresh x;
                     apply open_lc_core with (j := 0) (v := exp_fvar x);
                     try (apply H);
                     auto
    end.

  Lemma open_lc : forall (k : nat) (u e : exp), lc e -> e = {k ~> u} e.
  Proof.
    intros k u e Hlc.
    generalize dependent k.
    induction Hlc; try (simpl; reflexivity).
    - intros k.
      simpl.
      rewrite <- IHHlc.
      reflexivity.
    - intros k.
      simpl.
      rewrite <- IHHlc1.
      rewrite <- IHHlc2.
      f_equal.
      solve_open_lc_main.
    - intros k.
      simpl.
      f_equal.
      solve_open_lc_main.
    - intros k.
      simpl.
      rewrite <- IHHlc1.
      rewrite <- IHHlc2.
      reflexivity.
    - intros k.
      simpl.
      f_equal.
      solve_open_lc_main.
  Qed.

  Lemma subst_open : forall x u e v,
      lc u -> [x ~> u] ({0 ~> v} e) = {0 ~> ([x ~> u] v)}([x ~> u] e).
  Proof.
    intros x u e v Hlc.
    generalize dependent 0.
    induction e.
    - intros n.
      simpl. reflexivity.
    - intros n.
      simpl. reflexivity.
    - intros n.
      simpl.
      destruct (a == x).
      + apply open_lc; auto.
      + simpl. auto.
    - intros n0.
      simpl.
      destruct (n0 == n).
      + reflexivity.
      + simpl. reflexivity.
    - auto.
    - intros n.
      simpl.
      f_equal.
      apply IHe.
    - intros n.
      simpl.
      f_equal.
      + apply IHe1.
      + apply IHe2.
      + apply IHe3.
    - intros n.
      simpl.
      f_equal.
      apply IHe.
    - intros n.
      simpl.
      f_equal.
      apply IHe1.
      apply IHe2.
    - intros n.
      simpl.
      f_equal.
      apply IHe.
  Qed.

  Lemma subst_lc : forall x e u,
      lc e -> lc u -> lc ([x ~> u] e).
  Proof.
    intros x e u Hlc.
    generalize dependent u.
    induction Hlc; intros u Hlcu.
    - simpl. constructor.
    - simpl. constructor.
    - simpl.
      destruct (x0 == x); try constructor; auto.
    - simpl. constructor.
    - simpl. constructor. apply IHHlc; auto.
    - simpl.
      pick fresh y and apply lc_ifz; auto.
      unfold open in *.
      replace (exp_fvar y) with ([x ~> u] exp_fvar y).
      rewrite <- subst_open; auto.
      simpl.
      destruct (y == x).
      + subst. fsetdec.
      + auto.
    - simpl.
      pick fresh y and apply lc_abs; auto.
      unfold open.
      replace (exp_fvar y) with ([x ~> u] exp_fvar y).
      rewrite <- subst_open; auto.
      apply H0; auto.
      simpl.
      destruct (y == x).
      + subst. fsetdec.
      + auto.
    - simpl.
      constructor; auto.
    - simpl.
      pick fresh y and apply lc_fix.
      unfold open.
      replace (exp_fvar y) with ([x ~> u] exp_fvar y).
      rewrite <- subst_open; auto.
      apply H0; auto.
      simpl.
      destruct (y == x).
      + subst. fsetdec.
      + auto.
  Qed.

  Lemma typing_subst : forall Σ E e x u T1 T2,
      typing ((x ~ T1) ++ E) Σ e T2 ->
      typing E Σ u T1 ->
      typing E Σ ([x ~> u] e) T2.
  Proof.
    Admitted.

  Lemma beta_regular_left : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu)
                    (Σ', e', mu') k
      -> lc_by_need e mu.
  Proof.
    intros.
    remember (Σ, e, mu) as start_st.
    induction H; inversion Heqstart_st; destruct H; split; subst; auto.
    - constructor.
    - constructor.
      rewrite_env (mu_l ++ (a ~ e0) ++ mu_r).
      solve_uniq.
      rewrite_env (mu_l ++ (a ~ e0) ++ mu_r).
      intros.
      inversion H7; subst.
      destruct (x == a).
      + subst.
        assert (e = e0). {
          eapply binds_mid_eq; eauto.
          solve_uniq.
        }
        subst.
        auto.
      + apply H10 with (x := x).
        eapply binds_remove_mid; eauto.
  Qed.

  Lemma beta_regular_right : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu)
                    (Σ', e', mu') k
      -> lc_by_need e' mu'.
  Proof.
    intros.
    remember (Σ, e, mu) as start_st.
    remember (Σ', e', mu') as target_st.
    generalize dependent mu.
    generalize dependent mu'.
    generalize dependent e.
    generalize dependent e'.
    induction H.
    - intros e' e0 mu' Heqtarget_st mu0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split; auto.
      inversion H6; subst.
      eapply H8; eauto.
    - intros e1 e0 mu' Heqtarget_st mu Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split; auto.
      + constructor.
      + edestruct IHcbn_smallstep with (mu' := mu_l' ++ (a ~ exp_blackhole) ++ mu_r')
                                         (mu  := mu_l ++ (a ~ exp_blackhole) ++ mu_r).
        reflexivity.
        reflexivity.
        inversion H10; subst.
        constructor.
        * solve_uniq.
        * intros.
          {
            destruct (x == a).
            - subst.
              simpl_env in H13.
              assert (e0 = e'). {
                eapply binds_mid_eq; eauto.
                solve_uniq.
              }
              subst.
              auto.
            - apply H12 with (x := x).
              apply binds_remove_mid in H13; auto.
          }
    - intros e1 e0 mu' Heqtarget_st mu Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split.
      + repeat constructor.
      + inversion H4; subst.
        constructor.
        * solve_uniq.
        * intros.
          simpl_env in H7.
          {
            destruct (x == a).
            - subst.
              assert (e0 = e). {
                eapply binds_mid_eq; eauto.
              }
              subst.
              inversion H3; auto.
            - apply H6 with (x := x).
              apply binds_remove_mid in H7; auto.
          }
    - intros e1 e0 mu1 Heqtarget_st mu0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split.
      + inversion H1; subst.
        pick fresh x and apply lc_ifz; auto.
        edestruct IHcbn_smallstep.
        reflexivity.
        reflexivity.
        auto.
      + edestruct IHcbn_smallstep.
        reflexivity.
        reflexivity.
        auto.
    - intros e1 e0 mu' Heqtarget_st mu0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split; auto.
      inversion H2; subst; auto.
    - intros e1 e0 mu' Heqtarget_st mu0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split; auto.
      inversion H3; subst.
      pick fresh x.
      unfold open.
      rewrite subst_intro with (x := x); auto.
      apply subst_lc; auto.
      apply H10; auto.
      constructor.
    - intros e' e mu1 Heqtarget_st mu0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split; auto.
      * inversion H1; subst.
        edestruct IHcbn_smallstep.
        reflexivity.
        reflexivity.
        constructor; auto.
      * edestruct IHcbn_smallstep.
        reflexivity.
        reflexivity.
        auto.
    - intros e1 e0 mu1 Heqtarget_st mu Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      split; auto.
      * inversion H; subst.
        inversion H3; subst.
        inversion H7; subst.
        pick fresh x.
        unfold open.
        rewrite subst_intro with (x := x); auto.
        apply subst_lc; auto.
        apply H6; auto.
        constructor.
      * inversion H; subst.
        simpl_env.
        constructor.
        solve_uniq.
        intros.
        {
          destruct (x == a).
          - subst.
            assert (e0 = e2). {
              eapply binds_mid_eq; eauto.
            }
            subst.
            inversion H3; subst; auto.
          - inversion H4; subst.
            apply H7 with (x := x); auto.
            apply binds_remove_mid in H5; auto.
        }
    - intros e1 e0 mu1 Heqtarget_st mu0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      inversion H; subst.
      split; auto.
      + constructor.
      + simpl_env.
        constructor.
        * solve_uniq.
        * intros.
          {
            destruct (x == a).
            - subst.
              assert (e0 = open e (exp_sym a)). {
                eapply binds_mid_eq; eauto.
              }
              subst.
              inversion H3; subst.
              unfold open.
              pick fresh x.
              rewrite subst_intro with (x := x); auto.
              apply subst_lc; try constructor.
              apply H7; auto.
            - inversion H4; subst.
              apply H7 with (x := x).
              apply binds_remove_mid in H5; auto.
          }
  Qed.

  Lemma beta_regular : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu) (Σ', e', mu') k
      -> lc_by_need e mu /\ lc_by_need e' mu'.
  Proof.
    intros.
    split.
    eapply beta_regular_left; eauto.
    eapply beta_regular_right; eauto.
  Qed.

  Lemma step_uniq_left : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu) (Σ', e', mu') k
      -> uniq Σ.
  Proof.
    intros Σ Σ' e e' mu mu' k Hstep.
    remember (Σ, e, mu) as start_st.
    remember (Σ', e', mu') as target_st.
    generalize dependent Σ.
    generalize dependent Σ'.
    generalize dependent e.
    generalize dependent e'.
    generalize dependent mu.
    generalize dependent mu'.
    induction Hstep;
      intros;
      inversion Heqstart_st;
      inversion Heqtarget_st;
      subst;
      try solve_uniq.
    - eapply IHHstep.
      reflexivity.
      reflexivity.
    - eapply IHHstep.
      reflexivity.
      reflexivity.
  Qed.

  Lemma step_uniq_right : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu) (Σ', e', mu') k
      -> uniq Σ'.
  Proof.
    intros Σ Σ' e e' mu mu' k Hstep.
    remember (Σ, e, mu) as start_st.
    remember (Σ', e', mu') as target_st.
    generalize dependent Σ.
    generalize dependent Σ'.
    generalize dependent e.
    generalize dependent e'.
    generalize dependent mu.
    generalize dependent mu'.
    induction Hstep;
      intros;
      inversion Heqstart_st;
      inversion Heqtarget_st;
      subst;
      subst; try solve_uniq.
    - eapply IHHstep.
      reflexivity.
      reflexivity.
    - eapply IHHstep.
      reflexivity.
      reflexivity.
    - eapply IHHstep.
      reflexivity.
      reflexivity.
  Qed.

  Lemma step_uniq : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu) (Σ', e', mu') k
      -> uniq Σ /\ uniq Σ'.
  Proof.
    intros.
    split.
    eapply step_uniq_left; eauto.
    eapply step_uniq_right; eauto.
  Qed.

  Definition sigma_subset (Σ Σ' : sig_table) :=
    forall a t, binds a t Σ -> binds a t Σ'.

  Notation "z ⊆ z2" := (sigma_subset z z2) (at level 50, no associativity).

  Lemma sigma_subset_reflexive : forall Σ,
      Σ ⊆ Σ.
  Proof.
    intros Σ Hbind. auto.
  Qed.

  Hint Resolve sigma_subset_reflexive.

  Lemma typing_weakening_sigma : forall E Σ_l Σ_r a e t t2,
      typing E (Σ_l ++ Σ_r) e t ->
      uniq (Σ_l ++ (a ~ t2) ++ Σ_r) ->
      typing E (Σ_l ++ (a ~ t2) ++ Σ_r) e t.
  Proof.
  Admitted.

  Lemma typing_weakening_sigma_strengthened : forall E Σ Σ' e t,
      Σ ⊆ Σ' ->
      uniq Σ' ->
      typing E Σ e t ->
      typing E Σ' e t.
  Proof.
  Admitted.

  Lemma preservation_strengthened : forall Σ Σ' e e' mu mu' t k,
      cbn_smallstep (Σ, e, mu) (Σ', e', mu') k
      -> typing_mu Σ mu Σ
      -> typing nil Σ e t
      -> typing_mu Σ' mu' Σ' /\ typing nil Σ' e' t /\ Σ ⊆ Σ'.
  Proof.
    intros Σ Σ' e e' mu mu' t k Hstep Htyping_mu Htyping_e.
    remember (Σ, e, mu) as start_st.
    remember (Σ', e', mu') as target_st.
    generalize dependent Σ.
    generalize dependent Σ'.
    generalize dependent mu.
    generalize dependent mu'.
    generalize dependent e.
    generalize dependent e'.
    generalize dependent t.
    induction Hstep.
    - Case "Lookup".
      intros t e1 e0 mu1 m0 Σ1 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_a.
      subst.
      split.
      + auto.
      + inversion Htyping_mu0; subst.
        inversion Htyping_a; subst.
        split; auto.
        * destruct (H8 a t H14) as [e' H15].
          destruct H15.
          assert (e' = e1). {
            eapply binds_unique; eauto.
          }
          subst.
          apply H12; auto.
    - Case "InPlace".
      intros t e1 e0 mu1 m0 Σ1 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_a.
      simpl_env in *.
      inversion Htyping_mu0; subst.
      inversion Htyping_a; subst.
      assert (uniq Σ1). {
        eapply step_uniq_right; eauto.
      }
      {
        edestruct IHHstep as [Htyping_mu' [Htyping_e1 Hsubset]]; eauto.
        - SCase "Typing mu with blackhole".
          constructor; auto.
          intros a0 t0 Hbinds_a0.
          destruct (a0 == a).
          + SSCase "a0 = a".
            subst.
            exists exp_blackhole.
            split; auto.
            intros; solve_neq_contra.
          + SSCase "a0 <> a".
            destruct (H9 a0 t0 Hbinds_a0) as [e0 [Hbinds_e0 Htyping_e0]].
            exists e0.
            split; auto.
            * eapply binds_remove_mid in Hbinds_e0; eauto.
        - SCase "Typing e".
          destruct (H9 a t H15) as [e0 [Hbinds_e0 Htyping_e0]].
          assert (e0 = e). {
            eapply binds_unique; eauto.
          }
          subst.
          apply Htyping_e0; auto.
        - SCase "Goal".
          split; split; auto.
          inversion Htyping_mu'; subst.
          solve_uniq.
          intros.
          inversion Htyping_mu'; subst.
          destruct (a0 == a).
          + subst.
            assert (binds a t Σ1). {
              apply Hsubset; auto.
            }
            assert (t0 = t). {
              eapply binds_unique; eauto.
            }
            subst.
            exists e'.
            split; auto.
          + destruct (H18 a0 t0 H13) as [e2 [Hbinds_e2 Htyping_e2]].
            exists e2.
            split.
            * apply binds_remove_mid in Hbinds_e2; auto.
            * auto.
          + constructor; auto.
      }
    - Case "Succ".
      intros t e1 e0 mu1 m0 Σ1 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_mu0; subst.
      inversion Htyping_e0; subst.
      simpl_env in *.
      split.
      + SCase "Type mu".
        constructor; auto.
        intros.
        destruct (a0 == a).
        * subst.
          assert (t = typ_nat). {
            eapply binds_mid_eq; eauto.
          }
          exists e.
          split; auto.
          intros.
          subst.
          inversion Htyping_e0; subst.
          apply typing_weakening_sigma; auto.
        * apply binds_remove_mid in H7; auto.
          destruct (H6 a0 t H7) as [e1 [Hbinds_e1 Htyping_e1]].
          exists e1.
          split; auto.
          intros.
          apply typing_weakening_sigma; auto.
      + split.
        * constructor.
          constructor; auto.
        * intros x t Hbinds.
          auto.
    - Case "ifz".
      intros t e1 e0 mu1 m0 Σ1 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_e0; subst.
      inversion Htyping_mu0; subst.
      simpl_env in *.
      assert (typing_mu Σ1 mu1 Σ1 /\ typing nil Σ1 e' typ_nat /\ Σ0 ⊆ Σ1). {
        eapply IHHstep; eauto.
      }
      destruct H4.
      destruct H6.
      split; auto.
      split; auto.
      pick fresh x and apply typing_ifz; auto.
      eapply typing_weakening_sigma_strengthened; eauto.
      eapply step_uniq_right; eauto.
      apply typing_weakening_sigma_strengthened with (Σ := Σ0); auto.
      eapply step_uniq_right; eauto.
    - Case "ifz_zero".
      intros t e1 e0 mu1 m0 Σ1 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_e0; subst.
      inversion Htyping_mu0; subst.
      split; auto.
    - Case "ifz_succ".
      intros t e1 e0 mu1 m0 Σ1 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_e0; subst.
      inversion Htyping_mu0; subst.
      inversion H10; subst.
      split; auto.
      split; auto.
      unfold open.
      pick fresh x.
      rewrite subst_intro with (x := x); auto.
      eapply typing_subst; eauto.
    - Case "app_left".
      intros t e3 e0 mu3 m0 Σ3 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_mu0; subst.
      inversion Htyping_e0; subst.
      assert (typing_mu Σ3 mu3 Σ3 /\ typing nil Σ3 e1' (typ_parr t1 t) /\ Σ0 ⊆ Σ3). {
        eapply IHHstep; eauto.
      }
      destruct H4.
      destruct H5.
      split; auto.
      split; auto.
      econstructor; eauto.
      eapply typing_weakening_sigma_strengthened; eauto.
      eapply step_uniq_right; eauto.
    - Case "beta".
      intros T e3 e0 mu3 m0 Σ3 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_mu0; subst.
      inversion Htyping_e0; subst.
      inversion H11; subst.
      simpl_env in *.
      split; auto.
      + constructor; auto.
        intros.
        destruct (a0 == a).
        * subst.
          exists e2.
          split; auto.
          subst.
          assert (t = t1). {
            eapply binds_mid_eq; eauto.
          }
          subst.
          intros.
          eapply typing_weakening_sigma; eauto.
        * apply binds_remove_mid in H7; auto.
          destruct (H6 a0 t H7) as [e1 [Hbinds_e1 Htyping_e1]].
          exists e1.
          split; auto.
          intros.
          apply typing_weakening_sigma; auto.
      + split; auto.
        * unfold open in *.
          pick fresh x.
          rewrite subst_intro with (x := x); auto.
          apply typing_subst with (T1 := t1); auto.
          apply typing_weakening_sigma; auto.
          constructor; auto.
        * intros.
          intros z1 z2 Hsubset.
          apply binds_weaken; auto.
    - Case "fixpoint".
      intros T e3 e0 mu3 m0 Σ3 Heqtarget_st Σ0 Heqstart_st.
      inversion Heqtarget_st; inversion Heqstart_st; subst.
      intros Htyping_mu0 Htyping_e0.
      clear Heqstart_st. clear Heqtarget_st.
      inversion Htyping_mu0; subst.
      inversion Htyping_e0; subst.
      simpl_env in *.
      split; auto.
      + constructor; auto.
        intros.
        destruct (a0 == a).
        * subst.
          assert (t = T). {
            eapply binds_mid_eq; eauto.
          }
          subst.
          exists (open e (exp_sym a)).
          split; auto.
          intros.
          unfold open in *.
          pick fresh x.
          rewrite subst_intro with (x := x); auto.
          apply typing_subst with (T1 := T); auto.
          apply typing_weakening_sigma; auto.
          constructor; auto.
        * apply binds_remove_mid in H7; auto.
          destruct (H6 a0 t H7) as [e1 [Hbinds_e1 Htyping_e1]].
          exists e1.
          split; auto.
          intros.
          apply typing_weakening_sigma; auto.
      + split; auto.
        constructor; auto.
        intros z1 z2 Hsubset.
        apply binds_weaken; auto.
  Qed.

  Lemma preservation : forall Σ Σ' e e' mu mu' k,
      cbn_smallstep (Σ, e, mu) (Σ', e', mu') k
      -> eval_state_ok (Σ, e, mu)
      -> eval_state_ok (Σ', e', mu').
  Proof.
    intros.
    inversion H0; subst.
    eapply preservation_strengthened in H; eauto.
    destruct H.
    destruct H1.
    econstructor; eauto.
  Qed.

  Inductive cbn_loop : eval_state -> Prop :=
  | cbn_loop_sym : forall Σ a t mu,
      lc_mu mu ->
      uniq Σ ->
      binds a t Σ ->
      binds a exp_blackhole mu ->
      cbn_loop (Σ, exp_sym a, mu)
  | cbn_loop_circular_exp : forall e Σ a t mu_l mu_r,
      lc_by_need e (mu_l ++ (a ~ exp_blackhole) ++ mu_r) ->
      binds a t Σ ->
      cbn_loop (Σ, e, mu_l ++ (a ~ exp_blackhole) ++ mu_r) ->
      cbn_loop (Σ, exp_sym a, mu_l ++ (a ~ e) ++ mu_r)
  | cbn_loop_ifz : forall e Σ mu z_branch s_branch,
      lc_by_need (exp_ifz e z_branch s_branch) mu ->
      cbn_loop (Σ, e, mu) ->
      cbn_loop (Σ, exp_ifz e z_branch s_branch, mu)
  | cbn_loop_app : forall e1 e2 Σ mu,
      lc_by_need (exp_app e1 e2) mu ->
      cbn_loop (Σ, e1, mu) ->
      cbn_loop (Σ, exp_app e1 e2, mu).

  Inductive cbn_eval_state_initial : eval_state -> Prop :=
  | cbn_eval_state_initial_constr : forall e,
      lc e -> cbn_eval_state_initial (nil, e, nil).

  Inductive cbn_eval_state_final : eval_state -> Prop :=
  | cbn_eval_state_final_constr : forall Σ e mu,
      lc_by_need e mu ->
      uniq Σ ->
      cbn_is_val e Σ ->
      cbn_eval_state_final (Σ, e, mu).

  Lemma typing_exp_lc : forall E Σ e t,
      typing E Σ e t -> lc e.
  Proof.
    intros E Σ e t Htyping.
    induction Htyping; try constructor; auto.
    - pick fresh x and apply lc_ifz; auto.
    - pick fresh x and apply lc_abs; auto.
    - pick fresh x and apply lc_fix; auto.
  Qed.

  (*
  Lemma typing_mu_lc : forall Σ mu,
      typing_mu Σ mu Σ -> lc_mu mu.
  Proof.
    intros Σ mu Htyping.
    inversion Htyping; subst.
    constructor; auto.
    intros.
    Print lc_mu.
    destruct (e == exp_blackhole).
*)

  (*
  Lemma progress : forall Σ e mu,
      eval_state_ok (Σ, e, mu) ->
      cbn_eval_state_final (Σ, e, mu) \/
      cbn_loop (Σ, e, mu) \/
      exists Σ' e' mu' k, cbn_smallstep (Σ, e, mu) (Σ', e', mu') k.
  Proof.
    intros Σ e mu Hok.
    remember (Σ, e, mu) as start_st.
    generalize dependent Σ.
    generalize dependent e.
    generalize dependent mu.
    inversion Hok; subst.
    induction H.
    - intros mu0 e0 Σ0 Heqstart_st.
      inversion Heqstart_st; subst.
      inversion H0; subst.
      inversion Hok; subst.
      inversion H9; subst.
      inversion H11; subst.
*)

End CallByNeed.


Definition Unique (X: Type) ( p : X -> Prop) :=   exists x : X, and (p x) (forall  y : X, ( p y -> (x = y))).

Axiom the : forall (X: Type) (p : X -> Prop),  Unique X p -> X.

Axiom the_def : forall (X: Type) (p : X -> Prop) (e :Unique X p),  p ( (the X p) e ).

Theorem  uni : forall ( X: Type) (p : X -> Prop) (e : Unique X p) ( y : X), p y -> y = the X p e.

(** First version of proof
Proof.
(intros **).
(pose proof the_def).
(pose proof (the_def X p e)).
(pose proof (H0 X p e)).
instantiate.
(destruct e).
(destruct a).
(pose proof
  (e
     (the X p
        (ex_intro (fun x : X => p x /\ (forall y : X, p y -> x = y)) x
           (conj p0 e))))).
(pose proof (e y)).
(pose proof (H4 H)).
(pose proof (H3 H2)).
(induction H5).
exact H6.
Qed.  *)
Proof.
intros.
(pose proof (the_def X p e)).
(unfold Unique in e).
(destruct e).
(destruct a).
(pose proof (e y)).
(apply H1 in H).
(rewrite <- H).
(pose proof (e (the X p (ex_intro (fun x : X => p x /\ (forall y : X, p y -> x = y)) x (conj p0 e))))).
(apply H2 in H0).
assumption.
Qed.

Axiom M : Type.
Axiom P : M -> M -> Prop.
Axiom P_trans : forall (x: M) (y : M) (z : M),  and (P x y) (P y z) -> P x z.
Axiom P_id : forall x: M, P x x.
Axiom P_asym : forall ( x : M) (y : M), and (P x y) (P y x) ->  x = y.

Axiom P_sup : forall  p : M -> Prop, exists  z : M,  (forall x : M, (p x -> P x z)) /\  forall y : M, ((forall w : M, p w -> P w y) -> P z y).

Definition Min (x : M) := forall z : M, P z x.

Definition QA (t : M) := forall x : M, P x t -> x = t \/ Min x.

Axiom P_qa : forall (x : M) (y : M), (forall z : M, (QA z /\ P z x) -> P z y) -> P x y.

Definition sup (p : M -> Prop) := fun (z : M) =>  (forall x : M, (p x -> P x z)) /\  forall y : M, ((forall x : M, p x -> P x y) -> P z y).

Theorem con: forall p: M-> Prop, Unique M (sup p).
Proof.
intro.
(unfold sup).
(unfold Unique).
(pose proof (P_sup p)).
(destruct H).
(cut
  (forall y : M,
   (forall x1 : M, p x1 -> P x1 y) /\
   (forall y0 : M, (forall x1 : M, p x1 -> P x1 y0) -> P y y0) ->
   x = y)).
 intro.
 (pose proof (Logic.conj H H0)).
 (pose proof
   (Logic.ex_intro
      (fun x : M =>
       ((forall x0 : M, p x0 -> P x0 x) /\
        (forall y : M, (forall w : M, p w -> P w y) -> P x y)) /\
       (forall y : M,
        (forall x1 : M, p x1 -> P x1 y) /\
        (forall y0 : M, (forall x1 : M, p x1 -> P x1 y0) -> P y y0) ->
        x = y)) x H1)).
 exact H2.
 intro.
 (destruct H).
 intro.
 (destruct H1).
 (pose proof (H2 x)).
 (pose proof (H3 H)).
 (pose proof (H0 y)).
 (pose proof (H5 H1)).
 (pose proof (P_asym x y)).
 (pose proof (Logic.conj H6 H4)).
 (pose proof (H7 H8)).
 exact H9.
Qed.

Definition Sup (p: M -> Prop) :=  (the M) (sup p) (con p).

Theorem sup_M : forall p: M -> Prop, (sup p) (Sup p).
Proof.
intro.
(unfold Sup).
(pose proof (the_def M (sup p))).
(pose proof (H (con p))).
exact H0.
Qed.

Axiom P_min : forall (x: M) (p : M -> Prop), ( P x (Sup p) /\ not (Min x)) -> exists k :M,
(P k x /\ not (Min k) /\ exists z:M, P k z /\ p z  ).

Parameter w : M.

Definition T ( t : M) := forall y : M, P y t.

Definition QC (t : M) := forall y : M,  P t y -> ( y = t \/ T y ).

Axiom P_w : QC w.

Definition top := Sup (fun (x : M) => True).

Theorem t_un : Unique M (fun (x : M) =>  forall y: M, P y x).
Proof.
(unfold Unique).
(cut
  ((forall y : M, P y top) /\
   (forall y : M, (forall y0 : M, P y0 y) -> top = y))).
 intro.
 (pose proof
   (Logic.ex_intro
      (fun x : M =>
       (forall y : M, P y x) /\
       (forall y : M, (forall y0 : M, P y0 y) -> x = y)) top H)).
 exact H0.

 (pose proof (sup_M (fun _ : M => True))).

 (unfold sup).
 (unfold sup).

 (unfold sup in H).
 (unfold top).
 (destruct H).
 split.
  intro.
  (pose proof (H y)).
  (pose I).
  (pose proof (H1 t)).
  exact H2.

  intro.
  intro.
  (pose proof (H y)).
  (pose proof (H2 I)).
  (pose proof (H0 y)).
  (cut (forall y0 : M, True -> P y0 y)).
   (intros **).
   (intros **).
   (pose proof (H4 H5)).
   (pose proof (Logic.conj H6 H3)).
   (pose proof (P_asym (Sup (fun _ : M => True)) y)).
   (pose proof (H8 H7)).
   exact H9.

   intro.
   intro.
   (pose proof (H1 y0)).
   exact H6.
Qed.

Definition top2 := the M (fun (x : M) =>  forall y: M, P y x) t_un.

Axiom wt : not (top2 = w).

(**  Do the same for bottom and k *)

Definition A (x : M) := not (exists y : M, (not (y = x) /\ P y x )).

Fixpoint Ah (n : nat) : M -> Prop :=
 match n with
  | 0 =>   A
  | S n => fun (x : M) => ( forall y : M, P y x -> (y = x \/ (Ah n) y) )
  end.

Definition Ae ( n : nat) : M -> Prop :=
 match n with
  | 0 =>  Ah 0
  | S n => fun (x : M) => ( ((Ah (S n)) x) /\ not ((Ah n) x) )
 end.

Axiom hier : forall n : nat, exists x : M, (Ae n) x.


Goal forall n : nat, n = 0 -> n = 0.
intros.
rename n into p.
induction p; auto.
Qed.

(* Submitted by Iris Loeb (#842) *)

Section rename.

Variable A:Prop.

Lemma Tauto: A->A.
rename A into B.
tauto.
Qed.

End rename.


Add LoadPath "vst".

Require Import Coq.Unicode.Utf8.
Require Import msl.eq_dec.
Require Import List.
Import ListNotations.

Definition subst_t (D : Type) (R : Type) := D -> R.

(* Definition wf_subst{A : Type} (s : subst_t A) : Prop  := NoDup (fst (split s)). *)

Class Subst (A D R : Type) : Type :=
  subst: subst_t D R -> A -> A.

Fixpoint subst_prod (A B D R : Type) (SA : Subst A D R) (SB : Subst B D R) (s : subst_t D R) (p : (A * B)) :=
  match p with
    | (p1, p2) => (subst s p1, subst s p2)
  end.

Instance Subst_prod (A B D R : Type) (SA : Subst A D R) (SB : Subst B D R): Subst (A * B) D R :=
  subst_prod A B D R SA SB.

Fixpoint subst_list (A D R : Type) (SA : Subst A D R) (s : subst_t D R) (l : list A) :=
  match l with
    | nil => []
    | h :: t => subst s h :: subst_list A D R SA s t
  end.

Instance Subst_list (A D R : Type) (SA : Subst A D R) : Subst (list A) D R :=
  subst_list A D R SA.
(* Instance Subst_prod_list (A B D R : Type) (S : Subst A D R) : Subst (list (A * A)) D R := _. *)
(* Definition wf_subst (X : Type) (s : subst_t X) := *)
(*   NoDup (fst (split s)). *)


From mathcomp Require Import all_ssreflect.
From Paco Require Import paco paco2.
Require Import Setoid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Reserved Notation "x =l y" (at level 70, no associativity).
Reserved Notation "x =g y" (at level 70, no associativity).
Reserved Notation "x =a/g y" (at level 70, no associativity).
Reserved Notation "x '=1/g' y" (at level 70, no associativity).
Reserved Notation "x '=1/a' y" (at level 70, no associativity).
Reserved Notation "x '=1/a/g' y" (at level 70, no associativity).
Reserved Notation "x '=1/sval' y" (at level 70, no associativity).

(****************************************************************************)
(** Assumptions and Strict positivisation of functors                      **)
(****************************************************************************)

Structure equivalence A :=
  mkEquiv { eqRel : A -> A -> Prop;
            e_refl : forall x, eqRel x x;
            e_sym : forall x y, eqRel x y -> eqRel y x;
            e_trans : forall x y z, eqRel x y -> eqRel y z -> eqRel x z;
          }.

Hint Resolve e_refl : ffix.
Hint Resolve e_sym : ffix.
Hint Resolve e_trans : ffix.

Definition def_eq A : equivalence A :=
  {| eqRel := @eq A;
     e_refl := @erefl A;
     e_sym := @esym A;
     e_trans := @etrans A;
  |}.

Structure TyEq :=
  { Ty : Type;
    Eq : equivalence Ty
  }.
Coercion getTy (T : TyEq) := Ty T.

Coercion mkTy (A : Type) : TyEq :=
  {| Ty := A;
     Eq := def_eq A;
  |}.

Add Parametric Relation (A: TyEq) : A (eqRel (Eq A))
    reflexivity proved by (@e_refl A (Eq A))
    symmetry proved by (@e_sym A (Eq A))
    transitivity proved by (@e_trans A (Eq A))
      as ExtEq.

Reserved Notation "f =e g" (at level 70, no associativity).
(* Reserved Notation "f =1e g" (at level 70, no associativity). *)
Notation "f =e g" := (eqRel (Eq _) f g).
(* Notation "f =1e g" := (forall x, eqRel (Eq _) (f x) (g x)). *)

Definition extEq (A : TyEq) (B : Type) : equivalence (B -> A).
Proof.
  apply: (@mkEquiv _ (fun f g =>forall x, eqRel (Eq A) (f x) (g x))).
  - by move=>f x; apply: e_refl.
  - by move=>f g H x; apply: e_sym.
  - by move=>f g h Hf Hg x; apply: e_trans.
Defined.

Structure Functor :=
  { Shape : Type;
    Position : Type;
    (** Is position valid in shape? *)
    dom : Shape -> Position -> bool;
  }.

Definition Cont F (sh : Shape F) (X : TyEq)
  := {| Ty := sig (dom sh) -> X; Eq := extEq X _ |}.

Definition AppT F (X : Type) := {sh : Shape F & sig (dom sh) -> X}.

Lemma cont_irr F X (sh : Shape F) (f : sig (dom sh) -> X)
  : forall x p1 p2, f (exist _ x p1) = f (exist _ x p2).
Proof. move=> x/= p1 p2; by rewrite (bool_irrelevance p1 p2). Qed.

Definition AppR F (X : TyEq) (x y : AppT F X) : Prop
  := projT1 x = projT1 y /\
     (forall e d1 d2, projT2 x (exist _ e d1) =e projT2 y (exist _ e d2)).

Lemma AppR_inv_sh F X x y :
  @AppR F X x y -> projT1 x = projT1 y.
Proof. by case. Qed.

Lemma AppR_inv_k F X x y :
  @AppR F X x y ->
  forall e d1 d2, projT2 x (exist _ e d1) =e projT2 y (exist _ e d2).
Proof. by case. Qed.

Definition equivApp F (X : TyEq) : equivalence (AppT F X).
Proof.
  apply: (@mkEquiv _ (@AppR F X)).
  - move=> [shx kx]; constructor=>//=x d1 d2.
    rewrite (bool_irrelevance d1 d2); by apply: e_refl.
  - move=> x y [Sxy Exy]; split; first by apply/esym.
    by move=> e d1 d2; symmetry.
  - move=> x y z [Sxy Exy] [Syz Eyz]; split; first by rewrite Sxy.
    move=>e d1 d2; have d3: dom (projT1 y) e by move: d1; rewrite Sxy.
    rewrite (Exy e d1 d3) (Eyz e d3 d2); by reflexivity.
Defined.

Definition App F (X : TyEq)
  := {| Ty := AppT F X; Eq := equivApp F X |}.

Structure arr (A B : TyEq) :=
  { func :> Ty A -> Ty B;
    f_eq : forall x y, x =e y -> func x =e func y
  }.

Definition arrE (A B : TyEq) : equivalence (arr A B).
Proof.
  apply: (@mkEquiv _ (fun (f g : arr A B) => forall x, f x =e g x)).
  - by move=>x/=; auto with ffix.
  - by move=>x y/= H e; rewrite H; auto with ffix.
  - by move=>x y z/= H1 H2 e; rewrite H1.
Defined.

Definition arrow A B : TyEq :=
  {| Ty := arr A B;
     Eq := arrE A B;
  |}.

Definition fmapA_f F A B (f : arrow A B) (x : App F A) : App F B
  := existT _ (projT1 x) (f \o projT2 x).

Lemma fmapA_eqF F A B (f : arrow A B)
  : forall x y, x =e y -> fmapA_f (F:=F) f x =e fmapA_f f y.
Proof.
  move=> [sx kx] [sy ky] [/=Es Ek]; split=>//= e d1 d2.
  by apply/f_eq/Ek.
Qed.

Definition fmapA F A B (f : arrow A B) : arrow (App F A) (App F B)
  := {| func := _ ; f_eq := fmapA_eqF f |}.

Lemma comp_eq A B C (f : arrow B C) (g : arrow A B) :
  forall x y, x =e y -> (f \o g) x =e (f \o g) y.
Proof. by move=> x y H; apply/f_eq/f_eq. Qed.

Definition acomp A B C (f : arrow B C) (g : arrow A B) : arrow A C :=
  {| func := _; f_eq := comp_eq f g |}.

Notation "f \o g" := (acomp f g).

Lemma id_eq (A : TyEq) : forall (x y : A), x =e y -> id x =e id y.
Proof. by []. Qed.

Definition id A : arrow A A :=
  {| func := _; f_eq := @id_eq A |}.

Lemma fmap_id F A : fmapA F (id A) =e id _.
Proof.
  move=> [s k]/=; rewrite /fmapA_f/=; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1); by reflexivity.
Qed.

Lemma fmap_comp F A B C (f : arrow B C) (g : arrow A B)
  : fmapA F (f \o g) =e fmapA F f \o fmapA F g.
Proof.
  move=> [s k]/=; rewrite /fmapA_f/=; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1); by reflexivity.
Qed.

Add Parametric Morphism F (A B : TyEq) : (@fmapA F A B)
    with signature
    (eqRel (Eq (arrow A B)))
      ==> (eqRel (Eq (arrow (App F A) (App F B))))
      as fmapMorphism.
Proof.
  move=> f1 f2 Ef [s k]; split=>//= e d1 d2.
  by rewrite (bool_irrelevance d1 d2).
Qed.

Add Parametric Morphism (A B C : TyEq) : (@acomp A B C)
    with signature
    (eqRel (Eq (arrow B C)))
      ==> (eqRel (Eq (arrow A B)))
      ==> (eqRel (Eq (arrow A C)))
      as compMorphism.
Proof.
  move=> f1 f2 Ef g1 g2 Eg x=>//=.
  by apply/(e_trans (Ef (g1 x)))/f_eq/Eg.
Qed.

Definition Alg F A := arrow (App F A) A.
Definition CoAlg F A := arrow A (App F A).

Inductive LFixT F : Type :=
| LFix_in (sh : Shape F): (sig (dom sh) -> LFixT F) -> LFixT F.

Definition l_shape F (x : LFixT F) :=
  match x with
  | LFix_in sh _ => sh
  end.
Definition l_cont F (x : LFixT F) :=
  match x return sig (dom (l_shape x)) -> LFixT F with
  | LFix_in _ k => k
  end.

Fixpoint LFixR F (x y : LFixT F) : Prop :=
  l_shape x = l_shape y /\
  forall e d1 d2,
      LFixR (@l_cont F x (exist _ e d1)) (@l_cont F y (exist _ e d2)).

Lemma LFixR_inv_sh F (x y : LFixT F) : LFixR x y -> l_shape x = l_shape y.
Proof. by case: x=>[sx kx]; case: y=>[sy ky] []. Qed.

Lemma LFixR_inv_k F (x y : LFixT F)
  : LFixR x y ->
    forall e d1 d2,
      LFixR (@l_cont F x (exist _ e d1)) (@l_cont F y (exist _ e d2)).
Proof. by case: x=>[sx kx]; case: y=>[sy ky] []. Qed.

Lemma LFixR_refl F x : @LFixR F x x.
Proof.
  elim: x=>// shx k Ih; constructor=>//=x p1 p2.
  by rewrite (bool_irrelevance p1 p2); apply: Ih.
Qed.

Lemma LFixR_sym F x y : @LFixR F x y -> @LFixR F y x.
Proof.
  elim: x => sx kx Ih in y *; case: y => sy ky /=[/esym-Sxy E].
  split=>// e d1 d2; by apply/Ih/E.
Qed.

Lemma LFixR_trans F x y z : @LFixR F x y -> @LFixR F y z -> @LFixR F x z.
Proof.
  elim: x=> sx kx Ih in y z *; case: y=> sy ky/=; case: z=> sz kz/=.
  move=> [Sxy Exy] [Syz Eyz]; split; first by rewrite Sxy.
  move=> e d1 d2; apply: Ih; first by apply: Exy; rewrite Syz.
  by apply/Eyz.
Qed.

Definition LFix_Eq F :=
  {| eqRel := @LFixR F;
     e_refl := @LFixR_refl F;
     e_sym := @LFixR_sym F;
     e_trans := @LFixR_trans F;
  |}.

Definition LFix F :=
  {| Ty := LFixT F; Eq := @LFix_Eq F; |}.

Definition l_in_f F (x : App F (LFix F)) : LFix F :=
  LFix_in (projT2 x).

Lemma l_in_eq F x y : x =e y -> @l_in_f F x =e @l_in_f F y.
Proof. by case: x=> sx kx; case: y=> sy ky/= [/=Es Ek]; split. Qed.

Definition l_out_f F (x : LFix F) : App F (LFix F) :=
  match x with
  | LFix_in sh k => existT _ sh k
  end.

Lemma l_out_eq F x y : x =e y -> @l_out_f F x  =e @l_out_f F y.
Proof. by case: x=> sx kx; case: y=> sy ky/= [/=Es Ek]; split. Qed.

Definition l_in F : Alg F (LFix F) :=
  {| func := _; f_eq := @l_in_eq F |}.
Definition l_out F : CoAlg F (LFix F) :=
  {| func := _; f_eq := @l_out_eq F |}.

Lemma l_in_out F : l_in F \o l_out F =e id _.
Proof.
  move=>[s k]/=; split=>//= e d1 d2; rewrite (bool_irrelevance d1 d2).
  by apply: LFixR_refl.
Qed.

Lemma l_out_in F : l_out F \o l_in F =e id _.
Proof.
  move=>[s k]/=; split=>//= e d1 d2; rewrite (bool_irrelevance d1 d2).
  by apply: LFixR_refl.
Qed.

Definition cata_f F A (g : Alg F A) : Ty (LFix F) -> Ty A
  := fix f x :=
       match x with
       | LFix_in s k => g (existT _ s (comp f k))
       end.

Lemma cata_arr F A (g : Alg F A) :
  forall x y, x =e y -> cata_f g x =e cata_f g y.
Proof.
  move=> x y /=; elim: x => sx kx Ih/= in y *; case: y=> sy ky/= [Es Ek].
  apply/(f_eq g); split=>//= e d1 d2; by apply/Ih.
Qed.

Definition cata F A (g : Alg F A) : arrow (LFix F) A
  := {| func := _; f_eq := cata_arr g |}.

Lemma cata_univ_r F A (g : Alg F A) (f : arrow (LFix F) A)
  : f =e g \o fmapA F f \o @l_out F -> f =e cata g.
Proof.
  move=> H.
  elim=> sx kx /= Ih.
  rewrite (H _)/=; apply/f_eq; rewrite /fmapA_f/=.
  split=>//= e d1 d2.
  rewrite Ih (cont_irr (X:=LFix F) kx).
  by auto with ffix.
Qed.

Lemma cata_univ_l F A (g : Alg F A) (f : arrow (LFix F) A)
  : f =e cata g -> f =e g \o fmapA F f \o @l_out F.
Proof.
  move=> H.
  elim=> sx kx /= Ih.
  rewrite (H _)/=; apply/(f_eq g); rewrite /fmapA_f/=.
  split=>//= e d1 d2.
  rewrite Ih (cont_irr (X:=LFix F) kx).
  rewrite -[cata_f g _]/(cata g _) -(H _) Ih.
  by auto with ffix.
Qed.

Lemma cata_univ F A (g : Alg F A) (f : arrow (LFix F) A)
  : f =e cata g <-> f =e g \o fmapA F f \o @l_out F.
Proof. by split;[apply/cata_univ_l|apply/cata_univ_r]. Qed.

(* Finite anamorphisms *)
Inductive FinF F A (h : CoAlg F A) : A -> Prop :=
| FinF_fold x : (forall e, FinF h (projT2 (h x) e)) -> FinF h x.

Lemma FinF_inv F A (h : CoAlg F A) x
  : FinF h x -> forall e, FinF h (projT2 (h x) e).
Proof. by case. Defined.

(* Finite coalgebras *)
Structure FCoAlg F A :=
  { coalg :> CoAlg F A;
    finite : forall x, FinF coalg x
  }.

Definition ana_f_ F A (h : CoAlg F A) : forall (x : A), FinF h x -> LFix F
  := fix f x H :=
       let hx := h x in
       LFix_in (fun e => f (projT2 hx e) (FinF_inv H e)).

Lemma ana_f_irr F A (h : CoAlg F A)
  : forall (x : A) (F1 F2 : FinF h x), ana_f_ F1 =e ana_f_ F2.
Proof.
  move=>/=; fix Ih 2; move=> x [{}x Fx] F2; move: F2 Fx=> [{}x Fy] Fx/=.
  split=>// e d1 d2; rewrite (bool_irrelevance d2 d1) => {d2}.
  by apply: Ih.
Qed.

Definition ana_f F A (h : FCoAlg F A) : A -> LFix F
  := fun x => ana_f_ (finite h x).

Lemma ana_arr F A (h : FCoAlg F A) :
  forall x y, x =e y -> ana_f h x =e ana_f h y.
Proof.
  rewrite /ana_f; move=> x y; move: x y (finite h x) (finite h y).
  fix Ih 3; move=> x y [x' Fx] [y' Fy]/=; split.
  - by case: (f_eq (coalg h) H).
  - move=> e d1 d2 /=; apply: Ih.
    by move: (f_eq (coalg h) H)=> [E1 /(_ e d1 d2)].
Qed.

Definition ana F A (h : FCoAlg F A) : arrow A (LFix F)
  := {| func := ana_f h; f_eq := ana_arr h |}.

Lemma ana_univ_r F A (h : FCoAlg F A) (f : arrow A (LFix F))
  : f =e @l_in F \o fmapA F f \o coalg h -> f =e ana h.
Proof.
  move=> H; rewrite /ana/ana_f/==>x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite -[LFixR (f x) _]/(eqRel (Eq _) (f x) _) (H _)/=; split=>// e d1 d2.
  rewrite (bool_irrelevance d2 d1); by apply: Ih.
Qed.

Lemma ana_univ_l F A (h : FCoAlg F A) (f : arrow A (LFix F))
  : f =e ana h -> f =e @l_in F \o fmapA F f \o coalg h.
Proof.
  move=> H x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite (H _) /=/ana_f; move: (finite h x)=>Fx'; move: Fx' Fx.
  move=>[{}x Fx'] Fx/=; split=>// e d1 d2.
  rewrite (bool_irrelevance d2 d1).
  rewrite -[LFixR _ _]/(eqRel (Eq _) _ _).
  move: (H (projT2 (coalg h x) (exist _ e d1))); rewrite /ana/ana_f/=.
  rewrite -![LFixR _ _]/(eqRel (Eq _) _ _).
  rewrite ana_f_irr =><-/=; by apply: LFixR_refl.
Qed.

Lemma ana_univ F A (h : FCoAlg F A) (f : arrow A (LFix F))
  : f =e ana h <-> f =e @l_in F \o fmapA F f \o coalg h.
Proof. by split;[apply/ana_univ_l|apply/ana_univ_r]. Qed.

(** Hylomorphisms **)

Definition hylo_f_ F A B (g : Alg F B) (h : CoAlg F A)
  : forall (x : A), FinF h x -> B
  := fix f x H :=
       let hx := h x in
       g (existT (fun sh=> sig (dom sh) -> B)
                 (projT1 hx)
                 (fun e => f (projT2 hx e) (FinF_inv H e))).

Lemma hylo_f_irr F A B (g : Alg F B) (h : CoAlg F A)
  : forall (x : A) (F1 F2 : FinF h x), hylo_f_ g F1 =e hylo_f_ g F2.
Proof.
  move=>/=; fix Ih 2; move=> x [{}x Fx] F2; move: F2 Fx=> [{}x Fy] Fx/=.
  apply/f_eq=>/=; split=>//= e d1 d2; rewrite (bool_irrelevance d2 d1)=>{d2}.
  by apply: Ih.
Qed.

Definition hylo_f F A B (g : Alg F B) (h : FCoAlg F A)
  := fun x => hylo_f_ g (finite h x).

Lemma hylo_arr F A B (g : Alg F B) (h : FCoAlg F A)
  : forall x y, x =e y -> hylo_f g h x =e hylo_f g h y.
Proof.
  rewrite /hylo_f; move=> x y; move: x y (finite h x) (finite h y).
  fix Ih 3; move=> x y [x' Fx] [y' Fy]/= H; apply/f_eq=>/=.
  case: (f_eq (coalg h) H)=>/= Es Ek; split=>//= e d1 d2.
  by apply/Ih/Ek.
Qed.

Definition hylo F A B (g : Alg F B) (h : FCoAlg F A) : arrow A B
  := {| func := _ ; f_eq := hylo_arr g h |}.

Lemma hylo_univ_r F A B (g : Alg F B) (h : FCoAlg F A) (f : arrow A B)
  : f =e g \o fmapA F f \o coalg h -> f =e hylo g h.
Proof.
  move=> H; rewrite /hylo/hylo_f/==>x; move: x (finite h x).
  fix Ih 2; move=> x Fx; rewrite (H _)/=/fmapA_f/=; case: Fx=> {}x Fx/=.
  apply/f_eq => /=; split=>//= e d1 d2.
  by rewrite (bool_irrelevance d2 d1); apply/Ih.
Qed.

Lemma hylo_univ_l F A B (g : Alg F B) (h : FCoAlg F A) (f : arrow A B)
  : f =e hylo g h -> f =e g \o fmapA F f \o coalg h.
Proof.
  move=> H x; move: x (finite h x).
  fix Ih 2; move=> x [{}x Fx].
  rewrite (H _) /=/hylo_f; move: (finite h x)=>Fx'; move: Fx' Fx.
  move=>[{}x Fx'] Fx/=; apply/f_eq; split=>//= e d1 d2.
  rewrite (bool_irrelevance d2 d1) (H _) /=/hylo_f/= hylo_f_irr.
  by eauto with ffix.
Qed.

Lemma hylo_univ F A B (g : Alg F B) (h : FCoAlg F A) (f : arrow A B)
  : f =e hylo g h <-> f =e g \o fmapA F f \o coalg h.
Proof. by split;[apply/hylo_univ_l|apply/hylo_univ_r]. Qed.

Corollary hylo_unr F A B (g : Alg F B) (h : FCoAlg F A)
  : hylo g h =e g \o fmapA F (hylo g h) \o coalg h.
Proof. by rewrite -hylo_univ; reflexivity. Qed.

Lemma fin_out F : forall x, FinF (@l_out F) x.
Proof. by elim=>s k Ih; constructor; apply: Ih. Qed.

Definition f_out F : FCoAlg F (LFix F) :=
  {| coalg := @l_out F; finite := @fin_out F|}.

Lemma hylo_cata F B (g : Alg F B)
  : cata g =e hylo g (f_out F).
Proof. rewrite hylo_univ; apply/cata_univ; reflexivity. Qed.

Lemma hylo_ana F A (h : FCoAlg F A)
  : ana h =e hylo (l_in F) h.
Proof. by rewrite hylo_univ; apply/ana_univ; reflexivity. Qed.

Lemma compA A B C D (f : arrow C D) (g : arrow B C) (h : arrow A B)
  : f \o (g \o h) =e (f \o g) \o h.
Proof. move=>x; by eauto with ffix. Qed.

Lemma idKl A B (f : arrow A B)
  : f \o id A =e f.
Proof. move=> x; by eauto with ffix. Qed.

Lemma idKr A B (f : arrow A B)
  : id B \o f  =e f.
Proof. move=> x; by eauto with ffix. Qed.

Lemma compKl A B C (f : arrow B C) (g1 g2 : arrow A B)
  : g1 =e g2 -> f \o g1 =e f \o g2.
Proof. by move=>->; eauto with ffix. Qed.

Lemma compKr A B C (f1 f2: arrow B C) (g : arrow A B)
  : f1 =e f2 -> f1 \o g =e f2 \o g.
Proof. by move=>->; eauto with ffix. Qed.

Lemma hylo_fusion_l F A B C
      (h1 : FCoAlg F A) (g1 : Alg F B) (g2 : Alg F C) (f2 : arrow B C)
      (E2 : f2 \o g1 =e g2 \o fmapA F f2)
  : f2 \o hylo g1 h1 =e hylo g2 h1.
Proof.
  rewrite hylo_univ fmap_comp.
  rewrite compA -E2 -compA -compA.
  apply/compKl.
  rewrite compA -hylo_univ.
  reflexivity.
Qed.

Lemma hylo_fusion_r F A B C
      (h1 : FCoAlg F B) (g1 : Alg F C) (h2 : FCoAlg F A)
      (f1 : arrow A B) (E1 : h1 \o f1 =e fmapA F f1 \o h2)
  : hylo g1 h1 \o f1 =e hylo g1 h2.
Proof.
  rewrite hylo_univ fmap_comp.
  rewrite -!compA -E1 !compA.
  apply/compKr.
  rewrite -hylo_univ.
  reflexivity.
Qed.

Lemma deforest F A B C
      (h1 : FCoAlg F A) (g1 : Alg F B) (h2 : FCoAlg F B) (g2 : Alg F C)
      (INV: h2 \o g1 =e id _)
  : hylo g2 h2 \o hylo g1 h1 =e hylo g2 h1.
Proof.
  apply/hylo_fusion_l.
  rewrite [in H in H =e _]hylo_unr.
  rewrite -compA INV idKl.
  reflexivity.
  Restart.
  apply/hylo_fusion_r.
  rewrite [in H in H =e _]hylo_unr.
  rewrite compA compA INV idKr.
  reflexivity.
Qed.

Corollary cata_ana_hylo F A B (g : Alg F B) (h : FCoAlg F A)
  : cata g \o ana h =e hylo g h.
Proof. by rewrite hylo_cata hylo_ana; apply/deforest/l_out_in. Qed.

Section ExQsort.

  (* Defining a tree *)
  Inductive Ts A :=
  | Leaf | Node (ELEM : A).
  Inductive Tp := | Lbranch | Rbranch.
  Definition t_dom A (s : Ts A) : Tp -> bool :=
    match s with
    | Node _ => fun=>true
    | _ => fun=> false
    end.
  Definition Tree A :=
    {| Shape := Ts A;
       Position := Tp;
       dom := @t_dom A;
    |}.
  Lemma dom_leaf_false A : {y | t_dom (Leaf A) y} -> False.
  Proof. by move=>[]. Qed.
  Definition dom_leaf A B (x : {y | t_dom (Leaf A) y}) : B :=
    False_rect _ (dom_leaf_false x).

  Definition a_leaf A X : App (Tree A) X := existT _ (Leaf A) (@dom_leaf A _).
  Definition a_node A X (x : A) (l r : X) : App (Tree A) X :=
    existT _ (Node x) (fun p => match proj1_sig p with
                                | Lbranch => l
                                | Rbranch => r
                                end).

  Definition a_out A X (x : App (Tree A) X)
    : option (A * X * X)
    := match x with
       | existT s k =>
         match s return (sig (t_dom s) -> X) -> _ with
         | Leaf => fun=> None
         | Node x =>
           fun k=>
             Some (x,
                   k (exist _ Lbranch is_true_true),
                   k (exist _ Rbranch is_true_true))
         end k
       end.
  (* end tree *)

  Definition m_merge (x : App (Tree nat) (seq nat)) : Ty (seq nat) :=
    match a_out x with
    | None => [::]
    | Some (h, l, r) => l ++ h :: r
    end.
  Lemma m_merge_arr : forall x y, x =e y -> m_merge x =e m_merge y.
  Proof.
    move=>[[|hx]/= kx]/= [[|hy]//= ky] [//= [<-]] H.
    by rewrite /m_merge/= !H.
  Qed.
  Definition merge : Alg (Tree nat) (seq nat)
    := {| func := m_merge; f_eq := m_merge_arr |}.

  Definition m_split (x : Ty (seq nat)) : App (Tree nat) (seq nat) :=
    match x with
    | [::] => a_leaf _ _
    | h :: t => a_node h [seq x <- t | x <= h] [seq x <- t | x > h]
    end.
  Lemma m_split_arr : forall x y, x =e y -> m_split x =e m_split y.
  Proof. by move=> x y ->; eauto with ffix. Qed.
  Definition c_split : CoAlg (Tree nat) (seq nat)
    := {| func := m_split; f_eq := m_split_arr |}.

  (* Needs to be defined, otherwise msort does not reduce! *)
  Lemma split_fin : forall x, FinF c_split x.
  Proof.
    move=>x; move: {-1}(size x) (leqnn (size x))=> n.
    elim: n => [|n Ih] in x *; case: x=> [|h t]/=; eauto=>E; constructor=>/=.
    - by case.
    - by [].
    - move=> [e /=_]; apply/Ih.
      by case: e; rewrite size_filter (leq_trans (count_size _ _)).
  Defined.

  Definition tsplit := {| coalg := c_split; finite := split_fin |}.
  Definition msort : seq nat -> seq nat := func (hylo merge tsplit).
End ExQsort.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlNatInt.
Set Extraction TypeExpand.
Set Extraction Flag 2047.
Extract Inductive sigT => "(*)"  [ "(,)" ].
Extraction Inline Ty.
Extraction Inline Eq.
Extraction Inline func.
Extraction Inline coalg.
Extraction Inline getTy.
Extraction Inline hylo.
Extraction Inline hylo_f.
Extraction Inline hylo_f_.
Extraction Inline projT1.
Extraction Inline projT2.

Extraction Inline merge.
Extraction Inline a_leaf.
Extraction Inline a_node.
Extraction Inline m_merge.
Extraction Inline m_split.
Extraction Inline a_out.
Extraction Inline c_split.
Extraction Inline tsplit.
Recursive Extraction msort.


(** * Implementation of Section 3.3 *)
Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.

Require Import CMorphisms.
Require Import List.
Require Import Lra.

Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.

(** Implementation of Lemma 3.20 *)
Lemma hrr_ID_gen P : forall G T A r s, sum_vec r = sum_vec s -> HR P (T :: G) -> HR P ((vec s (-S A) ++ vec r A ++ T) :: G).
Proof.
  intros G T A; revert G T.
  induction A;intros G T r0 s Heq pi; unfold minus; fold minus.
  - apply hrr_ID; assumption.
  - apply hrr_ex_seq with (vec r0 (HR_covar n) ++ vec s (HR_var n) ++ T); [ Permutation_Type_solve | ].
    apply hrr_ID; try symmetry; assumption.
  - apply hrr_Z; apply hrr_Z; apply pi.
  - apply hrr_plus.
    apply hrr_ex_seq with (vec r0 (A1 +S A2) ++ vec s (-S A1) ++ vec s (-S A2) ++ T); [ Permutation_Type_solve | ].
    apply hrr_plus.
    eapply hrr_ex_seq.
    2:{ eapply IHA1; [ apply Heq | ].
        eapply hrr_ex_seq.
        2:{ eapply IHA2; [ apply Heq | apply pi ]. }
        Permutation_Type_solve. }
    Permutation_Type_solve.
  - apply hrr_mul.
    eapply hrr_ex_seq with (vec r0 (r *S A) ++ vec (mul_vec r s) (-S A) ++ T) ; [ Permutation_Type_solve | ].
    apply hrr_mul.
    apply hrr_ex_seq with (vec (mul_vec r s) (-S A) ++ vec (mul_vec r r0) A ++ T); [ Permutation_Type_solve | ].
    apply IHA ; [ | apply pi].
    rewrite ? sum_mul_vec.
    destruct r as [r Hr].
    simpl.
    apply R_blt_lt in Hr.
    nra.
  - apply hrr_min.
    + apply hrr_ex_seq with (vec r0 (A1 \/S A2) ++ vec s (-S A1) ++ T); [Permutation_Type_solve | ].
      apply hrr_max.
      apply hrr_W.
      eapply hrr_ex_seq; [ | apply IHA1; [ apply Heq | apply pi] ].
      Permutation_Type_solve.
    + apply hrr_ex_seq with (vec r0 (A1 \/S A2) ++ vec s (-S A2) ++ T); [Permutation_Type_solve | ].
      apply hrr_max.
      apply hrr_ex_hseq with ((vec r0 A1 ++ vec s (-S A2) ++ T) :: (vec r0 A2 ++ vec s (-S A2) ++ T) :: G) ; [ Permutation_Type_solve | ].
      apply hrr_W.
      eapply hrr_ex_seq; [ | apply IHA2; [ apply Heq | apply pi] ].
      Permutation_Type_solve.
  - apply hrr_ex_seq with (vec r0 (A1 /\S A2) ++ vec s (-S A1 \/S -S A2) ++ T); [ Permutation_Type_solve | ].
    apply hrr_min.
    + apply hrr_ex_seq with (vec s (-S A1 \/S -S A2) ++ vec r0 (A1) ++ T); [Permutation_Type_solve | ].
      apply hrr_max.
      apply hrr_W.
      apply IHA1; [ apply Heq | apply pi].
    + apply hrr_ex_seq with (vec s (-S A1 \/S -S A2) ++ vec r0 (A2) ++ T); [Permutation_Type_solve | ].
      apply hrr_max.
      apply hrr_ex_hseq with ((vec s (-S A1) ++ vec r0 A2 ++ T) :: (vec s (-S A2) ++ vec r0 A2 ++ T) :: G) ; [ Permutation_Type_solve | ].
      apply hrr_W.
      eapply hrr_ex_seq; [ | apply IHA2; [ apply Heq | apply pi] ].
      Permutation_Type_solve.
Qed.

(** Implementation of Lemma 3.21 *)
Lemma subs_proof P : forall G n t,
    HR P G ->
    HR P (subs_hseq G n t).
Proof with try assumption; try reflexivity.
  intros G n t pi.
  induction pi;unfold subs_hseq in *; fold subs_hseq in *; try rewrite ? subs_seq_vec in *; try rewrite subs_seq_app in *; unfold subs in *; fold subs in *; try now constructor.
  - replace (subs_seq (seq_mul r T) n t) with (seq_mul r (subs_seq T n t)) in IHpi by (clear; induction T; try destruct a; simpl; try rewrite IHT; try reflexivity).
    apply hrr_T with r...
  - case (n =? n0).
    + apply hrr_ID_gen...
    + apply hrr_ID...
  - eapply hrr_ex_seq; [ apply subs_seq_ex ; apply p | ]...
  - eapply hrr_ex_hseq; [ apply subs_hseq_ex; apply p | ]...
  - rewrite eq_subs_minus in IHpi.
    apply hrr_can with (subs A n t) r s...
Qed.

(** Implementation of Lemma 3.22 *)
Lemma hrr_plus_can_inv P : forall G T A B r, HR P ((vec r (A +S B) ++ T) :: G) -> HR (hr_frag_add_CAN (hr_frag_add_M P)) ((vec r A ++ vec r B ++ T) :: G).
Proof.
  intros G T A B r pi.
  apply hrr_can with (A +S B) r r; try reflexivity.
  apply hrr_ex_seq with ((vec r (-S (A +S B)) ++ vec r A ++ vec r B) ++ (vec r (A +S B) ++ T)); [ Permutation_Type_solve | ].
  apply hrr_M; try reflexivity.
  2:{ apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P) ; [ apply add_M_le_frag | apply add_CAN_le_frag]. }
  apply hrr_ex_hseq with (G ++ ((vec r (-S (A +S B)) ++ vec r A ++ vec r B) :: nil)); [ Permutation_Type_solve | ].
  apply hrr_W_gen.
  unfold minus; fold (-S A); fold (-S B).
  apply hrr_plus.
  apply hrr_ex_seq with (vec r (-S A) ++ vec r A ++ vec r (-S B) ++ vec r B); [ Permutation_Type_solve | ].
  apply hrr_ID_gen; try reflexivity.
  replace (vec r (-S B) ++ vec r B) with (vec r (-S B) ++ vec r B ++ nil) by (now rewrite app_nil_r).
  apply hrr_ID_gen; [ reflexivity | apply hrr_INIT ].
Qed.

Lemma hrr_Z_can_inv P : forall G T r, HR P ((vec r HR_zero ++ T) :: G) -> HR (hr_frag_add_CAN P) (T :: G).
Proof.
  intros G T r pi.
  apply hrr_can with HR_zero r r; try reflexivity.
  apply hrr_Z.
  apply HR_le_frag with P; try assumption.
  apply add_CAN_le_frag.
Qed.

Lemma hrr_mul_can_inv P : forall G T A r0 r, HR P ((vec r (r0 *S A) ++ T) :: G) -> HR (hr_frag_add_CAN (hr_frag_add_M P)) ((vec (mul_vec r0 r) A ++ T) :: G).
Proof.
  intros G T A r0 r pi.
  apply hrr_can with (r0 *S A) r r; try reflexivity.
  apply hrr_ex_seq with ((vec r (-S (r0 *S A)) ++ vec (mul_vec r0 r) A) ++ (vec r (r0 *S A) ++ T)); [ Permutation_Type_solve | ].
  apply hrr_M; try reflexivity.
  2:{ apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P); [ apply add_M_le_frag | apply add_CAN_le_frag]. }
  apply hrr_ex_hseq with (G ++ ((vec r (-S (r0 *S A)) ++ vec (mul_vec r0 r) A) :: nil)); [ Permutation_Type_solve | ].
  apply hrr_W_gen.
  unfold HR_minus; fold HR_minus.
  apply hrr_mul.
  replace (vec (mul_vec r0 r) (-S A) ++ vec (mul_vec r0 r) A) with (vec (mul_vec r0 r) (-S A) ++ vec (mul_vec r0 r) A ++ nil) by (now rewrite app_nil_r).
  apply hrr_ID_gen; [ reflexivity | ].
  apply hrr_INIT.
Qed.

Lemma hrr_max_can_inv P : forall G T A B r, HR P ((vec r (A \/S B) ++ T) :: G) -> HR (hr_frag_add_CAN (hr_frag_add_M P)) ((vec r B ++ T) :: (vec r A ++ T) :: G).
Proof.
  intros G T A B r pi.
  apply hrr_can with (A \/S B) r r; try reflexivity.
  apply hrr_ex_seq with ( (vec r (-S (A \/S B)) ++ vec r B) ++ (vec r (A \/S B) ++ T)); [Permutation_Type_solve | ].
  apply hrr_M; try reflexivity.
  2:{ eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
      apply hrr_W.
      apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P); [ apply add_M_le_frag | apply add_CAN_le_frag]. }
  apply hrr_ex_hseq with ((vec r A ++ T) :: (vec r (-S (A \/S B)) ++ vec r B) :: G); [ apply Permutation_Type_swap | ].
  apply hrr_can with (A \/S B) r r ; try reflexivity.
  apply hrr_ex_seq with ( (vec r (-S (A \/S B)) ++ vec r A) ++ (vec r (A \/S B) ++ T)); [Permutation_Type_solve | ].
  apply hrr_M; try reflexivity.
  2:{ eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
      apply hrr_W.
      apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P); [ apply add_M_le_frag | apply add_CAN_le_frag]. }
  unfold minus; fold minus.
  apply hrr_min.
  - apply hrr_ex_hseq with (( (vec r (-S A /\S -S B) ++ vec r B) :: G) ++ ((vec r (-S A) ++ vec r A) :: nil)); [ Permutation_Type_solve | ].
    apply hrr_W_gen.
    replace (vec r (-S A) ++ vec r A) with (vec r (-S A) ++ vec r A ++ nil) by (now rewrite app_nil_r).
    apply hrr_ID_gen; [reflexivity | apply hrr_INIT].
  - eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    apply hrr_min.
    + apply hrr_S.
      apply hrr_ex_seq with (vec r (-S A) ++ vec r A ++ vec r (-S B) ++ vec r B ++ nil) ; [ Permutation_Type_solve | ].
      apply hrr_ID_gen; [ reflexivity | apply hrr_ID_gen ; [ reflexivity | ] ].
      apply hrr_ex_hseq with (G ++ (nil :: nil)); [ Permutation_Type_solve | ].
      apply hrr_W_gen; apply hrr_INIT.
    + rewrite <-(app_nil_r (vec r B)).
      apply hrr_ID_gen; [ reflexivity | ].
      eapply hrr_ex_hseq with (((vec r (-S B) ++ vec r A) :: G) ++ (nil :: nil)); [ | apply hrr_W_gen; apply hrr_INIT ].
      Permutation_Type_solve.
Qed.

Lemma hrr_min_can_inv_l P : forall G T A  B r, HR P ((vec r (A /\S B) ++ T) :: G) -> HR (hr_frag_add_CAN (hr_frag_add_M P)) ((vec r A ++ T) :: G).
Proof.
  intros G T A B r pi.
  apply hrr_can with (A /\S B) r r; try reflexivity.
  apply hrr_ex_seq with ((vec r (-S (A /\S B)) ++ vec r A) ++ (vec r (A /\S B) ++ T)); [ Permutation_Type_solve | ].
  apply hrr_M; try reflexivity.
  2:{ apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P); [ apply add_M_le_frag | apply add_CAN_le_frag]. }
  unfold minus; fold minus.
  apply hrr_max.
  apply hrr_ex_hseq with (((vec r (-S B) ++ vec r A) :: G) ++ ((vec r (-S A) ++ vec r A) :: nil)); [ Permutation_Type_solve | ].
  apply hrr_W_gen.
  rewrite <-(app_nil_r (vec r A)).
  apply hrr_ID_gen; [ reflexivity | apply hrr_INIT].
Qed.

Lemma hrr_min_can_inv_r P : forall G T A  B r, HR P ((vec r (A /\S B) ++ T) :: G) -> HR (hr_frag_add_CAN (hr_frag_add_M P)) ((vec r B ++ T) :: G).
Proof.
  intros G T A B r pi.
  apply hrr_can with (A /\S B) r r; try reflexivity.
  apply hrr_ex_seq with ((vec r (-S (A /\S B)) ++ vec r B) ++ (vec r (A /\S B) ++ T)); [ Permutation_Type_solve | ].
  apply hrr_M; try reflexivity.
  2:{ apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P); [ apply add_M_le_frag | apply add_CAN_le_frag]. }
  unfold minus; fold minus.
  apply hrr_max.
  apply hrr_ex_hseq with (((vec r (-S A) ++ vec r B) :: G) ++ ((vec r (-S B) ++ vec r B) :: nil)); [ Permutation_Type_solve | ].
  apply hrr_W_gen.
  rewrite <-(app_nil_r (vec r B)).
  apply hrr_ID_gen; [ reflexivity | apply hrr_INIT].
Qed.

(** Implementation of Lemma 3.24 *)
Lemma hrr_T_vec P : forall G T vr,
    vr <> nil ->
    HR P (seq_mul_vec vr T :: G) ->
    HR (hr_frag_add_T P) (T :: G).
Proof.
  intros G T vr; revert P G T; induction vr; intros P G T Hnnil pi.
  - exfalso; auto.
  - simpl in *.
    destruct vr.
    + apply hrr_T with a; try reflexivity.
      simpl in pi; rewrite app_nil_r in pi.
      apply HR_le_frag with P; try assumption.
      apply add_T_le_frag.
    + apply hrr_C.
      apply hrr_T with a; try reflexivity.
      eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      refine (IHvr P (seq_mul a T :: G) T _ _) ; [ now auto | ].
      eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      apply hrr_S.
      apply pi.
Qed.

(** Implementation of Lemma 3.25 *)
Lemma hrr_T_vec_inv P : forall G T vr,
    HR P (T :: G) ->
    HR (hr_frag_add_T (hr_frag_add_M P)) (seq_mul_vec vr T :: G).
Proof with try assumption.
  intros G T vr; revert G T; induction vr; intros G T pi.
  - apply hrr_ex_hseq with (G ++ (nil :: nil)) ; [ Permutation_Type_solve | ].
    apply hrr_W_gen.
    apply hrr_INIT.
  - simpl.
    apply hrr_M; try reflexivity.
    + apply hrr_T with (inv_pos a); try reflexivity.
      rewrite seq_mul_twice.
      replace (time_pos (inv_pos a) a) with One by (apply Rpos_eq; destruct a; simpl;apply R_blt_lt in e;apply Rinv_l_sym; nra).
      rewrite seq_mul_One.
      apply HR_le_frag with P; try assumption.
      apply le_hr_frag_trans with (hr_frag_add_M P); [ apply add_M_le_frag | apply add_T_le_frag ].
    + apply IHvr.
      apply pi.
Qed.

(** Implementation of Corollary 3.26 *)
Lemma mix_A_B : forall G T A B vr vs,
    HR_T_M (((vec vs A) ++ (vec vr A) ++ T) :: G) ->
    HR_T_M (((vec vs B) ++ (vec vr B) ++ T) :: G) ->
    HR_T_M (((vec vs B) ++ (vec vr A) ++ T) :: G).
Proof.
  intros G T A B vr vs piA piB.
  destruct vr as [| r vr]; [ | destruct vs as [ | s vs ]]; try assumption.
  apply hrr_C.
  change (hr_frag_T_M) with (hr_frag_add_T hr_frag_T_M).
  apply hrr_T_vec with (r :: vr) ; [now auto | ].
  eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
  change (hr_frag_T_M) with (hr_frag_add_T hr_frag_T_M).
  apply hrr_T_vec with (s :: vs) ; [ now auto | ].
  apply hrr_S.
  apply hrr_ex_seq with ((seq_mul_vec (r :: vr) ((vec (s :: vs) A) ++ (vec (r :: vr) A) ++ T)) ++ (seq_mul_vec (s :: vs) ((vec (s :: vs) B) ++ (vec (r :: vr) B) ++ T))).
  2:{ apply hrr_M; try reflexivity.
      - change (hr_frag_T_M) with (hr_frag_add_T hr_frag_T_M).
        apply hrr_T_vec_inv.
        apply piA.
      - change (hr_frag_T_M) with (hr_frag_add_T hr_frag_T_M).
        apply hrr_T_vec_inv.
        apply piB. }
  transitivity ((seq_mul_vec (r :: vr) (vec (s :: vs) A) ++ seq_mul_vec (r :: vr) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) T) ++ seq_mul_vec (s :: vs) (vec (s :: vs) B ++ vec (r :: vr) B ++ T)).
  - apply Permutation_Type_app; try reflexivity.
    transitivity (seq_mul_vec (r :: vr) (vec (s :: vs) A) ++ seq_mul_vec (r :: vr) (vec (r :: vr) A ++ T)).
    + apply seq_mul_vec_app_r.
    + apply Permutation_Type_app; try reflexivity.
      apply seq_mul_vec_app_r.
  - transitivity ((seq_mul_vec (r :: vr) (vec (s :: vs) A) ++
                               seq_mul_vec (r :: vr) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) T) ++
                                                                                ( seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) (vec (r :: vr) B) ++ seq_mul_vec (s :: vs) T)).
    + apply Permutation_Type_app; try reflexivity.
      transitivity (seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) (vec (r :: vr) B ++ T)).
      * apply seq_mul_vec_app_r.
      * apply Permutation_Type_app; try reflexivity.
        apply seq_mul_vec_app_r.
    + transitivity ((seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) (vec (r :: vr) A) ++ seq_mul_vec (s :: vs) T) ++ seq_mul_vec (r :: vr) (vec (s :: vs) B ++ vec (r :: vr) A ++ T)).
      * transitivity ((seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) (vec (r :: vr) A) ++ seq_mul_vec (s :: vs) T) ++ (seq_mul_vec (r :: vr) (vec (s :: vs) B) ++ (seq_mul_vec (r :: vr) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) T))).
        -- transitivity ((seq_mul_vec (s :: vs) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) T) ++ seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) (vec (r :: vr) B) ++ seq_mul_vec (s :: vs) T).
           ++ do 2 (apply Permutation_Type_app; try reflexivity).
              apply seq_mul_vec_vec.
           ++ transitivity ((seq_mul_vec (s :: vs) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) (vec (r :: vr) A) ++ seq_mul_vec (r :: vr) T) ++ seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (r :: vr) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) T).
              ** do 3 (apply Permutation_Type_app; try reflexivity).
                 apply seq_mul_vec_vec.
              ** remember (seq_mul_vec (s :: vs) (vec (r :: vr) A)) as srA.
                 remember (seq_mul_vec (r :: vr) (vec (r :: vr) A)) as rrA.
                 remember (seq_mul_vec (s :: vs) (vec (s :: vs) B)) as ssB.
                 remember (seq_mul_vec (r :: vr) (vec (s :: vs) B)) as rsB.
                 Permutation_Type_solve.
        -- apply Permutation_Type_app; try reflexivity.
           transitivity (seq_mul_vec (r :: vr) (vec (s :: vs) B) ++ seq_mul_vec (r :: vr) (vec (r :: vr) A ++ T)).
           ++ apply Permutation_Type_app; try reflexivity.
              symmetry; apply seq_mul_vec_app_r.
           ++ symmetry; apply seq_mul_vec_app_r.
      * apply Permutation_Type_app; try reflexivity.
        transitivity (seq_mul_vec (s :: vs) (vec (s :: vs) B) ++ seq_mul_vec (s :: vs) (vec (r :: vr) A ++ T)).
        -- apply Permutation_Type_app; try reflexivity.
           symmetry; apply seq_mul_vec_app_r.
        -- symmetry; apply seq_mul_vec_app_r.
Qed.

(** Implementation of Corollary 3.27 *)
Lemma C_A_B : forall G T A B vr vs,
    HR_T_M (((vec vs B) ++ (vec vr A) ++ T) ::((vec vs B) ++ (vec vr B) ++ T) ::((vec vs A) ++ (vec vr A) ++ T) :: G) ->
    HR_T_M (((vec vs B) ++ (vec vr B) ++ T) ::((vec vs A) ++ (vec vr A) ++ T) :: G).
Proof.
  intros G T A B vr vs pi.
  destruct vr as [ | r vr]; [ | destruct vs as [ | s vs]].
  - simpl in *.
    apply hrr_C.
    apply pi.
  - simpl in *.
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    apply hrr_C.
    eapply hrr_ex_hseq ; [ | apply pi].
    apply Permutation_Type_skip.
    apply Permutation_Type_swap.
  - remember (s :: vs) as vs'; remember (r :: vr) as vr'.
    apply hrr_C.
    change hr_frag_T_M with (hr_frag_add_T hr_frag_T_M).
    apply hrr_T_vec with vs' ; [ rewrite Heqvs'; now auto | ].
    apply hrr_ex_hseq with ((vec vs' A ++ vec vr' A ++ T) :: (vec vs' B ++ vec vr' B ++ T) :: (seq_mul_vec vs' (vec vs' B ++ vec vr' B ++ T)) :: G).
    { etransitivity ; [ | apply Permutation_Type_swap ].
      etransitivity; [ apply Permutation_Type_swap | ].
      apply Permutation_Type_skip.
      apply Permutation_Type_swap. }
    apply hrr_C.
    change hr_frag_T_M with (hr_frag_add_T hr_frag_T_M).
    apply hrr_T_vec with vr'; [ rewrite Heqvr' ; now auto | ].
    eapply hrr_ex_hseq.
    { apply Permutation_Type_skip.
      etransitivity ; [ apply Permutation_Type_swap | ].
      apply Permutation_Type_skip.
      apply Permutation_Type_swap. }
    apply hrr_S.
    apply hrr_ex_seq with (seq_mul_vec (vr' ++ vs') (vec vs' B ++ vec vr' A ++ T)).
    2:{ change hr_frag_T_M with (hr_frag_add_T (hr_frag_add_M hr_frag_T_M)).
        apply hrr_T_vec_inv.
        eapply hrr_ex_hseq ; [ apply Permutation_Type_skip; apply Permutation_Type_swap | apply pi]. }
    rewrite seq_mul_vec_app_l.
    symmetry.
    transitivity ((seq_mul_vec vr' (vec vs' A) ++ seq_mul_vec vr' (vec vr' A) ++ seq_mul_vec vr' T) ++ seq_mul_vec vs' (vec vs' B ++ vec vr' B ++ T)).
    + apply Permutation_Type_app; try reflexivity.
      transitivity (seq_mul_vec vr' (vec vs' A) ++ seq_mul_vec vr' (vec vr' A ++ T)).
      * apply seq_mul_vec_app_r.
      * apply Permutation_Type_app; try reflexivity.
        apply seq_mul_vec_app_r.
    + transitivity ((seq_mul_vec vr' (vec vs' A) ++ seq_mul_vec vr' (vec vr' A) ++ seq_mul_vec vr' T) ++ ( seq_mul_vec vs' (vec vs' B) ++ seq_mul_vec vs' (vec vr' B) ++ seq_mul_vec vs' T)).
      * apply Permutation_Type_app; try reflexivity.
        transitivity (seq_mul_vec vs' (vec vs' B) ++ seq_mul_vec vs' (vec vr' B ++ T)).
        -- apply seq_mul_vec_app_r.
        -- apply Permutation_Type_app; try reflexivity.
           apply seq_mul_vec_app_r.
      * transitivity ((seq_mul_vec vr' (vec vs' B) ++ seq_mul_vec vr' (vec vr' A) ++ seq_mul_vec vr' T) ++ seq_mul_vec vs' (vec vs' B ++ vec vr' A ++ T)).
        -- transitivity ((seq_mul_vec vr' (vec vs' B) ++ seq_mul_vec vr' (vec vr' A) ++ seq_mul_vec vr' T) ++ (seq_mul_vec vs' (vec vs' B) ++ (seq_mul_vec vs' (vec vr' A) ++ seq_mul_vec vs' T))).
           ++ transitivity ((seq_mul_vec vs' (vec vr' A) ++ seq_mul_vec vr' (vec vr' A) ++ seq_mul_vec vr' T) ++ seq_mul_vec vs' (vec vs' B) ++ seq_mul_vec vs' (vec vr' B) ++ seq_mul_vec vs' T).
              ** do 2 (apply Permutation_Type_app; try reflexivity).
                 apply seq_mul_vec_vec.
              ** transitivity ((seq_mul_vec vs' (vec vr' A) ++ seq_mul_vec vr' (vec vr' A) ++ seq_mul_vec vr' T) ++ seq_mul_vec vs' (vec vs' B) ++ seq_mul_vec vr' (vec vs' B) ++ seq_mul_vec vs' T).
                 --- do 3 (apply Permutation_Type_app; try reflexivity).
                     apply seq_mul_vec_vec.
                 --- remember (seq_mul_vec vs' (vec vr' A)) as srA.
                     remember (seq_mul_vec vr' (vec vr' A)) as rrA.
                     remember (seq_mul_vec vs' (vec vs' B)) as ssB.
                     remember (seq_mul_vec vr' (vec vs' B)) as rsB.
                     Permutation_Type_solve.
           ++ apply Permutation_Type_app; try reflexivity.
              transitivity (seq_mul_vec vs' (vec vs' B) ++ seq_mul_vec vs' (vec vr' A ++ T)).
              ** apply Permutation_Type_app; try reflexivity.
                 symmetry; apply seq_mul_vec_app_r.
              ** symmetry; apply seq_mul_vec_app_r.
        -- apply Permutation_Type_app; try reflexivity.
           transitivity (seq_mul_vec vr' (vec vs' B) ++ seq_mul_vec vr' (vec vr' A ++ T)).
           ++ apply Permutation_Type_app; try reflexivity.
              symmetry; apply seq_mul_vec_app_r.
           ++ symmetry; apply seq_mul_vec_app_r.
Qed.