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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (mult lv0 lv1) lv2)).
Admitted.
QuickChick conj22eqsynthconj3.


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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 (plus Zero lv0))).
Admitted.
QuickChick conj14eqsynthconj4.


(*

  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.