From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B D E C F : Universe, ((wd_ A B /\ (wd_ B E /\ (wd_ A E /\ (wd_ A B /\ (wd_ A D /\ (wd_ B A /\ (wd_ A F /\ (wd_ B F /\ (col_ A B E /\ (col_ A B D /\ (col_ B A F /\ col_ A C F))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ A C /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ col_ A B C)))))))))))))) -> col_ O Cprime Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

(*Require Export SfLib.*)
Require Export Coq.Init.Notations.
Require Export tactics.
Require Export Peano.
Require Export Basics.
Require Export Bool.
Require Export Arith.
Require Export Arith.EqNat.
Require Omega.

(* Prop/Type exists depending on the switch universe-type.v/universe-prop.v *)
Notation "{ a , b : T $ P }" :=
  {a : T $ {b : T $ P}}
    (at level 0, a at level 99, b at level 99).
Notation "{ a , b , c : T $ P }" :=
  {a : T $ {b : T $ {c : T $ P}}}
    (at level 0, a at level 99, b at level 99, c at level 99).
Notation "{ a , b , c , d : T $ P }" :=
  {a : T $ {b : T $ {c : T $ {d : T $ P}}}}
    (at level 0, a at level 99, b at level 99, c at level 99, d at level 99).
Notation "{ a , b , c , d , e : T $ P }" :=
  {a : T $ {b : T $ {c : T $ {d : T $ {e : T $ P}}}}}
    (at level 0, a at level 99, b at level 99, c at level 99, d at level 99, e at level 99).
Notation "{ a , b , c , d , e , f : T $ P }" :=
  {a : T $ {b : T $ {c : T $ {d : T $ {e : T $ {f : T $ P}}}}}}
    (at level 0, a at level 99, b at level 99, c at level 99, d at level 99, e at level 99, f at level 99).

(* Some extra notation from SfLib *)
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).

(* Some lemmas from SfLib *)
Theorem beq_nat_sym :
  forall (n m : nat),
    beq_nat n m = beq_nat m n.
Proof.
  induction n; sp.
  unfold beq_nat; destruct m; sp.
  simpl; destruct m; simpl; sp.
Qed.

Definition Deq (T : Type) := forall (x y : T), {x = y} + {x <> y}.

Lemma deq_prod :
  forall (A B : Type), Deq A -> Deq B -> Deq (A * B).
Proof.
  unfold Deq; introv da db; introv; sp.
  generalize (da x0 y0) (db x y); introv ea eb; sp; subst; sp;
  right; intro k; inversion k; sp.
Defined.

Hint Resolve deq_prod : Deq.

Definition assert (b : bool) : Prop := b = true.

Lemma fold_assert :
  forall b,
    (b = true) = assert b.
Proof.
  unfold assert; auto.
Qed.

Lemma assert_orb :
  forall a b,
    assert (a || b) -> assert a + assert b.
Proof.
  destruct a; destruct b; sp.
Qed.

Lemma assert_andb :
  forall a b,
    assert (a && b) <-> assert a /\ assert b.
Proof.
  destruct a; destruct b; sp; split; sp.
Qed.

Lemma assert_of_andb :
  forall a b,
    assert (a && b) <=> assert a # assert b.
Proof.
  destruct a; destruct b; sp; split; sp.
Qed.

Lemma not_assert :
  forall b, b = false <-> ~ assert b.
Proof.
  destruct b; unfold assert; simpl; split; sp.
Qed.

Lemma not_of_assert :
  forall b, b = false <=> ! assert b.
Proof.
  destruct b; unfold assert; simpl; split; sp.
Qed.

Lemma andb_true :
  forall a b,
    a && b = true <-> a = true /\ b = true.
Proof.
  destruct a; destruct b; simpl; sp; split; sp.
Qed.

Lemma andb_eq_true :
  forall a b,
    a && b = true <=> a = true # b = true.
Proof.
  destruct a; destruct b; simpl; sp; split; sp.
Qed.

(* ------ useful stuff ------ *)

Lemma max_prop1 :
  forall a b, a <= max a b.
Proof.
  induction a; simpl; sp; try omega.
  destruct b; auto.
  assert (a <= max a b); auto; omega.
Qed.

Lemma max_prop2 :
  forall a b, b <= max a b.
Proof.
  induction a; simpl; sp; try omega.
  destruct b; auto; try omega.
  assert (b <= max a b); auto; omega.
Qed.

Lemma max_or :
  forall a b,
    (max a b = a) \/ (max a b = b).
Proof.
  induction a; simpl; sp; try omega.
  destruct b; auto.
  assert (max a b = a \/ max a b = b) by apply IHa; sp.
Qed.

Theorem comp_ind:
  forall P: nat -> Prop,
    (forall n: nat, (forall m: nat, m < n -> P m) -> P n)
    -> forall n:nat, P n.
Proof.
 intros P H n.
 assert (forall n:nat , forall m:nat, m < n -> P m).
 intro n0. induction n0 as [| n']; intros.
 inversion H0.
  apply le_S_n in H0.
  apply le_lt_or_eq in H0.
 sp; subst; sp.
 apply H0 with (n := S n).
  auto.
Qed.

Theorem comp_ind_type :
  forall P: nat -> Type,
    (forall n: nat, (forall m: nat, m < n -> P m) -> P n)
    -> forall n:nat, P n.
Proof.
 intros P H n.
 assert (forall n:nat , forall m:nat, m < n -> P m).
 intro n0. induction n0 as [| n']; intros.
 omega.
 destruct (eq_nat_dec m n'); subst; auto.
 apply IHn'; omega.
 apply H; apply X.
Defined.

(*
Print NTerm_ind.

Print eq_refl.

Require Import Eqdep.

Axiom dec_eq_eq :
  forall (A : Type),
    (forall a b : A, {a = b} + {a <> b})
    -> forall a b : A,
       forall e e' : a = b,
         e = e'. (* Proved in Eqdep_dec. *)

Definition eq_dep_eq_dec'
           (A : Type)
           (dec_eq : forall a b : A, {a = b} + {a <> b})
           (X : A -> Type)
           (a : A)
           (x y : X a)
           (e : eq_dep A X a x a y) : x = y
 := (match e in eq_dep _ _ _ _ a' y' return
          forall e' : a = a',
            (match e' in _ = a' return X a' with
                eq_refl => x
            end) = y'
    with
    | eq_dep_intro =>
      fun e : a = a =>
        match dec_eq_eq A dec_eq a a (eq_refl a) e
              in _ = e
              return match e in _ = a' return X a' with eq_refl => x end = x with
          | eq_refl => eq_refl x
        end
    end) (eq_refl a).
*)

Lemma trivial_if :
  forall T,
  forall b : bool,
  forall t : T,
    (if b then t else t) = t.
Proof.
  intros;  destruct b; auto.
Qed.

Hint Rewrite trivial_if.

Lemma minus0 :
  forall n, n - 0 = n.
Proof.
  destruct n; auto.
Qed.

Lemma pair_inj :
  forall A B,
  forall a c : A,
  forall b d : B,
    (a, b) = (c, d) -> a = c /\ b = d.
Proof.
  sp; inversion H; sp.
Qed.

Lemma S_inj :
  forall a b, S a = S b -> a = b.
Proof.
  auto.
Qed.

Lemma S_le_inj :
  forall a b, S a <= S b -> a <= b.
Proof.
  sp; omega.
Qed.

Lemma S_lt_inj :
  forall a b, S a < S b -> a < b.
Proof.
  sp; omega.
Qed.

Lemma not_or :
  forall a b,
    ~ (a \/ b) -> ~ a /\ ~ b.
Proof.
  sp; apply H; sp.
Qed.

Lemma not_over_or :
  forall a b,
    !(a [+] b) <=> !a # !b.
Proof.
  sp; split; sp.
Qed.

Theorem apply_eq :
  forall {A B} (f: A -> B) {a1 a2:A},
    a1 = a2 -> f a1 = f a2.
Proof. intros. rewrite H. reflexivity.
Qed.

Theorem iff_push_down_forall : forall A (P Q: A-> Prop) ,
  (forall a, P a <=> Q a) -> ((forall a, P a) <=> (forall a, Q a)).
Proof. introv Hiff. repeat split; intros; apply Hiff; auto.
Qed.

Theorem iff_push_down_forallT : forall A (P Q: A-> [univ]) ,
  (forall a, P a <=> Q a) -> ((forall a, P a) <=> (forall a, Q a)).
Proof. introv Hiff. repeat split; intros; apply Hiff; auto.
Qed.

Theorem iff_push_down_impliesT : forall P Q R,
  (R -> (P <=> Q)) -> ((R -> P) <=> (R -> Q)).
Proof. introv Hiff. repeat split; intros; apply Hiff; auto.
Qed.

Lemma sum_assoc :
  forall a b c,
    (a [+] (b [+] c)) <=> ((a [+] b) [+] c).
Proof.
  sp; split; sp.
Qed.

Definition isInl {A B : Type}
    (d : A + B) : bool :=
match d with
| inl _ => true
| inr _ => false
end.

Definition isInr {A B : Type}
    (d : A + B) : bool :=
match d with
| inl _ => false
| inr _ => true
end.

Definition isInlInl {A B C D: Type}
    (d : (A + B) + (C + D)) : bool :=
match d with
| inl (inl _) => true
| _ => false
end.

Definition liftNth {A: Type}
    (f : A-> bool) (l : list A ) (n:nat) : bool :=
match (nth_error l n) with
| Some x => f x
| None => false
end.

Definition liftInl {A B : Type}
    (f : A -> bool) (d : A + B) : bool :=
match d with
| inl a => f a
| inr _ => false
end.

Notation deq_nat := NPeano.Nat.eq_dec.
Hint Resolve NPeano.Nat.eq_dec : Deq.

(* ========= DEPENDENT PAIRS ========= *)

Definition eq_existsT (A : Type)
                      (B : A -> Type)
                      (a a' : A)
                      (b : B a)
                      (b' : B a')
                      (ea : a = a')
                      (eb : match ea in _ = a' return B a' with eq_refl => b end = b')
  : existT B a b = existT B a' b'
  := match ea as ea
              in _ = a'
        return forall b' : B a',
                 match ea in _ = a' return B a' with eq_refl => b end = b'
                 -> existT B a b = existT B a' b'
     with
       | eq_refl => fun b' eb => match eb with eq_refl => eq_refl (existT B a b) end
     end b' eb.

Lemma dep_pair_eq :
  forall {T : Type} {a b : T} (eq : a = b) (P : T -> Prop) (pa : P a) (pb : P b),
    @eq_rect T a P pa b eq = pb
    -> exist P a pa = exist P b pb.
Proof.
  intros.
  rewrite <- H.
  rewrite <- eq.
  reflexivity.
Qed.

Ltac apply_tiff_f H1 H2 :=
  let H3 := fresh in (
    (pose proof (fst (H1) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Ltac apply_tiff_b H1 H2 :=
  let H3 := fresh in (
    (pose proof (snd (H1) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Tactic Notation "apply_tiff"  constr(H1) constr(H2) :=
 (apply_tiff_f H1 H2 || apply_tiff_b H1 H2) .

Tactic Notation "refl" := reflexivity.

Theorem and_tiff_compat_l:
 forall A B C : [univ], (B <=> C) -> (A # B <=> A # C).
Proof.
 introv Hiff. rw Hiff. apply t_iff_refl.
Qed.

Definition transport {T:Type} {a b:T} {P:T -> Type} (eq:a=b) (pa: P a) : (P b):=
@eq_rect T a P pa b eq.

Definition typeCast {A B:Type}  (eq:A=B) (pa: A) : (B):=
@eq_rect Type A (fun X => X) pa B eq.

Definition injective_fun {A B: Type} (f: A->B)  :=
  forall (a1 a2: A), (f a1= f a2) -> a1=a2.

Lemma min_eq : forall n1 n2,
  n1=n2 -> min n1 n2 = n2.
Proof.
  introv H. rewrite  H.
  apply Min.min_idempotent.
Qed.

Lemma negb_eq_true :
  forall b, negb b = true <=> ! (assert b).
Proof.
  intro.
  unfold assert; destruct b; simpl; split; sp.
Qed.

Definition left_identity {S T : Type} (f: S -> T) (g: T-> S): Type :=
 forall s: S , (g (f s)) = s.

Definition bijection  {S T : Type} (f: S -> T) (g: T-> S) : Type
 := prod (left_identity f g)  (left_identity g f).

Definition injection {S T : Type} (f: S -> T) :=
  forall (s1 s2 : S), (f s1 = f s2) -> s1=s2.

Lemma left_id_injection: forall {S T : Type} (f: S -> T) (g: T-> S),
  left_identity f g -> injection f.
Proof.
  introv lid feq.
  apply_eq g feq ffeq.
  rw lid in ffeq.
  rw lid in ffeq.
  trivial.
Qed.

Definition equipollent (A B : Type)
 := {f : A -> B $ { g : B -> A $ bijection f g }}.

(** constructive defn. of surjection -- it gives
    the right inverse for free. classical one may
    be obtained by changing [sig] to [ex] *)
Definition Csurjection {S T : Type} (f: S -> T) :=
  forall (t : T), {s : S $ f s =t}.

Lemma injection_surjection_equipollent
  : forall {S T : Type} (f: S -> T) ,
  injection f
  -> Csurjection f
  -> equipollent S T.
Proof.
Abort.
(**
http://cstheory.stackexchange.com/questions/18962/formalizing-the-theory-of-finite-sets-in-type-theory
*)
Definition Fin (n:nat)
  := {m:nat & if lt_dec m n then unit else void}.

Lemma Fin_eq:
  forall (n: nat) (fa fb : Fin n),
    (projT1 fa) = (projT1 fb)
    -> fa = fb.
Proof.
  introv Heq.
  destruct fa as [a ap].
  destruct fb as [b bp].
  allsimpl.
  subst.
  apply eq_existsT with (ea := eq_refl).
  remember (lt_dec b n); destruct s; destruct ap, bp; auto.
Qed.

Lemma Fin_decidable : forall (n:nat), Deq (Fin n).
Proof.
  unfold Deq.
  intros.
  destruct (NPeano.Nat.eq_dec (projT1 x) (projT1 y)) as [T|F];[left|right].
  - apply Fin_eq; auto.
  - intro Heq. destruct F. destruct x. destruct y.
    inverts Heq. allsimpl. reflexivity.
Defined.

Hint Resolve Fin_decidable : Deq.

Lemma equipollent_Deq : forall (A B:Type),
    Deq A
    -> equipollent A B
    -> Deq B.
Proof.
  unfold Deq, equipollent, bijection.
  introv Ha Heq. intros. exrepnd.
  pose proof (Ha (g x) (g y)) as Hd.
  dorn Hd; [left| right].
  - apply left_id_injection in Heq1.
    repnud Heq1. auto.
  - introv Heq. apply Hd. f_equal; auto.
Qed.

Hint Resolve equipollent_Deq : Deq.

Lemma bool2_Equi :
  equipollent bool (Fin 2).
Abort.

(** This is a strong constructive version of
    finiteness of a type. It says that
    there should be a bijection between
    some finite initial segment of numbers
    and that type *)
Definition Finite (T : Type) :=
  {n:nat $ equipollent ( Fin n) T}.

Lemma Finite_Deq : forall (A:Type),
    Finite A
    -> Deq A.
Proof.
  introv Hf.
  repnud Hf. exrepnd.
  (* info_eauto with Deq *)
    eapply equipollent_Deq.
    apply Fin_decidable.
    exact Hf0.
Qed.

Hint Resolve Finite_Deq : Deq.

Lemma prod_assoc :
  forall a b c,
    (a # b) # c <=> a # (b # c).
Proof.
  sp; split; sp.
Qed.

Lemma prod_comm :
  forall a b,
    a # b <=> b # a.
Proof.
  sp; split; sp.
Qed.

Lemma or_true_l :
  forall t, True [+] t <=> True.
Proof. sp. Qed.

Lemma or_true_r :
  forall t, t [+] True <=> True.
Proof. sp. Qed.

Lemma or_false_r : forall t, t [+] False <=> t.
Proof. sp; split; sp. Qed.

Lemma or_false_l : forall t, False [+] t <=> t.
Proof. sp; split; sp. Qed.

Lemma and_true_l :
  forall t, True # t <=> t.
Proof. sp; split; sp. Qed.

Lemma not_false_is_true : !False <=> True.
Proof. sp; split; sp. Qed.

Lemma forall_num_lt_d : forall m P,
  (forall n, n < S m -> P n)
  -> P 0 # (forall n, n <  m -> P (S n) ).
Proof.
  introv Hlt.
  dimp (Hlt 0); auto; [omega|].
  dands; auto.
  introv Hgt.
  apply lt_n_S in Hgt.
  eauto.
Qed.
Ltac dforall_lt_hyp name :=
  repeat match goal with
  [ H : forall  n : nat , n< S ?m -> ?C |- _ ] =>
    apply forall_num_lt_d in H;
    let Hyp := fresh name in
    destruct H as [Hyp H]
  | [ H : forall  x : ?T , _ < 0 -> _ |- _ ] => clear H
  end.

Definition decidable (P: [univ]):= (P + (!P))%type.

Lemma decidable_prod : forall
  (P Q: [univ]),
  decidable P
  -> decidable Q
  -> decidable (P * Q).
Proof.
  introv Hpd Hqd.
  unfold decidable;
  destruct Hpd; destruct Hqd;
  try (left; dands; auto; fail);
  (right; introv Hc; repnd; auto).
Defined.

Require Import Coq.Logic.Eqdep_dec.

Lemma UIPReflDeq: forall { A : Type} (deq : Deq A)
  (a: A) (p: a=a), p= eq_refl.
Proof.
  intros.
  remember (@eq_refl A a) as eqr.
  apply UIP_dec.
  auto.
Qed.

Definition DeqP (A : Type):=
forall x0 y0 : A, x0 = y0 \/ x0 <> y0.

Lemma DeqDeqp : forall {A : Type},
  Deq A -> DeqP A.
Proof.
  introv deq.
  intros x y.
  destruct (deq x y);[left|right]; auto.
Qed.

(** copied from Coq.Logic.EqDep_dec.v
    and converted things from Prop to Type
    (and ex to sigT) *)

 Let projT {A : Type} {x: A} (dec: Deq A)
  {P:A -> Type} (exP: sigT P) (def:P x) : P x :=
   match exP with
     | existT x' prf =>
       match dec x' x with
         | left eqprf => eq_rect x' P prf x eqprf
         | _ => def
       end
   end.
 Theorem injRightsigT:
   forall  {A : Type} {x: A} (dec: Deq A) (P:A -> Type)  (y y':P x),
     existT P x y = existT P x y' -> y = y'.
 Proof.
   intros.
   cut (projT dec
      (existT _ x y) y = projT dec (existT _ x y') y).
   simpl.
   case (dec x x).
   intro e.
   elim e using K_dec; trivial.

  apply DeqDeqp. trivial.

   intros.
   case n; trivial.

   case H.
   reflexivity.
 Qed.

Ltac EqDecSndEq :=
  let dec:= fresh "dec" in
repeat match goal with
[H : @existT ?A _ _ _ = _ |- _ ] =>
  assert (Deq A) as dec by eauto with Deq;
  apply (injRightsigT dec) in H; clear dec
end.

Lemma DeqTrue:  forall {A} (deq : Deq A) (a : A),
  (deq a a) = (left (@eq_refl A a)).
Proof.
  intros; auto.
  destruct (deq a a) as [HH| HH].
  - f_equal.
    apply UIPReflDeq; auto.
  - destruct HH. auto.
Defined.

Lemma DeqSym:  forall {A} T (deq : Deq A) (a b: A)
  (f : (a=b) -> T) (c:T),
  match deq a b with
  | left p => f p
  | _ => c
  end
  =
  match deq b a with
  | left p => f (eq_sym p)
  | _ => c
  end.
Proof.
  intros.
  destruct (deq a b) as [HH| HH].
  - destruct (deq a b) as [H| H]; subst;sp.
    destruct (deq b b); sp;[].
    pose proof (UIPReflDeq deq _  e) as XX.
    rw XX.
    auto.
  - destruct (deq b a) as [H| H]; subst; sp.
Defined.

Definition constantFn {A B : Type} (f: A-> B): [univ] :=
  forall a1 a2, f a1 = f a2.

Lemma constantMapEq :
  forall {A B : Type} (f: A-> B),
  constantFn f
  -> forall l1 l2,
        length l1 = length l2
        -> map f l1 = map f l2.
Proof.
  introv Hc. repnud Hc.
  induction l1 as [| h1 t1 Hind]; introv Hleq;
  destruct l2; inverts Hleq;[|]; simpl. auto.
  f_equal; auto; congruence.
Defined.

Definition DeqBool : Deq bool := bool_dec.

Hint Resolve  deq_prod DeqBool: Deq.

Definition sigTDeq
 {A : Type} (deq : Deq A)
  (P : A -> Type)
  (deqf : forall (a:A), Deq (P a)) :
  Deq (sigT P).
  introv.
  destruct (deq (projT1 x) (projT1 y)) as [Heq | Hneq];
    [| right].
  - destruct x as [xa xb]. allsimpl.
    revert xb. rewrite Heq.
    intros. allsimpl.
    destruct y as [ya yb].
    allsimpl.
    destruct ((deqf ya) xb yb) as [beq | bneq];[left|right].
    + f_equal; auto.
    + introv Hc. EqDecSndEq.
      apply bneq. exact Hc.
  - introv Heq. apply (f_equal (@projT1 _ _)) in Heq.
    apply Hneq. exact Heq.
Defined.

Definition Deq2Bool {A : Type} (deq : Deq A) (a b : A)
  : bool.
destruct (deq a b);[exact true | exact false].
Defined.

Hint Resolve sigTDeq : Deq.

Lemma and_true_r :
  forall t, t # True <=> t.
Proof. sp; split; sp. Qed.


Require Import NoQ.Function.
Require Import NoQ.Monad.

Arguments None {A}.
Arguments Some {A} _.

Definition option_ret {A} : A -> option A := Some.
Definition option_bind {A B} (aM:option A) (f:A -> option B) : option B :=
  match aM with
  | None => None
  | Some a => f a
  end.
Instance Option_Monad : Monad option :=
  { ret := @option_ret
  ; bind := @option_bind
  }.


Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Omega.

Require Import v1.NeutronTactics.
Require Import v1.Multi.
Require Import v1.EpicsTypes.
Require Import v1.EpicsRecords.
Require Import v1.Step.

(* List lemmas - misc *)

(* TODO: move - copied from Interpret.v *)
Lemma in_map_index_list : forall n A x (f : index n -> A),
    In x (map f (index_list n)) ->
    exists i, x = f i.
intros0 Hin.
rewrite in_map_iff in Hin. break_exists. break_and.
eauto.
Qed.

(* List lemmas - forall*)

Lemma forall_app_1 : forall A P (xs ys : list A),
    (Forall P xs /\ Forall P ys) ->
    Forall P (xs ++ ys).
intros. break_and.
rewrite Forall_forall in *.
intros x Hin. apply in_app_or in Hin. destruct Hin; eauto.
Qed.

Lemma forall_app_2 : forall A P (xs ys : list A),
    Forall P (xs ++ ys) ->
    (Forall P xs /\ Forall P ys).
intros. repeat rewrite Forall_forall in *.
split; eauto using in_or_app.
Qed.

Lemma forall_app : forall A P (xs ys : list A),
    Forall P (xs ++ ys) <->
    (Forall P xs /\ Forall P ys).
intros. constructor; eauto using forall_app_1, forall_app_2.
Qed.

Lemma forall_concat : forall A P (xss : list (list A)),
    Forall (Forall P) xss ->
    Forall P (concat xss).
first_induction xss; intros0 Hfa.
{ simpl. constructor. }
inversion Hfa; subst.
simpl. rewrite forall_app. split; eauto.
Qed.

Lemma forall_tail : forall A P (x : A) xs,
    Forall P (x :: xs) ->
    Forall P xs.
inversion 1. assumption.
Qed.
Hint Resolve forall_tail.

Lemma Forall_map : forall A B (P : B -> Prop) (f : A -> B) xs,
    Forall (fun x => P (f x)) xs <-> Forall P (map f xs).
induction xs; intros; split; inversion 1; subst; simpl in *; eauto.
- constructor; eauto. rewrite <- IHxs. assumption.
- constructor; eauto. rewrite -> IHxs. assumption.
Qed.

(*
Lemma forall_for_each : forall n P f,
    (forall i : index n, Forall P (f i)) ->
    Forall P (for_each f).
intros0 Hf.
unfold for_each. eapply forall_concat. rewrite Forall_forall.
intros p Hin. forward eapply in_map_index_list; eauto.
break_exists. subst. eauto.
Qed.
*)

(* List lemmas - skipn *)

Lemma skipn_all : forall A n (xs : list A),
    n >= length xs ->
    skipn n xs = [].
first_induction xs; intros0 Hge.
{ destruct n; reflexivity. }
destruct n; simpl in *; [ omega | ].
eapply IHxs. omega.
Qed.

Lemma skipn_cons : forall A n (xs : list A) x,
    nth_error xs n = Some x ->
    skipn n xs = x :: skipn (S n) xs.
first_induction n; intros0 Hn.
- destruct xs; simpl in *; congruence.
- destruct xs; simpl in *; try congruence.
  eapply IHn. assumption.
Qed.

Lemma skipn_sub : forall A n (xs : list A) x,
    n < length xs ->
    nth_error xs (length xs - S n) = Some x ->
    skipn (length xs - S n) xs = x :: skipn (length xs - n) xs.
intros0 Hn Hlt.

replace (length xs - n) with (S (length xs - S n)) in * by omega.
eapply skipn_cons. assumption.
Qed.

Lemma skipn_sub' : forall A n (xs : list A),
    n < length xs ->
    exists x,
    nth_error xs (length xs - S n) = Some x /\
    skipn (length xs - S n) xs = x :: skipn (length xs - n) xs.
intros0 Hlt.
assert (Hnth : length xs - S n < length xs) by omega.
rewrite <- (nth_error_Some) in Hnth.
destruct (nth_error _ _) eqn:?; try congruence.
eexists; eauto using skipn_sub.
Qed.

(* List lemmas - in *)

Lemma in_concat : forall A (x : A) xss,
    In x (concat xss) ->
    exists xs, In xs xss /\ In x xs.
first_induction xss; intros0 H; simpl in H.
{ destruct H. }
rename a into xs.
eapply in_app_or in H. destruct H as [H | H].
- exists xs. firstorder eauto.
- forward eapply IHxss; eauto. break_exists. break_and.
  firstorder eauto.
Qed.

(*
Lemma in_for_each : forall n f x,
    In x (for_each f) ->
    exists i : index n, In x (f i).
intros0 H.
unfold for_each in H.
eapply in_concat in H. break_exists. break_and.
eapply in_map_index_list in H. break_exists.
subst. eauto.
Qed.
*)

(* Lookup lemmas *)

Lemma lookup_state_type : forall dbs dbt rn rs rt,
    dbt = database_state_type dbs ->
    rt = record_state_type rs ->
    lookup_state dbs rn = Some rs ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrs;
destruct dbs; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_config_type : forall dbc dbt rn rc rt,
    dbt = database_config_type dbc ->
    rt = record_config_type rc ->
    lookup_config dbc rn = Some rc ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrc;
destruct dbc; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_program_type : forall dbp dbt rn rp rt,
    dbt = database_program_type dbp ->
    rt = record_program_type rp ->
    lookup_program dbp rn = Some rp ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrc;
destruct dbp; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_config_type_ex : forall dbc dbt rn rc,
    dbt = database_config_type dbc ->
    lookup_config dbc rn = Some rc ->
    exists rt, lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Hnrc;
destruct dbt; destruct dbc; simpl in *; try congruence.
- eexists. reflexivity.
- fancy_injection Heqdbt. eapply IHrn; eauto.
Qed.

Lemma lookup_state_type_eq : forall dbs dbt rn rs rt,
    dbt = database_state_type dbs ->
    lookup_state dbs rn = Some rs ->
    lookup_type dbt rn = Some rt ->
    rt = record_state_type rs.
first_induction rn; intros0 Heqdbt Hls Hlt;
subst dbt; destruct dbs; simpl in *; try congruence.
eapply IHrn; eauto.
Qed.

Lemma lookup_Some_lt : forall A xs idx x,
    @lookup A xs idx = Some x ->
    idx < length xs.
intros. unfold lookup in *. rewrite <- nth_error_Some. congruence.
Qed.

Lemma lookup_lt_Some_ex : forall A xs idx,
    idx < length xs ->
    exists x, @lookup A xs idx = Some x.
intros. unfold lookup in *. rewrite <- nth_error_Some in H.
destruct (nth_error xs idx).
- eexists. reflexivity.
- congruence.
Qed.

Lemma lookup_length_ex : forall A B xs ys idx x,
    @lookup A xs idx = Some x ->
    (* Put length premise second so it gets processed later by `; eauto`. *)
    length xs = length ys ->
    exists y, @lookup B ys idx = Some y.
first_induction idx; intros;
destruct xs; simpl in *; try congruence;
destruct ys; simpl in *; try congruence.
- eexists. reflexivity.
- eapply IHidx; eauto.
Qed.

Lemma lookup_map : forall A B f xs rn x,
    @lookup A xs rn = Some x ->
    @lookup B (map f xs) rn = Some (f x).
first_induction rn; intros0 Hlook; destruct xs; simpl in *; try congruence.
eapply IHrn. assumption.
Qed.

Lemma lookup_map' : forall A B f xs ys rn x,
    @lookup A xs rn = Some x ->
    ys = map f xs ->
    @lookup B ys rn = Some (f x).
intros0 Hlook Heq. subst ys. eauto using lookup_map.
Qed.

Lemma sum_lt_init : forall xs x x',
    x < x' ->
    fold_left Nat.add xs x < fold_left Nat.add xs x'.
first_induction xs; intros0 Hlt; simpl in *.
{ assumption. }
apply IHxs. omega.
Qed.

Lemma sum_base_split : forall b1 b2 xs,
    fold_left Nat.add xs (b1 + b2) = b1 + fold_left Nat.add xs b2.
first_induction xs; intros; simpl.
{ omega. }
replace (b1 + b2 + a) with (b1 + (b2 + a)) by omega.
eapply IHxs.
Qed.

Lemma sum_base_add : forall b xs,
    fold_left Nat.add xs b = b + fold_left Nat.add xs 0.
intros.
replace b with (b + 0) at 1 by omega.
eapply sum_base_split.
Qed.

Lemma sum_cons : forall x xs base,
    fold_left Nat.add (x :: xs) base =
    x + fold_left Nat.add xs base.
intros. simpl.
rewrite Nat.add_comm.
eapply sum_base_split.
Qed.

Lemma sum_app : forall xs1 xs2 base,
    fold_left Nat.add (xs1 ++ xs2) base =
    base + fold_left Nat.add xs1 0 + fold_left Nat.add xs2 0.
intros.
rewrite fold_left_app. simpl.
rewrite <- sum_base_add, <- sum_base_add.
reflexivity.
Qed.

Lemma sum_init' : forall xs base x,
    fold_left Nat.add xs (base + x) =
    base + fold_left Nat.add xs x.
first_induction xs; intros; simpl.
{ omega. }
replace (base + x + a) with (base + (x + a)) by omega.
apply IHxs.
Qed.

Lemma sum_init : forall xs base,
    fold_left Nat.add xs base =
    base + fold_left Nat.add xs 0.
intros. replace (base) with (base + 0) at 1 by omega. eapply sum_init'.
Qed.

(* list_magic and friends *)

(* core lemmas used by list_magic *)
Lemma Forall_nth_error : forall X (P : X -> Prop) xs,
    Forall P xs ->
    (forall i x, nth_error xs i = Some x -> P x).
intros.
rewrite Forall_forall in *.
eauto using nth_error_In.
Qed.

Lemma nth_error_Forall : forall X (P : X -> Prop) xs,
    (forall i x, nth_error xs i = Some x -> P x) ->
    Forall P xs.
intros. rewrite Forall_forall in *. intros.
forward eapply In_nth_error; eauto. break_exists. eauto.
Qed.

Lemma Forall2_length : forall X Y (P : X -> Y -> Prop) xs ys,
    Forall2 P xs ys ->
    length xs = length ys.
induction xs; intros0 Hfa; invc Hfa; simpl; eauto.
Qed.

Lemma Forall2_nth_error : forall X Y (P : X -> Y -> Prop) xs ys,
    Forall2 P xs ys ->
    (forall i x y,
        nth_error xs i = Some x ->
        nth_error ys i = Some y ->
        P x y).
induction xs; intros0 Hfa; invc Hfa; intros0 Hnx Hny.
- destruct i; discriminate Hnx.
- destruct i; simpl in Hnx, Hny.
  + congruence.
  + eapply IHxs; eauto.
Qed.

Lemma nth_error_Forall2 : forall X Y (P : X -> Y -> Prop) xs ys,
    length xs = length ys ->
    (forall i x y,
        nth_error xs i = Some x ->
        nth_error ys i = Some y ->
        P x y) ->
    Forall2 P xs ys.
induction xs; intros0 Hlen Hnth; destruct ys; invc Hlen.
- constructor.
- constructor.
  + eapply Hnth with (i := 0); reflexivity.
  + eapply IHxs; eauto.
    intros. eapply Hnth with (i := S i); simpl; eauto.
Qed.

Lemma length_nth_error_Some : forall X Y  xs ys x i,
    @length X xs = @length Y ys ->
    nth_error xs i = Some x ->
    exists y, nth_error ys i = Some y.
intros.
destruct (nth_error ys i) eqn:?; try eauto.
rewrite nth_error_None in *.
assert (nth_error xs i <> None) by congruence.
rewrite nth_error_Some in *.
omega.
Qed.

Lemma Forall2_nth_error_Some : forall X Y (P : X -> Y -> Prop) xs ys x i,
    Forall2 P xs ys ->
    nth_error xs i = Some x ->
    exists y, nth_error ys i = Some y.
intros. eapply length_nth_error_Some. eapply Forall2_length. all:eauto.
Qed.

(* list_magic_using H:

   Given this context and goal:

    H : forall i,
        forall x, nth_error xs i = Some x ->
        forall y, nth_error ys i = Some y ->
        P x ->
        Q y ->
        R x y ->
        S x
    Hp : Forall P xs
    Hq : Forall Q ys
    Hr : Forall2 R xs ys
     -----
    Forall S x

   Complete the entire proof, by combining `H` with the lemmas above.
 *)

Ltac collect_length_hyps :=
    repeat match goal with
    | [ H : Forall2 _ ?xs_ ?ys_ |- _ ] =>
            lazymatch goal with
            | [ H : length xs_ = length ys_ |- _ ] => fail (* already known *)
            | [ |- _ ] =>
                    forward eapply Forall2_length with (xs := xs_) (ys := ys_) (1 := H)
            end
    end.

Ltac find_matching_entries HH i :=
    repeat match type of HH with
    | forall y, nth_error ?ys_ i = Some y -> _ =>
            first
                [ specialize (HH ?? **)
                | let Hexist := fresh "H" in
                  let y := fresh "y" in
                  let Hy := fresh "H" y in
                  forward eapply length_nth_error_Some with (ys := ys_) as Hexist;
                  [ | eassumption | ];
                  [ congruence | ];
                  destruct Hexist as [y Hy];
                  specialize (HH y Hy) ]
    end.

Ltac require_no_match P :=
    lazymatch goal with
    | [ H : P |- _ ] => fail "expected no hypothesis matching" P ", but found" H
    | [ |- _ ] => idtac
    end.

Ltac collect_entry_hyps i :=
    repeat match goal with
    | [ Hfa : Forall ?P ?xs, Hnth : nth_error ?xs i = Some ?x |- _ ] =>
            require_no_match (P x);
            assert (P x) by (eapply Forall_nth_error with (1 := Hfa) (2 := Hnth))
    | [ Hfa : Forall2 ?P ?xs ?ys,
        Hnx : nth_error ?xs i = Some ?x,
        Hny : nth_error ?ys i = Some ?y |- _ ] =>
            require_no_match (P x y);
            assert (P x y) by
                (eapply Forall2_nth_error with (1 := Hfa) (2 := Hnx) (3 := Hny))
    end.

Ltac list_magic_using HH :=
    let i := fresh "i" in
    collect_length_hyps;
    (eapply nth_error_Forall || (eapply nth_error_Forall2; [congruence | ..]));
    intro i; intros;
    specialize (HH i);
    collect_length_hyps; find_matching_entries HH i; collect_entry_hyps i;
    eapply HH; eauto.

(* list_magic_on (xs, (ys, (zs, tt))):

   Assert and attempt to prove a suitable `H`, based on the uses of `Forall` on
   `xs`, `ys`, and `zs` in the context and goal.  Solves goals of the form
   `Forall P xs` or `Forall P xs ys`, but may produce a subgoal to prove that
   `P` holds on a particular `x`. *)

Ltac build_list_magic_hyp_type_inner lists G :=
    let i := fresh "i" in
    simple refine (forall i : nat, (_ : Prop));
    let rec loop ls :=
        lazymatch ls with
        | (?l, ?ls) =>
                let x := fresh l "_" i in
                let Hx := fresh "H" x in
                simple refine (forall x, forall Hx : nth_error l i = Some x, (_ : Prop));
                loop ls
        | tt => idtac
        end in
    loop lists;
    repeat match goal with
    | [ Hfa : Forall ?P ?xs,
        Hnth : nth_error ?xs i = Some ?x |- _ ] =>
            simple refine (P x -> (_ : Prop));
            clear Hfa
    | [ Hfa : Forall2 ?P ?xs ?ys,
        Hnthx : nth_error ?xs i = Some ?x,
        Hnthy : nth_error ?ys i = Some ?y |- _ ] =>
            simple refine (P x y -> (_ : Prop));
            clear Hfa
    end;
    lazymatch G with
    | Forall ?P ?xs =>
            lazymatch goal with
            | [ Hnth : nth_error xs i = Some ?x |- _ ] =>
                    exact (P x)
            end
    | Forall2 ?P ?xs ?ys =>
            lazymatch goal with
            | [ Hnthx : nth_error xs i = Some ?x,
                Hnthy : nth_error ys i = Some ?y |- _ ] =>
                    exact (P x y)
            end
    end.

Ltac build_list_magic_hyp_type H_ty lists :=
    match goal with
    | [ |- ?G ] =>
            simple refine (let H_ty : Prop := _ in _);
            [ build_list_magic_hyp_type_inner lists G
            | simpl in H_ty ]
    end.

Ltac list_magic_on lists :=
    let H := fresh "H" in
    let H_ty := fresh H "_ty" in
    build_list_magic_hyp_type H_ty lists;
    assert (H : H_ty); unfold H_ty in *; clear H_ty;
        [ intros; eauto | try list_magic_using H ].

Fixpoint numbered' {A} n (xs : list A) :=
    match xs with
    | [] => []
    | x :: xs => (n, x) :: numbered' (S n) xs
    end.

Definition numbered {A} (xs : list A) := numbered' 0 xs.

Lemma numbered'_map_snd : forall A n (xs : list A),
    map snd (numbered' n xs) = xs.
first_induction xs; intros; eauto.
- simpl. f_equal. eauto.
Qed.

Lemma numbered_map_snd : forall A (xs : list A),
    map snd (numbered xs) = xs.
unfold numbered. intros. eapply numbered'_map_snd.
Qed.

Definition map_partial {A B} (f : A -> option B) : list A -> option (list B) :=
    let fix go xs :=
        match xs with
        | [] => Some []
        | x :: xs =>
                match f x, go xs with
                | Some y, Some ys => Some (y :: ys)
                | _, _ => None
                end
        end in go.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Basic definitions: float and rounding property *)
Require Import Fcore_Raux.

Section Def.

(** Definition of a floating-point number *)
Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }.

Implicit Arguments Fnum [[beta]].
Implicit Arguments Fexp [[beta]].

Variable beta : radix.

Definition F2R (f : float beta) :=
  (Z2R (Fnum f) * bpow beta (Fexp f))%R.

(** Requirements on a rounding mode *)
Definition round_pred_total (P : R -> R -> Prop) :=
  forall x, exists f, P x f.

Definition round_pred_monotone (P : R -> R -> Prop) :=
  forall x y f g, P x f -> P y g -> (x <= y)%R -> (f <= g)%R.

Definition round_pred (P : R -> R -> Prop) :=
  round_pred_total P /\
  round_pred_monotone P.

End Def.

Implicit Arguments Fnum [[beta]].
Implicit Arguments Fexp [[beta]].
Implicit Arguments F2R [[beta]].

Section RND.

(** property of being a round toward -inf *)
Definition Rnd_DN_pt (F : R -> Prop) (x f : R) :=
  F f /\ (f <= x)%R /\
  forall g : R, F g -> (g <= x)%R -> (g <= f)%R.

Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_DN_pt F x (rnd x).

(** property of being a round toward +inf *)
Definition Rnd_UP_pt (F : R -> Prop) (x f : R) :=
  F f /\ (x <= f)%R /\
  forall g : R, F g -> (x <= g)%R -> (f <= g)%R.

Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_UP_pt F x (rnd x).

(** property of being a round toward zero *)
Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) :=
  ( (0 <= x)%R -> Rnd_DN_pt F x f ) /\
  ( (x <= 0)%R -> Rnd_UP_pt F x f ).

Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_ZR_pt F x (rnd x).

(** property of being a round to nearest *)
Definition Rnd_N_pt (F : R -> Prop) (x f : R) :=
  F f /\
  forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R.

Definition Rnd_N (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_N_pt F x (rnd x).

Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  ( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ).

Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_NG_pt F P x (rnd x).

Definition Rnd_NA_pt (F : R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R.

Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_NA_pt F x (rnd x).

End RND.


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

Require Import HoTT HoTT.hit.Truncations Connectedness.
Require Export Utf8_core.
Require Import Forall_.
Require Import epi_mono reflective_subuniverse modalities.
Require Import sheaf_base_case.

Set Universe Polymorphism.
Global Set Primitive Projections.

Local Open Scope path_scope.
(* Local Open Scope equiv_scope. *)
Local Open Scope type_scope.

(* Readability *)
Arguments trunc_arrow {H} {A} {B} {n} H0: simpl never.
Arguments trunc_sigma {A} {P} {n} H H0: simpl never.
Arguments istrunc_paths {A} {n} H x y: simpl never.

Section Definitions.

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

  Parameter n0 : trunc_index.

  Definition n := trunc_S n0.

  Parameter mod_nj : Modality n.

  Definition nj := underlying_subu n mod_nj.

  (* The following two parameters are the hypothesis 26 *)
  Parameter j_is_nj : forall P, trunctype_type (j P) = trunctype_type (@st _ _ (O nj (@BuildTruncType _ P (@trunc_leq -1 n tt _ _)))).

  Parameter j_is_nj_unit : forall P x ,
                          transport idmap (j_is_nj P) (Oj_unit P x) = O_unit nj (@BuildTruncType _ P (@trunc_leq -1 n tt _ _)) x.

  Parameter islex_mod_nj : IsLex mod_nj.

  Definition islex_nj := islex_to_hfibers_preservation mod_nj islex_mod_nj.
  Definition lex_compat := islex_to_hfibers_preservation_compat mod_nj islex_mod_nj.

  Definition J :=
    (* pr1 (nchar_to_sub (pr1 o Oj)). *)
  {P : hProp & j P}.

  Definition Oj_J_Contr (χ:J) : Contr (j χ.1).
    apply BuildContr with (center := χ.2).
    intro. apply path_ishprop.
  Defined.

  Definition nJ := {T : TruncType n & (O nj T)}.

  (* Definition 18, for subobjects seen as a characteristic function [χ : E -> TruncType n], or as n-fibered functions *)
  Definition closed {E} (χ : E -> TruncType n) := forall e, IsEquiv (nj.(O_unit) (χ e)).

  (* Definition closed' E A (m : {f : A -> E & forall b:E, IsTrunc n (hfiber f b)}) := closed (nsub_to_char n (A;m)). *)

  Definition cloture {E} (χ : E -> TruncType n) : E -> TruncType n := nj.(O) o χ.

  (* Definition cloture' E A (m : {f : A -> E & forall b:E, IsTrunc n (hfiber f b)}) := *)
    (* nchar_to_sub (cloture (nsub_to_char n (A;m))). *)

  (* Proofs that the the closure of a subobject is closed *)
  Definition cloture_is_closed {E :Type} (χ : E -> TruncType n) : closed (cloture χ).
    intro. apply O_modal_equiv. exact fs.
  Defined.

  (* Lemma cloture_is_closed' (A:Type) (E:Type) (m : {f : A -> E & forall e:E, IsTrunc n (hfiber f e)}) : closed' (pr2 (cloture' m)). *)
  (*   unfold closed', cloture'.  *)
  (*   rewrite (eta_sigma (nchar_to_sub (cloture (nsub_to_char n (A; m))))). *)
  (*   pose (f := cloture_is_closed (nsub_to_char n (A; m))).  *)
  (*   rewrite <- (@nsub_eq_char_retr ua fs n _ (cloture (nsub_to_char n (A; m)))) in f. *)
  (*   exact f. *)
  (* Defined. *)

  Definition incl_Aeq_Eeq {E:Type} (χ:E -> TruncType n) (x:{e:E & χ e})
  : {e':{e:E & χ e} & x.1 = e'.1} -> {e':E & x.1 = e'}
    := λ X, (X.1.1;X.2).

  Definition eq_dense_1 {E:Type} (χ:E -> TruncType n) (x:{e:E & χ e})
  : {e':{e:E & χ e} & x.1 = e'.1} <~> (χ x.1).
    exists (λ X:(∃ e' : ∃ e : E, χ e, x.1 = e'.1), (transport (λ u, χ u) (X.2)^ X.1.2)).
    apply isequiv_adjointify with (g := (λ X, ((x.1;X);1)) : ((χ x.1) -> {e':{e:E & χ e} & x.1 = e'.1})).
    - intro u. reflexivity.
    - intro u. destruct u as [[e' e] p]. simpl in *. destruct p. simpl. reflexivity.
  Defined.

  Definition is_dense_eq {E:Type} (char : E -> TruncType n) := forall e:E, ({e':E & e=e'}) = O nj (char e).

  Definition is_dense_diag {E:Type} (char : E -> TruncType n) (dense_eq : is_dense_eq char)
    := forall x:{e:E & char e}, forall u:{e':{e:E & char e} & x.1 = e'.1}, (equiv_path _ _ (dense_eq x.1)) o (incl_Aeq_Eeq char x) = (O_unit nj _) o ((eq_dense_1 char x)).

(* For A a subobject of E, and x:A, this diagram commute : *)
(*                                                         *)
(*   {e':A & x.1 = e'.1} === (χ x.1).1                     *)
(*          |                    |                         *)
(*        ι |                    | η                       *)
(*          |                    |                         *)
(*          v                    v                         *)
(*    {e':E & x.1 = e'}  === (O nj (χ x.1)).1.1            *)

  (* Definition 19 *)
  Record EnJ (E:Type) :=
    {
      char :> E -> TruncType n ;
      dense_eq : forall e:E, ({e':E & e=e'}) = (O nj (char e))
    }.

  Arguments char {E} χ e: rename.
  Arguments dense_eq {E} χ e: rename.

  Definition dense_diag {E:Type} (char : EnJ E)
  : forall x:{e:E & char e}, forall u:{e':{e:E & char e} & x.1 = e'.1}, (equiv_path _ _ (dense_eq char x.1)) o (incl_Aeq_Eeq char x) = (O_unit nj _) o ((eq_dense_1 char x)).
    intros x u.
    apply path_forall; intro z.
    assert (Contr (O nj (char x.1))).
    { rewrite <- dense_eq. exists (x.1;1). intros [y q]. destruct q. reflexivity. }
    apply (path_contr).
  Qed.

  Definition witness_is_eta {E:Type} (χ:EnJ E) (x:{e:E & χ e})
  : transport idmap (dense_eq χ x .1) (x .1; 1) = O_unit nj (χ x .1) x.2
    := ap10 (dense_diag χ x (x;1)) (x;1).

  Definition EnJ_is_nJ {E:Type} (χ : EnJ E)
  : forall e:E, (O nj (χ e))
    := λ e, transport (λ T, T) (dense_eq χ e) (e;idpath).

  Definition dense_eta_equal {E:Type} (χ : EnJ E) (x:E) : forall (v w:χ x), O_unit nj (χ x) v = O_unit nj (χ x) w.
    intros v w.
    assert (forall (a b:(∃ e' : E, x = e')), a=b).
    intros a b.
    destruct a as [a p], b as [b q]. simpl.
    apply @path_sigma' with (p := p^@q).
    destruct p. destruct q. simpl. reflexivity.
    rewrite (dense_eq χ) in X; apply X.
  Defined.

  (* Definition 20, for (-1)-subobjects *)
  Definition E_to_χmono_map (T:TruncType (trunc_S n)) {E} (χ : E -> J) (f : E -> T) :
    {x:E & (χ x).1} -> T := f o pr1.

  Arguments E_to_χmono_map T {E} χ f _.

  (* Definition 20, for n-subobjects *)
  Definition E_to_χ_map (T:TruncType (trunc_S n)) {E} (χ : EnJ E) (f : E -> T) :
    {x:E & χ x} -> T := f o pr1.

  (* Definition 21 *)
  Definition separated T :=  ∀ E (χ : EnJ E), IsMono (E_to_χ_map T (E:=E) χ).

  (* Definition 22 *)
  Definition Snsheaf_struct T := (separated T) /\ (∀ E (χ : E -> J), IsEquiv (E_to_χmono_map T (E:=E) (χ))).

  Definition SnType_j_Type := {T : TruncType (trunc_S n) & Snsheaf_struct T}.

  Definition separated_is_HProp T : IsHProp (separated T).
    repeat (apply trunc_forall).
  Defined.

  Definition Snsheaf_struct_is_HProp T : IsHProp (Snsheaf_struct T).
    apply trunc_prod.
  Defined.

  (* If T is a n-Type, then if T is a n-sheaf, then T is also a (S n)-sheaf *)

  Lemma nsheaf_to_Snsheaf (T:TruncType (trunc_S n)) (Trn : IsTrunc n T) (nsheaf : IsSubu _ nj (@BuildTruncType n T Trn))
  : Snsheaf_struct T.
    split.
    { intros E χ u v.
      simple refine (isequiv_adjointify _ _ _ _).
      - unfold E_to_χ_map; simpl; intro p.
        apply path_forall; intro x.
        destruct χ as [χ χeq χdiag]. simpl in *.
        pose proof (transport idmap (χeq x) (x;1)). simpl in X.
        revert X.
        transparent assert (modal_family : (subuniverse_Type nj)).
        { simple refine (Build_subuniverse_Type _ nj (BuildTruncType _ (u x = v x)) _).
          apply istrunc_paths. apply trunc_succ. exact Trn.
          exact (subuniverse_paths _ nj (Build_subuniverse_Type _ nj (@BuildTruncType _ T Trn) nsheaf) (u x) (v x)). }
        apply (O_rec _ nj (χ x) modal_family); unfold modal_family; clear modal_family.
        intro xx; simpl.
        exact (ap10 p (x;xx)).
      - intro p. simpl. unfold E_to_χ_map in *; simpl in *.
        apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
        apply path_forall; intro x.
        pose (rew := @ap10_ap_precompose); unfold ap10 in rew; rewrite rew; clear rew.
        unfold ap10 at 1, path_forall at 1; rewrite eisretr. simpl.
        assert (χdiag := dense_diag χ).
        destruct χ as [χ χeq]. simpl in *.
        specialize (χdiag x (x;1)).
        unfold incl_Aeq_Eeq in χdiag.
        apply ap10 in χdiag.
        specialize (χdiag (x;1)). simpl in χdiag.
        rewrite χdiag.
        match goal with
          |[|- O_rec _ _ _ ?X _ _ = _] => set (sheaf := X) end.
        exact (ap10 (O_rec_retr _ _ (χ x.1) sheaf (λ xx : (χ x.1), ap10 p (x.1; xx))) x.2).
      - intro p. destruct p. simpl.
        match goal with
          |[|- path_forall u u ?X = _] => assert (X=(λ _, 1)) end.
        { apply path_forall; intro x. rewrite O_rec_const. reflexivity. }
        rewrite X. apply path_forall_1. }
    { intros E χ.
      simple refine (isequiv_adjointify _ _ _ _).
      - intros f x.
        unfold J in χ; simpl in *.
        assert (p := transport idmap (j_is_nj (χ x).1) (χ x).2).
        revert p. simpl. apply (O_rec _ nj _ (Build_subuniverse_Type _ nj (@BuildTruncType _ T Trn) nsheaf)).
        intros xx. simpl in *.
        exact (f (x;xx)).
      - intro f. apply path_forall; intro x; simpl in *.
        unfold E_to_χmono_map; simpl.
        assert ((χ x.1).2 = (Oj_unit (χ x.1).1 x.2)) by apply path_ishprop.
        rewrite X.
        transparent assert (TrH: (IsTrunc n ((λ x : E, (χ x).1) x.1))).
        intros x0 y. apply (@trunc_leq -1 n). exact tt. exact (istrunc_trunctype_type _).
        path_via (O_rec n nj
                        {|
                          trunctype_type := (χ x.1).1;
                          istrunc_trunctype_type := _ |}
                        {|
                          st := {| trunctype_type := T; istrunc_trunctype_type := Trn |};
                          subu_struct := nsheaf |}
                        (λ xx : (χ x.1).1, f (x.1;xx))
                        (O_unit nj {|
                          trunctype_type := (χ x.1).1;
                          istrunc_trunctype_type := _ |}
                                x.2)).

        apply ap. exact (j_is_nj_unit (χ x.1).1 x.2).
        exact (ap10 (O_rec_retr _ _ {| trunctype_type := (χ x.1).1; istrunc_trunctype_type := TrH |}
                                {|
     st := {| trunctype_type := T; istrunc_trunctype_type := Trn |};
     subu_struct := nsheaf |}
                                (λ xx : ((χ x.1).1), f (x.1; xx)))
                    x.2).
      - intro f.
        apply path_forall; intro x.
        assert (p := transport idmap (j_is_nj (χ x).1) (χ x).2).
        revert p. simpl.
        transparent assert (sheaf : (subuniverse_Type nj)).
        { simple refine (Build_subuniverse_Type n nj
           (BuildTruncType _ (O_rec n nj
       {|
       trunctype_type := (χ x).1;
       istrunc_trunctype_type := _ |}
       {|
       st := {| trunctype_type := T; istrunc_trunctype_type := Trn |};
       subu_struct := nsheaf |}
       (λ xx : (χ x).1, E_to_χmono_map T χ f (x; xx))
       (transport (λ x0 : Type, x0) (j_is_nj (χ x).1) (χ x).2) =
     f x)) _). }
        apply (O_rec _ _ _ sheaf).
        unfold sheaf; clear sheaf. simpl. intro xx.
        pose (j_is_nj_unit (χ x).1 xx).
        assert ((χ x).2 = (Oj_unit (χ x).1 xx)) by apply path_ishprop.
        rewrite X.
        transparent assert (TrH: (IsTrunc n ((λ x : E, (χ x).1) x))).
        intros x0 y. apply (@trunc_leq -1 n). exact tt. exact (istrunc_trunctype_type _).
        path_via (O_rec n nj
                        {|
                          trunctype_type := (χ x).1;
                          istrunc_trunctype_type := _|}
                        {|
                          st := {| trunctype_type := T; istrunc_trunctype_type := Trn |};
                          subu_struct := nsheaf |}
                        (λ xx0 : (χ x).1, E_to_χmono_map T χ f (x; xx0))
                        (O_unit nj
                                {|
                          trunctype_type := (χ x).1;
                          istrunc_trunctype_type := _|} xx)).
        apply ap; exact p.
        exact (ap10 (O_rec_retr _ nj {| trunctype_type := (χ x).1; istrunc_trunctype_type := TrH |} {|
     st := {| trunctype_type := T; istrunc_trunctype_type := Trn |};
     subu_struct := nsheaf |} (λ xx0 : (χ x).1, E_to_χmono_map T χ f (x; xx0))) xx). }
  Defined.

  Definition nj_inter_f (A : TruncType n) (φ : A -> TruncType n) :
    (O nj (BuildTruncType _ {a:A & φ a})) ->
    (O nj (BuildTruncType _ {a:A & (O nj (φ a))}))
    := function_lift _
         nj
         (BuildTruncType _ {a:A & φ a})
         (BuildTruncType _ {a:A & (O nj (φ a))})
         (λ X, (X.1;nj.(O_unit) _ X.2)).

  Definition nj_inter_g (A : TruncType n) (φ : A -> TruncType n) :
    (O nj (BuildTruncType _ {a:A & (O nj (φ a))})) ->
    (O nj (BuildTruncType _ {a:A & φ a})).
  Proof.
    apply O_rec. intro X.
    generalize X.2. apply O_rec; intro φa.
    apply nj.(O_unit). exact (X.1;φa).
  Defined.

  Instance nj_inter_equiv (A : TruncType n) (φ : A -> TruncType n) : IsEquiv (nj_inter_f A φ).
  apply (isequiv_adjointify _ (nj_inter_g A φ)).
  - intro x. unfold nj_inter_f, nj_inter_g. simpl in *.
    transitivity (function_lift n nj
                      (BuildTruncType _ {a:A & φ a})
                      (BuildTruncType _ {a:A & (O nj (φ a))})
                      (λ X : ∃ a : A, φ a,
                         (X.1;
                          O_unit nj
                                 (default_TruncType n (φ X.1) (istrunc_trunctype_type (φ X.1))) X.2))
                      (O_rec n nj
                         (BuildTruncType _ {a:A & (O nj (φ a))})
                         (O nj
                            (BuildTruncType _ {a:A & φ a}))
                         (λ X : (BuildTruncType _ {a:A & (O nj (φ a))}),
                            (function_lift n nj (φ X.1) (BuildTruncType _ {a:A & φ a}) (λ b, (X.1;b)))
                              X .2) x)
      ); auto with path_hints.

    pose (foo := ap10 (reflect_factoriality_pre n nj
                         (BuildTruncType _ {a:A & (O nj (φ a))})
                         (((O nj
                              (BuildTruncType _ {a:A & φ a}))))
                         (((O nj
                              (BuildTruncType _ {a:A & (O nj (φ a))}))))
                         (function_lift n nj
                                        (BuildTruncType _ {a:A & φ a})
                                        (BuildTruncType _ {a:A & (O nj (φ a))})
                                        (λ X : (BuildTruncType _ {a:A & φ a}), (X .1; O_unit nj (φ X .1) X .2)))
                         ((λ X : (BuildTruncType _ {a:A & (O nj (φ a))}),
                             function_lift n nj (φ X .1)
                                           (BuildTruncType _ {a:A & φ a}) (λ b : φ X.1, (X.1; b))
                                           X .2))) x
         ).
    etransitivity; try exact foo. clear foo.

    transitivity (
        O_rec n nj
          (BuildTruncType _ {a:A & (O nj (φ a))})
          (O nj
             (BuildTruncType _ {a:A & (O nj (φ a))}))
          (λ x0 :(BuildTruncType _ {a:A & (O nj (φ a))}),
             function_lift n nj (φ x0 .1)
                           (BuildTruncType _ {a:A & (O nj (φ a))})
                           (λ x : (φ x0 .1), (x0 .1; O_unit nj (φ x0 .1) x))
                           x0 .2) x
      ).
    apply (ap (λ u, O_rec n nj
                      (BuildTruncType _ {a:A & (O nj (φ a))})
                      (O nj
                         (BuildTruncType _ {a:A & (O nj (φ a))})) u x)).
    apply path_forall; intro x0.
    exact (ap10 (reflect_functoriality
                   n nj
                   (φ x0 .1)
                   (BuildTruncType _ {a:A & (φ a)})
                   (BuildTruncType _ {a:A & (O nj (φ a))})
                   (λ X, (X .1; O_unit nj (φ X .1) X .2))
                   (λ b : (φ x0 .1), (x0 .1; b))) x0.2
          ).
    exact (ap10 (O_rec_O_rec_dep_sect n nj
                                      (BuildTruncType _ {a:A & (O nj (φ a))})
                                      (λ a, (φ a.1))
                                      (λ u, λ v, (u.1;v))
                                      (λ u, u.2)
                                      (λ a, eta_sigma a)) x); simpl in foo.
  - intro x. unfold nj_inter_f, nj_inter_g. simpl.
    pose (foo := ap10 (reflect_factoriality_post n nj
                         (BuildTruncType _ {a:A & (φ a)})
                         (BuildTruncType _ {a:A & (O nj (φ a))})
                         (O nj
                            (BuildTruncType _ {a:A & (φ a)}))
                         (λ X : (BuildTruncType _ {a:A & (O nj (φ a))}),
                                O_rec n nj (φ X .1)
                                      (O nj
                                         (BuildTruncType _ {a:A & (φ a)}))
                                      (λ φa : (φ X .1),
                                              O_unit nj
                                                     (BuildTruncType _ {a:A & (φ a)})
                                                     (X .1; φa)) X .2)
                         (λ X,
                                (X .1; O_unit nj (φ X .1) X .2)))
                      x
         ).

    etransitivity; try exact foo. clear foo.
    apply (ap10 (O_rec_O_rec_dep_retr n nj
                                      (BuildTruncType _ {a:A & (φ a)})
                                      (λ a, (φ a .1))
                                      (λ a b, (a.1;b))
                                      (λ a, a.2)
                                      (λ a, eta_sigma a))
                x).
  Defined.

  Definition nj_inter (A : TruncType n) (φ : A -> TruncType n) :
    O nj (BuildTruncType n {a:A & (φ a)}) =
    O nj (BuildTruncType n {a:A & (O nj (φ a))}).
  Proof.
    apply unique_subuniverse.
    apply path_trunctype.
    exact (BuildEquiv _ _ _ (nj_inter_equiv _ _)).
  Defined.

  (** Put that elsewhere *)

  Lemma istruncmap_compose n {A B C:Type} (f:A -> B) (g: B -> C)
    : IsTruncMap n f -> IsTruncMap n g -> IsTruncMap n (g o f).
  Proof.
    intros Hf Hg.
    intro x.
    simple refine (trunc_equiv' _ (hfiber_compose f g x)^-1).
  Defined.

  Instance istruncmap_charn n {B:Type} (P: B -> TruncType n)
    : IsTruncMap n (pr1: sig P -> B).
  Proof.
    intro b. unfold hfiber.
    simple refine (@trunc_equiv (P b) _ (λ x:P b, ((b;x);1)) _ _ _).
    simple refine (isequiv_adjointify _ _ _ _).
    exact (fun X => transport (λ b, P b) (X.2) (X.1.2)).
    intros [[b' P'] eqb']; cbn in *. destruct eqb'.
    reflexivity.
    intro x; reflexivity.
  Defined.

  Lemma hfiber_compose_mono {A B C:Type} (f : A -> B) (g : B -> C) (Mg: IsMono g) b
    : hfiber f b <~> hfiber (g o f) (g b).
  Proof.
    simple refine (equiv_adjointify _ _ _ _).
    - intros [x p]. exact (x; ap g p).
    - intros [x p]. exact (x; (equiv_inv (IsEquiv := Mg (f x) b)) p).
    - intros [x p]. simple refine (path_sigma' _ 1 _); cbn.
      apply eisretr.
    - intros [x p]. simple refine (path_sigma' _ 1 _); simpl.
      apply eissect.
  Defined.

  (*********)

  (* Lemma 24 *)

  Definition nj_fibers_compose A B C (f : A -> B) (g : B -> C) (c : C)
             (HB : IsTruncMap n f) (HC : IsTruncMap n g)
  :
    O nj (@BuildTruncType _ (hfiber (g o f) c) (istruncmap_compose n f g HB HC c)) =
    O nj (BuildTruncType _ { w : hfiber g c & O nj (BuildTruncType _ (hfiber f w.1))}).
  Proof.
    etransitivity; [exact (ap (O nj) (@path_trunctype ua n (@BuildTruncType _ (hfiber (λ x : A, g (f x)) c) (istruncmap_compose n f g HB HC c)) _ (hfiber_compose f g c)))| cbn].
    apply unique_subuniverse. unfold default_TruncType.
    exact (ap (@st n nj) (nj_inter (@BuildTruncType _ (hfiber g c) (HC c)) (fun w => (@BuildTruncType _ (hfiber f w .1) (HB w.1))))).
  Defined.

  Definition type_j_f {E} (χ: E -> J)
  : (E -> subuniverse_Type nj) -> {e:E & (χ e).1}  -> subuniverse_Type nj
    := λ α e, α (pr1 e).

  Definition type_j_inv {E} (χ: E -> J) : ({e:E & (χ e).1} -> subuniverse_Type nj) -> E -> subuniverse_Type nj.
  Proof.
    intros α e.
    apply (O nj).
    pose (m := pr1 : {e:E & (χ e).1} -> E).
    pose (f := pr1 : {e: (∃ e : E, (χ e).1) & (α e)} -> (∃ e : E, (χ e).1)).
    assert (IsTruncMap n (m o f)).
    apply istruncmap_compose. apply istruncmap_charn.
    intro x. exact (@trunc_leq -1 n tt _ (istruncmap_charn -1 (pr1 o χ) x)).
    exact (BuildTruncType _ (hfiber (λ x : ∃ e : ∃ e : E, (χ e).1, α e, m (f x)) e)).
  Defined.

  Definition inter_symm E (χ φ : E -> Type) x :
  hfiber (λ t : {b : {b : E & χ b} & φ (pr1 b)}, pr1 (pr1 t)) x <~>
  hfiber (λ t : {b : {b : E & φ b} & χ (pr1 b)}, pr1 (pr1 t)) x.
    unfold hfiber. cbn.
    simple refine (equiv_functor_sigma' _ _).
    simple refine (equiv_adjointify _ _ _ _).
    - intros [[a b] c]. exact ((a;c);b).
    - intros [[a b] c]. exact ((a;c);b).
    - intros a. reflexivity.
    - intros a. reflexivity.
    - intros [[a b] c]; apply equiv_idmap.
  Defined.

  (* Proposition 23, sheaf part *)
  Instance nTjTiSnTjT_eq E (χ : E -> J) : IsEquiv (λ (f : E -> subuniverse_Type nj) (t : {b : E & pr1 ((χ b))}), f (pr1 t)).
  apply (isequiv_adjointify _ (type_j_inv (E:=E) χ)).
  - intro φ.
    unfold type_j_inv. simpl.
    apply path_forall; intro x.
    rewrite (O_modal n nj (φ x)).
    apply ap.
    apply path_trunctype. cbn.
    etransitivity; [| exact (equiv_inverse (hfiber_fibration x (trunctype_type o (@st n nj) o φ)))].
    symmetry. apply (hfiber_compose_mono pr1 pr1).
    intros X Y.
    apply isequiv_pr1_path_hprop.
  - intro φ.
    unfold type_j_inv. simpl.
    apply path_forall; intro x.
    rewrite (O_modal n nj (φ x)).
    assert (Tr1: IsTruncMap n (λ x0 : ∃ e : ∃ e : E, φ e, (χ e.1).1, (x0.1).1)).
    simple refine (istruncmap_compose n pr1 pr1 _ _).
    intro e; exact (@trunc_leq -1 n tt _ (istruncmap_charn -1 (λ t, (χ t.1).1) e)).

    match goal with
    |[|- O nj ?XX = _] =>
     path_via (O nj (@BuildTruncType _ (hfiber (λ x0 : ∃ e : ∃ e : E, (φ e), (χ e.1).1, x0.1.1) x) (istruncmap_fiber x)))
    end.
    apply ap.
    apply path_trunctype. cbn.
    exact (inter_symm _ (fun b => (χ b).1) (fun b => φ b) x).
    pose (X := nj_fibers_compose (∃ e : ∃ e : E, φ e, (χ e.1).1) {e:E & φ e} E pr1 pr1 x).
    assert (HB : IsTruncMap n (λ s : ∃ e : ∃ e : E, φ e, (χ e.1).1, s.1)).
    intro e. simple refine (@trunc_leq -1 n tt _ _).
    assert (HC : IsTruncMap n
                            (λ s : ∃ e : E, φ e, let (proj1_sig, _) := s in proj1_sig)).
    intro e. simple refine (istruncmap_charn _ _ _).
    cbn in *.
    specialize (X HB HC).
    match goal with
    |[|- O nj (@BuildTruncType _ _ ?foo) = _] => assert (rTr: istruncmap_compose n pr1 pr1 HB HC x = foo) by apply path_ishprop
    end.
    destruct rTr.
    etransitivity; [exact X| clear X; cbn].

    apply ap. apply path_trunctype. cbn.
    eapply transitive_equiv.
    apply equiv_sigma_contr.
    intro a.
    match goal with
    |[|- Contr (trunctype_type (@st n nj (O nj (BuildTruncType _ ?foo))))]
     => pose (f:= j_is_nj (BuildTruncType -1 foo))
    end.
    match goal with
    |[ f : _ = trunctype_type (@st n nj (O nj (@BuildTruncType _ _ ?foo))) |- Contr (trunctype_type (@st n nj (O nj (@BuildTruncType _ _ ?bar)))) ]
     => assert (foo = bar) by apply path_ishprop
    end.
    destruct X.
    apply (transport (fun X => Contr X) f); cbn.
    apply (transport (fun X => Contr (not (not X))) (path_universe_uncurried (hfiber_fibration a.1 (λ x, (χ x.1).1)))).
    apply Oj_J_Contr.
    apply equiv_path.
    exact (path_universe_uncurried (hfiber_fibration x φ))^.
  Defined.

  Definition nTjTiseparated_eq_fun_univ {E:Type} {χ:EnJ E} {φ1 φ2}
             (p: E_to_χ_map (@BuildTruncType _ (subuniverse_Type nj) (subuniverse_Type_is_TruncTypeSn n nj)) χ φ1 =
                 E_to_χ_map (@BuildTruncType _ (subuniverse_Type nj) _) χ φ2)
             (x:E)
  :  (φ1 x) -> (φ2 x).
    unfold E_to_χ_map in p.
    generalize dependent (EnJ_is_nJ χ x).
    simple refine (O_rec n nj (χ x) (Build_subuniverse_Type n nj (BuildTruncType _ (φ1 x -> φ2 x)) _) _).
    intro v.
    exact (transport (λ U, U) (ap (trunctype_type) (ap (@st n nj) (ap10 p (x;v))))).
  Defined.

  Lemma nTjTiseparated_eq_fun_univ_invol {E:Type} {χ:EnJ E} {φ1 φ2}
        (p: E_to_χ_map (@BuildTruncType _ (subuniverse_Type nj) (subuniverse_Type_is_TruncTypeSn n nj)) χ φ1 =
            E_to_χ_map (@BuildTruncType _ (subuniverse_Type nj) _) χ φ2)
        (x:E)
  : forall (y:φ2 x), nTjTiseparated_eq_fun_univ p x (nTjTiseparated_eq_fun_univ p^ x y) = y.
  Proof.
    intro y. unfold nTjTiseparated_eq_fun_univ; simpl.
    unfold E_to_χ_map in p; simpl in *.
    pose (foo := ap10 (ap10 (reflect_factoriality_arrow_space n nj
                               (χ x)
                               (φ1 x)
                               (φ2 x)
                               (λ v : (χ x),
                                      transport idmap
                                                (ap (trunctype_type) (ap (@st n nj) (ap10 p (x;v)))))
                               (λ v : (χ x),
                                      transport idmap

                                                (ap (trunctype_type) (ap (@st n nj) (ap10 p^ (x;v))))))
                            (EnJ_is_nJ χ x)) y
         ).
    apply (transport (λ u, u = y) foo^). clear foo.

    transitivity (O_rec n nj (χ x)
                    {|
                      st := {|
                             trunctype_type := φ2 x → φ2 x;
                             istrunc_trunctype_type := trunc_arrow
                                                         (istrunc_trunctype_type (φ2 x)) |};
                      subu_struct := subuniverse_arrow n nj (φ2 x) (φ2 x) |}
                    (λ (v : χ x) (x0 : φ2 x),
      transport (λ x1 : Type, x1)
        (ap trunctype_type (ap (@st n nj) (ap10 p (x; v))))
        (transport (λ x1 : Type, x1)
           (ap trunctype_type (ap (@st n nj) (ap10 p (x; v))))^ x0)) (EnJ_is_nJ χ x) y); auto with path_hints.
    apply (ap (λ u, O_rec n nj (χ x)
                          {|
                            st := {|
                                   trunctype_type := φ2 x → φ2 x;
                                   istrunc_trunctype_type := trunc_arrow
                                                               (istrunc_trunctype_type (φ2 x)) |};
                            subu_struct := subuniverse_arrow n nj (φ2 x) (φ2 x) |}
                          u (EnJ_is_nJ χ x) y)).
    funext v x0.
    apply ap. apply (ap (λ U, transport idmap U x0)).
    repeat rewrite <- ap_V. rewrite ap10_V. reflexivity.

    pose (fooo := @transport_arrow_space_dep_path n nj fs (φ1 x) (φ2 x) (χ x) (λ v, (ap (trunctype_type) (ap (@st n nj) (ap10 p (x;v)))))).
    simpl in fooo.

    apply (transport (λ U, O_rec n nj (χ x)
                                 {|
                                   st := {|
                                          trunctype_type := φ2 x → φ2 x;
                                          istrunc_trunctype_type := trunc_arrow
                                                                      (istrunc_trunctype_type (φ2 x)) |};
                                   subu_struct := subuniverse_arrow n nj (φ2 x) (φ2 x) |}
                                 U
                                 (EnJ_is_nJ χ x) y = y) fooo^).
    clear fooo; simpl.
    rewrite O_rec_const; reflexivity.
  Defined.

  Definition nTjTiseparated_eq_inv (E:Type) (χ:EnJ E) φ1 φ2 :
    (E_to_χ_map (@BuildTruncType _ (subuniverse_Type nj) (subuniverse_Type_is_TruncTypeSn n nj)) χ φ1 =
            E_to_χ_map (@BuildTruncType _ (subuniverse_Type nj) _) χ φ2)
    -> φ1 = φ2.
    intro p.
    simpl in *.
    unfold E_to_χ_map in p; simpl in p.
    apply path_forall; intro x.
    apply unique_subuniverse; apply path_trunctype.
    exists (nTjTiseparated_eq_fun_univ p x).
    apply isequiv_adjointify with (g := nTjTiseparated_eq_fun_univ (inverse p) x).
    - exact (nTjTiseparated_eq_fun_univ_invol p x).
    - exact (transport (λ u, ∀ y : φ1 x, nTjTiseparated_eq_fun_univ (inverse p) x (nTjTiseparated_eq_fun_univ u x y) = y) (inv_V p) (nTjTiseparated_eq_fun_univ_invol (inverse p) x)).
  Defined.

  (* Proposition 23, separation part *)
  Lemma nTjTiseparated_eq : separated (@BuildTruncType _ (subuniverse_Type nj) (@subuniverse_Type_is_TruncTypeSn _ nj ua)).
    intros E χ φ1 φ2.
    apply isequiv_adjointify with (g := @nTjTiseparated_eq_inv E χ φ1 φ2).
    - intro p.
      unfold E_to_χ_map in *; simpl in *.
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ (φ1 o (@pr1 _ (fun e => (χ e)))) (φ2 o pr1))).
      apply path_forall; intro x.
      unfold nTjTiseparated_eq_inv.
      pose (r:= @ap10_ap_precompose); unfold ap10 in r; rewrite r; clear r.
      unfold path_forall; rewrite eisretr.

      apply (@equiv_inj _ _ (equiv_inv (IsEquiv := isequiv_unique_subuniverse _ _ _ _))). apply isequiv_inverse.
      apply (@equiv_inj _ _ (equiv_inv (IsEquiv := isequiv_path_trunctype))). apply isequiv_inverse.
      repeat rewrite eissect.
      apply path_equiv; cbn.
      unfold nTjTiseparated_eq_fun_univ, EnJ_is_nJ.
      apply (transport (λ U, O_rec n nj _ {|
     st := {|
           trunctype_type := φ1 (let (proj1_sig, _) := x in proj1_sig)
                             → φ2 (let (proj1_sig, _) := x in proj1_sig);
           istrunc_trunctype_type := trunc_arrow
                                       (istrunc_trunctype_type
                                          (φ2
                                             (let
                                              (proj1_sig, _) := x in
                                              proj1_sig))) |};
     subu_struct := subuniverse_arrow n nj
                      (φ1 (let (proj1_sig, _) := x in proj1_sig))
                      (φ2 (let (proj1_sig, _) := x in proj1_sig)) |} _ U = _) ((witness_is_eta χ x)^)).
      etransitivity;
        [ exact (ap10 (O_rec_retr n nj (χ x.1) {|
     st := {|
           trunctype_type := φ1 (let (proj1_sig, _) := x in proj1_sig)
                             → φ2 (let (proj1_sig, _) := x in proj1_sig);
           istrunc_trunctype_type := trunc_arrow
                                       (istrunc_trunctype_type
                                          (φ2
                                             (let
                                              (proj1_sig, _) := x in
                                              proj1_sig))) |};
     subu_struct := subuniverse_arrow n nj
                      (φ1 (let (proj1_sig, _) := x in proj1_sig))
                      (φ2 (let (proj1_sig, _) := x in proj1_sig)) |}
                                    (λ v : χ (let (proj1_sig, _) := x in proj1_sig),
      transport (λ U : Type, U)
        (ap trunctype_type
           (ap (@st n nj) (ap10 p (let (proj1_sig, _) := x in proj1_sig; v)))))) x.2) |].
      repeat apply ap. destruct x as [x1 x2]. reflexivity.

    - intro p; destruct p.
      unfold E_to_χ_map, nTjTiseparated_eq_inv in *; simpl in *.
      eapply concat; [idtac | apply (path_forall_1 φ1)]; apply ap.
      apply path_forall; intro x; simpl.
      apply (@equiv_inj _ _ (equiv_inv (IsEquiv := isequiv_unique_subuniverse _ _ _ _))). apply isequiv_inverse.
      apply (@equiv_inj _ _ (equiv_inv (IsEquiv := isequiv_path_trunctype))). apply isequiv_inverse.
      repeat rewrite eissect.
      apply path_equiv; cbn.
      unfold transport, nTjTiseparated_eq_fun_univ; simpl.
      exact (ap10 (O_rec_const n nj (χ x) {|
     st := {|
           trunctype_type := φ1 x → φ1 x;
           istrunc_trunctype_type := trunc_arrow
                                       (istrunc_trunctype_type (φ1 x)) |};
     subu_struct := subuniverse_arrow n nj (φ1 x) (φ1 x) |} idmap) (EnJ_is_nJ χ x)).
  Defined.

  (* Proposition 23 *)
  Lemma nType_j_Type_is_SnType_j_Type : Snsheaf_struct (@BuildTruncType _ (subuniverse_Type nj) (@subuniverse_Type_is_TruncTypeSn _ nj ua)).
  Proof.
    split.
    apply nTjTiseparated_eq.
    intros E χ. unfold E_to_χ_map; simpl.
    exact (nTjTiSnTjT_eq _ _).
  Defined.

  Definition nType_j_Type_sheaf : SnType_j_Type :=
    ((@BuildTruncType _ (subuniverse_Type nj) (@subuniverse_Type_is_TruncTypeSn _ nj ua));nType_j_Type_is_SnType_j_Type).

  (* Proposition 25, sheaf part *)
  Instance dep_prod_SnType_j_Type_eq
           (A : Type)
           (B : A -> SnType_j_Type)
  : forall (E:Type) (χ : E -> J) (H := λ a, (snd (pr2 (B a))) E χ),
      IsEquiv (λ (f : E -> ∀ a : A, (B a).1) (t : {b : E & (χ b).1}), f (pr1 t)).
  intros E χ H.
  apply (isequiv_adjointify _ (λ g e a, (@equiv_inv _ _ _ (H a) (λ x, g x a) e))).
  - intro φ.
    apply path_forall; intro x.
    apply path_forall; intro a.
    destruct (H a) as [inv retr sect adj]; simpl in *.
    clear adj; clear sect.
    unfold Sect, E_to_χmono_map in retr.
    specialize (retr (λ x, φ x a)).
    exact (ap10 retr x).
  - intro φ.
    funext x a.
    destruct (H a) as [inv retr sect adj]; simpl in *.
    clear adj; clear retr.
    unfold Sect, E_to_χ_map in sect.
    specialize (sect (λ x, φ x a)).
    exact (ap10 sect x).
  Defined.

  Definition dep_prod_SnType_j_Type_sep_inv
             (A : Type)
             (B : A -> SnType_j_Type)
             (E : Type)
             (χ : EnJ E)
             (x y : E -> ∀ a : A, (B a).1)
  : (λ (f : E -> ∀ a : A, (B a).1) (t : {b : E & (χ b)}),
     f t .1) x =
    (λ (f : E -> ∀ a : A, (B a).1) (t : {b : E & (χ b)}),
     f t .1) y
    -> x = y.
  Proof.
    intro H; simpl in H.
    funext u a .
    simple refine (@ap10 _ _ (λ u, x u a) (λ u, y u a) _ u).
    pose ((fst (B a).2) E χ (λ v, x v a) (λ v, y v a)).
    exact (equiv_inv (IsEquiv := i) (path_forall _ _ (λ t, apD10 ((apD10 H) t) a))).
  Defined.

  (* Proposition 25, separated part *)
  Lemma dep_prod_SnType_j_Type_sep
        (A : Type)
        (B : A -> SnType_j_Type)
  : forall (E:Type) (χ : EnJ E), IsMono
                                   (λ (f : E -> ∀ a : A, (B a).1) (t : {b : E & χ b}), f (t.1)).
    intros E χ.
    unfold IsMono.
    intros f g.
    apply @isequiv_adjointify with (g := @dep_prod_SnType_j_Type_sep_inv A B E χ f g).
    - unfold Sect.
      intro p.
      unfold dep_prod_SnType_j_Type_sep_inv.
      unfold E_to_χ_map. simpl.
      unfold equiv_inv.
      pose (foo := path_forall_precompose (∃ b : E, χ b)
                                   E
                                   (∀ a : A, (B a).1)
                                   pr1
                                   f
                                   g
                                   (λ u : E,
                                          path_forall (f u) (g u)
                                                      (λ a : A,
                                                             ap10
                                                               ((let (equiv_inv, eisretr, eissect, _) :=
                                                                     fst (B a) .2 E χ (λ v : E, f v a) (λ v : E, g v a) in
                                                                 equiv_inv)
                                                                  (path_forall (λ t : ∃ b : E, (χ b), f t .1 a)
                                                                               (λ t : ∃ b : E, (χ b), g t .1 a)
                                                                               (λ t : ∃ b : E, (χ b), apD10 (apD10 p t) a))) u))).
      apply (transport (λ U, U=p) foo^); clear foo.
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
      unfold ap10 at 1, path_forall at 1; rewrite eisretr.
      apply path_forall; intro x.
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)); unfold path_forall at 1; rewrite eisretr.
      apply path_forall; intro a.

      pose (r := @ap10_ap_precompose (∃ b : E, χ b)
                             E
                             ((B a).1)
                             pr1
                             (λ v, f v a)
                             (λ v, g v a)
                             ((let (equiv_inv, eisretr, eissect, _) :=
                                   fst (B a) .2 E χ (λ v : E, f v a) (λ v : E, g v a) in
                               equiv_inv)
                                (path_forall (λ t : ∃ b : E, (χ b), f t .1 a)
                                             (λ t : ∃ b : E, (χ b), g t .1 a)
                                             (λ t : ∃ b : E, (χ b), apD10 (apD10 p t) a)))
                             x);
        unfold ap10 in r; rewrite <- r; clear r.
      rewrite (@eisretr _ _ _ (fst (B a) .2 E χ (λ v : E, f v a) (λ v : E, g v a))).

      unfold path_forall; rewrite eisretr.
      reflexivity.
    - intro v. unfold dep_prod_SnType_j_Type_sep_inv.
      unfold E_to_χ_map. simpl.
      destruct v. simpl.
      etransitivity; [idtac | apply path_forall_1]; apply ap; apply path_forall; intro x.
      etransitivity; [idtac | apply path_forall_1]; apply ap; apply path_forall; intro y.
      assert ((apD10
                 ((let (equiv_inv, eisretr, eissect, _) :=
                       fst (B y) .2 E χ (λ v : E, f v y) (λ v : E, f v y) in
                   equiv_inv)
                    (path_forall (λ t : ∃ b : E, χ b, f t .1 y)
                                 (λ t : ∃ b : E, χ b, f t .1 y) (λ t : ∃ b : E, χ b, 1)))) = λ _, 1).
      apply (@equiv_inj _ _ _ (isequiv_path_forall _ _)).
      unfold path_forall. rewrite eissect.
      apply (@equiv_inj _ _ _ (fst (B y) .2 E χ (λ v : E, f v y) (λ v : E, f v y))).
      pose (foo := @eisretr _ _ _ (fst (B y) .2 E χ (λ v : E, f v y) (λ v : E, f v y))).
      unfold Sect, equiv_inv in foo; simpl in foo.
      rewrite foo.
      unfold E_to_χ_map. simpl.
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
      rewrite eisretr.
      apply path_forall; intro t.
      match goal with
        |[|- _ = apD10 (ap _ ?X) _] => pose (ap10_ap_precompose (pr1 : ({e:E & χ e} -> E)) X) end. unfold ap10 in p; rewrite p.
      unfold ap10; rewrite eisretr. reflexivity.
      exact (apD10 X x).
  Defined.

  (* Proposition 25 *)
  Definition dep_prod_SnType_j_Type
    : forall A (B : A -> SnType_j_Type),
      Snsheaf_struct (BuildTruncType _ (forall a, pr1 (B a))).
  Proof.
    intros. split.
    exact (dep_prod_SnType_j_Type_sep _ _).
    exact (dep_prod_SnType_j_Type_eq _ _).
  Defined.

  (* Definition of diagonals *)
  Definition δ (T:TruncType (trunc_S n)) : T * T-> TruncType n.
    intros x. exists (fst x = snd x). simple refine (istrunc_paths _ _ _).
  Defined.

  Definition Δ (T:TruncType (trunc_S n)) := {x:T*T & δ T x}.

  Definition clδ (T:TruncType (trunc_S n)) := nj.(O) o (δ T).

  Definition clΔ (T:TruncType (trunc_S n)) := {x:T*T & clδ T x}.

  Lemma equal_hfibers (A B:Type) (r:A=B) (f g:A -> B) e (p : f = equiv_path _ _ r) (q : g = equiv_path _ _ r)
  : {a:A & a = e} <~> {a:A & f a = g e}.

    exists (λ x:(∃ a : A, a = e), (x.1 ; (ap f x.2) @ (ap10 (p@q^) e))).
    destruct r.
    assert (f=idmap).
    apply path_forall; intro x. exact (ap10 p x).
    destruct p. destruct q.
    rewrite X. simpl.
    apply @isequiv_adjointify with  (g:= ( λ x, (x.1; x.2))).
    - intro x. simpl. hott_simpl.
    - intro x. simpl. hott_simpl.
  Defined.

  Lemma dicde_l {E:Type} (φ:E -> TruncType n) (A:={e:E & φ e}) (clA := {e:E & (O nj (φ e))}) (e:clA)
  : (∃ rx : (O nj (φ e .1)),
       rx =
      e.2) =(∃ rx : (O nj (φ e .1)),
       O_rec n nj (φ e .1) (O nj (O nj (φ e .1)))
             (λ x : (φ e .1),
                    O_unit nj (O nj (φ e .1)) (O_unit nj (φ e .1) x)) rx =
       O_unit nj (O nj (φ e .1)) e .2).
  Proof.
    apply path_universe_uncurried.
    apply (@equal_hfibers
                   ((O nj (φ e .1)))
                   ((O nj (O nj (φ e .1))))
                   (ap (trunctype_type) (ap (@st n nj) ((O_invol_ n nj (φ e .1)))))
                   (O_rec n nj (φ e .1) (O nj (O nj (φ e .1)))
                          (λ x : (φ e .1), O_unit nj (O nj (φ e .1)) (O_unit nj (φ e .1) x)))
                   (O_unit nj (O nj (φ e .1)))
                   e.2).
    - cbn.
      etransitivity; [exact (O_rec_sect n nj (φ e .1) (O nj (O nj (φ e .1))) (O_unit nj _)) | apply OO_unit_idmap].
    - apply OO_unit_idmap.
  Defined.

  Lemma dicde_ll
        (E : Type)
        (φ : E → TruncType n)
        (A := ∃ e : E, (φ e) : Type)
        (clA := ∃ e : E, O nj (φ e) : Type)
        (a : ∃ e : E, O nj (φ e))
        (x : ∃ π : (φ a .1), O_unit nj (φ a .1) π = a .2)
        (π : ∃ π : (φ a .1), O_unit nj (φ a .1) π = a .2)
        (π' : ∃ π : (φ a .1), O_unit nj (φ a .1) π = a .2)
  : equiv_path _ _ (dicde_l φ a) (a .2; 1) =
    (O_unit nj (φ a .1) π' .1;
     islex_compat_func mod_nj (φ a .1) (O nj (φ a .1)) (O_unit nj (φ a .1)) _ π').
    unfold dicde_l.
    unfold path_universe_uncurried.
    rewrite eisretr. simpl. hott_simpl.
    apply @path_sigma' with (p := π'.2^). simpl. destruct π' as [b p]. simpl. destruct p. simpl.
    unfold islex_compat_func. simpl.
    apply ap10_O_retr_sect.
  Defined.

  Lemma dense_into_cloture_dense_eq {E:Type} (φ:E -> TruncType n) (A:={e:E & φ e}) (clA := {e:E & O nj (φ e)})
  : is_dense_eq (λ e:clA, (BuildTruncType _ {π : φ e.1 & O_unit nj _ π = e.2})).
    intro e.
    assert (rew := ((islex_nj (φ e .1) (O nj (φ e .1)) (O_unit nj _) e.2) @ (dicde_l φ e)^)).
    apply path_universe_uncurried.
    apply (transport (λ U, (∃ e' : clA, e = e') <~> U) (islex_nj (φ e .1) (O nj (φ e .1)) (O_unit nj _) e.2)^).
    apply (transport (λ U, (∃ e' : clA, e = e') <~> U) (dicde_l φ e)).

    exists ((λ x:(∃ e' : clA, e = e'), existT (λ u, u = e.2) e.2 1)).
    apply @isequiv_adjointify with (g:= (λ x:(∃ rx : ((O nj (φ e .1))), rx = e .2), ((e.1;x.1); path_sigma _ e (e.1;x.1) 1 x.2^))).

    - intros [x p]. destruct p. reflexivity.
    - intros [x p]. destruct p. simpl.
      apply @path_sigma' with (p := eta_sigma _).
      reflexivity.
  Defined.

  (** Put that elswhere *)
  Lemma transport_equiv (A: Type) (f g:A -> Type) (x y: A) (p: x=y) (q: f x <~> g x)
  : transport (λ a:A, f a <~> g a) p q
    = (equiv_compose' (equiv_path _ _ (ap g p)) (equiv_compose' q (equiv_inverse (equiv_path _ _ (ap f p))))).
    path_induction.
    destruct q. apply path_equiv. reflexivity.
  Defined.

  (*****)

  Lemma dense_into_cloture_dense_diag (E:Type) (φ:E -> TruncType n) (A:={e:E & φ e}) (clA := {e:E & (O nj (φ e))})
  : is_dense_diag _ (dense_into_cloture_dense_eq φ).
    intros x p.
    unfold dense_into_cloture_dense_eq.
    apply path_forall; intro y.
    unfold path_universe_uncurried. rewrite eisretr.
    simpl.
    destruct x as [a x]. simpl in x. simpl in p. destruct p as [a' q]. destruct a' as [a' π]. simpl in q.
    destruct q. simpl.
    destruct y as [[a' π'] q]. simpl in *. destruct q. simpl in *.
    unfold incl_Aeq_Eeq. simpl.
    rewrite <- transport_pp.
    rewrite transport_equiv. simpl.
    simpl.
    rewrite ap_idmap.
    rewrite transport_pp.

    pose (foo := lex_compat (φ a .1) (O nj (φ a .1)) (O_unit nj (φ a .1))). unfold equiv_path in foo; simpl in foo.
    specialize (foo a.2 π'). simpl in foo.
    unfold hfiber in foo. simpl in foo.

    apply (moveR_transport_V idmap (islex_nj (φ a .1) (O nj (φ a .1)) (O_unit nj (φ a .1)) a .2) (transport idmap (dicde_l φ a)  (a .2; 1))).

    apply (transport (λ U, transport idmap (dicde_l φ a) (a .2; 1) = U) foo^).
    clear foo.
    apply dicde_ll. exact π. exact π'.
  Qed.

  (* Any object seen as a subobject of its closure is closed *)
  Definition dense_into_cloture (E:Type) (φ:E -> TruncType n) (A:={e:E & φ e}) (clA := {e:E & (O nj (φ e))})
  : EnJ clA.
    simple refine (Build_EnJ _ _ (dense_into_cloture_dense_eq φ)).
  Defined.

  (*** CHECK IF THAT IS NEEDED *)

  (* Definition transport_density (E:Type) (φ:E -> TruncType n) (A:={e:E & (φ e).1}) (clA := {e:E & (O nj (φ e)).1.1}) *)
  (* : forall X, clA = X -> EnJ X. *)
  (*   pose (e := dense_into_cloture φ); simpl in e. *)
  (*   assert (χdiag := dense_diag e). *)
  (*   destruct e as [χ χeq]. *)
  (*   intros X p. *)
  (*   simple refine (Build_EnJ _ _). *)
  (*   - intro x. apply χ. *)
  (*     apply (equiv_path _ _ p). *)
  (*     exact x. *)
  (*   - destruct p. intro x. simpl. *)
  (*     apply χeq. *)
  (*   (* - destruct p. intros x e'. simpl. *) *)
  (*     (* apply χdiag. exact e'. *) *)
  (* Defined. *)

  (* Definition path_sigma_transport (E:Type) (φ χ : E -> Type) (eq : χ = φ) (x y : {e:E & φ e}) *)
  (* : (x = y) <~> ((x.1 ; transport idmap (ap10 eq x.1)^ x.2) = (y.1 ; transport idmap (ap10 eq y.1)^ y.2)). *)
  (*   destruct eq. simpl. *)
  (*   apply equiv_idmap. *)
  (* Defined. *)

  (* Definition path_sigma_transport_transport (E:Type) (φ χ : E -> Type) (α : {e:E & (χ e)} -> Type) (eq : χ = φ) (x y : {e:E & φ e}) (xy : x = y)  *)
  (* : transport (λ u:{e:E & (χ e)}, α u) ((path_sigma_transport eq x y) xy)^ *)
  (*   = *)
  (*   transport (λ u:{e:E & (φ e)}, α (u.1 ; transport idmap (ap10 eq u.1)^ u.2)) *)
  (*             xy^. *)
  (* destruct eq; simpl. reflexivity. *)
  (* Defined. *)

  (* Definition path_sigma_transport' (E:Type) (φ χ : E -> Type) (eq : χ == φ) (x y : {e:E & φ e}) *)
  (* : (x = y) <~> ((x.1 ; transport idmap (eq x.1)^ x.2) = (y.1 ; transport idmap (eq y.1)^ y.2)). *)
  (*   transitivity ((x.1; transport idmap (ap10 (path_forall _ _ eq) x.1)^ x.2) = (y.1; transport idmap (ap10 (path_forall _ _ eq) y.1)^ y.2)). *)
  (*   simple refine (path_sigma_transport _ _ _). *)
  (*   unfold ap10, path_forall. rewrite eisretr.  *)
  (*   apply equiv_idmap. *)
  (* Defined. *)

  (* Definition path_sigma_transport'_transport (E:Type) (φ χ : E -> Type) (α : {e:E & (χ e)} -> Type) (eq : χ == φ) (x y : {e:E & φ e}) (xy : x = y) *)
  (* : transport (λ u:{e:E & (χ e)}, α u) ((path_sigma_transport' eq x y) xy)^ *)
  (*   = *)
  (*   transport (λ u:{e:E & (φ e)}, α (u.1 ; transport idmap (eq u.1)^ u.2)) *)
  (*             xy^. *)
  (* simpl. *)
  (* destruct (eisretr apD10 eq). simpl.  simpl. *)
  (* exact (@path_sigma_transport_transport E φ χ α (path_forall χ φ eq) x y xy). *)
  (* Defined. *)
  (* Opaque path_sigma_transport'. *)

  (* Definition transport_density_sigma (E:Type) (φ:E -> TruncType n) (A:={e:E & (φ e).1}) (clA := {e:E & (O nj (φ e)).1.1}) *)
  (* : forall α:E -> TruncType n, (pr1 o pr1 o (O nj) o φ == pr1 o α) -> EnJ {e:E & (α e).1}. *)
  (*   intros α p. *)
  (*   transparent assert (X : (clA = (∃ e : E, (α e).1))). *)
  (*   { apply path_universe_uncurried. *)
  (*     apply (equiv_functor_sigma_id). *)
  (*     intro a. apply equiv_path. apply p. *)
  (*   } *)
  (*   pose (e := dense_into_cloture φ); simpl in e. *)
  (*   assert (χdiag := dense_diag e). *)
  (*   destruct e as [χ χeq]. *)
  (*   simple refine (Build_EnJ _ _). *)
  (*   - intro x. apply χ. *)
  (*     exists x.1. *)
  (*     apply (equiv_path _ _ (p x.1)). *)
  (*     exact x.2. *)
  (*   - intro e. simpl in *. *)

  (*     pose (eq := χeq (e.1; transport idmap (p e.1)^ e.2)). *)
  (*     etransitivity; try exact eq. clear eq. *)
  (*     apply path_universe_uncurried. *)
  (*     simple refine (equiv_functor_sigma' _ _). *)
  (*     apply (equiv_functor_sigma_id). *)
  (*     intro a. *)
  (*     apply equiv_path. exact (p a)^. *)
  (*     intro a. simpl. unfold functor_sigma. *)
  (*     apply path_sigma_transport'. *)
  (* Defined. *)

    (** We note that a type is separated if, and only if all its path spaces are n-sheaves *)
  Definition separated_nj_paths (T:TruncType (n.+1))
    : separated T -> forall x y:T, IsSubu n nj (BuildTruncType _ (x=y)).
  Proof.
    intros sepT x y.
    rewrite <- (subuniverse_iff_O n nj _).
    simple refine (O_unit_retract_equiv n nj _ _ _).
    intro p.
    specialize (sepT _ (dense_into_cloture (T*T) (λ x, BuildTruncType _ (fst x = snd x))) (fst o pr1) (snd o pr1)).
    apply (λ C, ap10 (equiv_inv (IsEquiv := sepT) C) ((x,y);p)).
    unfold E_to_χ_map. apply path_forall; intros q. exact q.2.1.
    intro p. destruct p.
    transparent assert (xx: (∃
                 (x : ∃ e : T ∧ T,
                      O nj (BuildTruncType _ (fst e = snd e)))
                 (π : fst (pr1 x) = snd (pr1 x)),
                 O_unit nj
                   (BuildTruncType _ (fst (pr1 x) = snd (pr1 x))) π =
                 pr2 x)).
    { simple refine (exist _  _ _).
      exists (x,x).
      apply O_unit. reflexivity.
      simpl. exists 1. reflexivity. }
    match goal with
    |[|- ap10 ?gg _ = _] => path_via (ap10 gg (pr1 xx))
    end.
    rewrite <- ap10_ap_precompose.
    unfold equiv_inv. simpl.
    destruct (sepT (∃ e : T ∧ T, O nj (BuildTruncType _ (fst e = snd e)))
            (dense_into_cloture (T ∧ T) (λ x0 : T ∧ T, BuildTruncType _ (fst x0 = snd x0)))
            (λ
             x0 : ∃ e : T ∧ T, O nj (BuildTruncType _ (fst e = snd e)),
             let (fst, _) := let (proj1_sig, _) := x0 in proj1_sig in fst)
            (λ
             x0 : ∃ e : T ∧ T, O nj (BuildTruncType _ (fst e = snd e)),
               let (_, snd) := let (proj1_sig, _) := x0 in proj1_sig in snd)) as [inv retr sect _].
    cbn in *.
    unfold Sect, E_to_χ_map in *; cbn in *.
    specialize (retr (path_forall _ _
              (λ
               q : ∃
                   (x0 : ∃ e : T ∧ T,
                         O nj (BuildTruncType _ (fst e = snd e)))
                   (π : fst (pr1 x0) = snd (pr1 x0)),
                   O_unit nj
                     (BuildTruncType _ (fst (pr1 x0) = snd (pr1 x0))) π =
                   pr2 x0, pr1 (pr2 q)))). clear sect.
    rewrite retr.
    unfold ap10, path_forall; rewrite eisretr. reflexivity.
  Defined.

  Definition nj_paths_separated (T:TruncType (n.+1))
    : (forall x y:T, IsSubu n nj (BuildTruncType _ (x=y))) -> separated T.
  Proof.
    intros H F χ f g.
    simple refine (isequiv_adjointify _ _ _ _).
    - intro p. apply path_forall; intro x.
      specialize (H (f x) (g x)).
      unfold E_to_χ_map in *.
      generalize (equiv_path _ _ (dense_eq χ x) (x;1)).
      apply (O_rec n nj (χ x) (Build_subuniverse_Type n nj (BuildTruncType _ (f x=g x)) _)).
      intro w.
      exact (ap10 p (x;w)).
    - intro p. unfold E_to_χ_map in *; cbn in *.
      rewrite (path_forall_precompose (∃ x : F, χ x) F T pr1 _ _ (λ x : F,
         O_rec n nj (χ x)
           {| st := BuildTruncType _ (f x = g x); subu_struct := H (f x) (g x) |}
           (λ w : χ x, ap10 p (x; w)) (transport idmap (dense_eq χ x) (x; 1)))).
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
      unfold path_forall; rewrite eisretr.
      apply path_forall; intro x.
      pose (r:= ap10 (dense_diag χ x (x;1)) (x;1)).
      unfold incl_Aeq_Eeq in r; cbn in r.
      rewrite r; clear r.
      pose (r := λ P Q f, ap10 (O_rec_retr n nj P Q f)).
      rewrite r. reflexivity.
    - intro p.
      apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
      unfold path_forall; rewrite eisretr.
      apply path_forall; intro x. simpl.
      generalize (equiv_path _ _ (dense_eq χ x) (x;1)).
      transparent assert (sh : (subuniverse_Type nj)).
      { simple refine (Build_subuniverse_Type n nj
                 (BuildTruncType _ (O_rec n nj (χ x)
                             {| st := BuildTruncType _ (f x = g x); subu_struct := H (f x) (g x) |}
                             (λ w : χ x, ap10 (ap (E_to_χ_map T χ) p) (x; w))
                             (transport idmap (dense_eq χ x) (x; 1)) = apD10 p x)) _).
        apply istrunc_paths.
        apply istrunc_paths. apply trunc_succ. apply istrunc_trunctype_type.
        assert (X: IsSubu n nj (BuildTruncType _ (f x = g x))). apply H.
        pose (pp:= subuniverse_paths n nj (Build_subuniverse_Type n nj (BuildTruncType _ (f x=g x)) _)
             (O_rec n nj (χ x)
                         {|
                         st := {|
                               trunctype_type := f x = g x;
                               istrunc_trunctype_type := istrunc_paths _
                                                  (f x) (g x) |};
                         subu_struct := H (f x) (g x) |}
                         (λ w : χ x, ap10 (ap (E_to_χ_map T χ) p) (x; w))
                         (transport idmap (dense_eq χ x) (x; 1)))
             (apD10 p x)).

        match goal with
        |[pp: IsSubu _ _ {| trunctype_type := _; istrunc_trunctype_type := ?XX|} |- IsSubu _ _ {| trunctype_type := _; istrunc_trunctype_type := ?YY|}]
           => assert (rr: XX = YY) by apply path_ishprop
        end.
        destruct rr. exact pp. }
      apply (O_rec n nj (χ x) sh).
      unfold sh; clear sh; cbn.
      intro w.
      pose (r:= ap10 (dense_diag χ (x;w) ((x;w);1)) ((x;w);1)).
      unfold incl_Aeq_Eeq in r; cbn in r.
      rewrite r; clear r.
      pose (r := λ P Q f, ap10 (O_rec_retr n nj P Q f)).
      rewrite r.
      unfold E_to_χ_map.
      apply (ap10_ap_precompose pr1 p (x; w)).
  Defined.

  Definition Omono (A B:TruncType (trunc_S n)) (f: A -> B)
    := forall x y:A, IsEquiv (function_lift n nj (BuildTruncType _ (x=y)) (BuildTruncType _ (f x=f y)) (ap (x:=x) (y:=y) f)).

  Definition Oepi (A B:TruncType (trunc_S n)) (f: A -> B)
    := forall b:B, (O nj (@BuildTruncType _ (Trunc -1 (hfiber f b)) (@trunc_leq -1 n tt _ _))).

End Definitions.


(* Copland specific event systems *)

(* LICENSE NOTICE

Copyright (c) 2018 The MITRE Corporation.
All Rights Reserved.

This proof script is free software: you can redistribute it and/or
modify it under the terms of the BSD License as published by the
University of California.  See license.txt for details. *)

(** Copland specific event systems. *)

Require Import Preamble More_lists StructTactics Defs Term_Defs Term Event_system.

Require Import Lia List PeanoNat.

(*
Set Nested Proofs Allowed.
*)

(** Construct an event system from an annotated term, place, and
    evidence. *)

Fixpoint ev_sys (t: AnnoTerm) p e: EvSys Ev :=
  match t with
  | aasp (i, j) x => leaf (i, j) (asp_event i x p e)
  | aatt (i, j) q x =>
    before (i, j)
      (leaf (i, S i) (req i p q (unanno x) e))
      (before (S i, j)
              (ev_sys x q e)
              (leaf (pred j, j) (rpy (pred j) p q (aeval x q e))))
  | alseq r x y => before r (ev_sys x p e)
                          (ev_sys y p (aeval x p e))
  | abseq (i, j) s x y =>
    before (i, j)
           (leaf (i, S i)
                 (Term_Defs.split i p))
           (before (S i, j)
                   (before (S i, (pred j))
                           (ev_sys x p (splitEv_T_l s e))
                           (ev_sys y p (splitEv_T_r s e)))
                   (leaf ((pred j), j)
                         (join (pred j) p)))
  | abpar (i, j) s x y =>
    before (i, j)
           (leaf (i, S i)
                 (Term_Defs.split i p))
           (before (S i, j)
                   (merge (S i, (pred j))
                           (ev_sys x p (splitEv_T_l s e))
                           (ev_sys y p (splitEv_T_r s e)))
                   (leaf ((pred j), j)
                         (join (pred j) p)))
  end.

Lemma evsys_range:
  forall t p e,
    es_range (ev_sys t p e) = range t.
Proof.
  induction t; intros; simpl; auto;
    repeat expand_let_pairs; simpl; auto.
Qed.

Ltac dest_range' :=
match goal with
| H:Range |- _ => destruct H
end.

Lemma well_structured_evsys:
  forall t p e,
    well_formed_r_annt t ->
    well_structured ev (ev_sys t p e).
Proof.
  induction t; intros; inv_wfr; simpl;
    try (
    repeat expand_let_pairs; dest_range'; (*destruct r as [i k]; *)
      simpl in *; subst; auto;
      try destruct a; (* asp destruct *)
      try destruct a; (* asp params destruct *)
        repeat (econstructor; repeat rewrite evsys_range; auto);
        tauto).
Defined.

Ltac do_evin :=
  match goal with
  | [H:ev_in _ (?C _) |- _] => inv H
  end.

(** The events in the event system correspond to the events associated
    with a term, a place, and some evidence. *)

Lemma evsys_events:
  forall t p e ev,
    well_formed_r_annt t ->
    ev_in ev (ev_sys t p e) <-> events t p e ev.
Proof.
  split; revert p; revert e; induction t; intros; inv_wfr; simpl in *;
    repeat expand_let_pairs; dest_range'; simpl in *;
      try (destruct a; auto; do_evin; auto);

      try (destruct a; try (destruct a); auto; do_evin; auto; tauto);

      try (
          repeat dest_range;
          repeat (find_rewrite; simpl in * );
          repeat (do_evin; auto);
          inv_events; auto);

          repeat (find_rewrite; simpl in * );
          (find_apply_lem_hyp Nat.succ_inj  ) ; subst; auto;
            tauto.
Defined.

Ltac inv_sup :=
  match goal with
  | [H:sup (?C _) _ |- _] => inv H
  end.

Ltac do_before_sup :=
  match goal with
  | [H: sup (before _ _ _) _ |- _] =>
    repeat apply before_sup in H
  | [H: sup (ev_sys _ _ _) (* (alseq (n, n0) ls x y) p)*) _
     |- _] =>
    repeat apply before_sup in H
  end.

Ltac inv_ws :=
  match goal with
  | [H:well_structured _ (?C _) |- _] => inv H
  end.

(** Maximal events are unique. *)

Lemma supreme_unique:
  forall t p e,
    well_formed_r_annt t ->
    exists ! v, supreme (ev_sys t p e) v.
Proof.
  intros t p e H.
  assert (G: well_structured ev (ev_sys t p e)).
  apply well_structured_evsys; auto.
  rewrite <- unique_existence.
  split.
  - exists (max (ev_sys t p e)).
    eapply supreme_max (*with (ev:=ev);*); eauto.
  - unfold uniqueness.
    intros x y H0 H1.
    erewrite <- sup_supreme (*with (ev:=ev)*) in H0; eauto.
    erewrite <- sup_supreme (*with (ev:=ev)*) in H1; eauto.
    revert H1.
    revert H0.
    revert G.
    revert p.
    revert e.
    induction H; intros;
      try(
          repeat dest_range; simpl in *;
          repeat break_let;
          repeat do_before_sup;

          try (inv_ws; eauto; tauto);

          repeat inv_sup; auto;
          tauto).
Defined.

Lemma evsys_max_unique:
  forall t p e,
    well_formed_r_annt t ->
    unique (supreme (ev_sys t p e)) (max (ev_sys t p e)).
Proof.
  intros t p e H.
  assert (G: well_structured ev (ev_sys t p e)).
  apply well_structured_evsys; auto.
  unfold unique.
  split.
  apply supreme_max with (ev:=ev); auto.
  intros.
  rewrite <- sup_supreme with (ev:=ev) in H0; auto.
  revert H0.
  revert G.
  revert x'.
  revert p.
  revert e.
  induction H;
    intros;
    repeat dest_range;
    repeat expand_let_pairs;
    inv_ws.
  -
    repeat inv_sup; auto.
  -
    repeat inv_sup; auto.
  -
    cbn.
    apply IHwell_formed_r_annt2.
    eassumption.
    cbn in *.
    do_before_sup.
    eassumption.
  -
    repeat do_before_sup.
    solve_by_inversion.
  -
    do_before_sup.
    solve_by_inversion.
Qed.

(*
(** Maximal event evidence output matches [aeval]. *)

Definition out_ev v :=
  match v with
  | copy _ _ e => e
  | kmeas _ _ _ _ e => e
  | umeas _ _ _ _ e => e
  | sign _ _ _ e => e
  | hash _ _ _ e => e
  | req _ _ _ e => e
  | rpy _ _ _ e => e
  | split _ _ _ _ e => e
  | join _ _ _ _ e => e
  end.

Lemma max_eval:
  forall t p e,
    well_formed t ->
    out_ev (max (ev_sys t p e)) = aeval t p e.
Proof.
  intros.
  revert e.
  revert p.
  induction H; intros; simpl; repeat expand_let_pairs; simpl; auto.
  destruct x; simpl; auto.
Qed.
*)

(** lseq is associative relative to the event semantics *)

Lemma lseq_assoc:
  forall t1 t2 t3 i p e n n' t' t'',
    anno (lseq t1 (lseq t2 t3)) i = (n, t') ->
    anno (lseq (lseq t1 t2) t3) i = (n',t'') ->

    same_rel
      (ev_sys t' p e)
      (ev_sys t'' p e).
Proof.
  intros; simpl.
  repeat expand_let_pairs; simpl.
  ff; repeat find_rewrite; ff.
  apply before_associative_pairs.
Qed.