Require Export HoTT Ch03.
Require Import HIT.TwoSphere.

Theorem ex4_1 `{Univalence} (A B : Type) (f : A <~> B) :
  {g : B -> A & {h : g o f == idmap & {e : f o g == idmap &
    (forall x, ap f (h x) = e (f x)) * (forall y, ap g (e y) = h (g y))}}}
  <~>
  forall x : A, @idpath _ x = @idpath _ x.
Proof.
  set (p := path_universe f).
  assert (fisp : f = equiv_path _ _ p).
    apply path_equiv. apply path_forall; intro a. simpl.
    unfold p. symmetry. apply transport_path_universe.
  clearbody p. induction p. rewrite fisp. simpl.

  equiv_via ({g : A -> A & {h : g == idmap & {e : g == idmap &
    (h == e)
  * ((fun y => ap g (e y)) == (fun y => h (g y)))}}}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro g. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro h. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e. simpl.
  simple refine (equiv_functor_prod' _ _).
  simple refine (equiv_functor_forall' _ _). apply equiv_idmap. intro b. simpl.
  simple refine (equiv_adjointify _ _ _ _).
    intro eq. apply ((ap_idmap _)^ @ eq).
    intro eq. apply ((ap_idmap _) @ eq).
    intro eq. hott_simpl.
    intro eq. hott_simpl.
  apply equiv_idmap.

  equiv_via ({g : A -> A & {h : g == idmap & {e : g == idmap &
   (h = e) * ((fun y => ap g (e y)) = (fun y => h (g y)))}}}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro g. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro h. simpl.
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e. simpl.
  simple refine (equiv_functor_prod' _ _).
  apply equiv_path_forall.
  apply equiv_path_forall.

  equiv_via ({h : {g : A -> A & g == idmap} & {e : h.1 == idmap &
   (h.2 = e) * ((fun y => ap h.1 (e y)) = (fun y => h.2 (h.1 y)))}}).
  refine (equiv_sigma_assoc _ _).

  transparent assert (HC : (Contr {g : A -> A & g == idmap})).
  exists (idmap; (fun x => 1)).
  intro h. destruct h as [g h].
  apply path_sigma_uncurried. simpl.
  exists (path_forall (fun x : A => x) g (fun x : A => (h x)^)).
  unfold pointwise_paths.
  apply path_forall; intro a.
  refine ((transport_forall_constant _ _ _) @ _).
  refine ((@path_forall_1_beta _ A (fun _ => A) a (fun z => z = a)
                               idmap g _ 1) @ _).
  refine ((transport_paths_l _ _) @ _).
  refine ((concat_p1 _) @ _).
  apply inv_V.
  equiv_via ({e : (center {g : A -> A & g == idmap}).1 == idmap &
   ((center {g : A -> A & g == idmap}).2 = e)
   * ((fun y => ap (center {g : A -> A & g == idmap}).1 (e y))
      = (fun y => (center {g : A -> A & g == idmap}).2
                     ((center {g : A -> A & g == idmap}).1 y)))}).
  refine (equiv_sigma_contr_base _ _ _).
  simpl. clear HC.

  equiv_via ({e : (fun x : A => x) == idmap &
             {p : (fun x => 1) = e
             & ((fun y : A => ap idmap (e y)) = (fun y : A => 1))}}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e.
  simple refine (equiv_adjointify _ _ _ _); simpl.
  intro p. apply (fst p; snd p).
  intro p. split. apply p.1. apply p.2.
  intro p. simpl. apply eta_sigma.
  intro p. simpl. apply eta_prod.

  equiv_via ({h : {e : (fun x:A => x) == idmap & (fun x => 1) = e}
                    & (fun y : A => ap idmap (h.1 y)) = (fun y : A => 1)}).
  refine (equiv_sigma_assoc _ _).

  equiv_via ({h : {e : (fun x:A => x) == idmap & (fun x : A => 1) = e}
                    & (fun y : A => h.1 y) = (fun y : A => 1)}).
  simple refine (equiv_functor_sigma' _ _). apply equiv_idmap. intro e. simpl.
  simple refine (equiv_adjointify _ _ _ _); simpl.
  intro eq. apply path_forall; intro a. refine (_ @ (apD10 eq a)).
    apply (ap_idmap _)^.
  intro eq. apply path_forall; intro a. refine ((ap_idmap _) @ _).
    apply (apD10 eq a).
  intro eq. refine (_ @ (eta_path_forall _ _ _)).
    apply (ap (path_forall _ _)). apply path_forall; intro a.
    apply moveR_Vp. refine ((apD10_path_forall _ _ _ a) @ _).
    reflexivity.
  intro eq. refine (_ @ (eta_path_forall _ _ _)).
    apply (ap (path_forall _ _)). apply path_forall; intro a.
    apply moveR_Mp. refine ((apD10_path_forall _ _ _ a) @ _).
    reflexivity.

  equiv_via ((fun y : A => (center {e : (fun x:A => x) == idmap & (fun x : A => 1) = e}).1 y) = (fun y : A => 1)).
  simple refine (equiv_sigma_contr_base _ _ _).

  simple refine (equiv_adjointify _ _ _ _).
  - intro eq. intro x. refine (_ @ (apD10 eq x)).
    apply (apD10 (center {e: (fun x:A => x) == idmap & (fun x:A => 1) = e}).2 x).
  - intro eq. apply path_forall. intro y.
    refine (_ @ (eq y)).
    apply (apD10 (center {e: (fun x:A => x) == idmap & (fun x:A => 1) = e}).2^ y).
  - intro eq. apply path_forall. intro x.
    apply moveR_Mp. refine ((apD10_path_forall _ _ _ _) @ _).
    refine (whiskerR _ (eq x)). refine (apD10_V _ x).
  - intro eq. apply (ap apD10)^-1. apply path_forall. intro x.
    refine ((apD10_path_forall _ _ _ _) @ _). apply moveR_Mp.
    refine (whiskerR _ (apD10 eq x)).
    refine (_ @ (apD10_V _ _)). f_ap.
Defined.

Lemma not_all_sets `{Univalence} : ~ forall A, IsHSet A.
Proof.
  intro oops.
  apply idmap_bool_ne_negb.
  refine ((equiv_path_path_universe _)^ @ _).
  refine (_ @ (equiv_path_path_universe _)). f_ap.
  apply oops.
Defined.

Lemma loop_ne_1 `{Univalence} : loop <> 1.
Proof.
  intro oops.
  apply not_all_sets. intros A x y. apply hprop_allpath.
  intros p q. induction q.
  refine ((S1_rec_beta_loop A x p)^ @ _).
  refine (ap (ap _) oops).
Defined.

Lemma Book_6_4_2 `{Univalence} : {h : forall (x : S1), x = x & h <> (fun x => 1)}.
Proof.
  simple refine (S1_ind _ loop _; _).
  - refine ((transport_paths_lr _ _) @ _).
    refine ((ap (fun w => w @ _) (concat_Vp _)) @ _).
    refine (concat_1p _).
  - intro oops. apply loop_ne_1.
    apply (apD10 oops Circle.base).
Defined.

Definition not_all_1type `{U : Univalence} : ~ (forall A, IsTrunc 1 A).
Proof.
  intro oops. apply Book_6_4_2.2.
  simple refine (equiv_hprop_allpath _ _ _ _).
  simple refine (trunc_equiv (@paths (S1 -> S1) idmap idmap) _).
  - apply apD10.
  - simple refine (trunc_equiv (@equiv_idmap S1 = @equiv_idmap S1)
                        (@path_equiv _ _ _ 1%equiv 1%equiv)^-1).
    apply hprop_allpath. simple refine (@set_path2 (S1 <~> S1) _ _ _).
    simple refine (trunc_equiv (S1 = S1) _).
    + apply equiv_path.
    + apply isequiv_equiv_path.
  - apply isequiv_apD10.
Defined.

Definition surf_ne_1 `{Univalence} : surf <> 1.
Proof.
  intro oops. apply not_all_1type.
  intros A x y p q. apply hprop_allpath. intros r s.
  induction s, p.
  refine ((S2_rec_beta_surf A x r)^ @ _).
  refine (ap (ap02 _) oops).
Defined.

Definition ap_homotopic {A B : Type} (f g : A -> B) (h : f == g)
         {x y : A} (q : x = y)
: ap f q = h x @ ap g q @ (h y)^.
Proof.
  apply moveL_pV. apply concat_Ap.
Defined.

Definition Book_6_4_2' `{Univalence}
: {h : forall x : S2, (idpath x) = 1 & h <> (fun x => 1)}.
Admitted.

Definition ex4_1' `{Univalence} : ~ IsHProp (forall x : S2, (idpath x) = 1).
Proof.
  intro oops. apply Book_6_4_2'.2.
  apply (equiv_hprop_allpath _ _ _ _).
Defined.

Definition equiv_to_contr_rel_equiv (A B : Type) :
  (A <~> B)
  ->
  {R : A -> B -> Type & (forall a, Contr {b : B & R a b})
                      * (forall b, Contr {a : A & R a b})}.
Proof.
  intro e.
  exists (fun a b => (e a = b)). split.
  intro a. apply contr_basedpaths.
  intro b. refine (@contr_equiv' {a : A & e^-1 b = a} _ _ _).
  simple refine (equiv_functor_sigma' _ _).
  apply equiv_idmap. intro a. simpl.
  simple refine (equiv_adjointify _ _ _ _).
  intro eq. simple refine (_ @ (eisretr e b)). apply (ap e). apply eq^.
  intro eq. simple refine (_ @ (eissect e a)). apply (ap e^-1). apply eq^.
  intro eq. induction eq. simpl.
  apply moveR_pM. refine (_ @ (concat_1p _)^). refine ((ap_V _ _) @ _).
  apply inverse2. refine ((ap_pp _ _ _) @ _).
  apply moveR_pM. refine ((ap_1 _ _ ) @ _). apply moveL_pV.
  refine ((concat_1p _) @ _). apply (eisadj e a)^.

  intro eq. induction eq. simpl.
  apply moveR_pM. refine ((ap_V _ _) @ _). refine (_ @ (concat_1p _)^).
  apply inverse2. refine ((ap_pp _ _ _) @ _). apply moveR_pM.
  refine ((ap_1 _ _) @ _). apply moveL_pV. refine ((concat_1p _) @ _).
  apply (other_adj _ _)^.
Defined.

Theorem isequiv_equiv_to_contr_rel_equiv `{Univalence} (A B : Type) :
  IsEquiv (equiv_to_contr_rel_equiv A B).
Proof.
  simple refine (isequiv_adjointify _ _ _ _).
  intro R. destruct R as [R [f g]].
  simple refine (equiv_adjointify _ _ _ _).
  intro a. apply (center {b : B & R a b}).1.
  intro b. apply (center {a : A & R a b}).1.

  intro b. simpl.
  destruct (center {a : A & R a b}) as [a p]. simpl.
  destruct (center {b0 : B & R a b0}) as [b' q]. change b with (b; p).1.
  apply (ap pr1). apply path_ishprop.

  intro a. simpl.
  destruct (center {b : B & R a b}) as [b q]. simpl.
  destruct (center {a0 : A & R a0 b}) as [a' p].
  change a with (@pr1 _ (fun a' => R a' b) (a; q)).
  apply (ap pr1). apply path_ishprop.

  intro R. apply path_sigma_hprop. destruct R as [R [f g]]. simpl.
  apply path_forall; intro a. apply path_forall; intro b.
  destruct (center {b0 : B & R a b0}) as [b' p]. simpl.
  apply path_universe_uncurried.
  simple refine (equiv_adjointify _ _ _ _).
  intro eq. apply (transport _ eq). apply p.
  intro q. change b with (b; q).1. change b' with (b'; p).1. apply (ap pr1).
  refine (path_contr _ _). apply (f a).
  intro q. refine ((pr2_path (path_contr (b'; p) (b; q))) @ _). reflexivity.
  intro eq. induction eq. simpl.
  path_via (@ap {b : B & R a b} _ pr1 (b'; p) _ 1). f_ap.
  apply concat_Vp.

  intro e. apply path_equiv. reflexivity.
Defined.

Definition qinv {A B : Type} (f : A -> B) :=
  {g : B -> A & (f o g == idmap) * (g o f == idmap)}.

Definition qinv_isequiv A B (f : A -> B) (p : qinv f) : IsEquiv f
  := isequiv_adjointify f p.1 (fst p.2) (snd p.2).

Definition isequiv_qinv : forall A B (f : A -> B), IsEquiv f -> qinv f.
Proof.
  intros A B f p. destruct p.
  exists equiv_inv. split. apply eisretr. apply eissect.
Defined.

Definition isequiv' {A B} (f : A -> B) :=
  (forall a, Contr {b : B & f a = b}) * (forall b, Contr {a : A & f a = b}).

Theorem ex4_2_i A B (f : A -> B) : qinv f -> isequiv' f.
Proof.
  intro p. apply qinv_isequiv in p.
  set (Hf := BuildEquiv A B f p).
  set (HR := equiv_to_contr_rel_equiv A B Hf).
  set (R := pr1 HR).
  set (Q := pr2 HR).
  split. apply (fst Q). apply (snd Q).
Defined.

Theorem ex4_2_ii A B (f : A -> B) : isequiv' f -> qinv f.
Proof.
  intro p. destruct p as [sect retr].
  transparent assert (g : (B -> A)).
  intro b. destruct (retr b). apply center.1.
  exists g. split.
  unfold g. intro b. destruct (retr b). apply center.2.
  unfold g. intro a. destruct (retr (f a)).
  apply (ap pr1 (contr (a; 1))).
Defined.

Lemma hprop_prod : forall A, IsHProp A -> forall B, IsHProp B -> IsHProp (A * B).
Proof.
  intros A HA B HB z z'.
  apply (trunc_equiv' _ (equiv_path_prod z z')).
Defined.

Theorem ex4_2_iii `{Funext} A B (f : A -> B) : IsHProp (isequiv' f).
Proof.
  unfold isequiv'.
  typeclasses eauto.
Defined.

Theorem concat_Ap_w (A B : Type) (f g : A -> B) (p : forall x : A, f x = g x)
         (x y : A) (q : x = y)
  : ap f q  = p x @ ap g q @ (p y)^.
Proof.
  apply moveL_pV. apply concat_Ap.
Defined.

Theorem Book_4_1_1 `{Funext} (A B : Type) (f : A <~> B) :
  qinv f <~> forall x : A, x = x.
Proof.
  unfold qinv.
  equiv_via ({h : {g : B -> A & (f o g == idmap)} & (h.1 o f == idmap)}).
  simple refine (equiv_adjointify _ _ _ _).
  intro w. exists (w.1; fst w.2). apply (snd w.2).
  intro w. exists w.1.1. split. apply w.1.2. apply w.2.
  intro w. destruct w as [[g h] e]. reflexivity.
  intro w. destruct w as [g [h e]]. reflexivity.

  transparent assert (H' : (Contr {g : B -> A & f o g == idmap})).
  exists (f^-1; eisretr f). intro h. destruct h as [w h].
  apply path_sigma_uncurried. simpl.
  exists (path_forall f^-1 w (fun b : B => ap f^-1 (h b)^ @ eissect f (w b))).
  unfold pointwise_paths.
  apply path_forall; intro b.
  refine ((transport_forall_constant _ _ _) @ _).
  refine ((@path_forall_1_beta _ B (fun _ => A) b (fun z => f z = b) _ _ _ _)
            @ _).
  refine ((transport_paths_Fl _ _) @ _).
  apply moveR_Vp. apply moveL_pM.
  refine (_ @ (ap_pp _ _ _)^).
  apply moveL_Mp. refine (_ @ (eisadj _ _)).
  apply moveR_Vp. apply moveL_pM.
  refine (_ @ (ap_compose _ _ _)).
  refine (_ @ (concat_Ap_w _ _ _ idmap (eisretr f) _ _ _)^).
  apply concat2. apply concat2. reflexivity. apply (ap_idmap _)^. reflexivity.

  equiv_via ((center {g : B -> A & f o g == idmap}).1 o f == idmap).
  refine (equiv_sigma_contr_base _ _ _).
  simpl. clear H'.

  simple refine (equiv_adjointify _ _ _ _).
  intro h. apply path_forall in h. intro x. refine ((eissect f _)^ @ _).
  apply (ap10 h x).
  intro h. intro x. refine ((eissect f _) @ _). apply (h x).
  intro h. apply path_forall; intro a.
  apply moveR_Vp. refine ((ap10_path_forall _ _ _ a) @ _). reflexivity.
  intro h. apply path_forall; intro a.
  apply moveR_Mp. apply concat2. reflexivity.
  refine ((ap10_path_forall _ _ _ a) @ _). reflexivity.
Defined.

Lemma equiv_prod_unit (A : Type) : A <~> A * Unit.
Proof.
  refine (equiv_adjointify (fun a => (a, tt)) (fun z => fst z) _ _).
  intro z. apply path_prod. reflexivity. apply eta_unit.
  intro a. reflexivity.
Defined.

Module Ex4.

Variables (A B C D : Type) (f : A -> B) (g : B -> C) (b : B).

Definition f_star (z : hfiber (g o f) (g b)) : hfiber g (g b) :=
  (f z.1; z.2).

Theorem ex4_4_i : hfiber (f_star) (b; 1) <~> hfiber f b.
Proof.
  equiv_via {a : A & {p : g (f a) = g b & (f_star (a; p) = (b; 1))}}.
  apply equiv_inverse. refine (equiv_sigma_assoc _ _). unfold f_star. simpl.

  equiv_via {a : A & {p : g (f a) = g b & {q : f a = b &
               transport (fun x => g x = g b) q p = 1}}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_functor_sigma_id _). intro p.
  apply equiv_inverse.
  refine (equiv_path_sigma (fun x => g x = g b) (f a; p) (b; 1)).

  equiv_via {a : A & {q : f a = b & {p : g (f a) = g b &
               transport (fun x => g x = g b) q p = 1}}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_sigma_comm _ _ _).

  equiv_via {a : A & {q : f a = b & {p : g (f a) = g b &
               p = transport (fun x => g x = g b) q^ 1}}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_functor_sigma_id _). intro p.
  refine (equiv_functor_sigma_id _). intro q.
  refine (BuildEquiv _ _ _ (isequiv_moveL_transport_V _ _ _ _)).

  equiv_via {a : A & {q : f a = b & Unit}}.
  refine (equiv_functor_sigma_id _). intro a.
  refine (equiv_functor_sigma_id _). intro p.
  refine equiv_contr_unit.

  refine (equiv_functor_sigma_id _). intro a.
  equiv_via ((f a = b) * Unit). refine (equiv_const_sigma_prod _ _).
  apply equiv_inverse. refine (equiv_prod_unit _).
Defined.

Theorem ex4_4_ii
  : hfiber (g o f) (g b) <~> {w : hfiber g (g b) & hfiber f w.1}.
Proof.
  apply equiv_inverse. unfold hfiber.

  equiv_via {b' : B & {p : g b' = g b & {x : A & f x = b'}}}.
  apply equiv_inverse.
  refine (equiv_sigma_assoc _ _).

  equiv_via {b' : B & {x : A & {_ : g b' = g b & f x = b'}}}.
  refine (equiv_functor_sigma_id _). intro b'.
  refine (equiv_sigma_comm _ _ _).

  equiv_via {x : A & {b' : B & {_ : g b' = g b & f x = b'}}}.
  refine (equiv_sigma_comm _ _ _).

  refine (equiv_functor_sigma_id _). intro a.

  equiv_via {b' : B & {p : f a = b' & g b' = g b}}.
  refine (equiv_functor_sigma_id _). intro b'.
  equiv_via ((g b' = g b) * (f a = b')).
  refine (equiv_const_sigma_prod _ _).
  equiv_via ((f a = b') * (g b' = g b)).
  refine (equiv_prod_symm _ _).
  apply equiv_inverse.
  refine (equiv_const_sigma_prod _ _).

  equiv_via {w : {b' : B & f a = b'} & g w.1 = g b}.
  refine (equiv_sigma_assoc _ _).

  equiv_via (g (center {b' : B & f a = b'}).1 = g b).
  refine (equiv_sigma_contr_base _ _ _). simpl.

  simple refine (equiv_adjointify _ _ _ _).
  - intro eq. apply eq.
  - intro eq. apply eq.
  - intro eq. reflexivity.
  - intro eq. reflexivity.
Defined.

End Ex4.

Theorem two_out_of_six {A B C D : Type} (f : A -> B) (g : B -> C) (h : C -> D) :
  IsEquiv (g o f) -> IsEquiv (h o g) ->
  (IsEquiv f /\ IsEquiv g /\ IsEquiv h /\ IsEquiv (h o g o f)).
Proof.
  intros Hgf Hhg. split.

  (* case f *)
  refine (isequiv_adjointify f ((g o f) ^-1 o g) _ _).
  intro b.
  change (f (((g o f) ^-1 o g) b)) with ((f o (g o f) ^-1 o g) b).
  assert ((f o (g o f) ^-1 o g) b
          =
          ((h o g) ^-1 o (h o g) o f o (g o f) ^-1 o g) b).
  change (((h o g) ^-1 o (h o g) o f o (g o f) ^-1 o g) b)
         with ((((h o g) ^-1 ((h o g) ((f o (g o f) ^-1 o g) b))))).
  rewrite (eissect (h o g)). reflexivity.
  rewrite X.
  change (((h o g) ^-1 o (h o g) o f o (g o f) ^-1 o g) b)
         with ((((h o g) ^-1 o h) ((((g o f) ((g o f) ^-1 (g b))))))).
  rewrite (eisretr (g o f)).
  change (((h o g) ^-1 o h) (g b)) with (((h o g) ^-1 o (h o g)) b).
  apply (eissect (h o g)).

  intro a. apply (eissect (g o f)).

  split.
  (* case g *)
  refine (isequiv_adjointify g ((h o g) ^-1 o h) _ _).
  intro c.
  change (g (((h o g) ^-1 o h) c)) with ((g o (h o g) ^-1 o h) c).
  assert ((g o (h o g) ^-1 o h) c
          =
          (g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c).
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (((g o (h o g) ^-1 o h) ((g o f) ((g o f) ^-1 c)))).
  rewrite (eisretr (g o f)). reflexivity.
  rewrite X.
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (g (((h o g) ^-1 ((h o g) ((f o (g o f) ^-1) c))))).
  rewrite (eissect (h o g)).
  change (g ((f o (g o f) ^-1) c)) with (((g o f) o (g o f) ^-1) c).
  apply (eisretr (g o f)).

  intro b. apply (eissect (h o g)).

  split.
  (* case h *)
  refine (isequiv_adjointify h (g o (h o g) ^-1) _ _).
  intro d. apply (eisretr (h o g)).

  intro c.
  change ((g o (h o g) ^-1) (h c)) with ((g o (h o g) ^-1 o h) c).
  assert ((g o (h o g) ^-1 o h) c
          =
          (g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c).
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (((g o (h o g) ^-1 o h) ((g o f) ((g o f) ^-1 c)))).
  rewrite (eisretr (g o f)). reflexivity.
  rewrite X.
  change ((g o (h o g) ^-1 o h o g o f o (g o f) ^-1) c)
         with (g ((h o g) ^-1 ((h o g) ((f o (g o f) ^-1) c)))).
  rewrite (eissect (h o g)).
  change (g ((f o (g o f) ^-1) c)) with (((g o f) o (g o f) ^-1) c).
  apply (eisretr (g o f)).

  (* case h o g o f *)
  refine (isequiv_adjointify (h o g o f) ((g o f) ^-1 o g o (h o g) ^-1) _ _).
  intro d.
  change ((h o g o f) (((g o f) ^-1 o g o (h o g) ^-1) d))
         with (h ((g o f) ((g o f) ^-1 ((g o (h o g) ^-1) d)))).
  rewrite (eisretr (g o f)).
  apply (eisretr (h o g)).

  intro a.
  change (((g o f) ^-1 o g o (h o g) ^-1) ((h o g o f) a))
         with ((((g o f) ^-1 o g) ((h o g) ^-1 ((h o g) (f a))))).
  rewrite (eissect (h o g)). apply (eissect (g o f)).
Qed.

Theorem isequiv_homotopic' : forall (A B : Type) (f g : A -> B),
  IsEquiv f -> f == g -> IsEquiv g.
Proof.
  intros A B f g p h.
  refine (isequiv_adjointify g f^-1 _ _).
  intros b. apply ((h (f^-1 b))^ @ (eisretr f b)).
  intros a. apply ((ap f^-1 (h a))^ @ (eissect f a)).
Defined.

Theorem Theorem2111' (A B : Type) (a a' : A) (f : A -> B) (H : IsEquiv f) :
  IsEquiv (fun p : a = a' => ap f p).
Proof.
  apply (two_out_of_six (fun p : a = a' => ap f p)
                        (fun p : (f a) = (f a') => ap f^-1 p)
                        (fun p : (f^-1 (f a)) = (f^-1 (f a')) => ap f p)).
  apply (isequiv_homotopic (fun p => (eissect f a) @ p @ (eissect f a')^)).
  intro p. induction p. hott_simpl.

  apply (isequiv_homotopic (fun p => (eisretr f (f a)) @ p @ (eisretr f (f a'))^)).
  intro p. induction p. hott_simpl.
Defined.

Module Ex6.

Hypothesis qinv_univalence : forall A B, qinv (equiv_path A B).

Theorem Book_4_9_2 (A B X : Type) (e : A <~> B) : (X -> A) <~> (X -> B).
Proof.
  destruct e as [f p].
  assert (qinv f) as q. exists f^-1. split.
    apply (eisretr f). apply (eissect f).
  assert (A = B) as r. apply (qinv_univalence A B).
  apply (BuildEquiv _ _ f p).
  path_induction. apply equiv_idmap.
Defined.

Lemma Book_4_1_2 `{Funext} (A : Type) (a : A) (q : a = a)
  : IsHSet (a = a) -> (forall x, Brck (a = x))
    -> (forall p : a = a, p @ q = q @ p)
    -> {f : forall (x : A), x = x & f a = q}.
Proof.
  intros eq g eta.
  transparent assert (Heq : (forall x y : A, IsHSet (x = y))).
  intros x y.
  assert (Brck (a = x)) as p by auto.
  assert (Brck (a = y)) as r by auto.
  strip_truncations.
  simple refine (@trunc_equiv (a = a) _ _ _ _ _).
  intros s. apply (p^ @ s @ r).
  apply isequiv_concat_lr.
  set (B := fun x => {r : x = x & forall s : a = x, (r = s^ @ q @ s)}).
  transparent assert (HB : (forall x, (IsHProp (B x)))).
  intro x. assert (Brck (a = x)) as p by auto.
  strip_truncations.
  apply hprop_allpath. intros rh r'h'.
  destruct rh as [r h], r'h' as [r' h'].
  apply path_sigma_uncurried. exists ((h p) @ (h' p)^). simpl.
  apply path_forall. intro t. apply Heq.
  transparent assert (f' : (forall x, B x)).
  intro x. assert (Brck (a = x)) as p by auto. strip_truncations.
  exists (p^ @ q @ p). intro s.
  apply moveL_pM. repeat (refine ((concat_pp_p _ _ _) @ _)).
  apply moveR_Vp. refine (_ @ (concat_pp_p _ _ _)).
  symmetry. apply eta.
  exists (fun x => (f' x).1).
  refine (((f' a).2 1) @ _).
  hott_simpl.
Defined.

End Ex6.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export type_environment.

Section natural_type_environment.
Context `{IntEnvSpec K}.
Context (ptr_size : ptr_type K → nat) (align_base : base_type K → nat).
Context (ptr_size_ne_0 : ∀ τ, ptr_size τ ≠ 0).
Context (align_void : align_base voidT = 1).
Context (align_int_divide : ∀ τi, (align_base (intT τi) | rank_size (rank τi))).
Context (align_ptr_divide : ∀ τp, (align_base (τp.*) | ptr_size τp)).
Context (alloc_can_fail : bool).

Definition natural_align_of (Γ : env K) : type K → nat := type_iter
  (**i TBase =>     *) align_base
  (**i TArray =>    *) (λ _ _ x, x)
  (**i TCompound => *) (λ c t τs rec, foldr lcm 1 (rec <$> τs)) Γ.
Definition natural_fields_align (Γ : env K) (τs : list (type K)) : nat :=
  foldr lcm 1 (natural_align_of Γ <$> τs).

Definition natural_padding (pos al : nat) : nat :=
  let z := pos `mod` al in if decide (z = 0) then 0 else al - z.

Definition natural_field_sizes (f : type K → nat) (Γ : env K)
    (whole_align : nat) : nat → list (type K) → list nat :=
  fix go pos τs :=
  match τs with
  | [] => []
  | τ :: τs =>
    let align := from_option (natural_align_of Γ) whole_align (head τs) in
    let sz := f τ + natural_padding (f τ + pos) align in
    sz :: go (sz + pos) τs
  end.
Definition natural_size_of (Γ : env K) : type K → nat :=
  type_iter
  (**i TBase =>     *) (λ τb,
    match τb with
    | voidT => 1 | intT τi => rank_size (rank τi) | τp.* => ptr_size τp
    end%BT)
  (**i TArray =>    *) (λ _, mult)
  (**i TCompound => *) (λ c t τs go,
    match c with
    | Struct_kind =>
       sum_list (natural_field_sizes go Γ (natural_fields_align Γ τs) 0 τs)
    | Union_kind =>
       let sz := foldr max 1 (go <$> τs) in
       sz + natural_padding sz (natural_fields_align Γ τs)
    end) Γ.

#[local] Instance natural_env : Env K := {
  size_of := natural_size_of;
  align_of := natural_align_of;
  field_sizes Γ τs :=
    natural_field_sizes (natural_size_of Γ) Γ (natural_fields_align Γ τs) 0 τs;
  alloc_can_fail := alloc_can_fail
}.

Lemma natural_padding_divide pos al :
  al ≠ 0 → (al | pos + natural_padding pos al).
Proof.
  intros. unfold natural_padding; case_decide.
  { rewrite Nat.add_0_r. by apply Nat.mod_divide. }
  exists (1 + pos `div` al). rewrite Nat.mul_add_distr_r, Nat.mul_1_l.
  assert (pos - al * pos `div` al < al).
  { rewrite <-Nat.mod_eq by done. by apply Nat.mod_bound_pos; lia. }
  assert (al * pos `div` al ≤ pos) by (by apply Nat.mul_div_le).
  rewrite Nat.mod_eq by done. lia.
Qed.
Lemma natural_align_of_compound_proper (Γ: env K) :
  let fcompound c t τs rec := foldr lcm 1 (rec <$> τs) in
  ∀ rec1 rec2 (c : compound_kind) t (τs : list (type K)),
  Γ !! t = Some τs → Forall (λ τ, rec1 τ = rec2 τ) τs →
  fcompound c t τs rec1 = fcompound c t τs rec2.
Proof.
  intros fcompound rec1 rec2 c t τs _.
  unfold fcompound. induction 1; simpl; auto using f_equal.
Qed.
Lemma natural_align_of_base Γ τb : align_of Γ (baseT τb) = align_base τb.
Proof. done. Qed.
Lemma natural_align_of_array Γ τ n : align_of Γ (τ.[n]) = align_of Γ τ.
Proof.
  unfold align_of; simpl; unfold natural_align_of. by rewrite type_iter_array.
Qed.
Lemma natural_align_of_compound Γ c t τs :
  ✓ Γ → Γ !! t = Some τs →
  align_of Γ (compoundT{c} t) = natural_fields_align Γ τs.
Proof.
  intros. unfold align_of; simpl; unfold natural_align_of.
  by rewrite type_iter_compound by eauto
    using natural_align_of_compound_proper with typeclass_instances.
Qed.
Lemma natural_align_of_weaken Γ1 Γ2 τ :
  ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → align_of Γ1 τ = align_of Γ2 τ.
Proof.
  intros. unfold align_of; simpl; unfold natural_align_of.
  apply type_iter_weaken; eauto
    using natural_align_of_compound_proper with typeclass_instances.
Qed.
Lemma natural_fields_align_weaken Γ1 Γ2 τs :
  ✓ Γ1 → ✓{Γ1}* τs → Γ1 ⊆ Γ2 →
  natural_fields_align Γ1 τs = natural_fields_align Γ2 τs.
Proof.
  intros ? Hτs ?. unfold natural_fields_align.
  induction Hτs; simpl; auto using natural_align_of_weaken.
Qed.
Lemma natural_field_sizes_weaken rec1 rec2 Γ1 Γ2 whole_align pos τs :
  ✓ Γ1 → Γ1 ⊆ Γ2 → ✓{Γ1}* τs → Forall (λ τ, rec1 τ = rec2 τ) τs →
  natural_field_sizes rec1 Γ1 whole_align pos τs =
    natural_field_sizes rec2 Γ2 whole_align pos τs.
Proof.
  intros ?? Hτs Hrec. revert pos Hτs.
  induction Hrec as [|τ τs Hτ ? IH]; intros; decompose_Forall; simpl; auto.
  rewrite Hτ, IH by done. destruct τs as [|τ2 τs]; simpl; [done|].
  decompose_Forall. by erewrite natural_align_of_weaken by eauto.
Qed.

Lemma natural_size_of_compound_proper Γ1 Γ2 rec1 rec2 c t τs :
  let fc Γ rec c (t : tag) τs :=
    match c with
    | Struct_kind =>
       sum_list (natural_field_sizes rec Γ (natural_fields_align Γ τs) 0 τs)
    | Union_kind =>
       let sz := foldr max 1 (rec <$> τs) in
       sz + natural_padding sz (natural_fields_align Γ τs)
    end in
  ✓ Γ1 → Γ1 ⊆ Γ2 → Γ1 !! t = Some τs → ✓{Γ1}* τs →
  Forall (λ τ, rec1 τ = rec2 τ) τs → fc Γ1 rec1 c t τs = fc Γ2 rec2 c t τs.
Proof.
  intros fc ??. destruct c; simpl.
  * intros _ Hτs Hrec. erewrite natural_fields_align_weaken by eauto.
    by erewrite natural_field_sizes_weaken by eauto.
  * intros. by erewrite Forall_fmap_ext_1, natural_fields_align_weaken by eauto.
Qed.
Lemma natural_size_of_base Γ τb :
  size_of Γ (baseT τb) =
    match τb with
    | voidT => 1 | intT τi => rank_size (rank τi) | τp.* => ptr_size τp
    end%BT.
Proof. done. Qed.
Lemma natural_size_of_array Γ τ n : size_of Γ (τ.[n]) = n * size_of Γ τ.
Proof. unfold size_of; simpl; unfold natural_size_of.
  by apply type_iter_array. Qed.
Lemma natural_size_of_compound Γ c t τs :
  ✓ Γ → Γ !! t = Some τs → size_of Γ (compoundT{c} t) =
    match c with
    | Struct_kind => sum_list (field_sizes Γ τs)
    | Union_kind =>
       let sz := foldr max 1 (size_of Γ <$> τs) in
       sz + natural_padding sz (natural_fields_align Γ τs)
    end.
Proof.
  intros. unfold size_of; simpl. unfold natural_size_of.
  by rewrite type_iter_compound by eauto
    using natural_size_of_compound_proper with typeclass_instances.
Qed.
Lemma natural_size_of_weaken Γ1 Γ2 τ :
  ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → size_of Γ1 τ = size_of Γ2 τ.
Proof.
  intros. unfold size_of; simpl. unfold natural_size_of.
  apply type_iter_weaken;
    eauto using natural_size_of_compound_proper with typeclass_instances.
Qed.
Lemma natural_align_ne_0 Γ τ : ✓ Γ → ✓{Γ} τ → align_of Γ τ ≠ 0.
Proof.
  intros HΓ. revert τ. refine (type_env_ind _ HΓ _ _ _ _).
  * intros τb _; rewrite natural_align_of_base; destruct τb;
      rewrite ?align_void; eauto using Nat_divide_ne_0, rank_size_ne_0.
  * intros. by rewrite natural_align_of_array.
  * intros c t τs Ht _ IH _. erewrite natural_align_of_compound by eauto.
    clear Ht. unfold natural_fields_align.
    induction IH; csimpl; rewrite ?Nat.lcm_eq_0; naive_solver.
Qed.

#[local] Instance natural_env_spec: EnvSpec K.
Proof.
  split.
  * apply _.
  * intros ??. apply ptr_size_ne_0.
  * done.
  * done.
  * by apply natural_size_of_array.
  * intros Γ t τs ??. by erewrite natural_size_of_compound by eauto.
  * intros Γ τs ?. unfold field_sizes; simpl.
    change natural_size_of with size_of.
    generalize (natural_fields_align Γ τs), 0. intros align.
    induction τs; simpl; constructor; auto with lia.
  * intros Γ t τs ? Hτs. erewrite natural_size_of_compound by eauto.
    apply Forall_impl with (λ τ,
      size_of Γ τ ≤ foldr max 1 (size_of Γ <$> τs)); [|simpl; auto with lia].
    clear Hτs. induction τs; csimpl; constructor; [lia|].
    apply Forall_impl with (1:=IHτs); intros; lia.
  * intros Γ τ n. by rewrite natural_align_of_array.
  * intros Γ c t τs i τ ? Ht Hi. erewrite natural_align_of_compound by eauto.
    clear Ht. revert i τ Hi. unfold natural_fields_align.
    induction τs; intros [|?] ??; simplify_equality';
      eauto 3 using Nat.divide_trans, Nat.divide_lcm_r, Nat.divide_lcm_l.
  * intros Γ τ HΓ. revert τ. unfold size_of; simpl.
    refine (type_env_ind _ HΓ _ _ _ _).
    + intros τb. rewrite natural_align_of_base, natural_size_of_base.
      destruct 1; auto. by rewrite align_void.
    + intros τ n ? ? _. rewrite natural_align_of_array, natural_size_of_array.
      by apply Nat.divide_mul_r.
    + intros c t τs Ht Hτs IH Hlen.
      erewrite natural_align_of_compound, natural_size_of_compound by eauto.
      assert (natural_fields_align Γ τs ≠ 0) as Hne_0.
      { clear Ht Hlen. unfold natural_fields_align.
        induction IH as [|τ τs IHτ ? IH]; decompose_Forall; simpl; [done|].
        rewrite Nat.lcm_eq_0; intros [|?]; [|by destruct IH].
        by apply (natural_align_ne_0 Γ τ). }
      destruct c; [|by apply natural_padding_divide].
      clear Ht Hτs IH. unfold field_sizes; simpl. revert Hne_0.
      generalize (natural_fields_align Γ τs); intros whole_align ?.
      rewrite <-(Nat.add_0_l (sum_list _)). generalize 0.
      induction τs as [|τ1 τs IH]; intros pos; simpl; [done|].
      rewrite (Nat.add_assoc pos), (Nat.add_comm pos).
      destruct τs as [|τ2 τs]; [simpl|by apply IH].
      rewrite Nat.add_0_r, <-Nat.add_assoc, (Nat.add_comm _ pos),
        Nat.add_assoc; auto using natural_padding_divide.
  * intros Γ τs i τ ? Hτs. revert i.
    cut (∀ whole_align i pos, τs !! i = Some τ →
      (from_option (natural_align_of Γ) whole_align (head τs) | pos) →
      (natural_align_of Γ τ | pos + sum_list (take i
         (natural_field_sizes (natural_size_of Γ) Γ whole_align pos τs)))).
    { intros help i ?. rewrite <-(Nat.add_0_l (offset_of _ _ _)).
      apply help; auto using Nat.divide_0_r. }
    intros whole_align. induction Hτs as [|τ' τs Hτ Hτs IH];
      intros [|i] pos al ?; simplify_equality'.
    { rewrite Nat.add_0_r. auto using Nat.divide_0_r. }
    rewrite Nat.add_assoc, (Nat.add_comm pos). apply IH; auto.
    clear IH. destruct Hτs as [|τ2 τs]; simplify_list_eq.
    rewrite <-Nat.add_assoc, (Nat.add_comm _ pos), Nat.add_assoc.
    by apply natural_padding_divide, natural_align_ne_0.
  * apply natural_size_of_weaken.
  * apply natural_align_of_weaken.
  * intros Γ1 Γ2 τs ? Hτs ?. unfold field_sizes; simpl.
    assert (Forall (λ τ, size_of Γ1 τ = size_of Γ2 τ) τs).
    { induction Hτs; constructor; auto using natural_size_of_weaken. }
    by erewrite natural_field_sizes_weaken, natural_fields_align_weaken by eauto.
Qed.
End natural_type_environment.


Load loadpath.
Require Import Coq.Lists.List.
Require Import veristar.variables veristar.datatypes.
Require Import Coqlib.
Require Import msl.Coqlib2.
Require Import ZArith.
Require Import veristar.compare.
Require Import veristar.clauses.

Fixpoint freshmax_expr (e: expr) : var :=
  match e with
  | Nil => minid
  | Var v => v
  end.

Definition var_max (x y : var) : var :=
 match Ident.compare x y with Lt => y | _ => x end.

Definition freshmax_pn_atom (a: pn_atom) : var :=
  match a with
  | Equ e1 e2 => var_max (freshmax_expr e1) (freshmax_expr e2)
  | Nequ e1 e2 => var_max (freshmax_expr e1) (freshmax_expr e2)
  end.

Definition freshmax_space_atom (a: space_atom) : var :=
  match a with
  | Next e1 e2 =>  var_max (freshmax_expr e1) (freshmax_expr e2)
  | Lseg e1 e2 =>  var_max (freshmax_expr e1) (freshmax_expr e2)
 end.

Definition freshmax_list {A} (f: A -> var) (l: list A) : var :=
  fold_right (fun a i => var_max (f a) i) minid l.

Definition freshmax_assertion (a: assertion) : var :=
  match a with
  | Assertion pi sigma =>
     var_max (freshmax_list freshmax_pn_atom pi)
            (freshmax_list freshmax_space_atom sigma)
  end.

Definition freshmax_pure_atom (a: pure_atom) : var :=
  match a with
  | Eqv e1 e2 => var_max (freshmax_expr e1) (freshmax_expr e2)
  end.

Definition freshmax_clause (c : clause) : var :=
 match c with
 | PureClause pi pi' _ _ =>  var_max (freshmax_list freshmax_pure_atom pi)
                                     (freshmax_list freshmax_pure_atom pi')
 | PosSpaceClause pi pi' sigma =>
     var_max (var_max (freshmax_list freshmax_pure_atom pi)
                                     (freshmax_list freshmax_pure_atom pi'))
                       (freshmax_list freshmax_space_atom sigma)
 | NegSpaceClause pi sigma pi' =>
     var_max (var_max (freshmax_list freshmax_pure_atom pi)
                                     (freshmax_list freshmax_pure_atom pi'))
                       (freshmax_list freshmax_space_atom sigma)
 end.

Lemma varmax_minid: forall x, var_max minid x = x.
Proof.
intros; unfold var_max.
id_compare minid x; auto.
apply minid_min in l; contradiction.
Qed.

Lemma varmax_minid': forall x, var_max x minid = x.
Proof.
intros; unfold var_max.
id_compare x minid; auto.
apply minid_min in l; contradiction.
Qed.

Lemma var_max_intro:
  forall a b c, Ident.lt a c -> Ident.lt b c -> Ident.lt (var_max a b) c.
Proof.
unfold var_max; intros; auto.
id_compare a b; auto.
Qed.

Lemma Ile_var_max1:  forall a b, Ile a (var_max a b).
Proof.
intros.
 unfold Ile, var_max.
 id_compare a b; subst; auto;  right; apply Ident.eq_equiv.
Qed.

Lemma Ile_var_max2:  forall a b, Ile b (var_max a b).
Proof.
intros.
 unfold Ile, var_max.
 id_compare a b; subst; auto;  right; apply Ident.eq_equiv.
Qed.

Lemma Ile_trans: forall a b c, Ile a b -> Ile b c -> Ile a c.
Proof.
 unfold Ile; intros.
 destruct H. left; destruct H0. eapply Ilt_trans; eauto.
 rewrite <- H0; auto. rewrite H in *; auto.
Qed.

Lemma Ile_minid: forall m, Ile minid m.
Proof.
 unfold Ile; intros.
 id_compare minid m. subst. right; apply Ident.eq_equiv.
 auto. apply minid_min in l; contradiction.
Qed.

Lemma var_max_intro':
  forall a b c, Ile a c -> Ile b c -> Ile (var_max a b) c.
Proof.
unfold var_max; intros; auto.
id_compare a b; auto.
Qed.

Lemma var_max_split': forall a b c, Ile (var_max a b) c -> Ile a c /\ Ile b c.
Proof.
unfold var_max; intros.
id_compare a b; subst; intuition.
destruct H. left; eapply Ilt_trans; eauto.
rewrite H in *. left; auto.
destruct H.
left; eapply Ilt_trans; eauto.
rewrite H in *.
left; auto.
Qed.

Lemma id_compare_refl: forall z, Ident.compare z z = Eq.
Proof. intro. id_compare z z; auto; contradiction (Ilt_irrefl l).
Qed.

Lemma id_compare_lt: forall x y, Ident.lt x y -> Ident.compare x y = Lt.
Proof. intros. id_compare x y; auto. subst; contradiction (Ilt_irrefl H).
contradiction (Ilt_irrefl (Ilt_trans H l)).
Qed.

Lemma id_compare_gt: forall x y, Ident.lt y x -> Ident.compare x y = Gt.
Proof. intros. id_compare x y; auto. subst; contradiction (Ilt_irrefl H).
contradiction (Ilt_irrefl (Ilt_trans l H)).
Qed.

Lemma var_max_assoc: forall x y z, var_max x (var_max y z) = var_max (var_max x y) z.
Proof.
intros.
unfold var_max.
id_compare x y.
subst. id_compare y z. subst.
rewrite id_compare_refl; auto.

rewrite id_compare_lt; auto.
rewrite id_compare_refl; auto.
id_compare y z; auto. subst. rewrite id_compare_lt; auto.
rewrite id_compare_lt; auto. eapply Ilt_trans; eauto.
id_compare x y; auto.
contradiction (Ilt_irrefl (Ilt_trans l1 l)).
id_compare y z; auto.
subst.
rewrite id_compare_gt; auto.
rewrite id_compare_gt; auto.
rewrite id_compare_gt; auto.
eapply Ilt_trans; eauto.
Qed.

Lemma var_max_com: forall x y, var_max x y = var_max y x.
Proof.
intros.
unfold var_max.
id_compare x y; auto.
subst; rewrite id_compare_refl; auto.
rewrite id_compare_gt; auto.
rewrite id_compare_lt; auto.
Qed.

Lemma var_max_split: forall a b c, Ident.lt (var_max a b) c -> Ident.lt a c /\ Ident.lt b c.
Proof.
unfold var_max; intros.
id_compare a b; subst; intuition.
transitivity b; auto.
transitivity a; auto.
Qed.

Lemma freshmax_list_app:
 forall {A} (f: A -> var) l1 l2,
    freshmax_list f (l1++l2) = var_max (freshmax_list f l1) (freshmax_list f l2).
Proof.
intros.
induction l1; simpl.
rewrite varmax_minid. auto.
rewrite IHl1.
rewrite var_max_assoc; auto.
Qed.

Lemma freshmax_list_rev:
 forall {A} (f: A -> var) l,
    freshmax_list f (rev l) = freshmax_list f l.
Proof.
induction l; simpl; auto.
rewrite freshmax_list_app.
rewrite IHl.
simpl.
rewrite (var_max_com (f a)).
rewrite varmax_minid.
apply var_max_com.
Qed.

Lemma Ile_freshmax_i3:
  forall s m,
    (forall x, M.In x s -> Ile (freshmax_clause x) m) ->
     Ile (freshmax_list freshmax_clause (M.elements s)) m.
Proof.
  intros.
  assert (forall x, List.In x (M.elements s) -> Ile (freshmax_clause x) m).
  intros. rewrite Melements_spec1 in H0. auto.
  clear H.
  revert H0; induction (M.elements s); simpl; intros.
  apply Ile_minid.
  apply var_max_intro'.
  apply H0; auto.
  apply IHl.
   intros; auto.
Qed.

Lemma merge_nil1:
  forall {A} (f: A -> A -> comparison) l, merge f nil l = l.
Proof.
 intros. induction l; simpl; auto.
Qed.

Lemma freshmax_list_merge:
  forall m al bl,
     Ile (freshmax_list freshmax_pure_atom al) m ->
     Ile (freshmax_list freshmax_pure_atom bl) m ->
     Ile (freshmax_list freshmax_pure_atom (merge pure_atom_cmp al bl)) m.
Proof.
 intros.
  revert bl H H0; induction al; simpl; intros; auto.
  revert H0; induction bl; simpl; intros; auto.
  apply var_max_split' in H; destruct H.
assert (IHal':
  forall bl, Ile (freshmax_list freshmax_pure_atom bl) m ->
       Ile (freshmax_list freshmax_pure_atom (merge pure_atom_cmp al bl)) m).
 intros; apply IHal; auto.
  clear IHal.
  revert H0; induction bl; intros.
  apply var_max_intro'; auto.
  apply var_max_split' in H0; destruct H0.
  destruct (pure_atom_cmp a a0).
  apply var_max_intro'; auto.
 apply IHal'; auto.
  apply var_max_intro'; auto.
  apply var_max_intro'; auto.
  apply IHal'.
  apply var_max_intro'; auto.
Qed.

Lemma Ile_freshmax_list:
  forall A (f: A -> var) m (s: list A),
    Ile (freshmax_list f s) m <-> (forall x, List.In x s -> Ile (f x) m).
Proof.
  intros.
  split; induction s; simpl; intros; try contradiction.
  destruct H0; subst.
  apply var_max_split' in H. destruct H; auto.
  apply var_max_split' in H. destruct H; auto.
  apply Ile_minid.
  simpl.
  apply var_max_intro'.
  apply H; simpl; auto.
  apply IHs; auto.
Qed.

Lemma freshmax_list_insu:
   forall A (f: A -> var) (cmp: A -> A -> comparison)
      (CMP_EQ: forall a b, a=b <-> Eq = cmp a b)
      a s,
      freshmax_list f (insert_uniq cmp a s) = var_max (f a) (freshmax_list f s).
Proof.
 induction s; simpl; intros; auto.
 case_eq (cmp a a0); intros.
 symmetry in H; apply CMP_EQ in H; subst a0.
 simpl.
 rewrite var_max_assoc.
 f_equal; auto.
 unfold var_max. destruct (Ident.compare (f a) (f a)); auto.
 simpl. rewrite IHs.
 repeat rewrite var_max_assoc.
 f_equal. apply var_max_com.
 simpl. auto.
Qed.

Lemma freshmax_list_sort:
  forall A (f: A -> var) (cmp: A -> A -> comparison)
      (CMP_EQ: forall a b, a=b <-> Eq = cmp a b)
      (s: list A),
    freshmax_list f (rsort_uniq cmp s) = freshmax_list f s.
Proof.
  induction s; simpl; intros; auto.
  rewrite freshmax_list_insu; auto.
  rewrite IHs; auto.
Qed.

Lemma freshmax_insu:
  forall m a pi,
       Ile (freshmax_pure_atom a) m ->
       Ile (freshmax_list freshmax_pure_atom pi) m ->
       Ile (freshmax_list freshmax_pure_atom
              (insert_uniq pure_atom_cmp a pi)) m.
Proof.
 intros. rewrite freshmax_list_insu; auto.
 apply var_max_intro'; auto.
Qed.


Require Import List.
Import ListNotations.

Definition bind{X Y} : list X -> (X -> list Y) -> list Y :=
  fun xs f => concat (map f xs).

Definition ret{X} : X -> list X := fun x => [x].

Notation "'do' x <- y ; cont" := (bind y (fun x => cont)) (at level 20).
Notation "'do_let' x := t ; cont" := (let x := t in cont) (at level 20).


Require Import
        Fiat.BinEncoders.Env.Common.Specs
        Coq.Arith.Peano_dec
        Coq.Logic.Eqdep_dec.

Import Vectors.VectorDef.VectorNotations.
Require Export
        Coq.Lists.List.

Section Vector.
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {transformer : Transformer B}.

  Variable A_predicate : A -> Prop.
  Variable A_predicate_rest : A -> B -> Prop.
  Variable A_encode_Spec : A -> CacheEncode -> Comp (B * CacheEncode).
  Variable A_decode : B -> CacheDecode -> option (A * B * CacheDecode).
  Variable A_cache_inv : CacheDecode -> Prop.
  Variable A_decode_pf
    : encode_decode_correct_f cache transformer A_predicate
                              A_predicate_rest
                              A_encode_Spec A_decode A_cache_inv.

  Fixpoint encode_Vector_Spec {n} (xs : Vector.t A n) (ce : CacheEncode)
    : Comp (B * CacheEncode) :=
    match xs with
    | Vector.nil => ret (transform_id, ce)
    | Vector.cons x _ xs' => `(b1, env1) <- A_encode_Spec x ce;
                    `(b2, env2) <- encode_Vector_Spec xs' env1;
                    ret (transform b1 b2, env2)
    end%comp.

  Fixpoint encode_Vector_Impl
           (A_encode_Impl : A -> CacheEncode -> B * CacheEncode)
           {n} (xs : Vector.t A n) (ce : CacheEncode)
    : B * CacheEncode :=
    match xs with
    | Vector.nil => (transform_id, ce)
    | Vector.cons x _ xs' =>
      let (b1, env1) := A_encode_Impl x ce in
      let (b2, env2) := encode_Vector_Impl A_encode_Impl xs' env1 in
      (transform b1 b2, env2)
    end%comp.

  Fixpoint decode_Vector (n : nat) (b : B) (cd : CacheDecode)
    : option (Vector.t A n * B * CacheDecode) :=
    match n with
    | O => Some (Vector.nil _, b, cd)
    | S s' => `(x, b1, e1) <- A_decode b cd;
              `(xs, b2, e2) <- decode_Vector s' b1 e1;
              Some (Vector.cons _ x _ xs, b2, e2)
    end.

(*  Lemma Vector_encode_preserves_rest_predicate
    : forall (sz : nat)
             (l : Vector.t A sz)
             (ext : B)
             (env xenv : CacheEncode) (l' : B) a a',
      encode_Vector_Spec l env ↝ (l', xenv) ->
      (forall x : A, Vector.In x l -> A_predicate x) ->
      A_predicate_rest a ext ->
      A_predicate_rest a' (transform l' ext).
  Proof.
    induction l.
    - simpl in *; intuition; computes_to_inv;
        injections; simpl; rewrite transform_id_left; eauto.
    - intros; simpl in *.
      unfold Bind2 in H; computes_to_inv; subst.
      destruct v; destruct v0; simpl in *.
      injections.
      rewrite <- transform_assoc.
      eapply A_predicate_rest_inv; eauto.
      eapply H0; econstructor.
      eapply (IHl _ _ _ _ _ H' (fun x H'' => H0 x (Vector.In_cons_tl _ _ _ H''))); intuition eauto.
  Qed. *)

  Fixpoint Vector_predicate_rest
           n
           (As : Vector.t A n)
           (b : B)
    : Prop :=
    match As with
    | Vector.nil => True
    | Vector.cons a _ As' =>
      (forall b' ce ce',
          computes_to (encode_Vector_Spec As' ce) (b', ce')
          -> A_predicate_rest a (transform b' b))
      /\ Vector_predicate_rest _ As' b
    end.

  Theorem Vector_decode_correct
    :
    forall sz,
      encode_decode_correct_f
        cache transformer
        (fun ls => forall x, Vector.In x ls -> A_predicate x)
        (Vector_predicate_rest sz)
        encode_Vector_Spec (decode_Vector sz) A_cache_inv.
  Proof.
    split.
    {
      intros env env' xenv l l' ext env_OK Eeq Ppred Ppred_rest Penc.
      generalize dependent env. generalize dependent env'.
      generalize dependent xenv.
      generalize dependent l'. induction l.
      { intros.
        simpl in *; intuition; computes_to_inv;
          injections; simpl; rewrite transform_id_left; eauto.
      }
      { intros; simpl in *.
        assert (A_predicate h) by (eapply Ppred; econstructor).
        unfold Bind2 in Penc; computes_to_inv; subst.
        destruct v; destruct v0; simpl in *.
        injections.
        destruct (fun H' => proj1 A_decode_pf _ _ _ _ _ (transform b0 ext) env_OK Eeq H H' Penc) as [ ? [? [? xenv_OK] ] ].
        intuition; destruct_ex.
        eapply H0; eauto.
        setoid_rewrite <- transform_assoc; setoid_rewrite H0;
          simpl.
        destruct (fun H' => IHl (fun x H => Ppred x (Vector.In_cons_tl _ _ _ H)) H' b0 xenv x xenv_OK c); intuition eauto.
        setoid_rewrite H5; simpl.
        eexists; intuition.
      }
    }
    { induction sz; simpl; intros.
      - injections; simpl; repeat eexists; intuition eauto.
        symmetry; apply transform_id_left.
        inversion H1.
      - destruct (A_decode bin env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_Vector sz b c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 A_decode_pf) in Heqo; eauto;
          destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst;
            eapply IHsz in Heqo0; eauto; destruct Heqo0 as [? [? ?] ];
              destruct_ex; intuition; subst.
        simpl.
        eexists; eexists; intuition eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        rewrite transform_assoc; reflexivity.
        inversion H5; subst; eauto.
        apply inj_pair2_eq_dec in H13; subst; eauto using eq_nat_dec.
    }
  Qed.

End Vector.

Lemma Vector_predicate_rest_True {A B}
      {cache : Cache}
      {transformer : Transformer B}
      (A_encode_Spec : A -> CacheEncode -> Comp (B * CacheEncode))
  : forall {n} (v : Vector.t A n) (b : B),
    Vector_predicate_rest (fun a b => True) A_encode_Spec n v b.
Proof.
  induction v; simpl; eauto.
Qed.


From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Lia.
From Coq Require Import FSets.FMapList.
From Coq Require Import FSets.FMapFacts.
From Coq Require Import Init.Nat.
From Coq Require Import Structures.OrderedTypeEx.
Require Import RuntimeDefinitions.
Require Import AppendixD.
Require Import AppendixC.
Require Import AppendixF.
Require Import AppendixE.
Require Import Semantics.
Require Import MLCOperations.

Module NatMapFacts := NatMapProperties.F.
Module CacheletMapFacts := CacheletMapProperties.F.

Definition tree_in_PLRU (R: set_indexed_PLRU) T: Prop :=
  exists x, (NatMap.find x R = Some T).

Notation "'<<' sigma ';' obs '>>'" := (state_and_trace sigma obs).

(* Helper Lemmas *)
Lemma cmp_to_eq : forall x y, (x =? y) = true -> x = y.
Proof.
  intro x.
  induction x.
  intros y H.
  destruct y. reflexivity. simpl in *. congruence.
  intros y H. destruct y.
  simpl in *. congruence. f_equal ; auto.
Qed.

Lemma cmp_uneq_helper1 : forall n m : nat,
    n <> m -> S n <> S m.
Proof.
  unfold not; intros.
  apply H. injection H0. intro. assumption.
Qed.
Lemma cmp_uneq_helper2 : forall n m : nat,
    S n <> S m -> n <> m.
Proof.
  unfold not; intros.
  apply H. lia.
Qed.
Lemma cmp_to_uneq : forall x y, (x =? y) = false <-> x <> y.
Proof.
  induction x. split.
  simpl. destruct y. discriminate. discriminate.
  simpl. destruct y. intros. contradiction. intros. reflexivity.
  simpl. destruct y.
  split. intros. discriminate. intros. reflexivity.
  split. intros. apply IHx in H. apply cmp_uneq_helper1. exact H.
  intros. apply cmp_uneq_helper2 in H. apply IHx in H. exact H.
Qed.

Lemma cmp_to_eq_and : forall x y z w, (x =? y) && (z =? w) = true -> x = y /\ z = w.
Proof.
  intros.
  apply andb_true_iff in H.
  destruct H.
  split.
  apply cmp_to_eq; exact H.
  apply cmp_to_eq; exact H0.
Qed.

Lemma cmp_to_uneq_and : forall x y z w, (x =? y) && (z =? w) = false -> x <> y \/ z <> w.
Proof.
  intros.
  apply andb_false_iff in H.
  destruct H.
  left. apply cmp_to_uneq in H. exact H.
  right. apply cmp_to_uneq in H. exact H.
Qed.

(* Cachelet Allocation Lemmas *)
Lemma cachelet_allocation_c : forall n e psi psi' F V C R F' V' C' R',
  cachelet_allocation n e psi = Some psi' ->
  psi = single_level_cache F V C R ->
  psi' = single_level_cache F' V' C' R' ->
  C = C'.
Proof.
  intros.
  unfold cachelet_allocation in H.
  case_eq psi; intros; destruct psi.
  injection H0; injection H2; intros; subst c v w s; subst c0 v0 w0 s0; clear H0 H2.
  subst psi'.
  unfold recursive_cachelet_allocation in H.
  generalize dependent e;
  generalize dependent F;
  generalize dependent V;
  generalize dependent C;
  generalize dependent R;
  generalize dependent F';
  generalize dependent V';
  generalize dependent C';
  generalize dependent R'.
  induction n.
  intros; injection H; intros; subst; auto.
  fold recursive_cachelet_allocation in *.
  intros.
  case_eq (way_first_allocation F); intros; destruct (way_first_allocation F).
  destruct c0.
  case_eq (NatMap.find s R); intros; destruct (NatMap.find s R).
  case_eq (NatMap.find e V); intros; destruct (NatMap.find e V).
  case_eq (NatMap.find s r0); intros; destruct (NatMap.find s r0).
  injection H0; injection H1; injection H2; injection H3; intros; subst p r w1 c; clear H0 H1 H2.
  specialize (IHn R' C' V' F' (NatMap.add s (update p0 w (enclave_ID_active e)) R) C
  (NatMap.add e (NatMap.add s (w :: w0) r0) V) (remove_CAT (w, s) F) e) as H_app.
  apply H_app. exact H.
  discriminate.
  discriminate.
  specialize (IHn R' C' V' F' (NatMap.add s (update p0 w (enclave_ID_active e)) R) C
  (NatMap.add e (NatMap.add s (w :: nil) r0) V) (remove_CAT (w, s) F) e) as H_app.
  apply H_app. exact H.
  discriminate.
  discriminate.
  specialize (IHn R' C' V' F' (NatMap.add s (update p0 w (enclave_ID_active e)) R) C
  (NatMap.add e (NatMap.add s (w :: nil) (NatMap.empty (list way_ID))) V) (remove_CAT (w, s) F) e) as H_app.
  apply H_app. exact H.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
Qed.

Lemma remove_CAT_f : forall c c' F,
  In c (recursive_remove_from_CAT c' F) -> In c F.
Proof.
  intros.
  unfold recursive_remove_from_CAT in H.
  induction F. exact H.
  case_eq (eq_cachelet_index c' a); intros; destruct (eq_cachelet_index c' a).
  apply (in_cons a c F). exact H.
  discriminate.
  discriminate.
  apply in_inv in H.
  fold recursive_remove_from_CAT in *.
  destruct H.
  subst.
  apply in_eq.
  apply in_cons.
  apply IHF.
  exact H.
Qed.

Lemma remove_CAT_f2_helper : forall a c c' F,
  (In c (recursive_remove_from_CAT c' F) \/ c = a) \/ c = c' ->
  In c (a :: recursive_remove_from_CAT c' F) \/ c = c'.
Proof.
  intros.
  destruct H.
  destruct H.
  left; apply in_cons; exact H.
  left; subst; apply in_eq; reflexivity.
  right; exact H.
Qed.

Lemma remove_CAT_f2_helper2 : forall P Q R,
  (P \/ Q) \/ R -> (P \/ R) \/ Q.
Proof.
  intros.
  destruct H.
  destruct H.
  left; left; exact H.
  right; exact H.
  left; right; exact H.
Qed.

Lemma remove_CAT_f2 : forall c c' F,
  In c F -> In c (recursive_remove_from_CAT c' F) \/ c = c'.
Proof.
  intros.
  induction F.
  simpl in H. left. simpl. exact H.
  unfold recursive_remove_from_CAT.
  case_eq (eq_cachelet_index c' a); intros; destruct (eq_cachelet_index c' a) in IHF.
  apply in_inv in H.
  destruct H.
  subst.
  unfold eq_cachelet_index in H0.
  destruct c'. destruct c.
  apply cmp_to_eq_and in H0.
  destruct H0. subst. right. auto.
  left. auto.
  apply in_inv in H.
  destruct H.
  subst.
  unfold eq_cachelet_index in H0.
  destruct c'. destruct c.
  apply cmp_to_eq_and in H0.
  destruct H0. subst. right. auto.
  left. auto. (* not exactly sure why that happens *)
  fold recursive_remove_from_CAT.
  apply in_inv in H. destruct H.
  destruct a; destruct c; destruct c'.
  injection H; intros; subst w0 s0.
  left. apply in_eq.
  apply remove_CAT_f2_helper.
  apply remove_CAT_f2_helper2.
  left. apply IHF. exact H.
  fold recursive_remove_from_CAT.
  apply in_inv in H. destruct H.
  destruct a; destruct c; destruct c'.
  injection H; intros; subst w0 s0.
  left. apply in_eq.
  apply remove_CAT_f2_helper.
  apply remove_CAT_f2_helper2.
  left. apply IHF. exact H.
Qed.

Lemma cachelet_allocation_f : forall n e psi psi' F V C R F' V' C' R' c,
  cachelet_allocation n e psi = Some psi' ->
  psi = single_level_cache F V C R ->
  psi' = single_level_cache F' V' C' R' ->
  In c F' -> In c F.
Proof.
  intros n.
  induction n.
  intros.
  unfold cachelet_allocation in H.
  subst psi psi'.
  unfold recursive_cachelet_allocation in H.
  injection H; intros; subst; exact H2.
  intros.
  unfold cachelet_allocation in H.
  subst psi.
  unfold recursive_cachelet_allocation in H.
  case_eq (way_first_allocation F); intros; destruct (way_first_allocation F).
  destruct c1.
  case_eq (NatMap.find s R); intros; destruct (NatMap.find s R).
  case_eq (NatMap.find e V); intros; destruct (NatMap.find e V).
  case_eq (NatMap.find s r0); intros; destruct (NatMap.find s r0).
  fold recursive_cachelet_allocation in H.
  injection H3; injection H4; injection H5; injection H0; intros;
  subst p r w1 c0; clear H3 H4 H5 H0.
  specialize (IHn e (single_level_cache (remove_CAT (w, s) F) (NatMap.add e (NatMap.add s (w :: w0) r0) V)
  C (NatMap.add s (update p0 w (enclave_ID_active e)) R)) psi' (remove_CAT (w, s) F)
  (NatMap.add e (NatMap.add s (w :: w0) r0) V) C (NatMap.add s (update p0 w (enclave_ID_active e)) R)
  F' V' C' R' c) as H_app.
  apply (remove_CAT_f c (w, s) F).
  unfold remove_CAT in H_app.
  apply H_app.
  unfold cachelet_allocation; exact H.
  reflexivity.
  exact H1.
  exact H2.
  discriminate.
  discriminate.
  fold recursive_cachelet_allocation in H.
  injection H3; injection H4; injection H0; intros;
  subst p r c0; clear H3 H4 H5 H0.
  specialize (IHn e (single_level_cache (remove_CAT (w, s) F) (NatMap.add e (NatMap.add s (w :: nil) r0) V)
  C (NatMap.add s (update p0 w (enclave_ID_active e)) R)) psi' (remove_CAT (w, s) F)
  (NatMap.add e (NatMap.add s (w :: nil) r0) V) C (NatMap.add s (update p0 w (enclave_ID_active e)) R)
  F' V' C' R' c) as H_app.
  apply (remove_CAT_f c (w, s) F).
  unfold remove_CAT in H_app.
  apply H_app.
  unfold cachelet_allocation; exact H.
  reflexivity.
  exact H1.
  exact H2.
  discriminate.
  discriminate.
  fold recursive_cachelet_allocation in H.
  injection H3; injection H0; intros;
  subst p c0; clear H3 H4 H0.
  specialize (IHn e (single_level_cache (remove_CAT (w, s) F) (NatMap.add e (NatMap.add s (w :: nil) (NatMap.empty (list way_ID))) V)
  C (NatMap.add s (update p0 w (enclave_ID_active e)) R)) psi' (remove_CAT (w, s) F)
  (NatMap.add e (NatMap.add s (w :: nil) (NatMap.empty (list way_ID))) V) C (NatMap.add s (update p0 w (enclave_ID_active e)) R)
  F' V' C' R' c) as H_app.
  apply (remove_CAT_f c (w, s) F).
  unfold remove_CAT in H_app.
  apply H_app.
  unfold cachelet_allocation; exact H.
  reflexivity.
  exact H1.
  exact H2.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
Qed.

(* Cachelet Deallocation Lemmas *)
Lemma cachelet_invalidation_c : forall c c' C C',
  cachelet_invalidation C c' = C' ->
  CacheletMap.In c C <-> CacheletMap.In c C'.
Proof.
  intros.
  unfold cachelet_invalidation in H.
  case_eq (CacheletMap.find c' C). intros.
  assert (A0 := H0). destruct (CacheletMap.find c' C) in H, A0.
  destruct w0.
  injection A0; intros; subst w; clear A0.
  split.
  {
    intros.
    rewrite <- H.
    apply CacheletMapFacts.add_in_iff.
    right; exact H1.
  }
  {
    intros.
    rewrite <- H in H1.
    apply CacheletMapFacts.add_in_iff in H1.
    destruct H1.
    destruct H1.
    destruct c; destruct c'.
    unfold fst in H1.
    unfold snd in H2.
    subst n n0.
    assert (CacheletMap.find (w, s) C <> None).
    intros contra. rewrite -> H0 in contra. discriminate.
    apply CacheletMapFacts.in_find_iff in H1.
    exact H1.
    exact H1.
  }
  discriminate.
  intros.
  destruct (CacheletMap.find c' C).
  discriminate.
  subst C'.
  split.
  intros; exact H.
  intros; exact H.
Qed.

Lemma free_cachelets_c_helper : forall P Q R,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros.
  split.
  intros; apply H0; apply H; exact H1.
  intros; apply H; apply H0; exact H1.
Qed.

Lemma free_cachelets_c : forall W e s F V C R F' V' C' R' c,
  free_cachelets e s W F V C R = Some (single_level_cache F' V' C' R') ->
  CacheletMap.In c C <-> CacheletMap.In c C'.
Proof.
  intros W.
  induction W.
  {
    intros.
    unfold free_cachelets in H.
    injection H; intros; subst.
    split.
    intros; exact H0.
    intros; exact H0.
  }
  {
    intros.
    unfold free_cachelets in H.
    case_eq (NatMap.find s R). intros.
    assert (A0 := H0). destruct (NatMap.find s R) in H, A0.
    fold free_cachelets in H.
    injection A0; intros; subst p0; clear A0.
    specialize (IHW e s ((a, s) :: F) V (cachelet_invalidation C (a, s))
      (NatMap.add s (update p a (enclave_ID_active e)) R) F' V' C' R' c) as H_app.
    assert (CacheletMap.In c C <-> CacheletMap.In c (cachelet_invalidation C (a, s))).
    apply (cachelet_invalidation_c c (a, s) C (cachelet_invalidation C (a, s))).
    reflexivity.
    apply (free_cachelets_c_helper (CacheletMap.In c C) (CacheletMap.In c (cachelet_invalidation C (a, s))) (CacheletMap.In c C')).
    exact H1.
    apply H_app.
    exact H.
    discriminate.
    intros. destruct (NatMap.find s R).
    discriminate.
    discriminate.
  }
Qed.

Lemma clear_remapping_list_c : forall e l F V C R F' V' C' R' c,
  clear_remapping_list e l F V C R = Some (single_level_cache F' V' C' R') ->
  CacheletMap.In c C <-> CacheletMap.In c C'.
Proof.
  intros e l.
  induction l.
  {
    intros.
    unfold clear_remapping_list in H.
    injection H; intros; subst.
    split.
    intros; exact H0.
    intros; exact H0.
  }
  {
    intros.
    unfold clear_remapping_list in H.
    destruct a.
    case_eq (free_cachelets e s w F V C R). intros.
    assert (A0 := H0). destruct (free_cachelets e s w F V C R) in H, A0.
    destruct s1. destruct s0.
    fold clear_remapping_list in H.
    injection A0; intros; subst; clear A0.
    apply (free_cachelets_c w e s F V C R c1 v0 w1 s0 c) in H0.
    specialize (IHl c1 v0 w1 s0 F' V' C' R' c) as H_app.
    apply (free_cachelets_c_helper (CacheletMap.In c C) (CacheletMap.In c w1) (CacheletMap.In c C')).
    exact H0.
    apply H_app.
    exact H.
    discriminate.
    intros.
    destruct (free_cachelets e s w F V C R).
    discriminate.
    discriminate.
  }
Qed.

Lemma cachelet_deallocation_c : forall e psi psi' F V C R F' V' C' R' c,
  cachelet_deallocation e psi = Some psi' ->
  psi = single_level_cache F V C R ->
  psi' = single_level_cache F' V' C' R' ->
  CacheletMap.In c C <-> CacheletMap.In c C'.
Proof.
  unfold cachelet_deallocation.
  destruct psi.
  case_eq (NatMap.find e v).
  intros r.
  destruct (NatMapProperties.to_list r).
  {
    intros.
    injection H1; intros; subst c v w s; clear H1; subst psi'.
    unfold clear_remapping_list in H0.
    injection H0; intros; subst.
    split.
    intros; exact H1.
    intros; exact H1.
  }
  {
    intros.
    unfold clear_remapping_list in H0.
    destruct p.
    injection H1; intros; subst c v w s; clear H1; subst psi'.
    case_eq (free_cachelets e k w0 F V C R). intros.
    assert (A0 := H1). destruct (free_cachelets e k w0 F V C R) in H0, A0.
    destruct s0.
    injection A0; intros; subst; clear A0.
    fold clear_remapping_list in H0.
    apply (free_cachelets_c w0 e k F V C R c v w s0 c0) in H1.
    apply (clear_remapping_list_c e l c v w s0 F' V' C' R' c0) in H0.
    apply (free_cachelets_c_helper (CacheletMap.In c0 C) (CacheletMap.In c0 w) (CacheletMap.In c0 C')).
    exact H1.
    exact H0.
    discriminate.
    intros.
    destruct (free_cachelets e k w0 F V C R).
    discriminate.
    discriminate.
  }
  intros.
  discriminate.
Qed.

(*
Lemma wf1_mlc_dealloc : forall h_tree state k lambda k' index psi psi' F V C R F' V' C' R' c,
  mlc_deallocation state k lambda h_tree = Some k' ->
  NatMap.find index k = Some psi ->
  NatMap.find index k' = Some psi' ->
  psi = single_level_cache F V C R ->
  psi' = single_level_cache F' V' C' R' ->
  (In c F -> CacheletMap.In c C) -> (In c F' -> CacheletMap.In c C').
Proof.
  unfold mlc_deallocation.
  intros h_tree.
  induction (get_hierarchy_tree_height h_tree).
  {
    intros.
    destruct state; destruct e.
*)

(* CC Update Lemma *)
(*
Lemma cc_update_c : forall psi state D l c psi' F V C R F' V' C' R' x,
  cc_update psi state D l = cc_update_valid c psi' ->
  psi = single_level_cache F V C R ->
  psi' = single_level_cache F' V' C' R' ->
  CacheletMap.In x C <-> CacheletMap.In x C'.
Proof.
  intros.
  split.
  {
    intros.
    unfold cc_update in H.
  }
  {

  }
Admitted.
*)

(* First Well-Formed Lemmas *)
Lemma wf1_mlc_alloc : forall n state k lambda h_tree k' index psi psi' F V C R F' V' C' R' c,
  mlc_allocation n state k lambda h_tree = Some k' ->
  NatMap.find index k = Some psi ->
  NatMap.find index k' = Some psi' ->
  psi = single_level_cache F V C R ->
  psi' = single_level_cache F' V' C' R' ->
  (In c F -> CacheletMap.In c C) -> (In c F' -> CacheletMap.In c C').
Proof.
  intros n.
  induction n.
  {
    intros.
    unfold mlc_allocation in H.
    destruct state. destruct e.
    unfold recursive_mlc_allocation in H.
    injection H; intros; subst k'.
    rewrite -> H0 in H1.
    injection H1; intros; subst psi' psi.
    injection H6; intros; subst.
    apply H4; exact H5.
    discriminate.
  }
  {
    intros.
    unfold mlc_allocation in H.
    destruct state; destruct e.
    unfold recursive_mlc_allocation in H.
    case_eq (NatMap.find lambda k).
    intros. assert (H6' := H6). destruct (NatMap.find lambda k) in H, H6'.
    case_eq (cachelet_allocation a r s0).
    intros. assert (H7' := H7). destruct (cachelet_allocation a r s0) in H, H7'.
    case_eq (get_cache_hierarchy_parent (cache_node lambda) h_tree).
    intros. assert (H8' := H8). destruct (get_cache_hierarchy_parent (cache_node lambda) h_tree) in H, H8'.
    case_eq c1.
    intros. subst c1.
    fold recursive_mlc_allocation in H.
    injection H6'; injection H7'; injection H8'; intros; subst s0 s2 c0; clear H6' H7' H8'.
    {
      case_eq (eqb lambda index).
      {
        intros. apply cmp_to_eq in H9.
        subst.
        destruct s1.
        specialize (IHn (enclave_state_value (enclave_ID_active r) (NatMap.empty enclave_memory_range_value))
        (NatMap.add index (single_level_cache c0 v w s0) k) p h_tree k' index (single_level_cache c0 v w s0)
        (single_level_cache F' V' C' R') c0 v w s0 F' V' C' R' c) as H_app.
        apply H_app; clear H_app.
        unfold mlc_allocation. exact H.
        apply NatMapFacts.add_eq_o. reflexivity.
        exact H1.
        reflexivity.
        reflexivity.
        intros. destruct s. rewrite -> H6 in H0.
        injection H0; intros; subst c1 v0 w0 s; clear H0.
        assert (HF := H7); apply (cachelet_allocation_f a r (single_level_cache F V C R) (single_level_cache c0 v w s0)
        F V C R c0 v w s0 c) in HF.
        assert (HC := H7); apply (cachelet_allocation_c a r (single_level_cache F V C R) (single_level_cache c0 v w s0)
        F V C R c0 v w s0) in HC. subst w.
        apply H4 in HF. exact HF.
        reflexivity.
        reflexivity.
        reflexivity.
        reflexivity.
        exact H2.
        exact H5.
      }
      {
        intros. apply cmp_to_uneq in H9.
        specialize (IHn (enclave_state_value (enclave_ID_active r) (NatMap.empty enclave_memory_range_value))
        (NatMap.add lambda s1 k) p h_tree k' index psi psi' F V C R F' V' C' R') as H_app.
        apply H_app; clear H_app.
        unfold mlc_allocation. exact H.
        rewrite <- H0. apply NatMapFacts.add_neq_o. exact H9.
        exact H1.
        exact H2.
        exact H3.
        exact H4.
        exact H5.
      }
    }
    intros; subst c1; discriminate.
    discriminate.
    intros; destruct (get_cache_hierarchy_parent (cache_node lambda) h_tree).
    discriminate.
    discriminate.
    discriminate.
    intros; destruct (cachelet_allocation a r s0).
    discriminate.
    discriminate.
    discriminate.
    intros; destruct (NatMap.find lambda k).
    discriminate.
    discriminate.
    discriminate.
  }
Qed.

Lemma wf1_mlc_alloc_none : forall n state k lambda h_tree k' index,
  mlc_allocation n state k lambda h_tree = Some k' ->
  NatMap.find index k = None ->
  NatMap.find index k' = None.
Proof.
  intros n.
  induction n.
  {
    intros.
    unfold mlc_allocation in H.
    destruct state; destruct e.
    unfold recursive_mlc_allocation in H.
    injection H; intros; subst k'.
    exact H0.
    discriminate.
  }
  {
    intros.
    unfold mlc_allocation in H.
    destruct state; destruct e.
    unfold recursive_mlc_allocation in H.
    case_eq (NatMap.find lambda k).
    intros. assert (H1' := H1). destruct (NatMap.find lambda k) in H, H1'.
    case_eq (cachelet_allocation a r s0).
    intros. assert (H2' := H2). destruct (cachelet_allocation a r s0) in H, H2'.
    case_eq (get_cache_hierarchy_parent (cache_node lambda) h_tree).
    intros. assert (H3' := H3). destruct (get_cache_hierarchy_parent (cache_node lambda) h_tree) in H, H3'.
    case_eq c0.
    intros. subst c0.
    fold recursive_mlc_allocation in H.
    injection H1'; injection H2'; injection H3'; intros; subst s0 s2 c; clear H1' H2' H3'.
    {
      case_eq (eqb index lambda); intros.
      {
        intros. apply cmp_to_eq in H4.
        subst lambda.
        destruct s1.
        specialize (IHn (enclave_state_value (enclave_ID_active r) (NatMap.empty enclave_memory_range_value))
        (NatMap.add index (single_level_cache c v w s0) k) p h_tree k' index) as H_app.
        apply H_app; clear H_app.
        unfold mlc_allocation. exact H.
        rewrite -> H0 in H1. discriminate.
      }
      {
        intros. apply cmp_to_uneq in H4.
        destruct s1.
        specialize (IHn (enclave_state_value (enclave_ID_active r) (NatMap.empty enclave_memory_range_value))
        (NatMap.add lambda (single_level_cache c v w s0) k) p h_tree k' index) as H_app.
        apply H_app; clear H_app.
        unfold mlc_allocation. exact H.
        rewrite <- H0.
        apply NatMapFacts.add_neq_o.
        auto.
      }
    }
    intros; injection H3'; intros; subst; discriminate.
    discriminate.
    intros; destruct (get_cache_hierarchy_parent (cache_node lambda) h_tree).
    discriminate.
    discriminate.
    discriminate.
    intros; destruct (cachelet_allocation a r s0).
    discriminate.
    discriminate.
    discriminate.
    intros; destruct (NatMap.find lambda k).
    discriminate.
    discriminate.
    discriminate.
  }
Qed.

(* Well-Formed Definitions *)
Definition wf1 (sigma: runtime_state): Prop :=
  forall k mu rho pi lambda c F V C R,
  (sigma = runtime_state_value k mu rho pi) ->
  (NatMap.MapsTo lambda (single_level_cache F V C R) k) ->
  ((In c F) -> (CacheletMap.In c C)).

Definition wf_c (sigma: runtime_state): Prop :=
  forall k mu rho pi lambda psi F V C R,
  (sigma = runtime_state_value k mu rho pi) ->
  psi = single_level_cache F V C R ->
  (NatMap.find lambda k = Some psi) ->
  (forall w s state l cache_val delta, cc_unfold psi state l = cc_unfold_valid F V C R (w, s) cache_val delta
    -> (CacheletMap.In (w, s) C)).

(*
(* Well-Formed Way Set Cache *)
Lemma wf_c_preservation_mlc_read : forall H18 sigma sigma' m k mu rho p p0 e' l' q lambda F V C R
  F' V' C' R' lambda0 l1 D delta0 obs0,
  sigma = (runtime_state_value m mu rho p) ->
  sigma' = (runtime_state_value k mu rho (NatMap.add p0 (process_value e' l' q) p)) ->
  NatMap.find lambda m = Some (single_level_cache F V C R) ->
  NatMap.find lambda k = Some (single_level_cache F' V' C' R') ->
  mlc_read m lambda0 e' mu l1 H18 = mlc_read_valid D delta0 obs0 k ->
  wf_c sigma -> wf_c sigma'.
Proof.
  intros H18.
  unfold mlc_read.
  induction (get_hierarchy_tree_height H18).
  {
    intros.
    unfold recursive_mlc_read in H3.
    discriminate.
  }
  {
    destruct sigma; destruct sigma'.
    unfold wf_c in *.
    intros.
    injection H5; intros; subst m1 m2 r0 p0; clear H5.
    unfold recursive_mlc_read in H3.
    fold recursive_mlc_read in H3.
    case_eq lambda0. intros.
    assert (A0 := H5). destruct lambda0 in A0, H3.
    case_eq (NatMap.find p3 m3). intros.
    assert (A1 := H5). destruct (NatMap.find p3 m3) in A1, H3.
    case_eq (cc_hit_read s1 e' l1). intros.
    assert (A2 := H9). destruct (cc_hit_read s1 e' l1) in A2, H3.
    injection H; injection H0; injection A0; injection A1; injection A2; injection H3;
    intros; subst.
    (*
    specialize (IHn (runtime_state_value m3 mu rho p1) (runtime_state_value (NatMap.add p0 s2 m3)
    mu rho (NatMap.add p2 (process_value e' l' q) p1)) m3 (NatMap.add p0 s2 m3) mu rho p1 p0 e'
    l' q lambda F V C R F0 V0 C0 R0
    *)

    specialize (H4 m3 mu rho p1 lambda (single_level_cache F V C R) F V C R) as H_app.
    assert (forall (w : way_ID) (s : set_ID) (state : enclave_state) (l : memory_address)
          (cache_val : way_set_cache_value) (delta : data_offset),
        cc_unfold (single_level_cache F V C R) state l =
        cc_unfold_valid F V C R (w, s) cache_val delta ->
        CacheletMap.In (elt:=way_set_cache_value) (w, s) C).
    apply H_app.
    reflexivity.
    reflexivity.
    exact H1.
    clear H_app.

    give_up.
    discriminate.
    intros; destruct (cc_hit_read s1 e' l1).
    discriminate.
    (*
    assert (A2 := H9). destruct (cc_hit_read s1 e' l1) in A2, H3. discriminate.
    injection H; injection H0; injection A0; injection A1; intros; subst; clear H H0 A0 A1.
    *)
    intros.
    discriminate.
    discriminate.
    discriminate.
    discriminate.
    injection A0; injection A1; injection A2; injection A3; intros; subst; clear A0 A1 A2 A3.
  }
*)

Lemma wf_c_preservation : forall sigma obs sigma' obs',
  wf1 sigma -> wf_c sigma -> <<sigma; obs>> ===> <<sigma'; obs'>> -> wf_c sigma'.
Proof.
  destruct sigma; destruct sigma'.
  unfold wf_c in *.
  unfold wf1 in *.
  intros.
  injection H2; intros; subst; clear H2.
  inversion H1.
  inversion H15; subst.
  - give_up.
  - give_up.
  - give_up.
  - give_up.
  - specialize (H0 k mu rho p lambda (single_level_cache F V C R) F V C R) as H_app.
    assert (forall (w : way_ID) (s : set_ID) (state : enclave_state) (l : memory_address)
          (cache_val : way_set_cache_value) (delta : data_offset),
        cc_unfold (single_level_cache F V C R) state l =
        cc_unfold_valid F V C R (w, s) cache_val delta ->
        CacheletMap.In (elt:=way_set_cache_value) (w, s) C).
    apply H_app.
    reflexivity.
    reflexivity.
    exact H4.
    specialize (H2 w s state l cache_val delta) as H_app2.
    apply H_app2.
    exact H5.
  - specialize (H0 k mu rho p lambda (single_level_cache F V C R) F V C R) as H_app.
    assert (forall (w : way_ID) (s : set_ID) (state : enclave_state) (l : memory_address)
          (cache_val : way_set_cache_value) (delta : data_offset),
        cc_unfold (single_level_cache F V C R) state l =
        cc_unfold_valid F V C R (w, s) cache_val delta ->
        CacheletMap.In (elt:=way_set_cache_value) (w, s) C).
    apply H_app.
    reflexivity.
    reflexivity.
    exact H4.
    specialize (H2 w s state l cache_val delta) as H_app2.
    apply H_app2.
    exact H5.
  - specialize (H0 k mu rho p lambda (single_level_cache F V C R) F V C R) as H_app.
    assert (forall (w : way_ID) (s : set_ID) (state : enclave_state) (l : memory_address)
          (cache_val : way_set_cache_value) (delta : data_offset),
        cc_unfold (single_level_cache F V C R) state l =
        cc_unfold_valid F V C R (w, s) cache_val delta ->
        CacheletMap.In (elt:=way_set_cache_value) (w, s) C).
    apply H_app.
    reflexivity.
    reflexivity.
    exact H4.
    specialize (H2 w s state l cache_val delta) as H_app2.
    apply H_app2.
    exact H5.
  - specialize (H0 k mu rho p lambda (single_level_cache F V C R) F V C R) as H_app.
    assert (forall (w : way_ID) (s : set_ID) (state : enclave_state) (l : memory_address)
          (cache_val : way_set_cache_value) (delta : data_offset),
        cc_unfold (single_level_cache F V C R) state l =
        cc_unfold_valid F V C R (w, s) cache_val delta ->
        CacheletMap.In (elt:=way_set_cache_value) (w, s) C).
    apply H_app.
    reflexivity.
    reflexivity.
    exact H4.
    specialize (H2 w s state l cache_val delta) as H_app2.
    apply H_app2.
    exact H5.
  - subst.
    specialize (H0 k mu rho p lambda (single_level_cache F V C R) F V C R) as H_app.
    assert (forall (w : way_ID) (s : set_ID) (state : enclave_state) (l : memory_address)
          (cache_val : way_set_cache_value) (delta : data_offset),
        cc_unfold (single_level_cache F V C R) state l =
        cc_unfold_valid F V C R (w, s) cache_val delta ->
        CacheletMap.In (elt:=way_set_cache_value) (w, s) C).
    apply H_app.
    reflexivity.
    reflexivity.
    exact H4.
    specialize (H2 w s state l cache_val delta) as H_app2.
    apply H_app2.
    exact H5.
Admitted.

(* First Well-Formed Condition *)
Lemma wf1_preservation : forall sigma obs sigma' obs',
  wf1 sigma -> <<sigma; obs>> ===> <<sigma'; obs'>> -> wf1 sigma'.
Proof.
  destruct sigma; destruct sigma'.
  unfold wf1 in *.
  intros.
  injection H1; intros; subst; clear H1.
  inversion H0.
  inversion H14; subst.
  - give_up.
    (*
    unfold mlc_read in H33; unfold recursive_mlc_read in H33.
    destruct (get_hierarchy_tree_height H18).
    discriminate.
    case_eq lambda0; intros; subst.
    case_eq (NatMap.find p2 m); intros; destruct (NatMap.find p2 m) in H33.
    case_eq (cc_hit_read s0 e' l0); intros; destruct (cc_hit_read s0 e' l0) in H33.
    unfold cc_hit_read in H5.
    case_eq (cc_unfold s0 e' l0); intros.
    give_up.
    *)
    (*
    give_up.

    unfold cc_unfold in H5.
    destruct s0; destruct l0.
    unfold block_to_set_and_tag in H5. subst.

    case_eq n0.
    case_eq lambda0.
    case_eq (NatMap.find p2 m).
    case_eq (cc_hit_read s e' l0).
    injection H33. injection H1. intros.
    destruct s0. subst.
    case_eq (Nat.eqb p1 p2). intros.
    apply cmp_to_eq in H4. subst.
    apply (NatMapFacts.add_mapsto_iff m p2 lambda (single_level_cache c1 v w s0) (single_level_cache F V C R)) in H2.
    destruct H2. destruct H2. injection H4. intros. subst.
    case_eq (OrderedPair.eqb
    case_eq (Nat.eqb lambda p2). intros.
    apply cmp_to_eq in H4. subst.
    destruct H2. injection H4. intros. subst.
    give_up.
    intros. apply cmp_to_uneq in H4.
    give_up.

    give_up.
    intros. apply cmp_to_uneq in H4.

    give_up.
    destruct (get_cache_hierarchy_parent (cache_node p2) H18).
    discriminate.
    discriminate.
    discriminate.
    destruct l0.
    destruct (NatMap.find b m2). subst.
    give_up.
    discriminate.
    destruct lambda0. subst.
    give_up.
    give_up.
    *)
    (* give_up. give_up. give_up. give_up. give_up. give_up. give_up. give_up. *)
  - case_eq (NatMap.find lambda m); intros; subst.
    destruct s.
    specialize (H m mu rho p lambda c c0 v w s) as H_app.
    assert (In c c0 -> CacheletMap.In c w).
    apply H_app. reflexivity.
    apply NatMapFacts.find_mapsto_iff. exact H1.
    generalize H3.
    apply (wf1_mlc_alloc r_bar_val e m lambda0 H17 k lambda (single_level_cache c0 v w s)
    (single_level_cache F V C R) c0 v w s F V C R c).
    exact H38.
    exact H1.
    apply NatMapFacts.find_mapsto_iff in H2; exact H2.
    reflexivity.
    reflexivity.
    exact H4.
    apply NatMapFacts.find_mapsto_iff in H2.
    generalize H3.
    assert (mlc_allocation r_bar_val e m lambda0 H17 = Some k ->
    NatMap.find (elt:=single_level_cache_unit) lambda m = None).
    auto.
    apply (wf1_mlc_alloc_none r_bar_val e m lambda0 H17 k lambda) in H4.
    intros.
    rewrite -> H2 in H4.
    discriminate.
    exact H38.
    exact H38.
  - give_up.
    (*
    unfold mlc_write in H32; unfold recursive_mlc_write in H32.
    destruct (get_hierarchy_tree_height H17).
    discriminate.
    destruct lambda0. destruct (NatMap.find p1 m).
    destruct (cc_hit_write s e' l0 v). destruct l0.
    injection H32. injection H1. intros.
    rewrite -> H37 in H38. subst.
    give_up.
    destruct (get_cache_hierarchy_parent (cache_node p2) H18).
    give_up.
    discriminate.
    discriminate.
    destruct l0. destruct (NatMap.find b m0). destruct v.
    discriminate.
    injection H33. intros.
    apply (H m m0 r p lambda c F V C R).
    auto. rewrite -> H34; injection H1; intros; rewrite -> H41; exact H2. exact H3.
    discriminate.
    *)
  - give_up.
  - apply (H k mu rho p lambda c F V C R).
    auto.
    apply NatMapFacts.find_mapsto_iff.
    apply NatMapFacts.find_mapsto_iff in H2.
    rewrite -> H2. reflexivity.
    exact H3.
  - apply (H k mu rho p lambda c F V C R).
    auto.
    apply NatMapFacts.find_mapsto_iff.
    apply NatMapFacts.find_mapsto_iff in H2.
    rewrite -> H2. reflexivity.
    exact H3.
  - apply (H k mu rho p lambda c F V C R).
    auto.
    apply NatMapFacts.find_mapsto_iff.
    apply NatMapFacts.find_mapsto_iff in H2.
    rewrite -> H2. reflexivity.
    exact H3.
  - apply (H k mu rho p lambda c F V C R).
    auto.
    apply NatMapFacts.find_mapsto_iff.
    apply NatMapFacts.find_mapsto_iff in H2.
    rewrite -> H2. reflexivity.
    exact H3.
  - subst.
    apply (H k mu rho p lambda c F V C R).
    auto.
    apply NatMapFacts.find_mapsto_iff.
    apply NatMapFacts.find_mapsto_iff in H2.
    rewrite -> H2. reflexivity.
    exact H3.
Admitted.

Definition wf4 (sigma: runtime_state): Prop :=
  forall k mu rho pi p epsilon l q e E raw_e,
  (sigma = runtime_state_value k mu rho pi) ->
  (NatMap.find p pi = Some (process_value epsilon l q)) ->
  (epsilon = enclave_state_value e E) ->
  (e = enclave_ID_inactive \/ (e = enclave_ID_active raw_e /\ NatMap.find raw_e E <> None)).

Lemma wf4_preservation : forall sigma obs sigma' obs',
  wf4 sigma -> <<sigma; obs>> ===> <<sigma'; obs'>> -> wf4 sigma'.
Proof.
  destruct sigma; destruct sigma'.
  unfold wf4 in *.
  intros.
  inversion H0.
  inversion H15.
  subst.
  - give_up.
  - give_up.
  - give_up.
  - give_up.
  - give_up.
  - give_up.
  - give_up.
  - apply (H m m0 r p p1 epsilon l q e E raw_e).
    auto. injection H1. intros. subst. auto.
Admitted.


Require Import HoTT.
Require Import Auxiliary.Family.
Require Import Auxiliary.WellFounded.
Require Import Syntax.ScopeSystem.
Require Import Auxiliary.Coproduct.
Require Import Auxiliary.Closure.
Require Import Syntax.All.
Require Import Typing.Context.
Require Import Typing.Judgement.
Require Import Typing.RawTypeTheory.
Require Import Presented.PresentedRawRule.
Require Import Presented.CongruenceRule.

(** Main definition in this file: [presented_raw_type_theory], the data one gives to specify a type theory (but before typechecking it) *)

Section TypeTheory.

  Context {σ : scope_system}.

  Record presented_raw_type_theory
  := {
  (* The family of _rules_, with their object-premise arities and conclusion forms specified *)
    tt_rule_data :> family (Judgement.form * arity σ)
  (* the judgement form of the conclusion of each rule *)
  ; tt_rule_form : tt_rule_data -> Judgement.form
    := fun i => fst (tt_rule_data i)
  (* the arity of the arguments (i.e. the *object* premises only) of each rule *)
  ; tt_rule_arity : tt_rule_data -> arity _
    := fun i => snd (tt_rule_data i)
  (* the ordering on rules *)
  ; tt_lt : well_founded_order tt_rule_data
  (* the signature over which each rule can be written *)
  ; tt_rule_signature : tt_rule_data -> signature σ
    := fun i => Family.fmap
        (fun (ja : Judgement.form * arity σ)
          => (class_of (fst ja), snd ja))
        (Family.subfamily tt_rule_data
          (fun j => Judgement.is_object (tt_rule_form j) * tt_lt j i))
  (* the actual rule specification of each rule *)
  ; tt_rule
    : forall i : tt_rule_data,
        rule
          (tt_rule_signature i)
          (tt_rule_arity i)
          (tt_rule_form i)
  }.

  Local Definition signature (T : presented_raw_type_theory)
    : signature σ.
  Proof.
    (* symbols are given by the object-judgement rules of T *)
    exists {r : T & Judgement.is_object (tt_rule_form _ r)}.
    intros r_H. set (r := pr1 r_H).
    split.
    - exact (class_of (tt_rule_form _ r)).
    - exact (tt_rule_arity _ r).
  Defined.
    (* NOTE: it is tempting to case-analyse here and say
      “when r is an object rule, use [(class_of …, tt_rule_arity …)];
       in case r is an equality rule, use reductio ad absurdum with Hr.”
     But we get stronger reduction behaviour by just taking [(class_of …, tt_rule_arity …)] without case-analysing first.  (And up to equality, we get the same result.)  *)
  (* TODO: consider making this a coercion? *)

  Local Definition include_rule_signature
      {T : presented_raw_type_theory} (r : T)
    : Signature.map (tt_rule_signature _ r)
                    (signature T).
  Proof.
    simple refine (_;_).
    - intros s_isob_lt. cbn in s_isob_lt.
      exact (pr1 s_isob_lt ; fst (pr2 (s_isob_lt))).
      (* TODO: introduce access functions for the signature components above? *)
    - intros s. apply idpath.
  Defined.

  (* NOTE: could easily be generalised to give the sub-type-theory on any down-closed subset of the rules, if that’s ever needed. *)
  Local Definition initial_segment (T : presented_raw_type_theory) (i : T)
    : presented_raw_type_theory.
  Proof.
    simple refine (Build_presented_raw_type_theory _ _ _ ).
    - refine (Family.subfamily (tt_rule_data T) _).
      intros j. exact (tt_lt _ j i).
    - refine (WellFounded.pullback _ (tt_lt T)).
      exact (projT1).
    - cbn. intros [j lt_j_i].
      refine (PresentedRawRule.fmap _ (tt_rule _ j)).
      apply Family.map_fmap.
      simple refine (_;_).
      + intros [k [k_obj lt_k_j]].
        simple refine (_;_).
        * exists k. apply (transitive _ _ j); assumption.
        * cbn. split; assumption.
      + intros ?; apply idpath.
  Defined.

  (* NOTE: in fact, this map should be an isomorphism *)
  Local Definition initial_segment_signature_to_rule_signature
        (T : presented_raw_type_theory) (i : T)
    : Signature.map
        (TypeTheory.signature (initial_segment T i))
        (tt_rule_signature _ i).
  Proof.
    simple refine (_;_).
    - intros [[j lt_j_i] j_obj]. exists j. split; assumption.
    - intros ?; apply idpath.
  Defined.

  Local Definition include_initial_segment_signature
        (T : presented_raw_type_theory) (i : T)
    : Signature.map
        (TypeTheory.signature (initial_segment T i))
        (TypeTheory.signature T).
  Proof.
    eapply Signature.compose.
    - apply include_rule_signature.
    - apply initial_segment_signature_to_rule_signature.
  Defined.

End TypeTheory.

Arguments presented_raw_type_theory _ : clear implicits.
Arguments tt_rule_data {_} _.
Arguments tt_rule_form {_ _} _.
Arguments tt_rule_arity {_ _} _.
Arguments tt_lt {_ _}.
Arguments tt_rule_signature {_ _} _.
Arguments tt_rule {_ _} _.

Section Flattening.

  Context {σ : scope_system}.

  Local Definition flatten (T : presented_raw_type_theory σ)
    : raw_type_theory (signature T).
  Proof.
    refine (_ + _)%family.
    (* First: the explicitly-given logical rules *)
    - exists (tt_rule_data T).
      intros r.
      refine (PresentedRawRule.flatten _ _).
      + (* translate rules up to the full signature *)
        refine (PresentedRawRule.fmap _ (tt_rule r)).
        apply include_rule_signature.
      + (* pick their symbol in the full signature, if applicable *)
        intros r_obj.
        exists (r; r_obj).
        split; apply idpath.
    (* Second: associated congruence rules for the object-judgement logical rules. *)
    - exists { r : T & Judgement.is_object (tt_rule_form r) }.
      intros [r Hr].
      refine (PresentedRawRule.flatten _ _).
      + simple refine
        (congruence_rule (PresentedRawRule.fmap _ (tt_rule r)) _ _ _ _).
        * apply include_rule_signature.
        * exact Hr.
        * exact (r;Hr). (* head symbol of original rule *)
        * apply idpath.
        * apply idpath.
      + intros []. (* no head symbol, since congs are equality rules *)
  Defined.

  (* Probably should go via a notion of “simple map” of type theories,
   in which [flatten] is functorial,
   based on simple maps of algebraic extensions. *)
  Local Lemma flatten_initial_segment
      (T : presented_raw_type_theory σ) (r : T)
    : Family.map_over
        (RawRule.fmap
           (include_initial_segment_signature T r))
        (flatten (initial_segment T r))
        (flatten T).
  Proof.
    apply Family.Build_map'; intros [ [i lt_i_r] | [ [ i lt_i_r] i_is_ob] ].
    - (* main rule *)
      admit.
    - (* congruence rule *)
      admit.
  Admitted. (* [flatten_initial_segment]: large and significant, possible complicated dependency structure *)

End Flattening.

Local Definition derivation {σ : scope_system} (T : presented_raw_type_theory σ) H
    : judgement (signature T) -> Type
  := RawTypeTheory.derivation (flatten T) H.


Definition NNPP:=forall Q:Prop,~~Q->Q.

Theorem T0:
forall A:Set->Prop,
forall P:Prop,
((exists x:Set,A x)->P)->forall x:Set,(A x->P).

intros.
apply H.
exists x.
apply H0.
Qed.

Theorem T1:
forall A:Set->Prop,
forall P:Prop,
(forall x:Set,(A x->P))->((exists x:Set,A x)->P).
intros.
elim H0.
apply H.
Qed.

Theorem T2:
forall A:
Set->Prop,
forall P:Prop,
NNPP->((forall x:Set,A x)->P)
->(exists x:Set,(A x->P)).
intros.
assert(~forall x:Set,(A x/\~P)).
intro.
apply H1.
Variable x:Set.
apply x.
apply H0.
apply H1.
apply H.
intro.
elim H1.
intros.
split.
apply H.
intro.
elim H2.
exists x0.
intro.
elim H3.
apply H4.
intro.
apply H2.
exists x.
intros.
apply H3.
Qed.

Theorem T2_1:forall A:
Set->Prop,
forall P:Prop,
NNPP->((forall x:Set,A x)->P)
->(exists x:Set,(A x->P)).

intros.
apply H.
intro.
assert (forall x:Set,(A x/\~P)).
intros.
split.
apply H.
intro.
apply H1.
exists x0.
intro.
elim H2.
apply H3.
intro.
elim H1.
exists x0.
intro.
apply H2.

assert P.
apply H0.
intro.
apply H2.
apply H2.
apply x.
apply H3.
Qed.

Theorem curry:
forall P:nat->nat->Prop,
(forall a:nat,{b:nat|P a b})
->{f:nat->nat|forall i:nat,P i (f i)}.

intros.
refine (fun i:nat=> match (H i)as Hk return
{f : nat -> nat | forall i : nat, P i (f i)}
with
|exist ci Hi=>_
end) .

exists (fun i:nat=>
match (H i) with
|exist ci Hi=>ci end).
intro.


From sgdt Require Import preamble category functor.

Local Open Scope category_scope.
Set Universe Polymorphism.

Module LeftOblique.
  Section Defs.
    Context {𝒞 𝒟 : Category.type} (F : 𝒞 ~~> 𝒟).

    Definition ob : Product.cat (𝒞^op) 𝒟 -> TYPE.cat.
    Proof.
      move=> [c d].
      by exact: (F c ~> d).
    Defined.

    Definition prefunctor_mixin : Prefunctor.mixin_of (Product.cat (𝒞^op) 𝒟) TYPE.cat ob.
    Proof.
      build=> u v [f1 f2]; rewrite /ob //=; move=> h.
      by exact: (F @@ f1 >> h >> f2).
    Defined.

    Canonical prefunctor : Prefunctor.type (Product.cat (𝒞^op) 𝒟) TYPE.cat.
    Proof. by esplit; apply: prefunctor_mixin. Defined.

    Definition functor_mixin : Functor.mixin_of _ _ prefunctor.
    Proof.
      build.
      - move=> u.
        apply: funE=> //= ?.
        by cbn; rewrite fidn seqR seqL.
      - move=> u v w f g.
        apply: funE=> //= ?.
        by cbn; rewrite ? fseq ?seqA.
    Qed.

    Canonical functor : Functor.type (Product.cat (𝒞^op) 𝒟) TYPE.cat.
    Proof. by esplit; apply: functor_mixin. Defined.
  End Defs.
End LeftOblique.

Module RightOblique.
  Section Defs.
    Context {𝒞 𝒟 : Category.type} (G : 𝒟 ~~> 𝒞).

    Definition ob : Product.cat (𝒞^op) 𝒟 -> TYPE.cat.
    Proof.
      move=> [c d].
      by exact: (@hom 𝒞 c (G d)).
    Defined.

    Definition prefunctor_mixin : Prefunctor.mixin_of (Product.cat (𝒞^op) 𝒟) TYPE.cat ob.
    Proof.
      build=> u v //=; cbn; move=> [f1 f2] h.
      refine (f1 >> h >> G @@ f2).
    Defined.

    Canonical prefunctor : Prefunctor.type (Product.cat (𝒞^op) 𝒟) TYPE.cat.
    Proof. by esplit; apply: prefunctor_mixin. Defined.

    Definition functor_mixin : Functor.mixin_of _ _ prefunctor.
    Proof.
      build.
      - move=> u.
        apply: funE=> //= ?.
        by cbn; rewrite fidn seqR seqL.
      - move=> u v w f g.
        apply: funE=> //= ?.
        by cbn; rewrite ? fseq ?seqA.
    Qed.

    Canonical functor : Functor.type (Product.cat (𝒞^op) 𝒟) TYPE.cat.
    Proof. by esplit; apply: functor_mixin. Defined.
  End Defs.
End RightOblique.

Module Preadjunction.
  Section Defs.
    Context {𝒞 𝒟 : Category.type} (F : 𝒞 ~~> 𝒟) (U : 𝒟 ~~> 𝒞).

    Record type :=
      { fwd : LeftOblique.functor F ~~~> RightOblique.functor U;
        bwd : RightOblique.functor U ~~~> LeftOblique.functor F }.
  End Defs.

  Arguments fwd [𝒞] [𝒟] [F] [U].
  Arguments bwd [𝒞] [𝒟] [F] [U].
End Preadjunction.

Module Adjunction.
  Section Defs.
    Context {𝒞 𝒟 : Category.type} (F : 𝒞 ~~> 𝒟) (U : 𝒟 ~~> 𝒞).

    Record mixin_of (T : Preadjunction.type F U) :=
      { bwd_fwd : forall U f, Preadjunction.bwd T U (Preadjunction.fwd T U f) = f;
        fwd_bwd : forall U f, Preadjunction.fwd T U (Preadjunction.bwd T U f) = f}.

    Record type := {transp; class: mixin_of transp}.
  End Defs.

  Arguments bwd_fwd [𝒞] [𝒟] [F] [U].
  Arguments fwd_bwd [𝒞] [𝒟] [F] [U].
End Adjunction.

Notation "F ⊣ U" := (Adjunction.type F U) (at level 100).

Section Facts.

  Context {𝒞 𝒟 : Category.type} {F : 𝒞 ~~> 𝒟} {U : 𝒟 ~~> 𝒞} (T : F ⊣ U).

  Definition transpose : LeftOblique.functor F ~> RightOblique.functor U :=
    Preadjunction.fwd (Adjunction.transp _ _ T).

  Definition untranspose : RightOblique.functor U ~> LeftOblique.functor F :=
    Preadjunction.bwd (Adjunction.transp _ _ T).

  Definition untranspose_transpose : forall U f, untranspose U (transpose U f) = f :=
    Adjunction.bwd_fwd _ (Adjunction.class _ _ T).

  Definition transpose_untranspose : forall U f, transpose U (untranspose U f) = f :=
    Adjunction.fwd_bwd _ (Adjunction.class _ _ T).
End Facts.

Module HorizontalComposition.

  Section Defs.
    Context
      {𝒞 𝒟 ℰ : Category.type}
        {F1 : 𝒞 ~> 𝒟}
        {G1 : 𝒟 ~> 𝒞}
        {F2 : 𝒟 ~> ℰ}
        {G2 : ℰ ~> 𝒟}
        (T1 : F1 ⊣ G1)
        (T2 : F2 ⊣ G2).

    Definition transp_fwd_fam U : LeftOblique.functor (Compose.functor F1 F2) U ~> RightOblique.functor (Compose.functor G2 G1) U.
    Proof.
      case: U=> c e //= f.
      apply: (transpose T1 (c, G2 e)).
      apply: (transpose T2 (F1 c, e)).
      apply: f.
    Defined.

    Definition transp_bwd_fam U : RightOblique.functor (Compose.functor G2 G1) U ~> LeftOblique.functor (Compose.functor F1 F2) U.
    Proof.
      case: U => c e //= f.
      apply: (untranspose T2 (F1 c, e)).
      apply: (untranspose T1 (c, G2 e)).
      apply: f.
    Defined.

    Definition transp_fwd_mixin : NatTrans.mixin_of _ _ transp_fwd_fam.
    Proof.
      build; case=> c1 e1; case=> c2 e2; case=> f1 f2.
      apply: funE=> x.
      have Q1 := unfunE _ _ (naturality (transpose T1) (c1, G2 e1) (c2, G2 e2) (f1, G2 @@ f2)).
      have Q2 := unfunE _ _ (naturality (transpose T2) (F1 c1, e1) (F1 c2, e2) (F1 @@ f1, f2)).
      cbn in Q2, Q1.
      by cbn; rewrite /transp_fwd_fam Q2 Q1.
    Qed.

    Definition transp_bwd_mixin : NatTrans.mixin_of _ _ transp_bwd_fam.
    Proof.
      build; case=> c1 e1; case=> c2 e2; case=> f1 f2.
      apply: funE=> x.
      have Q2 := unfunE _ _ (naturality (untranspose T2) (F1 c1, e1) (F1 c2, e2) (F1 @@ f1, f2)).
      have Q1 := unfunE _ _ (naturality (untranspose T1) (c1, G2 e1) (c2, G2 e2) (f1, G2 @@ f2)).
      cbn in Q1, Q2.
      by cbn; rewrite /transp_bwd_fam Q1 Q2.
    Qed.

    Canonical transp_fwd : LeftOblique.functor (Compose.functor F1 F2) ~> RightOblique.functor (Compose.functor G2 G1).
    Proof. by esplit; apply: transp_fwd_mixin. Defined.

    Canonical transp_bwd : RightOblique.functor (Compose.functor G2 G1) ~> LeftOblique.functor (Compose.functor F1 F2).
    Proof. by esplit; apply: transp_bwd_mixin. Defined.

    Canonical preadj : Preadjunction.type (Compose.functor F1 F2) (Compose.functor G2 G1).
    Proof.
      build.
      - apply: transp_fwd.
      - apply: transp_bwd.
    Defined.

    Lemma eta_cmp {A B C : Type} (f : A -> B) (g : B -> C) : (fun x => g (f x)) = g \o f.
    Proof. by []. Qed.

    Lemma cmp_assoc {A B C D : Type} (f : A -> B) (g : B -> C) (h : C -> D) : h \o (g \o f) = (h \o g) \o f.
    Proof. by []. Qed.

    Definition adj_mixin : Adjunction.mixin_of _ _ preadj.
    Proof.
      build; cbn.
      - case=> c e; rewrite /LeftOblique.ob //=; move=> f.
        rewrite /transp_bwd_fam /transp_fwd_fam //=.
        by rewrite ?untranspose_transpose.
      - case=> c e; rewrite /RightOblique.ob //=; move=> f.
        rewrite /transp_bwd_fam /transp_fwd_fam //=.
        by rewrite ?transpose_untranspose.
    Qed.

    Canonical adj : (Compose.functor F1 F2) ⊣ (Compose.functor G2 G1).
    Proof. esplit; apply: adj_mixin. Defined.
  End Defs.

End HorizontalComposition.

Module PointwiseLifting.
  Section Defs.
    Context (ℐ : Category.type) {𝒞 : Category.type} {𝒟 : Category.type} (F : 𝒞 ~~> 𝒟).

    Definition ob : Cat[ℐ,𝒞] -> Cat[ℐ,𝒟].
    Proof.
      move=> A.
      apply: Compose.functor.
      - exact: A.
      - exact: F.
    Defined.

    Definition prefunctor_mixin : Prefunctor.mixin_of _ _ ob.
    Proof.
      build=> A B f.
      build.
      - move=> i.
        rewrite /ob //=.
        rewrite /Compose.functor.
        Check F @@ f i.
        by exact (F @@ f _).
      - build=> i j ij.
        abstract by cbn; rewrite -?fseq naturality.
    Defined.

    Canonical prefunctor : Prefunctor.type Cat[ℐ,𝒞] Cat[ℐ,𝒟].
    Proof. by esplit; apply: prefunctor_mixin. Defined.

    Definition functor_mixin : Functor.mixin_of _ _ prefunctor.
    Proof.
      build.
      - move=> A.
        apply: NatTrans.ext.
        apply: dfunE=> i //=.
        by rewrite fidn.
      - move=> A B C f g.
        apply: NatTrans.ext.
        apply: dfunE=> i //=.
        by rewrite fseq.
    Qed.

    Canonical functor : Functor.type Cat[ℐ,𝒞] Cat[ℐ,𝒟].
    Proof. by esplit; apply: functor_mixin. Defined.
  End Defs.
End PointwiseLifting.

Module PointwiseLiftingAdjunction.
  Section Defs.
    Context (ℐ : Category.type) {𝒞 𝒟 : Category.type} (F : 𝒞 ~~> 𝒟) (U : _) (T : F ⊣ U).
    Local Notation F' := (PointwiseLifting.functor ℐ F).
    Local Notation U' := (PointwiseLifting.functor ℐ U).

    Definition transp_fwd_fam_fam : forall P, LeftOblique.functor F' P ->  forall i : ℐ, pi1 P i ~> U' (pi2 P) i.
    Proof.
      case=> A X f i.
      rewrite /U'; cbn.
      apply: (transpose T (A i, X i)).
      by apply: f.
    Defined.

    Lemma transp_fwd_fam_mixin : forall P f, NatTrans.mixin_of _ _ (transp_fwd_fam_fam P f).
    Proof.
      case=> A X.
      build=> i j ij.
      rewrite /PointwiseLifting.ob.
      have Qi := unfunE _ _ (naturality (transpose T) (A i, X i) (A i, X j) (idn _, X @@ ij)) (f i).
      have Qj := unfunE _ _ (naturality (transpose T) (A j, X j) (A i, X j) (A @@ ij, idn _)) (f j).
      rewrite /LeftOblique.ob /LeftOblique.functor /LeftOblique.prefunctor //= in Qi Qj.
      cbn in Qi, Qj.
      rewrite ?fidn ?seqL ?seqR in Qi Qj.
      by rewrite -Qi -Qj (naturality f).
    Qed.

    Canonical transp_fwd_fam : forall x, LeftOblique.functor F' x ~> RightOblique.functor U' x.
    Proof. by esplit; apply: transp_fwd_fam_mixin. Defined.

    Lemma transp_fwd_mixin : NatTrans.mixin_of _ _ transp_fwd_fam.
    Proof.
      build; case=> A1 X1; case=> A2 X2; case=> f g.
      apply: dfunE=> h.
      apply: NatTrans.ext.
      rewrite /transp_fwd_fam /transp_fwd_fam_fam //=.
      apply: dfunE=> i.
      have Q := unfunE _ _ (naturality (transpose T) (A1 i, X1 i) (A2 i, X2 i) (f i, g i)) (h i).
      cbn in Q.
      by rewrite Q.
    Qed.

    Canonical transp_fwd : LeftOblique.functor F' ~> RightOblique.functor U'.
    Proof. by esplit; apply: transp_fwd_mixin. Defined.

    Definition transp_bwd_fam_fam : forall P, RightOblique.functor U' P ->  forall i : ℐ, F' (pi1 P) i ~> (pi2 P) i.
    Proof.
      case=> A X f i.
      rewrite /F'; cbn.
      apply: (untranspose T (A i, X i)).
      by apply: f.
    Defined.

    Lemma transp_bwd_fam_mixin : forall P f, NatTrans.mixin_of _ _ (transp_bwd_fam_fam P f).
    Proof.
      case=> A X.
      build=> i j ij.
      rewrite /PointwiseLifting.ob.
      have Qi := unfunE _ _ (naturality (untranspose T) (A i, X i) (A i, X j) (idn _, X @@ ij)) (f i).
      have Qj := unfunE _ _ (naturality (untranspose T) (A j, X j) (A i, X j) (A @@ ij, idn _)) (f j).
      rewrite /RightOblique.ob /RightOblique.functor /RightOblique.prefunctor //= in Qi Qj.
      cbn in Qi, Qj.
      rewrite ?fidn ?seqL ?seqR in Qi, Qj.
      by rewrite -Qi -Qj (naturality f).
    Qed.

    Canonical transp_bwd_fam : forall x, RightOblique.functor U' x ~> LeftOblique.functor F' x.
    Proof. by esplit; apply: transp_bwd_fam_mixin. Defined.

    Lemma transp_bwd_mixin : NatTrans.mixin_of _ _ transp_bwd_fam.
    Proof.
      build; case=> A1 X1; case=> A2 X2; case=> f g.
      apply: dfunE=> h.
      apply: NatTrans.ext.
      rewrite /transp_bwd_fam /transp_bwd_fam_fam //=.
      apply: dfunE=> i.
      have Q := unfunE _ _ (naturality (untranspose T) (A1 i, X1 i) (A2 i, X2 i) (f i, g i)) (h i).
      cbn in Q.
      by rewrite Q.
    Qed.

    Canonical transp_bwd : RightOblique.functor U' ~> LeftOblique.functor F'.
    Proof. by esplit; apply: transp_bwd_mixin. Defined.

    Definition preadj : Preadjunction.type F' U'.
    Proof.
      build.
      - apply: transp_fwd.
      - apply: transp_bwd.
    Defined.

    Definition adj_mixin : Adjunction.mixin_of F' U' preadj.
    Proof.
      build; rewrite /LeftOblique.ob /RightOblique.ob //= /PointwiseLifting.ob.
      - case=> ? ? ? //=.
        apply: NatTrans.ext=> //=.
        rewrite /transp_bwd_fam /transp_fwd_fam /transp_bwd_fam_fam /transp_fwd_fam_fam //=.
        apply: dfunE=> ?.
        by rewrite untranspose_transpose.
      - case=> ? ? ? //=.
        apply: NatTrans.ext=> //=.
        rewrite /transp_bwd_fam /transp_fwd_fam /transp_bwd_fam_fam /transp_fwd_fam_fam //=.
        apply: dfunE=> ?.
        by rewrite transpose_untranspose.
    Qed.

    Canonical adj : F' ⊣ U'.
    Proof. by esplit; apply: adj_mixin. Defined.
  End Defs.
End PointwiseLiftingAdjunction.


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 D P Q : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ B P /\ (wd_ A P /\ (wd_ P Q /\ (col_ A C D /\ col_ B C D)))))) -> col_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.