Set Warnings "-notation-overridden,-parsing".
From mathcomp Require Import ssreflect ssrbool eqtype div ssralg.
From Tweetnacl.High Require Import mc.
From Tweetnacl.High Require Import mcgroup.
From Tweetnacl.High Require Import montgomery.
From Tweetnacl.High Require Import curve25519_Fp.
From Tweetnacl.High Require Import opt_ladder.
From Tweetnacl.High Require Import Zmodp2.
From Tweetnacl.High Require Import Zmodp2_rules.
From Tweetnacl.High Require Import curve25519_Fp2.
From Tweetnacl.High Require Import curve25519_Fp_twist25519_Fp_eq.
From Tweetnacl.High Require Import Zmodp.
From Tweetnacl.High Require Import GRing_tools.
Require Import Ring.
Require Import ZArith.

Import BinInt.

Open Scope ring_scope.
Import GRing.Theory.

Local Notation "p '#x0'" := (point_x0 p) (at level 30).

(* Conversion between curve25519 over F_p and F_p2 *)
Definition curve_Fp_to_Fp2 (p: point Zmodp.type) : (point Zmodp2.type) :=
match p with
  | EC_Inf => EC_Inf Zmodp2.type
  | EC_In x y => EC_In (Zmodp2.Zmodp2 x 0) (Zmodp2.Zmodp2 y 0)
end.

Lemma oncurve25519_Fp_impl : forall (x y: Zmodp.type),
oncurve curve25519_Fp_mcuType (EC_In x y) ->
(oncurve curve25519_Fp2_mcuType (EC_In (Zmodp2.pi (x, Zmodp.pi 0)) (Zmodp2.pi (y, Zmodp.pi 0)))).
Proof.
move => x y /=.
rewrite /a /b.
ring_simplify_this.
rewrite ?Zmodp2_mulE /= ?Zmodp2_addE /=.
rewrite /curve25519_Fp.a /curve25519_Fp.b.
ring_simplify_this.
move/eqP => -> /=.
apply eq_refl.
Qed.

Local Lemma on_curve_Fp_to_Fp2 : forall (p: point Zmodp.type),
  oncurve curve25519_Fp_mcuType p -> oncurve curve25519_Fp2_mcuType (curve_Fp_to_Fp2 p).
Proof.
  move=> [|x y] => //.
  apply oncurve25519_Fp_impl.
Qed.

Definition curve25519_Fp_to_Fp2 (p: mc curve25519_Fp_mcuType) : (mc curve25519_Fp2_mcuType) :=
match p with
  | MC u P => MC (on_curve_Fp_to_Fp2 u P)
end.

Local Lemma curve_add_Fp_to_Fp2 : forall (p q: point Zmodp_ringType) (p' q': point Zmodp2_ringType),
  p' = curve_Fp_to_Fp2 p ->
  q' = curve_Fp_to_Fp2 q ->
  MCGroup.add curve25519_Fp2_mcuType p' q' = curve_Fp_to_Fp2 (MCGroup.add curve25519_Fp_mcuType p q).
Proof.
  move => [|xp yp] [|xq yq] [|xp' yp'] [|xq' yq'] //= [] -> -> [] -> ->.
  rewrite /curve25519_Fp.a /curve25519_Fp.b.
  match goal with
    | [ |- _ = ?A ] => remember A as Freezer
  end.
  rewrite /eq_op /Equality.op /=.
  rewrite /eq_op /Equality.op /=.
  rewrite !eq_refl ?Bool.andb_true_r.
  rewrite ?expr2.
  have ->: 2%:R = Zmodp2.Zmodp2 (2%:R) 0 => //.
  have ->: 3%:R = Zmodp2.Zmodp2 (3%:R) 0 => //.
  Zmodpify => /=.
  ringify.
  subst Freezer.
  ring_simplify_this.
  case_eq (xp == xq) => -> //=.
  case_eq ((yp == yq) && (yp != 0)) => -> //=.
Qed.

Local Lemma curve25519_add_Fp_to_Fp2' : forall (p q: mc curve25519_Fp_mcuType) (p' q': mc curve25519_Fp2_mcuType),
  p' = curve25519_Fp_to_Fp2 p ->
  q' = curve25519_Fp_to_Fp2 q ->
  MCGroup.add curve25519_Fp2_mcuType p' q' = curve_Fp_to_Fp2 (MCGroup.add curve25519_Fp_mcuType p q).
Proof.
  move => [p Hp] [q Hq] [p' Hp'] [q' Hq'] Hpp' Hqq'.
  apply curve_add_Fp_to_Fp2.
  by simpl in Hpp'; inversion Hpp'.
  by simpl in Hqq'; inversion Hqq'.
Qed.

Local Lemma curve25519_add_Fp_to_Fp2: forall (p q: mc curve25519_Fp_mcuType),
  curve25519_Fp_to_Fp2 p + curve25519_Fp_to_Fp2 q = curve25519_Fp_to_Fp2 (p + q).
Proof.
  move => p q.
  have [p' Hp']: exists (p': mc curve25519_Fp2_mcuType), p' = curve25519_Fp_to_Fp2 p by exists (curve25519_Fp_to_Fp2 p).
  have [q' Hq']: exists (q': mc curve25519_Fp2_mcuType), q' = curve25519_Fp_to_Fp2 q by exists (curve25519_Fp_to_Fp2 q).
  ring_unfold.
  apply mc_eq.
  rewrite -(curve25519_add_Fp_to_Fp2' _ _ _ _ Hp' Hq') Hp' Hq'.
  reflexivity.
Qed.

Lemma nP_is_nP2 : forall (n:nat) (p: mc curve25519_Fp_mcuType),
  curve25519_Fp_to_Fp2 (p *+ n) = (curve25519_Fp_to_Fp2 p) *+n.
Proof.
  elim => [|n IHn] p.
  ring_simplify_this.
  exact: mc_eq.
  by rewrite ?GRing.mulrS -IHn curve25519_add_Fp_to_Fp2.
Qed.

(* this is a truncation, meaning we do not have the garantee that y = 0 *)
Definition cFp2_to_Fp p := match p with
  | Zmodp2.Zmodp2 x y => x
  end.

Lemma cFp2_to_Fp_cancel : forall p: mc curve25519_Fp_mcuType,
  p#x0 = cFp2_to_Fp ((curve25519_Fp_to_Fp2 p)#x0).
Proof. by case ; case. Qed.

Local Notation "p '/p'" := (cFp2_to_Fp p) (at level 40).

From mathcomp Require Import ssrnat.

Theorem curve25519_ladder_Fp_Fp2 (n : nat) x :
    (n < 2^255)%nat ->
    forall (p  : mc curve25519_Fp_mcuType),
    (curve25519_Fp_to_Fp2 p)#x0 = Zmodp2.Zmodp2 x 0 ->
    curve25519_Fp_ladder n x = ((curve25519_Fp_to_Fp2 p) *+ n)#x0 /p.
Proof.
  move => Hn p Hp.
  have Hp' := cFp2_to_Fp_cancel p.
  have Hp'' : p #x0 = x.
  move: Hp'; rewrite Hp => //=.
  rewrite (curve25519_Fp_ladder_ok n x Hn p Hp'').
  rewrite -nP_is_nP2.
  rewrite cFp2_to_Fp_cancel //.
Qed.

Close Scope ring_scope.


From Coq Require Extraction.

Inductive vec (A : Type) : nat -> Type :=
  | vnil : vec A 0
  | vcons : forall len, A -> vec A len -> vec A (1 + len).

Arguments vnil {A}%type_scope.
Arguments vcons {A}%type_scope _ _ _.

Fixpoint yo (n : nat) : vec bool n := match n with
  | O => vnil
  | S x => vcons _ false (yo x) end.

Recursive Extraction yo.

Definition tail {A} n (v: vec A (S n)) :=
  match v in vec _ (S m) return vec _ m with
  | vnil => 0
  | vcons n' a y => y
  end.

Recursive Extraction tail.

Definition o (n:nat) (y:unit) : n = n := eq_refl.
Arguments o {_} _.
Definition o2 : unit -> 1 = 1 := o.
Arguments o [_] _.
Fail Definition o3 : unit -> 1 = 1 := o.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Functor.Diagonal.
Require Import Category.Structure.Terminal.
Require Import Category.Instance.Cat.
Require Import Category.Instance.One.

Generalizable All Variables.

Corollary Diagonal_Unique (J C : Category) {D : Category} (d : D) :
  Δ[J](d) ≈[Cat] Δ(d) ∘[Cat] one.
Proof. exists (fun _ => iso_id); simpl; intros; cat. Qed.


Require Import HTS.Overture Category Strict_eq Path_eq Equivalences Cylinder.
Set Universe Polymorphism.

Definition FTYPE : Category.
Proof.
  rapply Build_Category.
  - exact FType.
  - exact (λ A B, A -> B).
  - exact (λ A, idmap).
  - exact (λ A B C g f, g o f).
  - reflexivity.
  - reflexivity.
  - reflexivity.
Defined.

Set Implicit Arguments.
(* g is a retract of f *)
(* f in the middle, g on the side *)
Record Retract {A B} (g : A -> B) {A' B'} (f : A' -> B') :=
  { ret_s : A -> A' ;
    ret_r : A' -> A ;
    ret_s' : B -> B' ;
    ret_r' : B' -> B ;
    ret_sr : ret_r o ret_s ≡≡ idmap ;
    ret_sr' : ret_r' o ret_s' ≡≡ idmap;
    ret_H1 : f o ret_s ≡≡ ret_s' o g ;
    ret_H2 : ret_r' o f ≡≡ g o ret_r }.
Unset Implicit Arguments.

Global Arguments Build_Retract {A B g A' B' f} s r s' r' sr sr' H1 H2 : rename.

Infix "RetractOf" := Retract (at level 30).

Lemma LP_Retract {A A' B' B C C' D D': Type}
      {f: A -> A'} {g: B' -> B} {f': C -> C'} {g': D' -> D}
      (Hf : f' RetractOf f) (Hg : g' RetractOf g)
  : LP (C:=TYPE) f g -> LP (C:=TYPE) f' g'.
Proof.
  intros H F G H1; cbn in *.
  assert (X: g o (ret_s Hg o F o ret_r Hf) ≡≡ ret_s' Hg o G o ret_r' Hf o f). {
    intro. ref (ret_H1 Hg _ E@ _). apply Eap.
    ref (Eap10 H1 _ E@ _). apply Eap.
    exact (ret_H2 Hf _)^E. }
  specialize (H ((ret_s Hg) o F o (ret_r Hf)) ((ret_s' Hg) o G o (ret_r' Hf)) (eq_funext X)).
  destruct H as [h [H2 H3]]; cbn in *.
  exists ((ret_r Hg) o h o (ret_s' Hf)). split; apply eq_funext; intro x; simpl.
  - transitivity (ret_r Hg (h (f (ret_s Hf x)))).
    repeat apply Eap. exact (ret_H1 Hf _)^E.
    transitivity (ret_r Hg (ret_s Hg (F (ret_r Hf (ret_s Hf x))))).
    apply Eap. apply (Eap10 H2).
    transitivity (F (ret_r Hf (ret_s Hf x))).
    apply (ret_sr Hg). apply Eap. apply (ret_sr Hf).
  - ref ((ret_H2 Hg _)^E E@ _).
    ref (Eap _ (Eap10 H3 _) E@ _).
    ref (ret_sr' Hg _ E@ _).
    apply Eap. exact (ret_sr' Hf _).
Defined.

Definition retract_id {A B} (f: A -> B) : f RetractOf f.
Proof.
  use Build_Retract; intro; cbn; try reflexivity.
Defined.

Definition LP_TYPE_FTYPE {A B A' B': FType} {f: A -> B} {g: A' -> B'}
  : LP (C:=TYPE) f g -> LP (C:=FTYPE) f g.
  auto.
Defined.

Record IsFibration {A B} (f : A -> B) := (* F *)
  { fib_A : Type ;
    fib_P : fib_A -> Type ;
    fib_Fib : PFibrant fib_P;
    fib_H : f RetractOf (π1 fib_P) }.

Global Arguments Build_IsFibration {A B f B'} P {FibP} H : rename.

Notation Fib := @IsFibration.

Definition fiber {A B} {FibB: Fibrant B} (f: A -> B)
  := λ y, ∃ x, f x = y.

Let f' {A B} {FibB: Fibrant B} (f: A → B) : A -> ∃ y, fiber f y
  := λ x, (f x ; x ; 1).

Notation "` A" := (Build_FType A) (at level 10).

Definition LP_f'_F {A B: FType} (f: A → B)
  : LLP (C:=FTYPE) Fib (f' f : `_ -> `_).
Proof.
  intros A'' B'' g [B' P HP Hg]. apply LP_TYPE_FTYPE.
  ref (LP_Retract (retract_id _) Hg _).
  intros F G H; cbn in *.
  transparent assert (α: ((∃ y, fiber f y) -> ∃ y, P (G y))). {
    refine (λ y, (y; _)).
    destruct y as [y [x p]].
    pose proof (Etransport P (Eap10 H x) (F x).2); cbn in X.
    destruct_path p. exact X. }
  transparent assert (β: ((∃ y, P (G y)) -> sigT P)). {
    exact (λ w, (G w.1; w.2)). }
  exists (β o α). split; [|reflexivity].
  apply eq_funext; intro x.
  use eq_sigma; cbn. exact (Eap10 H _)^E.
  now rewrite Etransport_Vp.
Defined.

Definition wfs_AC_F : weak_factorization_system (@LLP FTYPE (@IsFibration)) (@IsFibration).
Proof.
  use Build_weak_factorization_system; cbn.
  - intros A B f. exists (` (∃ y, fiber f y)).
    exists (f' f). exists (π1 _).
    split; [reflexivity|]. split.
    (* + apply LP_f'_F.  bug?? *)
    + apply (LP_f'_F _).
    + refine (Build_IsFibration _ (retract_id _)).
  - intros A B f; split; auto.
  - intros A B f; split; intros Hf.
    + intros A' B' g Hg. now apply Hg.
    + assert (LP (C:=FTYPE) (f' f: `_ -> `_) f). {
        apply Hf. apply LP_f'_F. }
      specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      refine (Build_IsFibration (fiber f) _).
      refine (Build_Retract (f' f) g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Record AFib A B (f : A -> B) := (* F *)
  { afib_A : FType ;
    afib_P : afib_A -> Type ;
    afib_Fib : PFibrant afib_P ;
    afib_H1 : ∀ y, Contr (afib_P y) ;
    afib_H2 : f RetractOf (π1 afib_P) }.

Global Arguments Build_AFib {A B f B'} P {FibP} HP H : rename.

Definition AFib_Fib {A B} (f: A -> B)
  : AFib _ _ f -> Fib _ _ f.
Proof.
  intros [B' P FibP HP H].
  exact (Build_IsFibration _ H).
Defined.

Definition LP_top'_AF {A B: FType} (f: A → B)
  : LLP (C:=FTYPE) AFib (top' (f:=f): `_ -> `_).
Proof.
  intros A'' B'' g [B' P FibP HP Hg].
  refine (LP_Retract (g:=_:`_ -> `_) (retract_id _) Hg _).
  clear g Hg. intros F G H; cbn in *.
  use exist.
  - intro w. exists (G w). revert w.
    use sig_cyl_ind; cbn.
    + intro x. exact ((Eap10 H x) E# (F x).2).
    + intro y. use center. apply HP.
    + intro; cbn. use path_contr.
      apply HP.
  - split; cbn. 2: reflexivity.
    apply eq_funext; intro x. use eq_sigma. exact (Eap10 H x)^E.
    rew Etransport_Vp. reflexivity.
Defined.

Definition wfs_C_AF : weak_factorization_system (@LLP FTYPE AFib) AFib.
Proof.
  use Build_weak_factorization_system; cbn.
  - intros A B f. exists (` (sigT (Cyl f))).
    exists top'. exists (π1 _).
    split; [reflexivity|]. split.
    + exact (LP_top'_AF _).
    + ref (Build_AFib _ _ (retract_id _)); cbn.
      apply Cyl_Contr.
  - intros; split; auto.
  - intros A B f; split; intros Hf.
    + intros A' B' g Hg. now apply Hg.
    + assert (LP (C:=FTYPE) (top' (f:=f): `_ -> `_) f). {
        apply Hf. apply LP_top'_AF. }
      specialize (X idmap (π1 _) E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      ref (Build_AFib (Cyl f) _ _); cbn.
      apply Cyl_Contr.
      refine (Build_Retract top' g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Definition weak_eq_retract {A B A' B': FType}
           (f: A -> B) (f': A' -> B')
           (Hf': f' RetractOf f) (Hf: IsEquiv f)
  : IsEquiv f'.
Proof.
  destruct Hf as [g Hg1 Hg2].
  destruct Hf' as [s r s' r' sr sr' Hf1 Hf2].
  refine (isequiv_adjointify (r o g o s') _ _); intro.
  - rewi Hf2. ref (ap _ (Hg1 _) @ _). apply Eq_to_paths, sr'.
  - rewi Hf1. ref (ap _ (Hg2 _) @ _). apply Eq_to_paths, sr.
Defined.

Definition two_out_of_three_weak_equiv
  : @two_out_of_three FTYPE (fun _ _ f => IsEquiv f).
Proof.
  intros A B C f g; cbn in *. repeat split; intros H1 H2.
  - now apply isequiv_compose.
  - ref (cancelL_isequiv g); assumption.
  - ref (cancelR_isequiv f); assumption.
Defined.

Definition AFib_aux {B: FType} {P: B -> Type} {FibP: PFibrant P} (H: IsEquiv (π1 P))
  : ∀ y, Contr (P y).
Proof.
  destruct H as [g Hg1 Hg2 Hg3]. intro y.
  use Build_Contr.
  - refine ((Hg1 y) # (g y).2).
  - intro w.
    specialize (Hg3 (y; w)); cbn in Hg3. rew Hg3; clear Hg3.
    rew (transport_compose P (π1 _) (Hg2 (y; w)) _)^.
    exact (apD _ (Hg2 (y; w))).
Defined.

Definition AFib_ok {A B: FType} (f: A -> B)
  : AFib _ _ f  <->  (IsEquiv f × Fib _ _ f).
Proof.
  split; intro H.
  - split.
    + destruct H as [B' P FibP HP Hf].
      ref (weak_eq_retract (_ : ` _ -> ` _) _ Hf _). clear f Hf; cbn.
      use isequiv_adjointify.
      * intro x; exists x; apply HP.
      * intro; exact 1.
      * intros [x w]; cbn.
        rew (contr _ _ w). exact 1.
    + destruct H as [B' P FibP H1 H2]. econstructor. eassumption. exact H2.
  - ref (Build_AFib (fiber f) _ _).
    + pose proof (two_out_of_three_weak_equiv _ _ _ (f' f: `_ -> `_) (pr1: `_ -> `_)); cbn in X.
      destruct X as [_ [_ H2]]. specialize (H2 (fst H)).
      refine (AFib_aux (P:=fiber f) (H2 _)).
      clear H2 H.
      use isequiv_adjointify.
      * exact (λ w, w.2.1).
      * intros [y [x p]]; cbn. unfold f'.
        destruct_path p. exact 1.
      * intro; exact 1.
    + assert (LP (C:=FTYPE) (f' f: `_ -> `_) f). {
        apply LP_f'_F. apply H. }
      specialize (X idmap pr1 E1); cbn in X. destruct X as [g [Hg1 Hg2]].
      refine (Build_Retract (f' f) g idmap idmap _ _ _ _);
        intro; try reflexivity; cbn.
      exact (Eap10 Hg1 _). exact (Eap10 Hg2^E _).
Defined.

Definition LLPAFib_ok {A B: FType} (f: A -> B)
  : LLP (C:=FTYPE) Fib f  <->  (IsEquiv f × LLP (C:=FTYPE) AFib f).
Proof.
  split.
  - intro H; split.
    + ref (let X := H _ B (pr1: `_ -> `_) _ (f' f) idmap E1 in _).
      ref (Build_IsFibration _ (retract_id _)).
      destruct X as [g [Hg1 Hg2]]; cbn in *.
      use isequiv_adjointify.
      * exact (λ w, (g w).2.1).
      * intro x; pose (g x).2.2. cbn in *.
        rew p. apply Eq_to_paths. exact (Eap10 Hg2 _).
      * intro x; cbn. rew (Eap10 Hg1 x). exact 1.
    + intros A' B' F Hf. apply H. now apply AFib_Fib.
  - intros [H2 H1] A' B' g Hg.
    ref (LP_Retract (f:=f' f: `_ -> `_) _ (retract_id _) _).
    +  clear A' B' g Hg.
       assert (X : AFib (sigT (fiber f)) B pr1). {
         destruct H2 as [g Hg1 Hg2 Hg3].
         ref (Build_AFib _ _ (retract_id _)).
         intro y; cbn. exists (g y; Hg1 _).
         intros [x p].
         ref (path_sigma _ ((ap g p)^ @ Hg2 _) _).
         rew transport_paths_Fl. rew ap_pp. rew (Hg3 _)^.
         rew ap_V. rew inv_pp. rew inv_V.
         rew (ap_compose g f _)^.
         rew concat_pp_p. ref (moveR_Vp _ _ _ _).
         destruct_path p. cbn. exact (concat_1p _ @ (concat_p1 _)^). }
       specialize (H1 (` (sigT (fiber f))) B pr1 X (f' f) idmap E1); clear X.
       destruct H1 as [Ɣ [H H']]; cbn in *.
       use (Build_Retract idmap idmap Ɣ pr1); intro; try reflexivity.
       exact (Eap10 H' _). exact (Eap10 H^E _).
    + now ref (LP_f'_F _ _ _ _ _).
Defined.

Definition fibrant_types_give_fibrations {A: Type} {FibA: Fibrant A}
  : IsFibration (λ _:A, tt).
Proof.
  ref (Build_IsFibration (λ _:`unit, A) _).
  ref (Build_Retract (λ x, (tt; x)) (π2 (λ _:unit, A)) idmap idmap _ _ _ _);
    intro; try reflexivity; cbn.
  destruct x as [[] y]; reflexivity.
Defined.

Definition type_model_structure : model_structure FTYPE.
Proof.
  rapply Build_model_structure.
  - exact (fun _ _ f => IsEquiv f).
  - exact Fib.
  - exact (@LLP FTYPE AFib).
  - apply two_out_of_three_weak_equiv.
  - eapply wfs_iff_R. apply @AFib_ok.
    exact wfs_C_AF.
  - eapply wfs_iff_L. apply @LLPAFib_ok. exact wfs_AC_F.
Defined.

(* Print Assumptions type_model_structure. *)

(* F are retracts of their π1 : Σ fiber -> B *)
Definition F_caract {A B: FType} {f: A -> B}
  : IsFibration f <-> ∃ (g: sigT (fiber f) -> A), f o g ≡≡ pr1 × g o (f' f) ≡≡ idmap.
Proof.
  split.
  - intros [B' P FibP [s r s' r' rs rs' H1 H2]].
    use exist.
    + intros [y [x p]]. apply r. exists (s' y).
      destruct_path p.
      ref ((H1 x) E# _). exact (s x).2.
    + split; cbn.
      * intros [y [x p]]; cbn.
        ref ((H2 _)^E E@ _); cbn. apply rs'.
      * intro x. ref (_ E@ rs x).
        apply Eap. use eq_sigma. exact (H1 _)^E.
        apply Etransport_Vp.
  - intros [g [H1 H2]].
    ref (Build_IsFibration (fiber f) _).
    ref (Build_Retract (f' f) g idmap idmap _ _ _ _);
      intro; cbn; try reflexivity.
    apply H2. sym H1.
Defined.

(* AC are retracts of their f' *)
Definition AC_caract {A B: FType} (f: A -> B)
  : LLP (C:=FTYPE) Fib f <-> ∃ (g: B -> sigT (fiber f)), g o f ≡≡ f' f × pr1 o g ≡≡ idmap.
Proof.
  split; intro H.
  - specialize (H (` (sigT (fiber f))) _ pr1 (Build_IsFibration _ (retract_id _))).
    specialize (H (f' f) idmap E1).
    destruct H as [g [H1 H2]]. exists g. split; apply Eap10; assumption.
  - intros X Y g Hg. ref (LP_Retract (f:=f' f: `_ -> `_) _ (retract_id _) _).
    use (Build_Retract idmap idmap H.1 pr1); try (intro; reflexivity).
    apply H.2. cbn. symmetry. apply H.2.
    now apply (LP_f'_F _).
Defined.

Record Cofib {A B} (f : A -> B) := (* C *)
  { cofib_A : FType ;
    cofib_B : FType ;
    cofib_k : cofib_A -> cofib_B ;
    cofib_H : f RetractOf (top' (f:=cofib_k)) }.
Arguments Build_Cofib {A B f A' B'} k H : rename.

(* C are injections into cylinders *)
Definition C_caract {A B: FType} (f: A -> B)
  : LLP (C:=FTYPE) AFib f <-> Cofib f.
Proof.
  split.
  - intro Hf. use (Build_Cofib f).
    specialize (Hf (` (sigT (Cyl f))) B pr1).
    specialize (Hf (Build_AFib (Cyl f) Cyl_Contr (retract_id _))).
    specialize (Hf top' idmap E1).
    destruct Hf as [g [Hg1 Hg2]]; cbn in *.
    use (Build_Retract idmap idmap g pr1); intro; try reflexivity.
    exact (Eap10 Hg2 _). exact (Eap10 Hg1^E _).
  - intros [A' B' f' Hf] A'' B'' g Hg.
    use (LP_Retract (f:=_:`_->`_) Hf (retract_id _)).
    ref (LP_top'_AF _ _ _ g Hg).
Defined.

(* C are injections in THEIR cylinders *)
Definition C_caract2 {A B: FType} (f: A -> B)
  : LLP (C:=FTYPE) AFib f <-> ∃ (g: B -> sigT (Cyl f)), g o f ≡≡ top' × pr1 o g ≡≡ idmap.
Proof.
  split.
  - intro Hf.
    specialize (Hf (` (sigT (Cyl f))) B pr1).
    specialize (Hf (Build_AFib (Cyl f) Cyl_Contr (retract_id _))).
    specialize (Hf top' idmap E1).
    destruct Hf as [g [Hg1 Hg2]]; cbn in *.
    exists g; split; now apply Eap10.
  - intros [g [H1 H2]].
    intros A' B' h H.
    ref (LP_Retract (f:=top' (f:=f): `_->`_) _ (retract_id _) _).
    + use (Build_Retract idmap idmap g pr1); try (intro; reflexivity).
      exact H2. intro; cbn; sym H1.
    + apply (LP_top'_AF _). assumption.
Defined.

Definition Cofib_W {A B: FType} (f: A -> B)
  : IsEquiv (top' (f:=f)) <-> IsEquiv f.
Proof.
  assert (H': IsEquiv (π1 (Cyl f))). {
    use isequiv_adjointify. exact base'.
    intro; cbn. exact 1.
    intro x. unfold base'. ref (path_sigma _ 1 _); cbn.
    apply (contr _ (Cyl_Contr (f:=f) x.1)). }
  split; intro H.
  - exact (isequiv_compose H H').
  - ref (cancelL_isequiv (π1 (Cyl f))).
    exact H'. exact H.
Defined.

Record ACofib {A B} (f : A -> B) := (* AC *)
  { acofib_A : FType ;
    acofib_B : FType ;
    acofib_k : acofib_A -> acofib_B ;
    acofib_Hk : IsEquiv acofib_k ;
    acofib_H : f RetractOf (top' (f:=acofib_k)) }.

Arguments Build_ACofib {A B f A' B'} k Hk H : rename.

(* AC are injections into cylinders of weak equivalences *)
Definition AC_caract2 {A B: FType} (f: A -> B)
  : LLP (C:=FTYPE) Fib f <-> ACofib f.
Proof.
  use transitive_iff. 2: apply LLPAFib_ok. split.
  - intros [Hf H].
    ref (Build_ACofib f Hf _).
    specialize (H (` (sigT (Cyl f))) B pr1).
    assert (AFib (∃ y, Cyl f y) B pr1). {
      ref (Build_AFib _ _ (retract_id _)).
      cbn. apply Cyl_Contr. }
    specialize (H X top' idmap E1); clear X.
    destruct H as [g [H1 H2]]; cbn in *.
    ref (Build_Retract idmap idmap g pr1 _ _ _ _);
      intro; try reflexivity.
    now apply Eap10. exact (Eap10 H1 _)^E.
  - intros [A' B' k Hk H]; split.
    + ref (weak_eq_retract (_: `_ -> `_) _ H _); clear H; cbn.
      revert Hk. apply Cofib_W.
    + apply C_caract. ref (Build_Cofib k H).
Defined.

Definition IsInjEq {A B: FType} (f: A -> B)
  := ∃ (r: B -> A) (H1: r o f ≡≡ idmap) (H2: f o r == idmap),
  forall x, H2 (f x) ≡ Eq_to_paths (Eap f (H1 x)).

(* AC are injective equivalences *)
Definition AC_caract3 {A B: FType} (f: A -> B)
  : LLP (C:=FTYPE) Fib f <-> IsInjEq f.
Proof.
  use transitive_iff.
  2: apply AC_caract. split.
  - intros [g [H1 H2]]. exists (λ y, (g y).2.1).
    use exist. intro x. exact (Eap (λ w, w.2.1) (H1 x)).
    use exist. intro y. pose (g y).2.2. cbn in *.
    ref (concat_pE (g y).2.2 _). exact (H2 y).
    intro x; cbn.
    pose (EapD (λ w: sigT (fiber f), w.2.2) (H1 x)^E); cbn in *.
    rewi e; clear e.
    pose (Etransport_paths_FlFrE (f:=λ w, f w.2.1) (g:= pr1) (H1 x)^E E1);
      cbn in *.
    ref (Eap (λ p, concat_pE p (H2 (f x))) _ E@ _).
    2: exact e; clear e.
    ref (concat_pE_ETP _ _ E@ Eap Eq_to_paths (Eq_UIP _ _)).
  - intros [s [H1 [H2 H3]]].
    use exist. ref (fun y => (y; s y; H2 y)).
    split; cbn.
    intro x. ref (eq_sigma _ E1 _); cbn.
    ref (eq_sigma _ (H1 x) _). rew (H3 x).
    ref (Etransport_paths_FlFrE (H1 x) (Eap f (H1 x)) E@ _).
    ref (Eap Eq_to_paths (Eq_UIP _ E1)).
    reflexivity.
Defined.

Definition AF_caract {A B: FType} (f: A -> B)
  : AFib _ _ f <-> ∃ g : (∃ x, Cyl f x) -> A, g o top' ≡≡ idmap × f o g ≡≡ pr1.
Proof.
  split.
  - intro H.
    pose proof (LP_top'_AF f _ _ f H idmap pr1 E1).
    destruct X as [g [Hg1 Hg2]]; cbn in *.
    exists g. split; ref (Eap10 _); assumption.
  - intros [g [Hg1 Hg2]]. use (Build_AFib (Cyl f)).
    apply Cyl_Contr.
    ref (Build_Retract top' g idmap idmap _ _ _ _); cbn; try reflexivity.
    exact Hg1. intro; sym Hg2.
Defined.

(* Print Assumptions type_model_structure. *)
(* Print Assumptions F_caract. *)
(* Print Assumptions C_caract2. *)
(* Print Assumptions AF_caract. *)

Definition pi1_fib {A} (P: A -> Type) (H: forall x, IsFibration (fun _: P x => tt))
  : IsFibration (π1 P).
  pose (B := fun x => (fib_A _ (H x))).
  pose (Q := (fun w: sigT B => (fib_P _ (H w.1)) w.2)).
  ref (Build_IsFibration Q _) .
  pose (Fib := fun x => (fib_Fib _ (H x))). classes.
  pose (R := fun x => (fib_H _ (H x))).
  pose (s := fun x => ret_s (R x) : _ -> exists y, Q (x; y)).
  pose (r := fun x => ret_r (R x) : (exists y, Q (x; y)) -> _).
  pose (s' := fun x => ret_s' (R x) : _ -> B x).
  pose (r' := fun x => ret_r' (R x) : B x -> _).
  use Build_Retract.
  - intros [x y]. ref ((x; _); (s x y).2).
  - intros [[x y] z]. ref (x; r x (y; z)).
  - intro x. ref (x; s' x tt).
  - intros [x y]. exact x.
  - intros [x y]; cbn. ref (eq_sigma _ E1 _); cbn.
    exact (ret_sr (R x) y).
  - intros x; cbn. reflexivity.
  - intros [x y]; cbn.  ref (eq_sigma _ E1 _); simpl.
    exact (ret_H1 (R x) y).
  - intros  [[x y] z]; cbn.  reflexivity.
Defined.


Require Import VST.msl.msl_standard.
Require Import VST.msl.Coqlib2.
Require Import Coq.ZArith.ZArith.
Require Import VST.zlist.sublist.
Set Implicit Arguments.

Inductive fold_rel (A: Type) (f: A -> A -> A -> Prop):  A -> list A -> A -> Prop :=
| fold_rel_nil: forall w, fold_rel f w nil w
| fold_rel_cons: forall a l w w1 w2,
            f w a w1 ->
            fold_rel f w1 l w2 ->
            fold_rel f w (a::l) w2.

Inductive list_forall2 {A B} (P: A -> B -> Prop): list A -> list B -> Prop :=
  | list_forall2_nil:
      list_forall2 P nil nil
  | list_forall2_cons:
      forall a1 al b1 bl,
      P a1 b1 ->
      list_forall2 P al bl ->
      list_forall2 P (a1 :: al) (b1 :: bl).

Fixpoint replace (A: Type) (l: list A) (n:nat) (new: A) {struct n} : option (list A) :=
  match (l, n) with
    | (nil, n) => None
    | (x :: xs, O) => Some (new :: xs)
    | (x :: xs, S n) =>
      match (replace xs n new) with
        |  None => None
        |  Some xs => Some (x :: xs)
      end
  end.

Definition list_join {A} {JA: Join A}: A -> list A -> A -> Prop :=
   fold_rel join.

Lemma list_join_assoc1 {A} {JA: Join A}{PA: Perm_alg A}:
 forall {a b cl d e},
   join a b d -> list_join d cl e ->
  exists f, list_join b cl f /\ join a f e.
Proof.
intros.
revert a b H.
induction H0; intros.
exists b. split; auto. constructor.
destruct (join_assoc H1 H) as [ba [? ?]].
destruct (IHfold_rel _ _ H3) as [f [? ?]]; clear IHfold_rel.
exists f; split; auto.
econstructor; eauto.
Qed.

Lemma list_join_assoc2 {A}  {JA: Join A}{PA: Perm_alg A}:
  forall {a b: A} {cl e f},
   list_join b cl f -> join a f e ->
   exists d,  join a b d /\ list_join d cl e.
Proof.
do 3 intro; revert a b; induction cl; intros; inv H.
exists e; split; auto; constructor.
destruct (IHcl _ _ _ _ H6 H0) as [d [? ?]].
destruct (join_assoc (join_comm H4) (join_comm H)) as [g [? ?]].
exists g; split; auto.
constructor 2 with d; auto.
Qed.

Lemma list_join_app {A} {JA: Join A}:
  forall {a: A} {bl c dl e},
   list_join a bl c -> list_join c dl e -> list_join a (bl++dl) e.
Proof.
intros a bl; revert a; induction bl; intros.
inv H.
simpl.
auto.
inv H.
rewrite <- app_comm_cons.
econstructor 2.
apply H4.
eapply IHbl.
apply H6.
auto.
Qed.

Lemma list_join_unapp {A}  {JA: Join A}:
  forall {a:A}  {bl dl e},
  list_join a (bl++dl) e -> exists c, list_join a bl c /\ list_join c dl e.
Proof.
intros a bl; revert a; induction bl; intros.
simpl in H. exists a; split; auto. constructor.
rewrite <- app_comm_cons in H.
inv H.
destruct (IHbl _ _ _ H5) as [c [? ?]]. clear IHbl.
exists c.
split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_1 {A} {JA: Join A}:
  forall a b c: A, join a b c = list_join a (b::nil) c.
Proof.
intros; apply prop_ext; split; intros.
econstructor 2; eauto.
constructor.
inv H.
inv H5.
auto.
Qed.

Definition age1_list {A} `{ageable A} := list_forall2 age.

Lemma age1_list_join {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall l (phi phi' phi2: A),
        age phi phi' ->
        list_join phi l phi2 ->
        exists l', exists phi2', age1_list l l' /\ age phi2 phi2' /\ list_join phi' l' phi2'.
Proof.
induction l; intros; inv H0.
exists (@nil A).
exists phi'.
repeat split; auto; constructor.
rename w1 into phi1.
destruct (age1_join _ H4 H) as [a' [phi1' [? [? ?]]]].
specialize ( IHl phi1 phi1' phi2 H2 H6).
destruct IHl as [l' [phi2' [? [? ?]]]].
exists (a' :: l').
exists phi2'.
repeat split; auto; econstructor 2; eauto.
Qed.

Lemma age1_list_join2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall (l: list A) phi phi2 phi2',  age1 phi2 = Some phi2' -> list_join phi l phi2 ->
        exists l', exists phi',  age1 phi = Some phi' /\ age1_list l l' /\ list_join phi' l' phi2'.
Proof.
induction l; intros; inv H0.
exists (@nil A).
exists phi2'.
repeat split; auto; constructor.
rename w1 into phi1.
destruct (IHl phi1 phi2 phi2' H H6) as [l' [phi1' [? [? ?]]]].
destruct (age1_join2 _ H4 H0) as [phi' [a' [? [? ?]]]].
exists (a'::l'). exists phi'.
repeat split; auto; econstructor 2; eauto.
Qed.

Lemma list_join_split_nth {A}{JA: Join A}{PA: Perm_alg A}:
 forall n (l: list A) phin phi phia phib phi2,
  nth_error l n = Some phin -> list_join phi l phi2 -> join phib phia phin ->
           exists phic, exists l',
                 replace l n phib = Some l' /\ join phi phia phic /\ list_join phic l' phi2.
Proof.
induction n; intros.
inv H.
destruct l.
discriminate.
inv H3.
inv H0.
simpl.
destruct (join_assoc H1 (join_comm H4))
      as [f [? ?]].
exists f; exists (phib::l).
repeat split; auto.
econstructor 2; eauto.
simpl in H.
destruct l.
inv H.
inv H0.
destruct (IHn _ _ _ _ _ _ H H7 H1) as [phic [l' [? [? ?]]]].
simpl. rewrite H0.
destruct (join_assoc (join_comm H5) H2) as [f [? ?]].
exists f; exists (a::l'); repeat split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_join_nth {A} {JA: Join A}{PA: Perm_alg A}:
 forall n (l: list A) phin phi phia phib phi2,
  nth_error l n = Some phin -> list_join phi l phi2 -> join phi2 phia phib ->
           exists phic, exists l',
                 join phin phia phic /\ replace l n phic = Some l' /\ list_join phi l' phib.
Proof.
induction n; intros.
inv H.
destruct l; try discriminate.
inv H0.
inv H3.
simpl.
destruct (list_join_assoc2 H7 (join_comm H1)) as [f [? ?]].
destruct (join_assoc H5 (join_comm H)) as [g [? ?]].
exists g; exists (g::l); repeat split; auto.
econstructor 2; eauto.
destruct l; simpl in H.
inv H.
inv H0.
simpl.
destruct (IHn _ _ _ _ _ _ H H7 H1) as [phic  [l' [? [? ?]]]].
exists phic. rewrite H2. exists (a::l').
repeat split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_eq : forall {A} {JA: Join A} {PA: Perm_alg A} (b : list A) a c c'
  (Hc : list_join a b c) (Hc' : list_join a b c'), c = c'.
Proof.
  induction b; intros; inv Hc; inv Hc'; auto.
  assert (w0 = w1) by (eapply join_eq; eauto).
  subst; eapply IHb; eauto.
Qed.

Lemma join_shares_nth : forall {A} {JA: Join A} {PA: Perm_alg A} {dI: Inhabitant A}
                          (shs: list A) (sh1 sh: A) (i: Z),
    list_join sh1 shs sh -> (0 <= i < Zlength shs)%Z ->
  exists (sh': A), list_join (Znth i shs) (remove_Znth i shs) sh' /\ join sh1 sh' sh.
Proof.
  induction shs; simpl; intros.
  { rewrite Zlength_nil in *; lia. }
  inv H.
  destruct (Z.eq_dec i 0).
  - subst; rewrite remove_Znth0, sublist_1_cons, Zlength_cons, sublist_same, Znth_0_cons; auto; try lia.
    eapply list_join_assoc1; eauto.
  - rewrite Zlength_cons in *. generalize (IHshs w1 sh (i - 1)%Z H6 ltac:(lia)).
    intros (sh2 & ? & ?).
    rewrite Znth_pos_cons, remove_Znth_cons; try lia.
    generalize (join_sub_joins_trans(a := a)(b := sh2)(c := w1)
                  ltac:(eexists; eapply join_comm; eauto)
                         ltac:(eexists; eapply join_comm; eauto)).
    intros (sh' & ?); exists sh'; split.
    + generalize (list_join_assoc2(a := a)(b := Znth (i - 1) shs)
                    (cl := remove_Znth (i - 1) shs)(e := sh')(f := sh2) H ltac:(auto)).
      intros (d & ? & ?). apply join_comm in H3.
      econstructor; eauto.
    + pose proof (join_assoc(a := sh1)(b := a)(c := sh2)(d := w1)(e := sh)) as X.
      repeat match goal with X : ?a -> _, H : ?a |- _ => specialize (X H) end.
      destruct X as (f & Ha' & ?).
      assert (f = sh') by (eapply join_eq; eauto).
      subst; auto.
Qed.

Lemma list_join_comm : forall {A} {JA: Join A} {PA: Perm_alg A} (l1 l2 : list A) a b,
    list_join a (l1 ++ l2) b -> list_join a (l2 ++ l1) b.
Proof.
  induction l1; intros; [rewrite app_nil_r; auto|].
  inversion H as [|????? H1 H2]; subst.
  apply IHl1, list_join_unapp in H2.
  destruct H2 as (c & Hl2 & Hl1).
  apply join_comm in H1.
  destruct (list_join_assoc1 H1 Hl2) as (? & ? & ?).
  eapply list_join_app; eauto.
  apply join_comm in H2. econstructor; eauto.
Qed.

(*****************************)

Lemma list_join_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall (phi1: A) l phi2, list_join phi1 l phi2 -> comparable phi1 phi2.
Proof.
  intros; revert phi1 phi2 H; induction l; simpl; intros; inv H.
  apply comparable_refl.
  rename w1 into phi0.
  apply comparable_trans with phi0.
  apply join_comparable with a; auto.
  auto.
Qed.

Lemma join_comparable'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi2 phi3.
Proof. intros; apply join_comparable with phi1; apply join_comm; auto. Qed.

Lemma join_comparable2'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi2 phi1.
Proof. intros; apply comparable_sym; eapply join_comparable2; eauto. Qed.

Lemma list_join_comparable'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall (phi1: A) l phi2, list_join phi1 l phi2 -> comparable phi2 phi1.
Proof. intros; apply comparable_sym; eapply list_join_comparable; eauto. Qed.

Lemma join_comparable''  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi3 phi2.
Proof. intros; apply comparable_sym; eapply join_comparable'; eauto. Qed.

Lemma join_comparable'''  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi3 phi1.
Proof. intros; apply comparable_sym; eapply join_comparable; eauto. Qed.

Lemma joins_comparable  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall phi1 phi2: A, joins phi1 phi2 -> comparable phi1 phi2.
Proof.
  unfold joins; intros.
  destruct H as [phi3 ?].
  eapply join_comparable2; eauto.
Qed.

Lemma joins_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
     forall phi1 phi2: A, joins phi2 phi1 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
apply comparable_sym.
eapply join_comparable2; eauto.
Qed.

Lemma join_sub_comparable  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
  forall phi1 phi2: A, join_sub phi1 phi2 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
eapply join_comparable; eauto.
Qed.

Lemma join_sub_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}:
     forall phi1 phi2: A, join_sub phi2 phi1 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
apply comparable_sym.
eapply join_comparable; eauto.
Qed.

Lemma eq_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall phi1 phi2: A, phi1=phi2 -> comparable phi1 phi2.
Proof.
intros; subst; apply comparable_refl.
Qed.

Lemma eq_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall phi1 phi2: A, phi2=phi1 -> comparable phi1 phi2.
Proof.
intros; subst; apply comparable_refl.
Qed.

Lemma ageN_join {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w3 w1': A),
   join w1 w2 w3 ->
      ageN n w1 = Some w1' ->
      exists w2', exists w3',
        ageN n w2 = Some w2' /\ ageN n w3 = Some w3' /\ join w1' w2' w3'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
exists w2; exists w3; repeat split; auto.
inv H0; auto.
case_eq (age1 w1); intros; rewrite H1 in H0; try discriminate.
destruct (age1_join _ H H1) as [w2' [w3' [? [? ?]]]].
destruct (IHn _ _ _ _ H2 H0) as [w2'' [w3'' [? [? ?]]]].
clear IHn.
exists w2''; exists w3''. rewrite H3; rewrite H4.
repeat split; auto.
Qed.

Lemma ageN_join2 {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w3 w3': A),
   join w1 w2 w3 ->
      ageN n w3 = Some w3' ->
      exists w1', exists w2',
        ageN n w1 = Some w1' /\ ageN n w2 = Some w2' /\ join w1' w2' w3'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
exists w1; exists w2; repeat split; auto.
inv H0; auto.
case_eq (age1 w3); intros; rewrite H1 in H0; try discriminate.
destruct (age1_join2 _ H H1) as [w1' [w2' [? [? ?]]]].
destruct (IHn _ _ _ _ H2 H0) as [w1'' [w2'' [? [? ?]]]].
clear IHn.
exists w1''; exists w2''. rewrite H3; rewrite H4.
repeat split; auto.
Qed.

Lemma ageN_comparable {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{FA: Flat_alg A}:
  forall n (w1 w2 w1' w2': A),
        ageN n w1 = Some w1' -> ageN n w2 = Some w2' -> comparable w1 w2 -> comparable w1' w2'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
inv H; inv H0; auto.
revert H H0; case_eq (age1 w1); case_eq (age1 w2); intros; try discriminate.
eapply IHn; eauto.
eapply age_comparable; eauto.
Qed.

Lemma join_unage  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall (phi3 phi1' phi2' phi3': A),
    age1 phi3 = Some phi3' ->
    join phi1' phi2' phi3' ->
    exists phi1, exists phi2, join phi1 phi2 phi3 /\
      age1 phi1 = Some phi1' /\ age1 phi2 = Some phi2'.
Proof.
  intros.
  apply (unage_join2 _ H0 H).
Qed.

Lemma join_unage'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
    forall phi1 phi1' phi2' phi3' : A,
      age1 phi1 = Some phi1' ->
      join phi1' phi2' phi3' ->
      exists phi2, exists phi3, join phi1 phi2 phi3 /\
        age1 phi2 = Some phi2' /\ age1 phi3 = Some phi3'.
Proof.
   intros. apply (unage_join _ H0 H).
Qed.

Lemma unageN'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (phi1 phi1' phi2' phi3' : A),
    ageN n phi1 = Some phi1' ->
    join phi1' phi2' phi3' ->
    exists phi2, exists phi3, join phi1 phi2 phi3 /\
      ageN n phi2 = Some phi2' /\ ageN n phi3 = Some phi3'.
Proof.
induction n; intros.
inv H. exists phi2'; exists phi3'; split; auto.
 unfold ageN in H. simpl in H.
 revert H; case_eq (age1 phi1); intros.
  specialize ( IHn a phi1' phi2' phi3' H1 H0).
  destruct IHn as [phi2 [phi3 [? [? ?]]]].
  destruct (join_unage' _ _ _ H H2) as [phi4 [phi5 [? [? ?]]]].
  exists phi4; exists phi5. split; auto.
 split; unfold ageN; simpl. rewrite H6; auto. rewrite H7; auto.
 inv H1.
Qed.

#[export] Hint Resolve join_comparable join_comparable'  join_comparable'' join_comparable'''
      join_comparable2 join_comparable2' list_join_comparable list_join_comparable'
      joins_comparable joins_comparable2 join_sub_comparable join_sub_comparable2
      eq_comparable  eq_comparable2
  : comparable.

#[export] Hint Immediate comparable_refl  comparable_sym  : comparable.

Ltac Comp1 phi1 phi2 :=
   solve [ eauto 3 with comparable typeclass_instances |
  match goal with
  | H: comparable phi1 ?phi |- _ => Comp2 H phi1 phi phi2
  | H: comparable ?phi phi1 |- _ => Comp2 H phi1 phi phi2
  | H: join phi1 ?phia ?phib |- _ =>  Comp3 H phi1 phia phib phi2
  | H: join ?phia phi1 ?phib |- _ =>   Comp3 H phi1 phia phib phi2
  | H: join ?phia ?phib phi1 |- _ =>   Comp3 H phi1 phia phib phi2
  | H: joins phi1 ?phi |- _ =>  Comp2 H phi1 phi phi2
  | H: joins ?phi phi1 |- _ =>  Comp2 H phi1 phi phi2
  | H: join_sub phi1 ?phi |- _ => Comp2 H phi1 phi phi2
  | H: join_sub ?phi phi1 |- _ => Comp2 H phi1 phi phi2
  | H: list_join phi1 _ ?phi |- _ =>  Comp2 H phi1 phi phi2
  | H: list_join ?phi _ phi1 |- _ =>  Comp2 H phi1 phi phi2
  | H: phi1 = ?phi  |- _ => Comp2 H phi1 phi phi2
  | H: ?phi = phi1  |- _ => Comp2 H phi1 phi phi2
 end]
  with Comp2 H phi1 phi phi2 :=
            solve [apply comparable_trans with phi;
                         [eauto 3 with comparable  typeclass_instances |clear H; Comp1 phi phi2]
                   | clear H; Comp1 phi1 phi2]
  with Comp3 H phi1 phia phib phi2 :=
           solve [apply comparable_trans with phia;
                          [eauto 3 with comparable typeclass_instances |clear H; Comp1 phia phi2]
                  |apply comparable_trans with phib;
                          [eauto 3 with comparable  typeclass_instances | clear H; Comp1 phib phi2]
                   | clear H; Comp1 phi1 phi2].

Ltac Comp := match goal with
                | |- comparable ?phi1 ?phi2 => Comp1 phi1 phi2
                | |-  level ?phi1 = level ?phi2 => apply comparable_fashionR; Comp1 phi1 phi2
(*                | |- level _ = level _ => rewrite comparable_level; Comp *)
                end.

Definition not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A} (phi phi': A)  : Prop :=
     exists phi1, necR phi phi1 /\ comparable phi1 phi'.

Lemma comparable_not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A} :
    forall phi phi' : A , comparable phi phi' -> not_any_younger phi phi'.
Proof.
  intros.
  exists phi; split; auto; apply rt_refl.
Qed.

Lemma necR_not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi phi' : A, necR phi phi' -> not_any_younger phi phi'.
Proof. intros; exists phi'; split; auto. apply comparable_refl. Qed.

Lemma not_any_younger_refl {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
 forall phi : A, not_any_younger phi phi.
Proof. intros; exists phi; split; auto. apply comparable_refl. Qed.

Lemma not_any_younger_trans {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi1 phi2 phi3, not_any_younger phi1 phi2 -> not_any_younger phi2 phi3 ->
            not_any_younger phi1 phi3.
Proof.
intros.
destruct H as [phi1' [? ?]].
destruct H0 as [phi2' [? ?]].
generalize (comparable_common_unit H1); intros [e1 [? ?]].
generalize (nec_join2 H4 H0); intros [a [b [? [? _]]]].
generalize (nec_join H3 H6); intros [u [v [? [? _]]]].
exists u.
split.
econstructor 3; eauto.
Comp.
Qed.

Lemma not_any_younger_None {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi phi', age1 phi = None -> not_any_younger phi phi' -> age1 phi' = None.
Proof.
intros.
destruct H0 as [phi1 [? ?]].
revert phi' H1.
induction H0; intros.
unfold age in H0.
inversion2 H H0.
generalize (comparable_common_unit H1); intros [e1 [? ?]].
case_eq (age1 phi'); [intros w ? | intro]; auto.
exfalso.
generalize (age1_join2 _ H2 H3); intros [a [b [? [? ?]]]].
generalize (age1_join _ H0 H5); intros [c [d [? [? ?]]]].
unfold age in H8; inversion2 H H8.
assert (x=y).
clear - H0_ H.
induction H0_.
 unfold age in *.
inversion2 H H0.
auto.
rewrite <- IHH0_2; auto.
rewrite <- IHH0_1; auto.
subst y.
auto.
Qed.

Lemma nec_join3 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall {x x' y' z' : A},
       join x' y' z' ->
       necR x x' ->
       exists y,
         exists z,
           join x y z /\ necR y y' /\ necR z z'.
Proof.
intros.
revert y' z' H.
induction H0; intros.
destruct (unage_join _ H0 H) as [y0 [z0 [? [? ?]]]].
exists y0; exists z0; split; auto.
split; constructor 1; auto.
exists y'; exists z'.
split; auto.
rename z into x'.
rename y into x1.
destruct (IHclos_refl_trans2 _ _ H) as [x'' [y'' [? [? ?]]]].
destruct (IHclos_refl_trans1 _ _ H0) as [x0 [y0 [? [? ?]]]].
exists x0; exists y0.
split; auto.
split; econstructor 3; eauto.
Qed.


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.
Set Universe Polymorphism.

From Coq Require Import
     Relation_Definitions
     RelationClasses
.

Require Import Fix.
Require Import GHC.Base.
Require Import Adverb.Adverb.
Require Import ClassesOfFunctors.DictDerive.
Require Import ClassesOfFunctors.Laws.

Open Scope adverb_scope.

(** * Statically. *)

(* begin statically_adv *)
(* Statically and StaticallyInParallel *)
Inductive ReifiedApp (E : Type -> Type) (R : Type) : Type :=
| EmbedA (e : E R)
| Pure (r : R)
| LiftA2 {X Y : Type} (f : X -> Y -> R)
         (a : ReifiedApp E X) (b : ReifiedApp E Y).
(* end statically_adv *)

(* begin statically_methods *)
Definition embed {E A} : E A -> ReifiedApp E A := EmbedA.

Definition pure {E A} : A -> ReifiedApp E A := Pure.

Definition liftA2 {E A B C} :
  (A -> B -> C) -> ReifiedApp E A -> ReifiedApp E B -> ReifiedApp E C :=
  LiftA2.

Definition fmap {E A B} (f : A -> B) (a : ReifiedApp E A) : ReifiedApp E B :=
  liftA2 id (pure f) a.
(* end statically_methods *)

(** The above code is for illustration purpose. In real code, we do not use
    thoses names because they conflict with the type class names. We reset these
    definitions to use non-conflicting names here. *)
Reset pure.

Definition pureS {E A} (a : A) : ReifiedApp E A :=
  Pure a.

Definition liftA2S {E A B C} (f : A -> B -> C)
           (a : ReifiedApp E A) (b : ReifiedApp E B) : ReifiedApp E C :=
  LiftA2 f a b.

Definition apS {E A B} (f : ReifiedApp E (A -> B))
           (a : ReifiedApp E A) : ReifiedApp E B :=
  liftA2S id f a.

Definition fmapS {E A B} (f : A -> B) (a : ReifiedApp E A) : ReifiedApp E B :=
  apS (pureS f) a.

Global Instance Functor_Statically {E : Type -> Type} : Functor (ReifiedApp E) :=
  fun r k => k {| fmap__      := fun {a} {b} => fmapS ;
               op_zlzd____ := fun {a} {b} => fmapS ∘ const |}.

Global Instance Applicative_Statically {E : Type -> Type} : Applicative (ReifiedApp E) :=
  fun r k => k {| liftA2__ := fun {a b c} => liftA2S ;
               op_zlztzg____ := fun {a b} => apS ;
               op_ztzg____ := fun {a b} fa => liftA2S id ((fmapS ∘ const) id fa) ;
              pure__ := fun {a} => pureS |}.

(* begin interpA *)
Fixpoint interpA {E I : Type -> Type} `{Applicative I} {A : Type}
  (interpE : forall A, E A -> I A) (t : ReifiedApp E A) : I A :=
  match t with
  | EmbedA e => interpE _ e
  | Pure a => pure a
  | LiftA2 f a b => liftA2 f (interpA interpE a) (interpA interpE b)
  end.
(* end interpA *)

Reset interpA.

(** The above code is for illustration purpose. In real code, [interpA] is also
parameterized over an equivalence relation. *)

Definition interpA
  {E I : Type -> Type} `{Applicative I}
  {EqI : forall (A : Type), relation (I A)} {A : Type}
  (interpE : forall A, E A -> I A) :=
  let fix go {A : Type} (t : ReifiedApp E A) : I A :=
    match t with
    | EmbedA e => interpE _ e
    | Pure a => pure a
    | LiftA2 f a b => liftA2 f (go a) (go b)
    end
  in @go A.

(** * The adverb simulation. *)
#[global] Instance ReifiedApperbSim :
  ReifiedApp ⊧ Applicative__Dict UNDER IdT :=
  {| interp := fun E I D =>
                 @interpA E I (apdict_functor I D) (apdict_applicative I D)
  |}.

Declare Scope statically_scope.

Reserved Notation "a ≅ b" (at level 42).

Inductive StaticallyBisim {E A} : relation (ReifiedApp E A) :=
| statically_congruence :
    forall {X Y} a1 a2 b1 b2 (f : X -> Y -> A),
      a1 ≅ a2 -> b1 ≅ b2 -> liftA2 f a1 b1 ≅ liftA2 f a2 b2
| statically_left_id :
    forall {X} (a : X) (b : ReifiedApp E A),
      liftA2 (fun _ => id) (pure a) b ≅ b
| statically_right_id :
    forall {X} (a : ReifiedApp E A) (b : X),
      liftA2 (fun x _ => x) a (pure b) ≅ a
| statically_assoc :
    forall {X Y Z} a b c (f : X -> Y -> Z -> A) g,
      (forall x y z, f x y z = g y z x) ->
      liftA2 id (liftA2 f a b) c ≅ liftA2 (flip id) a (liftA2 g b c)
| statically_natural :
    forall {X Y Z T P} a b c p (q : X -> Y -> T) f (g : Y -> Z -> P),
      (forall x y z, p (q x y) z = f x (g y z)) ->
      liftA2 p (liftA2 q a b) c ≅ liftA2 f a (liftA2 g b c)
| statically_refl : forall a, a ≅ a
| statically_sym : forall a b, a ≅ b -> b ≅ a
| statically_trans : forall a b c, a ≅ b -> b ≅ c -> a ≅ c
where "a ≅ b" := (StaticallyBisim a b) : statically_scope.

Global Program Instance ReifiedApperb : Adverb ReifiedApp :=
  {| Bisim := fun _ _ => StaticallyBisim ;
     Refines := fun _ _ => StaticallyBisim
  |}.
Next Obligation.
  constructor.
  - intros a. constructor.
  - intros a b. constructor. assumption.
  - intros a b c ? ?. econstructor; eassumption.
Qed.
Next Obligation.
  constructor.
  - intros a. constructor.
  - intros a b c ? ?. econstructor; eassumption.
Qed.

(* begin statically_soundness *)
Theorem soundness_of_statically :
  forall {E I : Type -> Type} {A : Type}
    {EqI : forall (A : Type), relation (I A) } `{forall A, Equivalence (EqI A) }
    {D : Applicative__Dict I}
    {_ : @ApplicativeLaws I EqI (apdict_functor _ D) (apdict_applicative _ D)}
    {_ : @ApplicativeCongruenceLaws I EqI (apdict_functor _ D) (apdict_applicative _ D)}
    (interpE : forall A, E A -> I A) (x y : ReifiedApp E A),
    (* The theorem states that [≅] is an under-approximation of [EqI]. *)
    x ≅ y ->
    EqI _ (interp (C0:=D)(EqI:=EqI) interpE x) (interp (C0:=D)(EqI:=EqI) interpE y).
(* end statically_soundness *)
Proof.
  intros until y. induction 1.
  - unfold interp. cbn.
    apply liftA2_cong; assumption.
  - unfold interp. cbn.
    apply liftA2_left_id; assumption.
  - unfold interp. cbn.
    apply liftA2_right_id; assumption.
  - unfold interp. cbn.
    apply assoc; assumption.
  - unfold interp. cbn.
    apply naturality; assumption.
  - unfold interp. cbn. reflexivity.
  - unfold interp. cbn. symmetry. assumption.
  - unfold interp. cbn. etransitivity; eassumption.
Qed.