Require Import FP.Data.Ascii.
Require Import FP.Data.String.
Require Import FP.Data.List.
Require Import FP.Data.N.
Require Import FP.Data.NRelations.
Require Import FP.Data.NStructures.
Require Import FP.Data.Function.
Require Import FP.Structures.Monad.
Require Import FP.Structures.Functor.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Show.
Require Import FP.Structures.Comonad.
Require Import FP.Structures.Foldable.
Require Import FP.Structures.Functor.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.Iterable.
Require Import FP.Structures.Applicative.
Require Import FP.Structures.Additive.
Require Import FP.Structures.Applicative.
Require Import FP.Structures.Functor.
Require Import FP.Structures.FZero.
Require Import FP.Structures.Traversable.
Require Import FP.Structures.Monad.
Require Import FP.Structures.Comonad.
Require Import FP.Data.PrettyI.
Require Import FP.Structures.Monoid.

Import AdditiveNotation.
Import MonadNotation.
Import EqDecNotation.
Import ApplicativeNotation.
Import FunctionNotation.
Import CharNotation.
Import ListNotation.
Import MonoidNotation.
Import ComonadNotation.
Import StringNotation.
Import NNotation.

Section coercions.
  Context {m} {M:FUnit m} {MP:FZero m}.
  Definition coerce_cons {A} (xs:list A) : m (A*list A) :=
    match xs with
    | [] => fzero
    | x::xs => funit (x,xs)
    end.
End coercions.

Section Show.
  Context {A} {AS:Show A}.

  Section list_show.
    Variable (R:Type) (SR:ShowResult R).

    Fixpoint list_show_inner (xL:list A) : R :=
      match xL with
      | nil => gunit
      | x::xL' =>
             raw_string "; "
          ** show x
          ** list_show_inner xL'
      end.

    Definition list_show (xL:list A) : R :=
      match xL with
      | nil => raw_string "[]"
      | x::nil =>
             raw_char "["%char
          ** show x
          ** raw_char "]"%char
      | x1::x2::xL =>
             raw_char "["%char
          ** show x1
          ** list_show_inner (x2::xL)
          ** raw_char "]"%char
      end.
  End list_show.

  Global Instance list_Show : Show (list A) := { show := list_show }.
End Show.

Section Pretty.
  Context {A} {SP:Pretty A}.

  Fixpoint list_pretty_inner (xL:list A) :=
    match xL with
    | nil => nil_d
    | x::xL =>
        text_d "; " `concat_d`
        nest_d 2 (pretty x) `concat_d`
        line_d `concat_d`
        list_pretty_inner xL
    end.

  Fixpoint list_pretty (xL:list A) : doc :=
    match xL with
    | [] => text_d "[]"
    | [x] =>
      group_d begin
        text_d "[ " `concat_d`
        nest_d 2 (pretty x) `concat_d`
        line_d `concat_d`
        text_d "]"
      end
    | x1::x2::xL =>
      group_d begin
        text_d "[ " `concat_d`
        nest_d 2 (pretty x1) `concat_d`
        line_d `concat_d`
        list_pretty_inner (x2::xL) `concat_d`
        text_d "]"
      end
    end.
  Global Instance list_Pretty : Pretty (list A) := { pretty := list_pretty }.

End Pretty.

Section Monoid.
  Context {A:Type}.
  Global Instance list_Monoid : Monoid (list A) :=
    { monoid_times := app
    ; monoid_unit := nil
    }.
End Monoid.

Fixpoint list_cofold {A} {m} {M:Comonad m} {B}
    (f:A -> m B -> B) (bM:m B) (xs:list A) : B :=
  match xs with
  | [] => coret bM
  | x::xs =>
      let bM := codo bM => list_cofold f bM xs in
      f x bM
  end.
Instance list_Foldable {A} : Foldable A (list A) :=
  { cofold := @list_cofold _ }.

Fixpoint list_coiter {A} {m} {M:Comonad m} {B}
    (f:m B -> A -> B) (bM:m B) (xs:list A) : B :=
  match xs with
  | [] => coret bM
  | x::xs =>
      let bM := codo bM => f bM x in
      list_coiter f bM xs
  end.
Instance list_Iterable {A} : Iterable A (list A) :=
  { coiter := @list_coiter _ }.

Fixpoint list_sequence {u} {uA:Applicative u} {A}
    (xs:list (u A)) : u (list A) :=
  match xs with
  | nil => funit nil
  | x::xs' => funit cons <@> x <@> list_sequence xs'
  end.
Instance list_Traversable : Traversable list :=
  { tsequence := @list_sequence }.

Definition list_mbuild {A} {m} {M:Monad m}
  (fld:forall {B}, (A -> B -> B) -> B -> m B) : m (list A) :=
    fld cons nil.
Instance list_Buildable {A} : Buildable A (list A) :=
  { mbuild := @list_mbuild _ }.

Instance list_FMap : FMap list :=
  { fmap := @map }.

Fixpoint zip {A B} (xs:list A) (ys:list B) : list (A*B) :=
  match xs,ys with
  | nil,_ => nil
  | _,nil => nil
  | x::xs',y::ys' => (x,y)::zip xs' ys'
  end.

Fixpoint zip_with {A B C} (f:A -> B -> C) (xs:list A) (ys:list B) : list C :=
  match xs,ys with
  | nil, _ => nil
  | _, nil => nil
  | x::xs',y::ys' => f x y::zip_with f xs' ys'
  end.

Fixpoint unzip {A B} (xys:list (A*B)) : list A * list B :=
  match xys with
  | nil => (nil, nil)
  | (x,y)::xys' =>
      let (xs,ys) := unzip xys'
      in (x::xs,y::ys)
  end.

Fixpoint nth {A} (n:N) (xs:list A) : option A :=
  match xs with
  | [] => None
  | x::xs => if n =! 0 then Some x else nth (n - 1) xs
  end.

Section Monad.
  Definition list_funit {A} (a:A) : list A := [a].
  Global Instance list_FUnit : FUnit list :=
    { funit := @list_funit }.

  Fixpoint list_bind {A B} (xs:list A) (f:A -> list B) : list B :=
    match xs with
    | [] => []
    | x::xs => f x ** list_bind xs f
    end.
  Global Instance list_MBind : MBind list :=
    { bind := @list_bind }.
End Monad.

(*
Section MonadPlus.
  Definition list_mzero {A} : list A := [].
  Definition list_mplus {A B} (xs:list A) (ys:list B) : list (A+B) :=
    fmap inl xs ** fmap inr ys.
  Global Instance list_MonadPlus : MonadPlus list :=
    { mzero := @list_mzero
    ; mplus := @list_mplus
    }.
End MonadPlus.
*)

Section Groupish.
  Context {T} {T_GTimes : GTimes T} {T_GUnit : GUnit T}.

  Definition gproductr := foldr gtimes gunit.
  Definition gproductl := foldl gtimes gunit.
End Groupish.

(*
Section Alternative.
  Context {t} {F:FMap t} {A:Alternative t}.

  Definition fchoices {A} : list (t A) -> t A := foldr fchoice fzero.
End Alternative.
*)

Fixpoint replicateM {m A} {M:Monad m} (n:nat) (aM:m A) : m (list A) :=
  match n with
  | O => ret nil
  | S n' =>
      x <- aM ;;
      xs <- replicateM n' aM ;;
      ret $ cons x xs
  end.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Equiv.

Lemma label_transform3: forall (X X0:atom) T D,
    X \notin fl_tt T \u {{X0}} ->
    type D ->
    open_tt (subst_label X (subst_tt X (typ_label X D) T))
             (typ_label X0 (open_tt (subst_label X (subst_tt X (typ_label X D) T)) X0))
      = subst_label X (subst_tt X (typ_label X D) (open_tt T (typ_label X0 (open_tt T X0)))).
Proof with auto.
  intros.
  rewrite  subst_tt_open_tt ...
  rewrite subst_label_open_tt ...
  f_equal...
  rewrite drop_label_reverse_type...
  rewrite drop_label_reverse_type...
  solve_notin.
Qed.

Lemma label_transform4 : forall (X X0:atom) T D,
    X \notin fl_tt T \u {{X0}} ->
    type D ->
    (open_tt (subst_label X (subst_tt X (typ_label X D) T)) X0) = (subst_label X (subst_tt X (typ_label X D) (open_tt T X0))).
Proof with auto.
  intros.
  rewrite <- subst_label_open_tt_var...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma binds_subst_label_existial : forall E X Y T U,
    binds X (bind_sub U) (map (drop_label Y) (map (subst_tb Y (typ_label Y T)) E)) ->
    exists Q,
      binds X (bind_sub Q) E.
Proof with auto.
  induction E;intros;simpl in *...
  analyze_binds H...
  destruct a.
  analyze_binds H...
  2: {
    destruct IHE with (X:=X) (Y:=Y) (U:=U) (T:=T)...
    exists x...
  }
  destruct b;simpl in *.
  + dependent destruction BindsTacVal.
    exists t...
  + inversion BindsTacVal.
  + inversion BindsTacVal.
Qed.

Lemma binds_subst_label_existial_lb : forall E X Y T U,
    binds X (bind_sub_lb U) (map (drop_label Y) (map (subst_tb Y (typ_label Y T)) E)) ->
    exists Q,
      binds X (bind_sub_lb Q) E.
Proof with auto.
  induction E;intros;simpl in *...
  analyze_binds H...
  destruct a.
  analyze_binds H...
  2: {
    destruct IHE with (X:=X) (Y:=Y) (U:=U) (T:=T)...
    exists x...
  }
  destruct b;simpl in *.
  + inversion BindsTacVal.
  + dependent destruction BindsTacVal.
    exists t...
  + inversion BindsTacVal.
Qed.

Lemma WF_narrowing_env_subst_inv: forall E1 E2 (X:atom) Y S,
    WF (map (subst_tb Y S) E1 ++ Y ~ bind_sub typ_top ++ E2) X ->
    WF (E1 ++ Y ~ bind_sub typ_top ++ E2) X.
Proof with auto.
  induction E1;intros...
  simpl in *.
  destruct a.
  dependent destruction H...
  + analyze_binds H...
    -
      destruct b.
      * apply WF_var with (U:=t)...
      * simpl in *.
        inversion BindsTacVal...
      * simpl in *.
        inversion BindsTacVal...
    -
      rewrite_env (nil ++ (a~ b) ++ E1 ++ (Y, bind_sub typ_top) :: E2).
      apply WF_weakening...
      apply IHE1  with (S:=S)...
      apply WF_var with (U:=U)...
    -
      apply WF_var with (U:=typ_top)...
    -
      apply WF_var with (U:=U)...
  + analyze_binds H...
    -
      destruct b.
      * apply WF_var with (U:=t)...
      * apply WF_var_lb with (U:=t)...
      * simpl in *.
        inversion BindsTacVal...
    -
      rewrite_env (nil ++ (a~ b) ++ E1 ++ (Y, bind_sub typ_top) :: E2).
      apply WF_weakening...
      apply IHE1  with (S:=S)...
      apply WF_var_lb with (U:=U)...
    -
      apply WF_var_lb with (U:=U)...
Qed.

(* Lemma sub_map_inv_var: forall X Y X0 C E1 E2,
    X <> Y -> X0 <> Y ->
  sub (map (subst_tb Y C) E1 ++ (Y, bind_sub typ_top) :: E2) X X0 ->
  sub (map (subst_tb Y C) E1 ++ (Y, bind_sub typ_top) :: E2) X0 X ->
  wf_env (E1 ++ (Y, bind_sub typ_top) :: E2) ->
  sub (E1 ++ (Y, bind_sub typ_top) :: E2) X X0.
Proof with auto.
  intros.
  pose proof suba_sub_tvar_chain H1.
  pose proof suba_sub_tvar_chain H2.
  destruct H4 as [W1 ?].
  destruct H5 as [W2 ?].
  pose proof sub_tvar_chain_antisym H4 H5.
  subst.
  apply sa_fvar...
  get_well_form.
  apply WF_narrowing_env_subst_inv in H6...
Qed. *)

Lemma drop_label_reverse_wf: forall E1 E2 C D A X,
    WF (map (drop_label X) (map (subst_tb X (typ_label X C)) E1) ++
            (X, bind_sub typ_top) :: E2)
       (subst_label X (subst_tt X (typ_label X D) A)) ->
    X \notin fl_tt A -> type D ->
    WF (E1 ++ (X, bind_sub typ_top) :: E2) A.
Proof with auto.
  intros.
  assert (type A) as HA.
  get_type...
  rewrite drop_label_reverse_type in H...
  apply type_to_rec in HA.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent C.
  generalize dependent D.
  generalize dependent X.
  induction HA;intros;simpl in *;try solve [dependent destruction H;auto]...
  -
    destruct (X==X0);subst...
    +
      apply WF_var with (U:=typ_top)...
    +
      simpl in H...
      dependent destruction H...
      * analyze_binds H...
        apply binds_subst_label_existial in BindsTac.
        destruct_hypos.
        apply WF_var with (U:=x)...
        apply WF_var with (U:=U)...
      * analyze_binds H...
        apply binds_subst_label_existial_lb in BindsTac.
        destruct_hypos.
        apply WF_var_lb with (U:=x)...
        apply WF_var_lb with (U:=U)...
  -
    dependent destruction H.
    constructor...
    apply IHHA1 with (C:=C) (D:=D)...
    apply IHHA2 with (C:=C) (D:=D)...
  -
    dependent destruction H5.
    apply WF_rec with (L:=L \u L0 \u {{X}});intros...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H2 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- subst_tt_open_tt_var...
      rewrite  subst_label_open_tt_var...
      apply H5...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- label_transform3...
      apply H6...
  -
    dependent destruction H3.
    apply WF_all with (L:=L \u L0 \u {{X}});intros...
    +
      apply IHHA with (C:=C) (D:=D)...
    +
      rewrite_env ((X0 ~ bind_sub T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- label_transform4...
      simpl.
      rewrite drop_label_reverse_type...
      assert (T1 = subst_label X (subst_tt X (typ_label X D) T1)).
      rewrite drop_label_reverse_type ...
      rewrite H6.
      apply H4...
  -
    dependent destruction H3.
    apply WF_all_lb with (L:=L \u L0 \u {{X}});intros...
    +
      apply IHHA with (C:=C) (D:=D)...
    +
      rewrite_env ((X0 ~ bind_sub_lb T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- label_transform4...
      simpl.
      rewrite drop_label_reverse_type...
      assert (T1 = subst_label X (subst_tt X (typ_label X D) T1)).
      rewrite drop_label_reverse_type ...
      rewrite H6.
      apply H4...
  -
    destruct (l==X);subst...
    +
      apply notin_union  in H0.
      destruct_hypos.
      apply test_solve_notin_7 in H0.
      destruct H0.
    +
      dependent destruction H.
      constructor...
      apply IHHA with (C:=C) (D:=D)...
Qed.

Lemma WF_nominal_inversion: forall E1 E2 X A (X0:atom) D C,
    WF (X0 ~ bind_sub typ_top ++
           map (subst_tb X (typ_label X (open_tt C X))) E1 ++ (X, bind_sub typ_top) :: E2)
          (open_tt (subst_tt X (typ_label X (open_tt D X)) A) X0)->
    X \notin {{X0}} \u fl_tt A  ->
    wf_env (X0 ~ bind_sub typ_top ++
           map (subst_tb X (typ_label X (open_tt C X))) E1 ++ (X, bind_sub typ_top) :: E2) ->
    type (open_tt D X) ->
    WF (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2) (open_tt A X0) .
Proof with auto.
  intros.
  rewrite subst_tt_open_tt_var in H...
  rewrite_env ((X0 ~ bind_sub typ_top ++
           map (subst_tb X (typ_label X (open_tt C X))) E1) ++ (X, bind_sub typ_top) :: E2) in H.
  apply WF_drop_label in H...
  simpl in H...
  rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
  apply drop_label_reverse_wf with (C:=open_tt C X) (D:=open_tt D X)...
  solve_notin.
Qed.

Ltac solve_bind_inv :=
repeat match goal with
| H: sub _ _ (typ_fvar ?X) |- _ => inversion H;clear H
| H: sub _ (typ_fvar ?X) _ |- _ => inversion H;clear H
end;subst;
let InvTac := fresh "InvTac" in
match goal with
| [ H1: binds ?X (bind_sub_lb _) ?E ,
  H2: binds ?X (bind_sub _) ?E |- _ ] =>
  pose proof binds_ub_lb_invalid _ _ _ H1 H2 as InvTac
end;
try solve [exfalso;apply InvTac;apply uniq_from_wf_env;get_well_form;auto].

Lemma binds_ub_lb_invalid_ext: forall E1 E2 X X1 S U B U0,
  binds X (bind_sub_lb U)
      (map (subst_tb X1 S) E1 ++ (X1, bind_sub B) :: E2) ->
  binds X (bind_sub U0) (E1 ++ (X1, bind_sub B) :: E2) ->
  wf_env (E1 ++ (X1,bind_sub B) :: E2) ->
  False.
Proof with auto.
  intros.
  destruct (X == X1).
  + subst. analyze_binds_uniq H0. apply uniq_from_wf_env...
    apply binds_mid_eq in H... inversion H.
  + apply binds_map_free_sub with (S:=S) in H0...
      analyze_binds H.
      { analyze_binds H0.
        + pose proof binds_ub_lb_invalid _ _ _ BindsTac BindsTac0.
          apply H. apply uniq_from_wf_env in H1.
          apply uniq_app_1 in H1. apply uniq_map_2...
        + apply in_split in BindsTac0.
          destruct_hypos. subst E2.
          apply uniq_from_wf_env in H1.
          apply fresh_app_l with (x:=X) (a:=bind_sub (subst_tt X1 S U0)) in H1...
          apply binds_In in BindsTac. rewrite dom_map in BindsTac... }
      { analyze_binds H0.
        + apply in_split in BindsTac0.
          destruct_hypos. subst E2.
          apply uniq_from_wf_env in H1.
          apply fresh_app_l with (x:=X) (a:=bind_sub_lb U) in H1...
          apply binds_In in BindsTac. rewrite dom_map in BindsTac...
        + pose proof binds_ub_lb_invalid _ _ _ BindsTac0 BindsTac.
          apply H. apply uniq_from_wf_env in H1.
          apply uniq_app_2 in H1. inversion H1...
      }
Qed.

Lemma subst_reverse_equiv: forall A,
    type4rec A -> forall B, type4rec B ->
    forall X C D E1 E2 S,
    X \notin fl_tt A \u fl_tt B \u fv_tt S \u fv_tt C \u fv_tt D->
    equiv (map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2 ) (subst_tt X (typ_label X (open_tt C X)) A) (subst_tt X (typ_label X (open_tt D X)) B) ->
    equiv (E1 ++ (X, bind_sub typ_top) :: E2) A B ->
    WF ((X, bind_sub typ_top) :: E2) (open_tt C X) ->
    WF ((X, bind_sub typ_top) :: E2) (open_tt D X) ->
    WF ((X, bind_sub typ_top) :: E2) (open_tt S X) ->
    wf_env (E1 ++ (X, bind_sub typ_top) :: E2) ->
    (equiv ((X, bind_sub typ_top) ::E2) (open_tt C X)  (open_tt D X) \/ (X \notin fv_tt A \u fv_tt B )) .
Proof with auto.
  unfold equiv.
  intros A HA;induction HA;
    intros B HB;induction HB;intros;destruct_hypos;simpl in *;try solve [inversion H0|
      inversion H1|inversion H2|inversion H3|inversion H4|inversion H5|inversion H6|inversion H7|inversion H8|inversion H9|inversion H10|destruct (X==X0);subst;auto;inversion H0
      ]...
  - destruct (X == X0)... subst X0.
    dependent destruction H7...
  -
    destruct (X==X0);subst...
    inversion H6. subst.
    apply binds_mid_eq in H9... inversion H9.
      apply uniq_from_wf_env...
  -
    destruct (X==X1);destruct (X0==X1);subst...
    +
      dependent destruction H0.
      dependent destruction H7.
      left.
      apply wf_env_cons in H5...
      apply sub_strengthening_env in H0...
      apply sub_strengthening_env in H7...
    +
      inversion H0...
      subst. inversion H6;subst...
      2:{ apply binds_mid_eq in H10... inversion H10. apply uniq_from_wf_env... }
      pose proof binds_ub_lb_invalid_ext _ _ _ _ _ _ _ _ H9 H10.
      destruct H8...
    +
      inversion H7...
      subst. inversion H1;subst...
      2:{ apply binds_mid_eq in H10... inversion H10. apply uniq_from_wf_env... }
      pose proof binds_ub_lb_invalid_ext _ _ _ _ _ _ _ _ H9 H10.
      destruct H8...
  - solve_bind_inv.
  - solve_bind_inv.
  - solve_bind_inv.
  - solve_bind_inv.
  - solve_bind_inv.
  - solve_bind_inv.
  -
    dependent destruction H0.
    dependent destruction H7.
    dependent destruction H1.
    dependent destruction H6.
    clear IHHB1 IHHB2.
    destruct IHHA1 with (B:=T0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S)...
    destruct IHHA2 with (B:=T3) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S)...
  - solve_bind_inv.
  -
    clear H4 H6.
    dependent destruction H8.
    dependent destruction H15.
    dependent destruction H12.
    dependent destruction H15.
    pick fresh Y.
    assert (type (open_tt C X)) by (get_type;auto).
    assert (type (open_tt D X)) by (get_type;auto).
    destruct H0 with (X:=Y) (X0:=X) (B:=open_tt T0 (typ_label Y (open_tt T0 Y))) (C:=C) (D:=D) (E1:=Y~bind_sub typ_top ++E1) (E2:=E2) (S:=S)...
    +
      solve_notin.
    +
      split.
      *
        rewrite_env (Y ~ bind_sub typ_top ++
                     map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
      rewrite subst_tt_open_tt_twice...
      rewrite subst_tt_open_tt_twice...
      *
        rewrite_env (Y ~ bind_sub typ_top ++
                     map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
      rewrite subst_tt_open_tt_twice...
      rewrite subst_tt_open_tt_twice...
    +
      split.
      *
        apply H14...
      *
        apply H17...
    +
      rewrite_env (Y ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2)...
    +
      right.
      apply notin_union in H24.
      destruct_hypos.
      apply notin_fv_open_inv in H24.
      apply notin_fv_open_inv in H25...
  -
    solve_bind_inv.
  -
    clear H2 IHHB.
    dependent destruction H4.
    dependent destruction H11.
    dependent destruction H5.
    dependent destruction H10.
    destruct IHHA with (B:=T0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:= E2) (S:=S)...
    clear IHHA.
    pick fresh Y.
    destruct H0 with (B:=open_tt T3 Y) (X:=Y) (X0:=X) (C:=C) (D:=D) (E1:=Y ~ bind_sub T1 ++E1) (E2:=E2) (S:=S);clear H0...
    +
      solve_notin.
    +
      split.
      *
        rewrite <- subst_tt_open_tt_var...
        rewrite <- subst_tt_open_tt_var...
        rewrite_env (nil ++ Y ~ bind_sub (subst_tt X (typ_label X (open_tt S X)) T1) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing with (Q:=subst_tt X (typ_label X (open_tt D X)) T0)...
        --
          clear Fr.
          assert (subst_tt X (typ_label X (open_tt D X)) T0 = subst_tt X (typ_label X (open_tt S X)) T0).
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite H0.
          assert (equiv (X ~ bind_sub typ_top ++ E2) (typ_label X (open_tt S X)) (typ_label X (open_tt S X))).
          {
            apply wf_env_cons in H10.
            unfold equiv;split;constructor;
            apply Reflexivity...
          }
          apply equiv_sub_subst...
        --
          apply H2...
        --
          get_type...
        --
          get_type...
      *
        rewrite <- subst_tt_open_tt_var...
        rewrite <- subst_tt_open_tt_var...
        rewrite_env (nil ++ Y ~ bind_sub (subst_tt X (typ_label X (open_tt S X)) T1) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing with (Q:=subst_tt X (typ_label X (open_tt C X)) T1)...
        --
          clear Fr.
          assert (subst_tt X (typ_label X (open_tt C X)) T1 = subst_tt X (typ_label X (open_tt S X)) T1).
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite H0.
          assert (equiv (X ~ bind_sub typ_top ++ E2) (typ_label X (open_tt S X)) (typ_label X (open_tt S X))).
          {
            apply wf_env_cons in H10.
            unfold equiv;split;constructor;
            apply Reflexivity...
          }
          apply equiv_sub_subst_refl...
          get_well_form...
        --
          apply H4...
        --
          get_type...
        --
          get_type...
    +
      split.
      *
        rewrite_env (nil ++ Y ~ bind_sub T1 ++ E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing with (Q:=T0)...
        apply H5...
      *
        rewrite_env (Y ~ bind_sub T1 ++ E1 ++ (X, bind_sub typ_top) :: E2).
        apply H6...
    +
      rewrite_env (Y ~ bind_sub T1 ++ E1 ++ (X, bind_sub typ_top) :: E2)...
      constructor...
      get_well_form...
    +
      right.
      apply notin_union in H12.
      destruct_hypos.
      apply notin_fv_open_inv in H0.
      apply notin_fv_open_inv in H12.
      solve_notin.
  -
    solve_bind_inv.
  -
    clear H2 IHHB.
    dependent destruction H4.
    dependent destruction H11.
    dependent destruction H5.
    dependent destruction H10.
    destruct IHHA with (B:=T0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:= E2) (S:=S)...
    clear IHHA.
    pick fresh Y.
    destruct H0 with (B:=open_tt T3 Y) (X:=Y) (X0:=X) (C:=C) (D:=D) (E1:=Y ~ bind_sub_lb T1 ++E1) (E2:=E2) (S:=S);clear H0...
    +
      solve_notin.
    +
      split.
      *
        rewrite <- subst_tt_open_tt_var...
        rewrite <- subst_tt_open_tt_var...
        rewrite_env (nil ++ Y ~ bind_sub_lb (subst_tt X (typ_label X (open_tt S X)) T1) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing_lb with (Q:=subst_tt X (typ_label X (open_tt D X)) T0)...
        --
          clear Fr.
          assert (subst_tt X (typ_label X (open_tt D X)) T0 = subst_tt X (typ_label X (open_tt S X)) T0).
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite H0.
          assert (equiv (X ~ bind_sub typ_top ++ E2) (typ_label X (open_tt S X)) (typ_label X (open_tt S X))).
          {
            apply wf_env_cons in H10.
            unfold equiv;split;constructor;
            apply Reflexivity...
          }
          apply equiv_sub_subst...
        --
          apply H2...
        --
          get_type...
        --
          get_type...
      *
        rewrite <- subst_tt_open_tt_var...
        rewrite <- subst_tt_open_tt_var...
        rewrite_env (nil ++ Y ~ bind_sub_lb (subst_tt X (typ_label X (open_tt S X)) T1) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing_lb with (Q:=subst_tt X (typ_label X (open_tt C X)) T1)...
        --
          clear Fr.
          assert (subst_tt X (typ_label X (open_tt C X)) T1 = subst_tt X (typ_label X (open_tt S X)) T1).
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite H0.
          assert (equiv (X ~ bind_sub typ_top ++ E2) (typ_label X (open_tt S X)) (typ_label X (open_tt S X))).
          {
            apply wf_env_cons in H10.
            unfold equiv;split;constructor;
            apply Reflexivity...
          }
          apply equiv_sub_subst_refl...
          get_well_form...
        --
          apply H4...
        --
          get_type...
        --
          get_type...
    +
      split.
      *
        rewrite_env (nil ++ Y ~ bind_sub_lb T1 ++ E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing_lb with (Q:=T0)...
        apply H5...
      *
        rewrite_env (Y ~ bind_sub_lb T1 ++ E1 ++ (X, bind_sub typ_top) :: E2).
        apply H6...
    +
      rewrite_env (Y ~ bind_sub_lb T1 ++ E1 ++ (X, bind_sub typ_top) :: E2)...
      constructor...
      get_well_form...
    +
      right.
      apply notin_union in H12.
      destruct_hypos.
      apply notin_fv_open_inv in H0.
      apply notin_fv_open_inv in H12.
      solve_notin.

  -
    solve_bind_inv.
  -
    dependent destruction H0...
    dependent destruction H7...
    dependent destruction H1.
    dependent destruction H6.
    clear IHHB.
    destruct IHHA with (B:=A0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S)...
Qed.


(* Use of idents bound to ltac names in a "match" *)

Definition foo : Type.
Proof.
  let x := fresh "a" in
  refine (forall k : nat * nat, let '(x, _) := k in (_ : Type)).
  exact (a = a).
Defined.
Goal foo.
intros k. elim k. (* elim because elim keeps names *)
intros.
Check a. (* We check that the name is "a" *)


From Coq Require Import
     List
     Logic.FunctionalExtensionality.

From Heapster Require Import
     Permissions
     SepStep.

From ITree Require Import
     ITree
     Basics.Basics
     ITreeFacts
     Events.State
     Events.StateFacts
     Events.Nondeterminism
     Events.Exception
     Eq.EqAxiom.

Require Import Paco.paco.

Import ITreeNotations.
Import ListNotations.
Import ITree.Basics.Basics.Monads.

Local Open Scope itree_scope.

Ltac rewritebisim lem := pose proof lem as bisim;
                         eapply bisimulation_is_eq in bisim;
                         setoid_rewrite bisim;
                         clear bisim.

Ltac rewritebisim_in lem H := pose proof lem as bisim;
                              eapply bisimulation_is_eq in bisim;
                              setoid_rewrite bisim in H;
                              clear bisim.

Variant modifyE S : Type -> Type :=
| Modify : (S -> S) -> modifyE S S.

(** return one of the elements in [x :: xs], as well as the complete list of unchosen elements *)
Fixpoint choose' {E} `{nondetE -< E} {X} (x : X) (xs : list X) (rest : list X) :
  itree E (X * list X)
  := match xs with
     | [] => Ret (x, rest)
     | x' :: xs => or
                   (Ret (x, (x' :: xs) ++ rest)) (* [x] *)
                   (choose' x' xs (x :: rest)) (* not [x] *)
     end.
Definition choose {E} `{nondetE -< E} {X} x xs : itree E (X * list X) :=
  choose' x xs [].

Definition E config := modifyE config +' nondetE.

Section parallel.
  Parameter config : Type.

  Definition thread := stateT config (itree (E config)) unit.

  Definition par_match par (curr : itree (E config) (config * unit)) (rest : list thread)
    : itree (E config) (config * unit) :=
    match (observe curr) with
    | RetF (s', _) => match rest with
                     | [] => Ret (s', tt)
                     | h :: t => Tau (par (h s') t)
                     end
    | TauF t => Tau (par t rest)
    | VisF (inl1 e) k =>
      match e in modifyE _ C return (C -> itree (E config) (config * unit)) -> _ with
      | Modify _ f =>
        fun k' =>
          '(curr', rest') <- choose k' rest;;
          Vis (inl1 (Modify _ f)) (fun s' => (par (curr' s') rest'))
      end k
    | VisF (inr1 e) k =>
      vis e (fun b => par (k b) rest)
    end.
  CoFixpoint par := par_match par.
  Lemma rewrite_par curr rest : par curr rest = par_match par curr rest.
  Proof.
    apply bisimulation_is_eq.
    revert curr rest.
    ginit. gcofix CIH. intros. gstep. unfold par. red. reflexivity.
  Qed.

  (* Not true using ≅, need equivalence that involves nondeterminism: *)
  (* Lemma par_unit : *)
  (*   forall t s, par (fun s => Ret (s, tt)) [t] s ≅ par t [fun s => Ret (s, tt)] s. *)
  (* Proof. *)
  (*   intros. rewrite rewrite_par. unfold par_match. simpl. *)
  (*   (* do 2 rewrite rewrite_par. *) *)
  (*   rewrite (rewrite_par t [_]). *)
  (*   unfold par_match. simpl. *)
  (*   destruct (observe (t s)) eqn:?. *)
  (*   - destruct r. pstep. (* rewrite rewrite_par. unfold par_match. *) constructor. *)
  (*     left. *)
  (*     do 2 rewrite rewrite_par. unfold par_match. rewrite Heqi. simpl. *)
  (*     pstep. constructor; auto. *)
  (*   - pstep. constructor. left. revert Heqi. revert t t0 s. pcofix CIH. intros. *)
  (*     do 2 rewrite rewrite_par. unfold par_match. rewrite Heqi. *)
  (*     rewrite (rewrite_par (fun _ => t0) _). unfold par_match. rewrite Heqi. simpl. *)
  (*   - destruct e. *)
  (* Qed. *)
End parallel.

(* the config is our last known state *before* giving up control *)
Variant typing_gen {R} typing (p : perm) (Q : R -> @Perms config) :
  config -> itree (E config) (R) -> Prop :=
| typing_gen_ret r c :
    pre p c ->
    (* (forall c', rely p c c' -> p ∈ Q (c', r)) -> *)
    p ∈ Q r ->
    typing_gen typing p Q c (Ret r)
| typing_gen_tau t p' c :
    pre p c ->
    sep_step p p' ->
    typing p' Q c t ->
    typing_gen typing p Q c (Tau t)
| typing_gen_vis k f p' c :
    pre p c ->
    (forall c, pre p c -> guar p c (f c)) ->
    sep_step p p' ->
    (forall c', rely p (f c) c' -> typing p' Q (f c) (k c')) ->
    typing_gen typing p Q c (Vis (inl1 (Modify _ f)) k)
(* (* other events. TODO: generalize E *) *)
| typing_gen_e X c p' (e : nondetE X) k :
    pre p c ->
    sep_step p p' ->
    (forall x, typing p' Q c (k x)) ->
    typing_gen typing p Q c (Vis (inr1 e) k)
.

Lemma typing_gen_mon {R} : monotone4 (@typing_gen R).
Proof.
  repeat intro. inversion IN; subst; econstructor; eauto.
Qed.
Hint Resolve typing_gen_mon : paco.

Definition typing_ {R} := paco4 (@typing_gen R) bot4.

Lemma typing__rely {R} p Q c c' (t : itree (E config) (R)) :
  rely p c c' ->
  typing_ p Q c t ->
  typing_ p Q c' t.
Proof.
  revert p Q c c' t. pcofix CIH. intros p Q c c' t Hrely Ht.
  pinversion Ht; subst.
  - pstep. constructor. respects. intros. apply H0; auto. (* etransitivity; eauto. *)
  - pstep. econstructor; eauto. right. eapply CIH; eauto. eapply sep_step_rely; eauto.
  - pstep. econstructor; eauto. right.
    assert (rely p (f c) (f c')) by admit.
    assert (rely p (f c) c'0) by (etransitivity; eauto).
    eapply CIH.
    + eapply sep_step_rely; eauto. (* apply H1. apply H5. *)
    + specialize (H2 _ H5). pclearbot. apply H2.
  - pstep. econstructor; eauto. right. eapply CIH; eauto. eapply sep_step_rely; eauto.
    apply H1.
Admitted.

Lemma typing__lte {R} p Q Q' c (t : itree (E config) R) :
  typing_ p Q c t ->
  (forall r, Q r ⊨ Q' r) ->
  typing_ p Q' c t.
Proof.
  revert p Q Q' c t. pcofix CIH. intros p Q Q' c t Htyping Hlte.
  pstep. pinversion Htyping; pclearbot; subst; econstructor; eauto.
  - intros. apply Hlte; eauto.
  - intros. specialize (H2 _ H3). pclearbot. eauto.
  - intros. specialize (H1 x). eauto.
Qed.

(* Lemma typing__lte' p p' Q c (t : itree (E config) (config * unit)) : *)
(*   typing_ p Q c t -> *)
(*   p <= p' -> *)
(*   typing_ p' Q c t. *)
(* Proof. *)
(*   revert p p' Q c t. pcofix CIH. intros p p' Q c t Ht Hlte. *)
(*   pinversion Ht; subst. *)
(*   - pstep. constructor; auto. *)
(*     + apply Hlte. *)
(*     + eapply Perms_upwards_closed; eauto. *)
(* Qed. *)

(* Definition typing {R} P Q (t : stateT config (itree (E config)) R) := *)
(*   forall p c, p ∈ P -> pre p c -> typing_ p Q (t c). *)
Definition typing {R} P Q (t : itree (E config) R) :=
  forall p c, p ∈ P -> pre p c -> typing_ p Q c t.

Lemma typing_lte {R} P P' (Q Q' : config * R -> Perms) t: (* (t : stateT config (itree (E config)) R) : *)
  typing P Q t ->
  P' ⊨ P ->
  (forall r, Q r ⊨ Q' r) ->
  typing P' Q' t.
Proof.
  repeat intro. eapply typing__lte; eauto.
Qed.

Lemma typing__bind {R S} p Q1 Q2 c
      (t1 : itree (E config) R)
      (t2 : R -> itree (E config) S)
      r' :
  typing_ p Q1 c t1 ->
  (forall r p c, p ∈ Q1 r ->
            pre p c ->
            paco4 typing_gen r' p Q2 c (t2 r)) ->
  paco4 typing_gen r' p Q2 c (bind t1 t2).
Proof.
  revert p Q1 Q2 c t1 t2. pcofix CIH. intros p Q1 Q2 c t1 t2 Ht1 Ht2.
  pinversion Ht1; subst.
  - rewritebisim @bind_ret_l.
    eapply paco4_mon; eauto.
  - rewritebisim @bind_tau.
    pstep. econstructor; eauto. right. eapply CIH; eauto.
  - rewritebisim @bind_vis. pstep. econstructor; eauto. intros.
    right. eapply CIH; eauto.
    specialize (H2 _ H3). pclearbot. apply H2.
  - rewritebisim @bind_vis. pstep. econstructor; eauto. intros.
    right. eapply CIH; eauto. apply H1.
Qed.

Lemma typing_bind {R S} P Q1 Q2
      (t1 : itree (E config) R)
      (t2 : R -> itree (E config) S) :
  typing P Q1 t1 ->
  (forall r, typing (Q1 r) Q2 (t2 r)) ->
  typing P Q2 (bind t1 t2).
Proof.
  intros Ht1 Ht2 p c Hp Hpre.
  eapply typing__bind; eauto. (* intros. eapply Ht2; eauto. apply H; reflexivity. *)
Qed.

Lemma typing__tau {R} p (Q : R -> Perms) c t :
  typing_ p Q c t ->
  typing_ p Q c (Tau t).
Proof.
  intros Ht.
  pinversion Ht; subst; simpl; try solve [pstep; econstructor; try reflexivity; eauto].
Qed.

(* Lemma typing__par_empty p Q c t : *)
(*   typing_ p Q c t -> *)
(*   typing_ p Q c (par t []). *)
(* Proof. *)
(*   revert p t c. *)
(*   pcofix CIH. *)
(*   intros p t c Ht. *)
(*   rewrite rewrite_par. unfold par_match. *)
(*   pinversion Ht; subst; simpl. *)
(*   - destruct r0. pstep. constructor; auto. *)
(*   - pstep. econstructor; eauto. (* right. eapply CIH; eauto. *) *)
(*   - pstep. unfold choose, choose'. *)
(*     assert ((fun _ : config => x_ <- Ret (k, []);; let (curr', rest') := x_ in Vis (inl1 (Modify config f)) (fun s' => par curr' rest' s')) = *)
(*             (fun _ => Vis (inl1 (Modify config f)) (fun s' => par k [] s'))). *)
(*     { apply functional_extensionality. intros. *)
(*       rewritebisim @bind_ret_l. reflexivity. } *)
(*     unfold thread, stateT in H4. rewrite H4. *)

(* TODO after this point *)
Lemma typing__par_empty p Q c t :
  typing_ p Q c t ->
  typing_ p Q c (par t []).
Proof.
  revert p t c.
  pcofix CIH.
  intros p t c Ht.
  rewrite rewrite_par. unfold par_match.
  pinversion Ht; subst; simpl.
  - destruct r0, u. pstep. constructor; auto.
  - pstep. econstructor; eauto. (* right. eapply CIH; eauto. *)
  - pstep. unfold choose, choose'.
    rewritebisim @bind_ret_l.
    econstructor; eauto.
    clear Ht H.
    right. eapply CIH; eauto.
    specialize (H2 _ H). pclearbot. eauto.
  - pstep. econstructor; eauto. intros. right. apply CIH. apply H1.
Qed.

Lemma typing_par_empty P Q t :
  typing P Q t ->
  typing P Q (par t []).
Proof.
  intros Ht p c Hp Hpre. apply typing__par_empty; auto.
Qed.

Lemma typing__frame p p' r (Q : unit -> Perms) R c t :
  typing_ p Q c t ->
  r ∈ R ->
  p ** r <= p' ->
  pre p' c ->
  typing_ p' (fun c' => Q c' * R) c t.
Proof.
  revert p p' r Q R t c.
  pcofix CIH. intros p p' r' Q R t c Ht Hr Hp' Hpre.
  pinversion Ht; subst.
  - destruct r0. pstep. constructor; auto.
    (* apply Hp'. *)
    eapply Perms_upwards_closed; eauto. apply sep_conj_Perms_perm; auto.
    (* apply H0; auto. apply Hp'; auto. *)
  - pstep. econstructor; auto.
    + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_l.
      apply Hp' in Hpre. apply Hpre.
      apply H0.
    + right. eapply CIH; eauto. reflexivity.
      split; [| split]. pinversion H1; auto.
      apply Hp'. apply Hpre.
      apply H0. apply Hp' in Hpre. apply Hpre.
  - pstep. econstructor; auto.
    (* + apply Hp'. constructor. left. auto. *)
    + intros. apply Hp'. constructor. left. apply H0. apply Hp'; auto.
    + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_l.
      apply Hp' in Hpre. apply Hpre.
      apply H1.
    + intros. right.
      assert (rely p (f c) c').
      { apply Hp'. auto. }
      specialize (H2 _ H4). pclearbot.
      eapply CIH; eauto. reflexivity.
      split; [| split].
      * pinversion H2; auto.
      * pose proof Hpre as Hpre'. apply Hp' in Hpre'. destruct Hpre' as (Hp & Hr' & Hsep).
        specialize (H0 _ Hp). apply Hsep in H0. respects. (* etransitivity; eauto. apply Hp'. auto. apply Hp'; auto. *)
      * apply H1. apply Hp' in Hpre. apply Hpre.
  - pstep. econstructor; eauto.
    + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_l.
      apply Hp' in Hpre. apply Hpre.
      apply H0.
    + intros. specialize (H1 x). right. eapply CIH; eauto. reflexivity.
      split; [| split]. pinversion H1; auto.
      apply Hp'. auto.
      apply Hp' in Hpre. apply H0. apply Hpre.
Qed.

Lemma typing__frame' p p' r (Q R : (config * unit) -> Perms) t c :
  typing_ p Q c t ->
  (forall c', rely r c c' -> r ∈ R (c', tt)) ->
  r ** p <= p' ->
  pre p' c ->
  typing_ p' (fun c => R c * Q c) c t.
Admitted.
(* Proof. *)
(*   revert p p' r Q R t c. *)
(*   pcofix CIH. intros p p' r' Q R t c Ht Hr Hp' Hpre. *)
(*   pinversion Ht; subst. *)
(*   - pstep. constructor; auto. destruct r0. intros. *)
(*     eapply Perms_upwards_closed; eauto. apply sep_conj_Perms_perm; auto. *)
(*     + apply Hr; auto. apply Hp'; auto. *)
(*     + apply H0; auto. apply Hp'; auto. *)
(*   - pstep. econstructor; auto. *)
(*     + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_r. *)
(*       apply Hp' in Hpre. destruct Hpre as (_ & _ & Hpre). symmetry in Hpre. apply Hpre. *)
(*       apply H0. *)
(*     + right. eapply CIH; eauto. reflexivity. *)
(*       (* intros. apply Hr. apply Hp'. eapply sep_step_rely; eauto. *) *)

(*       split; [| split]. *)
(*       apply Hp'. apply Hpre. *)
(*       pinversion H1; auto. *)
(*       symmetry. apply H0. apply Hp' in Hpre. *)
(*       destruct Hpre as (_ & _ & Hpre). symmetry in Hpre. apply Hpre. *)
(*   - pstep. econstructor; eauto. *)
(*     + apply Hp'. constructor. right. auto. *)
(*     + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_r; eauto. *)
(*       apply Hp' in Hpre. destruct Hpre as (_ & _ & Hpre). symmetry in Hpre. apply Hpre. *)
(*     + intros. right. *)
(*       assert (rely p c' c''). *)
(*       { apply Hp'. auto. } *)
(*       specialize (H2 _ H4). pclearbot. *)
(*       eapply CIH; eauto. 2: reflexivity. *)

(*       intros. apply Hr. etransitivity; eauto. *)
(*       apply Hp' in Hpre. destruct Hpre as (_ & _ & Hsep). transitivity c'. *)
(*       apply Hsep; auto. apply Hp'; auto. *)

(*       split; [| split]. *)
(*       * pose proof Hpre as Hpre'. apply Hp' in Hpre'. destruct Hpre' as (_ & _ & Hsep). *)
(*         apply Hsep in H0. respects. etransitivity; eauto. apply Hp'. auto. apply Hp'; auto. *)
(*       * pinversion H2; auto. *)
(*       * symmetry. apply H1. apply Hp' in Hpre. *)
(*         destruct Hpre as (_ & _ & Hpre). symmetry in Hpre. apply Hpre. *)
(*   - pstep. econstructor; eauto. *)
(*     + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_r; eauto. *)
(*       apply Hp' in Hpre. destruct Hpre as (_ & _ & Hpre). symmetry in Hpre. apply Hpre. *)
(*     + intros. specialize (H1 x). right. eapply CIH; eauto. reflexivity. *)
(*       split; [| split]. *)
(*       apply Hp'. auto. *)
(*       pinversion H1; auto. *)
(*       symmetry. apply Hp' in Hpre. apply H0. *)
(*       destruct Hpre as (_ & _ & Hpre). symmetry in Hpre. apply Hpre. *)
(* Qed. *)

(* Lemma typing_frame P P' (Q : config * unit -> Perms) t : *)
(*   typing P Q t -> *)
(*   typing (P * P') (fun r => Q r * P') t. *)
(* Proof. *)
(*   intros Ht p'' c (p & p' & Hp & Hp' & Hlte) Hpre. *)
(*   specialize (Ht _ _ Hp). *)
(*   revert Ht Hp Hp' Hlte. revert P P' Q t p p'' p'. *)
(*   pcofix CIH. intros. pinversion Ht; subst; simpl. *)
(*   - destruct r0. pstep. constructor; auto. *)
(*     admit. *)
(*     intros. eapply Perms_upwards_closed; eauto. *)
(*     apply sep_conj_Perms_perm; auto. apply H0. apply Hlte; auto. *)
(*   - pstep. econstructor; auto. *)
(*     + eapply sep_step_lte; eauto. eapply sep_step_sep_conj_l. *)
(*       apply Hp' in Hpre. apply Hpre. *)
(*       apply H0. *)

(*     2: { *)
(*       right. eapply CIH; eauto. *)

(*     eapply typing__frame; eauto. apply H; auto. apply H3. auto. *)
(* Qed. *)

Lemma typing__par p1 p2 p Q1 Q2 c t1 t2 :
  typing_ p1 Q1 c t1 ->
  typing_ p2 Q2 c (t2 c) ->
  p1 ** p2 <= p ->
  pre p c ->
  typing_ p (fun c => Q1 c * Q2 c) c (par t1 [t2]).
Proof.
  revert p1 p2 p c t1 t2. pcofix CIH. intros p1 p2 p c t1 t2 Ht1 Ht2 Hlte Hpre.
  rewrite rewrite_par. unfold par_match.
  (* assert (Hguar1: guar p1 c c) by reflexivity. specialize (Ht1 _ Hguar1). *)
  pinversion Ht1; subst; simpl.
  - destruct r0, u. pstep. econstructor; eauto. reflexivity. left.
    eapply paco4_mon_bot; eauto. eapply typing__frame'; eauto.
    apply typing__par_empty. apply Ht2; intuition.
    intros; eauto.
  - pstep. econstructor; eauto.
    2: { right. eapply CIH. apply H3. apply Ht2.
         reflexivity. split; [| split]; auto.
         pinversion H3; auto.
         apply Hlte; auto.
         apply H1. apply Hlte in Hpre. apply Hpre.
    }
    etransitivity; eauto. apply sep_step_lte'; eauto.
    apply sep_step_sep_conj_l; auto. apply Hlte in Hpre. apply Hpre.
  - unfold choose, choose', or. rewritebisim @bind_vis. simpl.
    pstep. econstructor; eauto. reflexivity.
    intros []; left; rewritebisim @bind_ret_l.
    + pstep. econstructor; auto.
      * apply Hlte. constructor 1; auto.
      * eapply sep_step_lte; eauto. apply sep_step_sep_conj_l; eauto.
        apply Hlte in Hpre. apply Hpre.
      * intros. right. eapply CIH; eauto.
        -- assert (Hrely : rely p1 c' c''). apply Hlte; auto.
           specialize (H4 _ Hrely). pclearbot. eauto.
        -- apply Hlte in H3. destruct H3.
           (* eapply typing_rely. transitivity c'; eauto. *)
           (* apply Hlte in Hpre. destruct Hpre as (_ & _ & Hsep). *)
        (* apply Hsep; eauto. auto. *)
           admit.
        -- reflexivity.
        -- split; [| split].
           ++ apply Hlte in H3. destruct H3. specialize (H4 _ H3).
              pclearbot. pinversion H4; auto.
           ++ respects; auto. apply Hlte; eauto.
              apply Hlte in Hpre. pose proof Hpre as (_ & _ & Hsep).
              respects; eauto. apply Hsep; eauto. apply Hpre.
           ++ apply H2; auto. apply Hlte in Hpre. apply Hpre.
    + admit.
  - pstep. econstructor; auto.
    2: { intros. specialize (H3 x). right. eapply CIH. apply H3. eauto. reflexivity.
         split; [| split].
         - pinversion H3; auto.
         - apply Hlte; auto.
         - apply H1. apply Hlte in Hpre. apply Hpre. }
    eapply sep_step_lte; eauto. apply sep_step_sep_conj_l; auto.
    apply Hlte in Hpre. apply Hpre.
Admitted.

Lemma typing_par P1 P2 (Q1 Q2 : config * unit -> Perms) t1 t2 :
  typing P1 Q1 t1 ->
  typing P2 Q2 t2 ->
  typing (P1 * P2) (fun c => Q1 c * Q2 c) (par t1 [t2]).
Proof.

  repeat intro. destruct H1 as (? & ? & ? & ? & ?).
  eapply typing__par; eauto. unfold typing in *.
  apply H; auto. apply H4; auto.
  apply H0; auto. apply H4; auto.

  (* (* revert t1 t2 P1 P2 Q1 Q2. *) *)
  (* intros Ht1 Ht2 p c (p1 & p2 & Hp1 & Hp2 & Hlte) Hpre. *)
  (* assert (Hpre1 : pre p1 c). { apply Hlte; auto. } *)
  (* assert (Hpre2 : pre p2 c). { apply Hlte; auto. } *)
  (* specialize (Ht1 _ _ Hp1 Hpre1). *)
  (* specialize (Ht2 _ _ Hp2 Hpre2). *)
  (* revert Ht1 Ht2 Hp1 Hp2 Hlte Hpre Hpre1 Hpre2. revert t1 t2 c p1 p2 p (* P1 P2 Q1 Q2 *). *)
  (* (* pcofix CIH. *) intros t1 t2 c p1 p2 p (* P1 P2 Q1 Q2 *). *)
  (* intros Ht1 Ht2 Hp1 Hp2 Hlte Hpre Hpre1 Hpre2. *)
  (* rewrite rewrite_par. unfold par_match. pinversion Ht1; subst; simpl. *)
  (* - destruct r0. pstep. econstructor; eauto. reflexivity. left. *)
  (*   eapply paco4_mon_bot; eauto. eapply typing__frame'; eauto. *)
  (*   apply typing__par_empty. apply Ht2; auto. *)
  (*   intros; eauto. *)
  (* - pstep. econstructor; eauto. *)
  (*   2: { right. eapply CIH. apply H3. apply Ht2. all: auto. *)
  (*        admit. (* we need typing_ version... *) *)
  (*        reflexivity. split; [| split]; auto. *)
  (*        pinversion H3; auto. *)
  (*        apply H1. apply Hlte in Hpre. apply Hpre. *)
  (*        pinversion H3; auto. *)
  (*   } *)
  (*   etransitivity; eauto. apply sep_step_lte'; eauto. *)
  (*   apply sep_step_sep_conj_l; auto. apply Hlte in Hpre. apply Hpre. *)
  (* - unfold choose, choose', or. rewritebisim @bind_vis. simpl. *)
  (*   pstep. econstructor; eauto. reflexivity. *)
  (* - eapply typing_par_empty in Ht2. *)
  (*   red in Ht2. *)
  (*   eapply paco4_mon_bot. apply Ht2; eauto. admi.t *)
  (*   intros. eauto. *)
  (* - *)
Qed.


Require Import BoolProd Coq.Lists.Streams.

Declare ML Module "mTranslateStream".
Open Scope my_scope.

(* For the internal of the plugin. *)
Definition timesBool := fun Aᵗ => Aᵗ × bool.
Definition pairTrue   := fun (Aᵗ : Type) => (Aᵗ, true).

CoFixpoint id {A : Type} (x : A) : Stream A :=
  Cons x (id x).

(* This translation implements a constructive version of the negation of stream extensionality. *)

(* EqSt is bisimilarity. *)
Implement notStreamExt : forall (A : Type),
    A -> {s1 : Stream A & {s2 : Stream A & EqSt s1 s2 /\ (s1 = s2 -> False)}}
  using timesBool pairTrue.
Proof.
  compute. intros A x. exists (id x, true). exists (id x, false). cbn. split.
  - apply EqSt_reflex.
  - intro H.  apply (f_equal snd) in H; cbn in H. discriminate H.
Defined.

(* ** Some check of the translation on other types. *** *)

Implement f : {P : Prop & {Q : Prop &  ((P -> Q) -> (Q -> P) -> P = Q) -> False}}
                using timesBool pairTrue.
Abort.

Implement foo : forall A B : Type, forall (f g : A -> B), forall x, f x = g x
                using timesBool pairTrue.
Abort.

Implement wqd : forall (A : Type) (B : A -> Prop), forall x, B x
                using timesBool pairTrue.
compute.
Abort.


Require Import Raft.

Section TermSanityInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition no_entries_past_current_term_host net :=
    forall (h : name) e,
      In e (log (nwState net h)) ->
      eTerm e <= currentTerm (nwState net h).

  Definition no_entries_past_current_term_nw net :=
    forall e p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm entries leaderCommit ->
      In e entries ->
      eTerm e <= t.

  Definition no_entries_past_current_term net :=
    no_entries_past_current_term_host net /\
    no_entries_past_current_term_nw net.

  Class term_sanity_interface : Prop :=
    {
      no_entries_past_current_term_invariant :
        forall net,
          raft_intermediate_reachable net ->
          no_entries_past_current_term net
    }.
End TermSanityInterface.


Require Import TreeIAux.
Lemma leftisthp2consistent_maket0 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = i_0))/\(not (treei_ancestor  iti_0 u_1 u_0))/\(treei_member  iti_0 u_0)/\(treei_ancestor  iti_2 u_1 u_0)/\(treei_member  iti_2 u_0)/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (treei_ancestor  iti_1 u_1 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket1 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = i_0))/\(not (treei_member  iti_0 u_0))/\(treei_ancestor  iti_2 u_1 u_0)/\(treei_member  iti_2 u_0)/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (treei_ancestor  iti_1 u_1 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket2 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = i_0))/\(not (treei_member  iti_0 u_0))/\(treei_ancestor  iti_2 u_1 u_0)/\(treei_member  iti_2 u_0)/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (treei_member  iti_1 u_1)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket3 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_ancestor  iti_2 u_1 u_0))/\(treei_member  iti_2 u_0)/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (not (u_1 = i_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket4 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_ancestor  iti_2 u_1 u_0))/\(treei_member  iti_2 u_0)/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_0 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket5 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_0 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket6 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (not (treei_member  iti_0 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket7 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(treei_member  iti_0 u_1)/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_2 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket8 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_0 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket9 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_member  iti_1 u_0)/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (treei_member  iti_2 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket10 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_ancestor  iti_1 u_1 u_0)/\(treei_member  iti_1 u_0)/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (treei_ancestor  iti_2 u_1 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket11 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((u_1 = i_0)/\(not (treei_ancestor  iti_1 u_1 u_0))/\(treei_member  iti_1 u_0)/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (treei_ancestor  iti_2 i_0 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket12 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = i_0))/\(not (treei_ancestor  iti_1 u_1 u_0))/\(treei_member  iti_1 u_0)/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_2 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket13 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_ancestor  iti_2 u_1 u_0)/\(not (treei_member  iti_1 u_0))/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (u_1 = i_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket14 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_ancestor  iti_2 u_1 u_0)/\(not (treei_member  iti_1 u_0))/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (treei_member  iti_0 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket15 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_member  iti_0 u_0)/\(not (treei_ancestor  iti_2 u_1 u_0))/\(not (treei_member  iti_1 u_0))/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (treei_member  iti_2 u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket16 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_member  iti_0 u_0)/\(not (treei_ancestor  iti_2 u_1 u_0))/\(not (treei_member  iti_1 u_0))/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (u_1 = i_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket17 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_member  iti_2 u_0)/\(not (treei_member  iti_0 u_0))/\(not (treei_ancestor  iti_2 u_1 u_0))/\(not (treei_member  iti_1 u_0))/\(treei_member  iti_1 u_1)/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (u_0 = i_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket18 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_1 u_1))/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (u_1 = i_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket19 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_1 u_1))/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_1 i_0 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket20 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((treei_ancestor  iti_2 i_0 u_0)/\(treei_member  iti_2 u_0)/\(not (treei_member  iti_1 u_1))/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (i_0 = u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket21 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_ancestor  iti_2 i_0 u_0))/\(treei_member  iti_2 u_0)/\(not (treei_member  iti_1 u_1))/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (i_0 = u_0)).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket22 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(not (treei_member  iti_1 u_1))/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (treei_member  iti_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket23 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(not (treei_member  iti_1 u_1))/\(not (treei_member  iti_0 u_1))/\(treei_member  iti_2 u_1)) -> (not (treei_ancestor  iti_2 i_0 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket24 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_1))) -> (not (treei_ancestor  iti_0 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket25 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_1))) -> (not (u_1 = i_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket26 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_1))) -> (not (treei_ancestor  iti_2 u_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket27 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_0 u_0))/\(treei_member  iti_2 u_0)/\(not (treei_member  iti_2 u_1))) -> (not (treei_member  iti_0 u_1))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket28 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_0 u_0))/\(treei_member  iti_2 u_0)/\(not (treei_member  iti_2 u_1))) -> (not (treei_member  iti_1 u_1))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket29 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(not (treei_member  iti_2 u_1))) -> (not (treei_member  iti_0 u_1))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket30 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (treei_member  iti_2 u_0))/\(not (treei_member  iti_2 u_1))) -> (not (treei_member  iti_1 u_1))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket31 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = u_0))/\(not (treei_member  iti_2 u_0))/\(not (treei_member  iti_2 u_1))) -> (not (u_0 = i_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket32 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = u_0))/\(not (treei_member  iti_2 u_0))/\(not (treei_member  iti_2 u_1))) -> (not (treei_member  iti_0 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma leftisthp2consistent_maket33 (i_0:nat) (iti_0:treei nat) (iti_1:treei nat) (iti_2:treei nat) (u_0:nat) (u_1:nat) : (imaket_spec  i_0 iti_0 iti_1 iti_2) -> (((not (u_1 = u_0))/\(not (treei_member  iti_2 u_0))/\(not (treei_member  iti_2 u_1))) -> (not (treei_member  iti_1 u_0))).
Proof. solve_imaket; try (assert (u_0 = u_1); subst; eauto). Qed.


Require Import floyd.base.
Require Import floyd.client_lemmas.
Require Import floyd.assert_lemmas.

Local Open Scope logic.

Lemma typed_true_nullptr:
 forall v t t',
   typed_true tint (force_val (sem_cmp Ceq (tptr t) (tptr t') v (Vint Int.zero))) ->
   v=nullval.
Proof.
 intros.
 destruct v; inv H.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Lemma typed_true_nullptr':
  forall  {cs: compspecs}  t t' v,
    typed_true tint (eval_binop Oeq (tptr t) (tptr t') v nullval) -> v=nullval.
Proof.
 intros. unfold eval_binop, typed_true in H.
 destruct v; inv H; auto.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Lemma typed_true_Oeq_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Oeq (tptr t) (tptr t')) v `nullval)) |--
   local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 destruct (v rho); inv H.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Definition  binary_operation_to_comparison (op: binary_operation) :=
 match op with
 | Oeq => Some (@eq Z)
 | Cop.One => Some Zne
 | Olt => Some Z.lt
 | Ole => Some Z.le
 | Ogt => Some Z.gt
 | Oge => Some Z.ge
 | _ => None
 end.

(*
Lemma typed_true_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |--  tc_expr Delta e1 ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |-- tc_expr Delta e2 ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_true
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 (tc_expr Delta e1 && (tc_expr Delta e2
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_true (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R)))).
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
(*do 2 rewrite insert_local.*)
unfold PROPx, LOCALx; intro rho; simpl.
normalize.
autorewrite with norm1 norm2; normalize.
rewrite <- andp_assoc.
apply andp_derives; auto.
eapply derives_trans.
apply andp_derives; apply typecheck_expr_sound; auto.
normalize. split; auto.
rewrite H1,H0 in *.
clear H5 H2 H0 H1.
destruct (eval_expr e1 rho); inv H6.
destruct (eval_expr e2 rho); inv H7.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H4.
destruct op; inv H; simpl in H4.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
 contradiction H4; auto.
unfold Zne.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
contradict H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; try omega; contradict H4; auto.
Qed.
*)

Definition  binary_operation_to_opp_comparison (op: binary_operation) :=
 match op with
 | Oeq => Some Zne
 | Cop.One => Some (@eq Z)
 | Olt => Some Z.ge
 | Ole => Some Z.gt
 | Ogt => Some Z.le
 | Oge => Some Z.lt
 | _ => None
 end.

(*
Lemma typed_false_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_opp_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e1) ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e2) ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_false
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 ( local (tc_environ Delta) && ((tc_expr Delta e1) && ( (tc_expr Delta e2)
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_false (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))))).
apply andp_right.
rewrite <- insert_local. apply andp_left1; auto.
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
unfold PROPx, LOCALx; intro rho; simpl.
unfold local,lift1 at 1.
apply derives_extract_prop; intro TCE.
eapply derives_trans.
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply derives_refl.
normalize. autorewrite with norm1 norm2; normalize.
apply andp_right; auto. apply prop_right.
split; auto.
clear H6 TCE.
rewrite H0 in *; rewrite H1 in *.
clear H0 H1 H4.
destruct (eval_expr e1 rho); inv H2.
destruct (eval_expr e2 rho); inv H3.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H5.
destruct op; inv H; simpl in H5.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
intro; apply H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; omega.
Qed.
*)

Lemma typed_false_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_false tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `nullval)) |--
    local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 destruct (v rho); inv H.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Lemma typed_true_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `nullval)) |--
   local (`(ptr_neq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 unfold ptr_neq, ptr_eq; simpl; intro.
 destruct (v rho); try contradiction.
 pose proof (Int.eq_spec Int.zero i). destruct H0. rewrite H0 in H1.
 subst. inv H.
Qed.

Lemma typed_false_Oeq_nullval:
 forall  {cs: compspecs} v t t',
   local (`(typed_false tint) (`(eval_binop Oeq (tptr t) (tptr t')) v `nullval)) |--
   local (`(ptr_neq nullval) v).
Proof.
intros. subst.
 unfold_lift; intro rho.  unfold local, lift1; apply prop_derives; intro.
 intro. apply ptr_eq_e in H0. rewrite <- H0 in H.
 inv H.
Qed.

Lemma local_entail_at:
  forall n S T (H: local (locald_denote S) |-- local (locald_denote T))
    P Q R,
    nth_error Q n = Some S ->
    PROPx P (LOCALx Q (SEPx R)) |--
    PROPx P (LOCALx (replace_nth n Q T) (SEPx R)).
Proof.
 intros.
 unfold PROPx, LOCALx; simpl; intro rho;  apply andp_derives; auto.
 apply andp_derives; auto.
 unfold local, lift1.
 specialize (H rho). unfold local,lift1 in H.
 revert Q H0; induction n; destruct Q; simpl; intros; inv H0.
 unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
  unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
Qed.

Lemma local_entail_at_semax_0:
  forall Espec {cs: compspecs}Delta P Q1 Q1' Q R c Post,
   local (locald_denote Q1) |-- local (locald_denote Q1') ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1'::Q) (SEPx R))) c Post  ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1::Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre0.
eapply (local_entail_at 0).
apply H. reflexivity.
auto.
Qed.

(*
Ltac simplify_typed_comparison :=
match goal with
| |- semax _ (PROPx _ (LOCALx (`(typed_true _) ?A :: _) _)) _ _ =>
 (eapply typed_true_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lower; apply prop_right; auto ]
   | try solve [go_lower; apply prop_right; auto ]
   | ])
 ||
  (let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_true_Oeq_nullval
           | apply typed_true_One_nullval
           ]
    |  ])
| |- semax _ (PROPx _ (LOCALx (`(typed_false _) ?A :: _) _)) _ _ =>
 (eapply typed_false_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lower; apply prop_right; auto ]
   | try solve [go_lower; apply prop_right; auto ]
   | ])
 ||
  let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_false_Oeq_nullval
           | apply typed_false_One_nullval
           ]
    |  ]
| |- _ => idtac
end.
*)

Definition compare_pp op p q :=
   match p with
            | Vptr b z =>
               match q with
               | Vptr b' z' => if eq_block b b'
                              then Vint (if Int.cmpu op z z' then Int.one else Int.zero)
                              else Vundef
               | _ => Vundef
               end
             | _ => Vundef
   end.

Lemma force_sem_cmp_pp:
  forall op p q,
  isptr p -> isptr q ->
  force_val (sem_cmp_pp op p q) =
   match op with
   | Ceq => Vint (if eq_dec p q then Int.one else Int.zero)
   | Cne => Vint (if eq_dec p q then Int.zero else Int.one)
   | _ => compare_pp op p q
   end.
Proof.
intros.
destruct p; try contradiction.
destruct q; try contradiction.
unfold sem_cmp_pp.
destruct op; simpl; auto.
if_tac. if_tac. inv H2. rewrite Int.eq_true; reflexivity.
rewrite Int.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H2. rewrite Int.eq_true by auto. reflexivity.
rewrite Int.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Int.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Int.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Int.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Int.ltu i i0); reflexivity | reflexivity].
Qed.

Hint Rewrite force_sem_cmp_pp using (now auto) : norm.


(* -*- coq-prog-args: ("-emacs" "-indices-matter" "-type-in-type") -*- *)

Require Export Utf8_core.
Require Import HoTT HoTT.hit.Truncations Connectedness.
Require Import Limit.
Require Import PathGroupoid_ Forall_ Equivalences_ epi_mono reflective_subuniverse modalities OPaths.
Require Import sheaf_base_case.
Require Import sheaf_def_and_thm.

Set Universe Polymorphism.
Global Set Primitive Projections.

Local Open Scope path_scope.
Local Open Scope type_scope.

Context `{ua: Univalence}.
Context `{fs: Funext}.

Local Definition n0 := sheaf_def_and_thm.n0.
Local Definition n := sheaf_def_and_thm.n.
Local Definition mod_nj := sheaf_def_and_thm.mod_nj.
Local Definition nj := sheaf_def_and_thm.nj.
Local Definition j_is_nj := sheaf_def_and_thm.j_is_nj.
Local Definition j_is_nj_unit := sheaf_def_and_thm.j_is_nj_unit.
Local Definition islex_mod_nj := sheaf_def_and_thm.islex_mod_nj.
Local Definition islex_nj := sheaf_def_and_thm.islex_nj.
Local Definition lex_compat := sheaf_def_and_thm.lex_compat.

Local Open Scope Opath_scope.

Module Export OTid.

  Private Inductive OTid (A:TruncType (n.+1)) : Type :=
    | Ot : A -> (OTid A).

  Arguments Ot {A} a.

  Axiom Otp : forall {A:TruncType (n.+1)} (a b:A), O nj (BuildTruncType _ (a = b)) -> Ot a = Ot b.

  Axiom Otp_1 : forall {A:TruncType (n.+1)} (a:A), Otp a a °1 = 1.

  Definition OTid_ind (A:TruncType (n.+1)) (P : OTid A -> Type)
             (Ot' : forall a, P (Ot a))
             (Otp' : forall a b p, transport P (Otp a b p) (Ot' a) = Ot' b)
             (Otp_1' : forall a, transport2 P (Otp_1 a) (Ot' a) = Otp' a a °1)
    : forall w, P w
    := fun w => match w with
                |Ot a => fun _ => Ot' a
                end Otp_1'.

  Axiom OTid_ind_beta_Otp : forall (A:TruncType (n.+1)) (P : OTid A -> Type)
             (Ot' : forall a, P (Ot a))
             (Otp' : forall a b p, transport P (Otp a b p) (Ot' a) = Ot' b)
             (Otp_1' : forall a, transport2 P (Otp_1 a) (Ot' a) = Otp' a a °1)
             a b p,
      apD (OTid_ind A P Ot' Otp' Otp_1') (Otp a b p) = Otp' a b p.

  Axiom OTid_ind_beta_Otp_1 : forall (A:TruncType (n.+1)) (P : OTid A -> Type)
             (Ot' : forall a, P (Ot a))
             (Otp' : forall a b p, transport P (Otp a b p) (Ot' a) = Ot' b)
             (Otp_1' : forall a, transport2 P (Otp_1 a) (Ot' a) = Otp' a a °1)
             a,
      apD02 (OTid_ind A P Ot' Otp' Otp_1') (Otp_1 a) @ (concat_p1 _) @ (Otp_1' a) = OTid_ind_beta_Otp A P Ot' Otp' Otp_1' a a °1.

End OTid.

Definition OTid_rec (A:TruncType (n.+1)) (P:Type)
           (Ot': A -> P)
           (Otp' : forall (a b:A) (p:O nj (BuildTruncType _ (a=b))), Ot' a = Ot' b)
           (Otp_1' : forall a, Otp' a a °1 = 1)
  : OTid A -> P.
Proof.
  simple refine (OTid_ind _ _ Ot' (fun a b p => transport_const _ _ @ Otp' a b p)  _).
  intro a.
  pose (p:=whiskerR (transport2_const (A:=OTid A) (B:= P) (Otp_1 a) (Ot' a) @ concat_p1 _)^ (Otp' a a °1)). cbn in p.
  pose (p1:=(whiskerL (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)) (Otp_1' a) @ concat_p1 _)^).
  exact (p1 @ p).
Defined.

Definition OT_rec_beta_Otp (A:TruncType (n.+1)) (P:Type)
           (Ot': A -> P)
           (Otp' : forall (a b:A) (p:O nj (BuildTruncType _ (a=b))), Ot' a = Ot' b)
           (Otp_1' : forall a, Otp' a a °1 = 1)
           a b p
  : ap (OTid_rec A P Ot' Otp' Otp_1') (Otp a b p) = Otp' a b p.
Proof.
  simple refine (cancelL (transport_const (Otp a b p) (Ot' a)) _ _ _).
  pose (e1:= OTid_ind_beta_Otp A (λ _ : OTid A, P) Ot'
        (λ (a0 b0 : A) (p1 : O nj (BuildTruncType _ (a0 = b0))),
         transport_const (Otp a0 b0 p1) (Ot' a0) @ Otp' a0 b0 p1)
        (λ a0 : A,
         (whiskerL (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0))
            (Otp_1' a0) @
          concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0)))^ @
         whiskerR
           (transport2_const (Otp_1 a0) (Ot' a0) @
            concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0)))^
         (Otp' a0 a0 °1)) a b p).

  pose (e2:= apD_const (OTid_ind A (λ _ : OTid A, P) Ot'
        (λ (a0 b0 : A) (p2 : O nj (BuildTruncType _ (a0 = b0))),
         transport_const (Otp a0 b0 p2) (Ot' a0) @ Otp' a0 b0 p2)
        (λ a0 : A,
         (whiskerL (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0))
            (Otp_1' a0) @
          concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0)))^ @
         whiskerR
           (transport2_const (Otp_1 a0) (Ot' a0) @
            concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0)))^
         (Otp' a0 a0 °1))) (Otp a b p)).
  exact (e2^@ e1).
Defined.

Definition OT_rec_beta_Otp_1 (A:TruncType (n.+1)) (P:Type)
           (Ot': A -> P)
           (Otp' : forall (a b:A) (p:O nj (BuildTruncType _ (a=b))), Ot' a = Ot' b)
           (Otp_1' : forall a, Otp' a a °1 = 1)
           a
  : ap02 (OTid_rec A P Ot' Otp' Otp_1') (Otp_1 a) = OT_rec_beta_Otp A P Ot' Otp' Otp_1' a a °1 @ (Otp_1' a).
Proof.
  apply (cancel2L (transport2_const (Otp_1 a) (Ot' a))).
  apply (cancelL (apD_const (OTid_rec A P Ot' Otp' Otp_1') (Otp a a °1))).
  apply (cancelR _ _ (concat_p_pp (q:=transport_const _ _))^).
  apply (cancelR _ _ (whiskerL (transport2 _ (Otp_1 a) (Ot' a)) (apD_const (OTid_rec A P Ot' Otp' Otp_1') 1)^)).
  simple refine ((apD02_const (OTid_rec A P Ot' Otp' Otp_1') (Otp_1 a) )^ @ _).
  apply (cancelR _ _ (concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)))).
  apply (cancelR _ _ ((whiskerL (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)) (Otp_1' a) @
                                concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)))^ @
                                                                                whiskerR
                                                                                (transport2_const (Otp_1 a) (Ot' a) @
                                                                                concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)))^
                      (Otp' a a °1))).
  Opaque concat_p_pp.
  simple refine (OTid_ind_beta_Otp_1 _ _ _ _ _ _ @ _); cbn.
  apply (cancelL (apD_const
                    (OTid_ind A (λ _ : OTid A, P) Ot'
                           (λ (a0 b0 : A) (p2 : O nj (BuildTruncType _ (a0 = b0))),
                            transport_const (Otp a0 b0 p2) (Ot' a0) @ Otp' a0 b0 p2)
                           (λ a0 : A,
                                   (whiskerL (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0))
                                             (Otp_1' a0) @
                                             concat_p1
                                             (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0)))^ @
                                                                                whiskerR
                                                                                (transport2_const (Otp_1 a0) (Ot' a0) @
                                                                                concat_p1
                                                                                (transport2 (λ _ : OTid A, P) (Otp_1 a0) (Ot' a0)))^
                                   (Otp' a0 a0 °1))) (Otp a a °1))^).

  apply (@equiv_inj _ _ _ (isequiv_cancelL (transport_const (Otp a a °1) (Ot' a))
                                           (ap (OTid_rec A P Ot' Otp' Otp_1') (Otp a a °1))
                                           (Otp' a a °1))).

  path_via (OT_rec_beta_Otp A P Ot' Otp' Otp_1' a a °1).
  apply (@equiv_inj _ _ _ (isequiv_inverse _ (feq:= isequiv_cancelL (transport_const (Otp a a °1) (Ot' a))
                                                                    (ap (OTid_rec A P Ot' Otp' Otp_1') (Otp a a °1))
                                                                    (Otp' a a °1)))).
  rewrite eissect. cbn. repeat rewrite concat_pp_p.
  rewrite concat_V_pp.
  rewrite !inv_pp. repeat rewrite concat_p_pp. rewrite concat_pp_V.

  rewrite whiskerR_pp.
  rewrite whiskerR_RV.
  rewrite <- (apD (λ u, (whiskerR (concat_p1 (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)))
                                  u)) (Otp_1' a)^).
  cbn. rewrite transport_paths_FlFr. cbn. rewrite !ap_V; rewrite !inv_V.
  rewrite !concat_ap_pFq. rewrite ap_idmap. rewrite !inv_pp; rewrite !inv_V.
  rewrite !concat_p_pp. rewrite concat_pV_p. rewrite (concat_p1 ((transport2_const (Otp_1 a) (Ot' a) @@
                                                                                (OT_rec_beta_Otp A P Ot' Otp' Otp_1' a a °1 @ Otp_1' a)) @
                                                                                (concat_p_pp )^)).
  rewrite whiskerR_RV.
  apply moveL_pV.
  unfold whiskerR at 1, whiskerL at 1.
  rewrite concat_concat2. cbn.
  rewrite (concat_1p (transport2_const (Otp_1 a) (Ot' a))).
  rewrite (concat_p1 (OT_rec_beta_Otp A P Ot' Otp' Otp_1' a a °1)).
  simple refine ((concat_p1 _)^ @ _). rewrite !concat_pp_p.
  match goal with
  |[|- _ = (?P @@ ?Q) @ ?R] => path_via (((P @ 1) @@ Q) @ R)
  end.
  2: rewrite (concat_p1 (transport2_const (Otp_1 a) (Ot' a))); reflexivity.
  rewrite <- concat_concat2.
  rewrite !concat_pp_p. apply whiskerL.
  rewrite !concat_p_pp. apply moveL_pV. rewrite concat_1p.
  rewrite !concat_pp_p. simple refine ((concat_p1 _)^@ _).
  apply whiskerL. cbn.
  pose (rew:= @triangulator _ _ _ _ (transport2 (λ _ : OTid A, P) (Otp_1 a) (Ot' a)) 1).
  apply moveL_Vp in rew. rewrite rew; clear rew. cbn.
  rewrite inv_pp. cbn. rewrite concat_1p. symmetry; apply concat_pV.
Qed.

Lemma path_OT_lemma (A:(n.+1)-Type) (B:Type)
      (α β :OTid A -> B)
      (eq1: α o Ot == β o Ot)
      (eq2: forall a b p, eq1 a @ ap β (Otp a b p) = ap α (Otp a b p) @ eq1 b)
      (eq3: forall a,  (eq2 a a °1)
                      = transport (λ U, eq1 a @ ap β U = ap α U @ eq1 a) (Otp_1 a)^ (concat_p1 (eq1 a) @ (concat_1p (eq1 a))^))
  : ∀ a : A,
    transport2 (λ w : OTid A, α w = β w) (Otp_1 a) (eq1 a) =
    transport_paths_FlFr (Otp a a °1) (eq1 a) @
                         (concat_pp_p (p:=(ap α (Otp a a °1))^)
                          (q:=eq1 a)
                            (r:=ap β (Otp a a °1))
                            @ cancelL (ap α (Otp a a °1))
                            ((ap α (Otp a a °1))^ @ (eq1 a @ ap β (Otp a a °1)))
                            (eq1 a)
                            (concat_p_Vp (ap α (Otp a a °1)) (eq1 a @ ap β (Otp a a °1)) @ eq2 a a °1)).
Proof.
  intro a; cbn.
  rewrite eq3; clear eq3. clear eq2. generalize (eq1 a). intro p. clear eq1.
  unfold cancelL.
  pose (rew :=@transport_paths_FlFr _ _ (λ U:Ot a = Ot a, p @ ap β U) (λ U:Ot a = Ot a, ap α U @ p)).
  rewrite rew; clear rew.
  cbn.
  repeat rewrite concat_pp_p.
  rewrite ap_V. rewrite inv_V.
  repeat rewrite whiskerL_pp.
  symmetry.

  match goal with
  |[|- ?PP1 @ (?PP2 @ ((?PP3 @ (?PP4 @ ((?PP5 @ (?PP6 @ ?PP7)) @ ?PP8)) @ ?PP9))) = ?PP10] =>
   set (P1 := PP1);
     set (P2 := PP2);
     set (P3 := PP3);
     set (P4 := PP4);
     set (P5 := PP5);
     set (P6 := PP6);
     set (P7 := PP7);
     set (P8 := PP8);
     set (P9 := PP9);
     set (P10 := PP10)
  end.
  rewrite (@concat_pp_p _ _ _ _ _ P3 (P4 @ ((P5 @ (P6 @ P7)) @ P8)) P9).
  rewrite (@concat_pp_p _ _ _ _ _ P4 ((P5 @ (P6 @ P7)) @ P8) P9).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P5 _ _).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P6 _ _).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P7 _ _).

  unfold P1; clear P1.
  match goal with
  |[|- ?ff _ p @ _ = _]
   => rewrite <- (apD (λ U, ff U p) (Otp_1 a)^)
  end.
  cbn.
  rewrite (transport_paths_FlFr (f:= λ U, transport (λ x : OTid A, α x = β x) U p)
                                (g:= λ U, ((ap α U)^ @ p) @ ap β U)).
  rewrite ap_V. rewrite inv_V.

  unfold P10. rewrite transport2_is_ap.
  repeat rewrite concat_pp_p.
  match goal with
  |[|- _ = ?XX] => path_via (XX @ 1)
  end.
  apply whiskerL.
  rewrite ap_V.
  do 3 apply moveR_Vp.
  match goal with
  |[|- _ = ?PP11 @ (?PP12 @ ?PP13)]
   => set (P11 := PP11); set (P12 := PP12); set (P13 := PP13); cbn in *
  end.

  unfold P3; clear P3.

  rewrite <- (apD (λ U, (concat_V_pp (ap α U)
                                     ((ap α U)^ @ (p @ ap β U)))^) (Otp_1 a)^).
  cbn.
  rewrite (transport_paths_FlFr (f:=(λ U : Ot a = Ot a, (ap α U)^ @ (p @ ap β U)))
                                (g:=λ U : Ot a = Ot a, (ap α U)^ @ (ap α U @ ((ap α U)^ @ (p @ ap β U))))).
  rewrite ap_V. rewrite inv_V.
  match goal with
  |[|- _ @ (((?PP31 @ ?PP32) @ ?PP33) @ _) = _] =>
   set (P31 := PP31); set (P32 := PP32); set (P33 := PP33); cbn in *
  end.
  repeat rewrite (@concat_pp_p _ _ _ _ _ P31).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P32).
  rewrite (@concat_p_pp _ _ _ _ _ P2 P31 _).

  assert (rr: P11 @ (concat_pp_p) = (P2 @ P31)).
  { unfold P2, P31, P11.
    rewrite concat_ap_FpFq_pp_p. rewrite concat_ap_FpFq_p_pp.
    unfold whiskerR, whiskerL.
    repeat rewrite concat_p_pp. apply whiskerR.
    reflexivity. }
  destruct rr.
  rewrite (@concat_pp_p _ _ _ _ _ P11).
  apply whiskerL.
  match goal with |[|- ?PP1 @ _ = _] => set (P1 := PP1) end.
  clear P10; clear P11.

  do 2 apply moveR_Mp.
  repeat rewrite (concat_p_pp (r:=P9)). apply moveR_pM.
  unfold P9.
  rewrite <- (apD (λ U, (concat_V_pp (ap α U) p)^) (Otp_1 a)^). simpl.
  rewrite (transport_paths_Fr (g:= λ U, (ap α U)^ @ (ap α U @ p))).
  clear P2.
  repeat rewrite (concat_p_pp (r:=P8)).
  apply moveR_pM.
  set (P2 := ap (λ U : Ot a = Ot a, (ap α U)^ @ (ap α U @ p)) (Otp_1 a)^).

  unfold P8.
  rewrite <- (apD (λ U, whiskerL (z:=β (Ot a)) (q:= 1 @ p) (r := ap α (Otp a a °1) @ p) (ap α U)^) (Otp_1 a)^).
  rewrite transport_arrow.
  simpl.
  rewrite transport_const.
  rewrite transport_paths_FlFr.
  do 2 rewrite inv_pp.
  repeat rewrite ap_V. rewrite whiskerL_LV. repeat rewrite inv_V.
  match goal with
  |[|- _ = _ @ (?PP16 @ (?PP15 @ ?PP14)) ] =>
   set (P14 := PP14); set (P15 := PP15); set (P16 := PP16); simpl in P14, P15, P16
  end.
  unfold P4.
  rewrite <- (apD (λ U, (whiskerL (ap α U)^
                         (concat_p_Vp (ap α U) (p @ ap β U)))) (Otp_1 a)^).
  simpl.
  rewrite transport_paths_FlFr. simpl.
  rewrite ap_V. rewrite inv_V.
  match goal with
  |[|- _ @ (((?PP17 @ ?PP18) @ ?PP19) @ _) = _]
   => set (P17:=PP17); set (P18 := PP18); set (P19 := PP19)
  end.
  clear P4. clear P8. clear P9. clear P31.
  unfold P6, P7; clear P6; clear P7.
  rewrite <- (apD (λ U, (whiskerL (ap α U)^ (concat_p1 p) @
                                                          whiskerL (ap α U)^ (concat_1p p)^)) (Otp_1 a)^).
  simpl.
  rewrite transport_paths_FlFr.
  rewrite ap_V. rewrite inv_V.
  match goal with
  |[|- _ @ (_ @ (_ @ ((?PP6 @ ?PP7) @ ?PP8))) = _]
   => set (P6:=PP6); set (P7:=PP7); set (P8:=PP8)
  end.

  unfold P5; clear P5.
  rewrite <- (apD (λ U, whiskerL (q:=p @ ap β (Otp a a °1)) (r:=p@1) (ap α U)^) (Otp_1 a)^).
  rewrite transport_arrow.
  rewrite transport_const. rewrite transport_paths_FlFr.
  simpl.
  rewrite ap_V. rewrite inv_V.
  repeat rewrite (concat_p_pp (r:=P8)).
  repeat rewrite (concat_p_pp (r:=P14)).

  unfold P8, P14. repeat rewrite ap_V. apply whiskerR. clear P8; clear P14.
  repeat rewrite (concat_pp_p (p:=P17)).
  rewrite <- (concat_pp_p (p:=P33) (q:=P17)).
  unfold P33, P17; clear P33; clear P17.
  rewrite ap_V. rewrite concat_Vp.
  match goal with |[|- 1 @ ?XX = _] => rewrite (concat_1p XX) end.
  pose (p1 := whiskerL_1p (concat_p_Vp 1 (p @ 1))). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  unfold P18; clear P18; rewrite p1; clear p1.
  unfold P15; clear P15.
  pose (p1 := whiskerL_1p (ap (λ U : Ot a = Ot a, ap α U @ p) (Otp_1 a))). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  unfold P7; clear P7.
  pose (p1 := whiskerL_1p (concat_p1 p)). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  pose (p1 := whiskerL_1p (concat_1p p)^). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  pose (p1 := whiskerL_1p (ap (λ U : Ot a = Ot a, p @ ap β U) (Otp_1 a))). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  repeat rewrite concat_pp_p.
  unfold  P19, P6, P32, P1, P12, P13, P2, P16.
  clear P19; clear P6; clear P32; clear P1; clear P12; clear P13; clear P2; clear P16.
  (* rewrite inv_V. *)
  rewrite (concat_p1 (concat_1p p)).
  match goal with
  |[|- ?PP1 @ (?PP2 @ (?PP3 @ (?PP4 @ (?PP5 @ (?PP6 @ (?PP7 @ (?PP8 @ (?PP9 @ (?PP10 @ (?PP11 @ (?PP12 @ (?PP13 @ (?PP14 @ (?PP15 @ (?PP16)))))))))))))))
       =
       ?PP17 @ (?PP18 @ ((?PP19 @ ?PP20) @ ((?PP21 @ ?PP22) @ (?PP23 @ (?PP24 @ (?PP25 @ ?PP26))))))] =>
   set (P1 := PP1);
     set (P2 := PP2);
     set (P3 := PP3);
     set (P4 := PP4);
     set (P5 := PP5);
     set (P6 := PP6);
     set (P7 := PP7);
     set (P8 := PP8);
     set (P9 := PP9);
     set (P10 := PP10);
     set (P11 := PP11);
     set (P12 := PP12);
     set (P13 := PP13);
     set (P14 := PP14);
     set (P15 := PP15);
     set (P16 := PP16);
     set (P17 := PP17);
     set (P18 := PP18);
     set (P19 := PP19);
     set (P20 := PP20);
     set (P21 := PP21);
     set (P22 := PP22);
     set (P23 := PP23);
     set (P24 := PP24);
     set (P25 := PP25);
     set (P26 := PP26)
  end.
  repeat rewrite (concat_p_pp (r:=P16)).
  apply whiskerR. clear P16.
  assert (rr : 1 = P14 @ P13).
  symmetry. unfold P13, P14. apply concat_pV.
  destruct rr. rewrite (concat_p1 P13).
  clear P15. clear P20. simpl in *.
  assert (rr: P1 @ (P2 @ P3) = P17).
  { unfold P1, P2, P3, P17.
    clear P1; clear P2; clear P17;
    clear P3; clear P4; clear P5; clear P6; clear P7; clear P8; clear P9
    ; clear P10; clear P11; clear P12; clear P13; clear P14; clear P18; clear P19
    ; clear P21; clear P22; clear P23; clear P24; clear P25; clear P26.
    destruct p. reflexivity. }
  destruct rr.
  repeat rewrite concat_pp_p.
  do 3 apply whiskerL.
  clear P1; clear P2; clear P26.

  assert (rr: P18 @ (P19 @ P14) = P11 @ P12).
  { unfold P18, P19, P14, P11, P12. cbn.
    clear P3; clear P4; clear P5; clear P6; clear P7; clear P8; clear P9
    ; clear P10; clear P11; clear P12; clear P13; clear P14; clear P18; clear P19
    ; clear P21; clear P22; clear P23; clear P24; clear P25.
    destruct p; reflexivity. }
  rewrite (concat_p_pp  (q:= (P19 @ P14))).
  rewrite rr; clear rr.
  rewrite (concat_p_pp (p:=P9)).
  unfold P9, P10. rewrite concat_Vp. rewrite (concat_1p (P11 @ (P12 @ P13))).
  clear P9; clear P10.
  rewrite (concat_p_pp (p:=P3)).
  unfold P3 at 1, P11 at 1. rewrite concat_Vp.
  rewrite (concat_1p (P12 @ P13)).
  clear P3.
  assert (rr: P4 @ (P5 @ (P6 @ P7)) = P11).
  { repeat rewrite (concat_p_pp (r:=P7)).
    apply moveR_pM.

    unfold P4, P5, P6, P7, P11.
    clear P4; clear P5; clear P6; clear P7; clear P8
    ; clear P11; clear P12; clear P13; clear P14; clear P18; clear P19
    ; clear P21; clear P22; clear P23; clear P24; clear P25.
    rewrite <- (ap_V (λ U : Ot a = Ot a, p @ ap β U) (Otp_1 a)).
    rewrite ap_V. apply moveR_Vp.

    rewrite <- (apD (λ U, concat_1p (p @ ap β U)) (Otp_1 a)^).
    simpl.
    rewrite transport_paths_FlFr. simpl.
    rewrite ap_V. rewrite inv_V.
    repeat rewrite concat_p_pp.
    match goal with
    |[|- ?P1 @ (?P2 @ ?P3) = _]
     => rewrite (concat_p_pp (p:=P1))
    end. apply whiskerR.
    match goal with
    |[|- ?P1 @ (?P2 @ ?P3) = _]
     => rewrite (concat_p_pp (p:=P1))
    end. apply whiskerR.
    rewrite concat_ap_Fpq.
    unfold whiskerR.
    rewrite concat_ap_pFq. unfold whiskerL.
    rewrite concat_concat2. rewrite (concat_p1 (ap (λ u : Ot a = Ot a, (ap α u)^) (Otp_1 a))).
    rewrite (concat_1p (ap (λ u : Ot a = Ot a, p @ ap β u) (Otp_1 a))).
    rewrite concat_ap_FpFq_p_pp.
    unfold whiskerR, whiskerL.
    rewrite concat_pp_p. apply moveL_Mp.
    rewrite concat2_inv.
    rewrite concat_concat2.
    rewrite concat_Vp.
    rewrite (concat_1p (ap (λ u : Ot a = Ot a, p @ ap β u) (Otp_1 a))).
    rewrite concat_ap_pFq. unfold whiskerL.
    rewrite (concat2_p_pp). reflexivity. }
  rewrite (concat_pp_p (p:=P11)).
  destruct rr.
  rewrite (concat_pp_p (p:=P4)); apply whiskerL.
  rewrite (concat_pp_p (p:=P5)); apply whiskerL.
  rewrite (concat_pp_p (p:=P6)); apply whiskerL.
  do 2 apply whiskerL.
  clear P4; clear P5; clear P6; clear P7; clear P8; clear P12.
  clear P14; clear P18; clear P19.
  unfold P13, P21, P22, P23, P24, P25.
  clear P13; clear P21; clear P22; clear P23; clear P24; clear P25.
  rewrite <- (apD (λ U, concat_1p (ap α U @ p)) (Otp_1 a)^).
  rewrite transport_paths_FlFr. simpl.
  repeat rewrite ap_V. rewrite inv_V.
  repeat rewrite concat_pp_p. rewrite concat_Vp.
  rewrite (concat_p1).
  apply moveL_Vp.
  repeat rewrite (concat_p_pp (r:=(concat_1p (1 @ p)))). apply moveL_pM.
  match goal with
  |[|- ?XX = _] => assert (rr: 1 = XX)
  end.
  { destruct p. reflexivity. }
  destruct rr.
  apply moveL_Vp. rewrite concat_p1.
  rewrite concat_ap_Fpq.
  rewrite concat_ap_pFq. unfold whiskerR, whiskerL.
  rewrite concat_concat2.
  rewrite concat_p1, (concat_1p (ap (λ u : Ot a = Ot a, ap α u @ p) (Otp_1 a))).
  rewrite concat_ap_FFpq_p_pp. rewrite concat_ap_Fpq.
  unfold whiskerR. simpl.
  rewrite <- concat2_p_pp. reflexivity.
Qed.

Lemma path_OT (A:(n.+1)-Type) (B:Type)
      (α β :OTid A -> B)
      (eq1: α o Ot == β o Ot)
      (eq2: forall a b p, eq1 a @ ap β (Otp a b p) = ap α (Otp a b p) @ eq1 b)
      (eq3: forall a,  (eq2 a a °1)
                      = transport (λ U, eq1 a @ ap β U = ap α U @ eq1 a) (Otp_1 a)^ (concat_p1 (eq1 a) @ (concat_1p (eq1 a))^))
  : α == β.
Proof.
  simple refine (OTid_ind _ _ _ _ _).
  - exact eq1.
  - intros a b p.
    simple refine (transport_paths_FlFr _ _ @ _).
    etransitivity; try apply concat_pp_p.
    apply (cancelL (ap α (Otp a b p))).
    etransitivity; try apply eq2.
    apply concat_p_Vp.
  - rapply path_OT_lemma. exact eq3.
Defined.

Lemma path_OT_compute (A:(n.+1)-Type) (B:Type)
      (α β :OTid A -> B)
      (eq1: α o Ot == β o Ot)
      (eq2: forall a b p, eq1 a @ ap β (Otp a b p) = ap α (Otp a b p) @ eq1 b)
      (eq3: forall a,  (eq2 a a °1)
                       = transport (λ U, eq1 a @ ap β U = ap α U @ eq1 a) (Otp_1 a)^ (concat_p1 (eq1 a) @ (concat_1p (eq1 a))^)) x
  : path_OT A B α β eq1 eq2 eq3 (Ot x) = eq1 x.
Proof.
  reflexivity.
Defined.

Lemma equiv_ap_OTid_fun {X Y:TruncType (n.+1)} (e: X -> Y)
  : OTid X -> OTid Y.
Proof.
  simple refine (OTid_rec _ _ _ _ _).
  intro x; apply Ot; exact (e x).
  intros a b p; cbn. apply Otp.
  exact (Oap e p).
  intro a; cbn. etransitivity; [apply (ap (Otp (e a) (e a)) (Oap_1 e))| apply Otp_1].
Defined.

Lemma isequiv_ap_OTid_path {X Y:TruncType (n.+1)} (e: X = Y :> Type)
  : IsEquiv (equiv_ap_OTid_fun (equiv_path _ _ e)).
Proof.
  destruct X as [X tX], Y as [Y tY]; cbn in *.
  destruct e; cbn in *.
  assert (r: tX = tY) by apply path_ishprop. destruct r.
  simple refine (isequiv_homotopic idmap _).

  simple refine (path_OT _ _ _ _ _ _ _).
  - intro x; reflexivity.
  - intros a b p; cbn.
    simple refine (concat_1p _ @ _ @ (concat_p1 _)^).
    unfold equiv_ap_OTid_fun. cbn.
    simple refine (OT_rec_beta_Otp _ _ _ _ _ _ _ _ @ _ @ (ap_idmap _)^).
    cbn.
    apply ap.
    apply Oap_idmap.
  - intro a; cbn. rewrite transport_paths_FlFr.
    rewrite concat_ap_Fpq; rewrite concat_ap_pFq.
    apply moveR_pV. do 3 rewrite concat_pp_p.
    pose (rew:= whiskerR_p1 (ap (ap idmap) (Otp_1 a)^)).
    rewrite concat_pp_p in rew; apply moveL_Vp in rew; rewrite rew; clear rew.
    cbn. apply moveL_Vp. do 4 rewrite concat_p_pp.
    pose (rew:= whiskerL_1p (ap (ap (equiv_ap_OTid_fun idmap)) (Otp_1 a)^)).
    rewrite concat_pp_p in rew; apply moveL_Vp in rew; rewrite rew; clear rew.
    cbn. rewrite !concat_1p. rewrite !ap_V.
    rewrite <- (ap02_is_ap _ _ (equiv_ap_OTid_fun idmap) _ _ _ _ (Otp_1 a)).
    unfold equiv_ap_OTid_fun. cbn.
    rewrite OT_rec_beta_Otp_1. rewrite inv_pp. rewrite concat_pV_p.
    rewrite <- (apD (λ U, ap_idmap U) (Otp_1 a)^).
    rewrite transport_paths_FlFr. cbn. rewrite !ap_V.
    rewrite (ap_idmap (Otp_1 a)). rewrite concat_p1. rewrite !inv_pp.
    rewrite !inv_V. rewrite concat_p_pp. simple refine (_ @ concat_1p _). apply whiskerR.
    apply moveR_pM. rewrite concat_1p. simple refine (_ @ concat_p1 _).
    rewrite !concat_pp_p. apply whiskerL.
    rewrite <- ap_V. rewrite <- ap_pp.
    path_via ((ap (Otp a a) (idpath °1))).
    apply ap. apply moveR_Vp. simple refine (_ @ (concat_p1 _)^).
    apply (Oap_idmap_Oap_1 a).
Qed.

Lemma isequiv_ap_OTid `{ua: Univalence} {X Y:TruncType (n.+1)} (e: X <~> Y)
  : IsEquiv (equiv_ap_OTid_fun e).
Proof.
  simple refine (isequiv_homotopic (equiv_ap_OTid_fun (equiv_path _ _ (path_universe_uncurried e))) _).
  exact ua.
  apply (isequiv_ap_OTid_path (path_universe_uncurried e)).
  rewrite equiv_path_path_universe_uncurried. intro; reflexivity.
Qed.

Lemma equiv_ap_OTid {X Y:TruncType (n.+1)} (e: X <~> Y)
  : OTid X <~> OTid Y.
Proof.
  exists (equiv_ap_OTid_fun e).
  apply isequiv_ap_OTid.
Defined.

Section OT_telescope.

  Context `{ua: Univalence}.
  Context `{fs: Funext}.

  Definition OTtelescope_aux (X:TruncType (n.+1)) (m: nat)
  : TruncType (n.+1).
    induction m as [|m U].
    - exact X.
    - exact (BuildTruncType _ (Trunc (n.+1) (OTid U))).
  Defined.

  Definition OTtelescope (X:TruncType (n.+1))
  : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros m. exact (OTtelescope_aux X m).
    - intros n m q; destruct q; simpl.
      intro x. apply tr. apply Ot. exact x.
  Defined.

End OT_telescope.