(***************************************************************************
* Formalization of SN for the lambda_ex calculus			   *
*									   *
* General rewriting definitions	for explicit substitutions		   *
*									   *
* Fabien Renaud & Stephane Zimmerman, 2011				   *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2016  *
***************************************************************************)

Require Import Metatheory.
Require Import LambdaES_Defs.
Require Import List.

(** Given a relation Red, constructs its contextual closure. The contextual closure of a reduction is build in such a way that regularity is preserved. In particular, note the condition requiring that only terms can be introduced by the constructors for applications and explicit substitutions. *)
Inductive L_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | L_redex : forall t s, Lterm t -> Lterm s -> Red t s -> L_contextual_closure Red t s
  | L_app_left : forall t t' u, L_contextual_closure Red t t' -> Lterm u ->
	  		      L_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | L_app_right : forall t u u', L_contextual_closure Red u u' -> Lterm t ->
	  		       L_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | L_abs_in : forall t t' L, (forall x, x \notin L -> L_contextual_closure Red (t^x) (t'^x)) ->
                            L_contextual_closure Red (pterm_abs t) (pterm_abs t').

Inductive ES_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ES_redex : forall t s, Red t s -> ES_contextual_closure Red t s
  | ES_app_left : forall t t' u, ES_contextual_closure Red t t' -> term u ->
	  		      ES_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | ES_app_right : forall t u u', ES_contextual_closure Red u u' -> term t ->
	  		       ES_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | ES_abs_in : forall t t' L, (forall x, x \notin L -> ES_contextual_closure Red (t^x) (t'^x)) ->
                            ES_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ES_subst_left : forall t t' u L, (forall x, x \notin L -> ES_contextual_closure Red (t^x) (t'^x)) ->
	        term u -> ES_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
  | ES_subst_right : forall t u u', ES_contextual_closure Red u u' -> term t ->
	  	ES_contextual_closure Red  (pterm_sub t u) (pterm_sub t u').
(*
Inductive ESlab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| ESlab_redex : forall t s, Red t s -> ESlab_contextual_closure Red t s
| ESlab_app_left : forall t t' u, ESlab_contextual_closure Red t t' -> term u ->
	  		          ESlab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
| ESlab_app_right : forall t u u', ESlab_contextual_closure Red u u' -> term t ->
	  		           ESlab_contextual_closure Red (pterm_app t u) (pterm_app t u')
| ESlab_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
                                ESlab_contextual_closure Red (pterm_abs t) (pterm_abs t')
| ESlab_sub_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
	                              term u -> ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
| ESlab_sub_right : forall t u u', ESlab_contextual_closure Red u u' -> term t ->
	  	                     ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t u')
| ESlab_lsub_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
	                               term u -> ESlab_contextual_closure Red  (pterm_lsub t u) (pterm_lsub t' u)
| ESlab_lsub_right : forall t u u', ESlab_contextual_closure Red u u' -> term t ->
	  	                      ESlab_contextual_closure Red  (pterm_lsub t u) (pterm_lsub t u').
*)
(** Given a relation Red, constructs its parallel contextual closure *)
Inductive L_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| L_p_redex : forall t s, Lterm t -> Lterm s -> Red t s -> L_p_contextual_closure Red t s
| L_p_app : forall t t' u u', L_p_contextual_closure Red t t' -> L_p_contextual_closure Red u u' ->
	  		      L_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
| L_p_abs_in : forall t t' L, (forall x, x \notin L -> L_p_contextual_closure Red (t^x) (t'^x)) ->
                              L_p_contextual_closure Red (pterm_abs t) (pterm_abs t').

Inductive ES_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ES_p_redex : forall t s, term t -> term s -> Red t s -> ES_p_contextual_closure Red t s
  | ES_p_app : forall t t' u u', ES_p_contextual_closure Red t t' -> ES_p_contextual_closure Red u u' ->
	  		ES_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | ES_p_abs_in : forall t t' L, (forall x, x \notin L -> ES_p_contextual_closure Red (t^x) (t'^x)) ->
               ES_p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ES_p_sub : forall t t' u u' L, (forall x, x \notin L -> ES_p_contextual_closure Red (t^x) (t'^x)) ->
              ES_p_contextual_closure Red u u' ->
	      ES_p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u').
(*
Inductive ESlab_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ESlab_p_redex : forall t s, Red t s -> ESlab_p_contextual_closure Red t s
  | ESlab_p_app : forall t t' u u', ESlab_p_contextual_closure Red t t' -> ESlab_p_contextual_closure Red u u' ->
	  		          ESlab_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | ESlab_p_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                  ESlab_p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ESlab_p_subst : forall t t' u u' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                      ESlab_p_contextual_closure Red u u' ->
	                              ESlab_p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u')
  | ESlab_p_lsubst : forall t t' u u' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                       ESlab_p_contextual_closure Red u u' ->
	                               ESlab_p_contextual_closure Red (t[[u]]) (t'[[u']]).
*)
Hint Constructors L_contextual_closure ES_contextual_closure L_p_contextual_closure ES_p_contextual_closure.
(* ESlab_contextual_closure ESlab_p_contextual_closure. *)

(** Given a relation Red, constructs its transitive closure *)
Inductive trans_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | one_step_reduction : forall t u, Red t u -> trans_closure Red t u
  | transitive_reduction : forall t u v, trans_closure Red t u -> trans_closure Red u v -> trans_closure Red t v.

(** Given a relation Red, constructs its transitive reflexive closure *)
Inductive star_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | reflexive_reduction : forall t, star_closure Red t t
  | star_trans_reduction : forall t u, trans_closure Red t u -> star_closure Red t u.

(** Given a reduction, the composition of two star closure is still a star closure
Lemma star_transitive_closure:
    forall (Red: pterm -> pterm -> Prop) (t u v : pterm),
     Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
 intros Red t u v H0 H1.
 forwards~ H: (one_step_reduction t u).
 induction H1. apply star_trans_reduction.
 apply one_step_reduction; assumption.
 apply star_trans_reduction.
 apply transitive_reduction with (u := t0); trivial.
Qed.
*)
Lemma transitive_closure_composition :
    forall Red t u v, trans_closure Red t u -> trans_closure Red u v -> trans_closure Red t v.
Proof.
  intros_all. induction H.
  apply transitive_reduction with (u := u); trivial. constructor 1; auto.
  apply transitive_reduction with (u := u) ; auto.
Qed.

Lemma star_transitive_closure_composition_1 :
    forall Red t u v, trans_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros_all. induction H0.
  apply star_trans_reduction; trivial.
  apply star_trans_reduction.
  apply transitive_reduction with t0; trivial.
Qed.

Lemma star_transitive_closure_composition_2 :
    forall Red t u v, star_closure Red t u -> trans_closure Red u v -> star_closure Red t v.
Proof.
  intros_all. induction H.
  apply star_trans_reduction; trivial.
  apply star_trans_reduction.
  apply transitive_reduction with u; trivial.
Qed.

Lemma star_closure_composition:
    forall Red t u v, star_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros_all. induction H. assumption.
  apply star_transitive_closure_composition_1 with (u := u); assumption.
Qed.
(*
Lemma transitive_star_derivation:
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v -> exists u, Red t u /\  star_closure Red u v.
Proof.
  intros_all. induction H.
  exists u. split; trivial. apply reflexive_reduction.
  intros t' u' v' H0 H1. exists u'.
  split; trivial.
  apply star_trans_reduction; trivial.
Qed.

Lemma transitive_star_derivation':
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v <-> (Red t v \/ (exists u, Red t u /\  (exists u', star_closure Red u u' /\ Red u' v))).
Proof.
 intros. split. intros. destruct H.
 left; trivial. right. exists u. split; trivial.
 clear H. induction H0. exists t0. split; trivial.
 apply reflexive_reduction. destruct IHtrans_closure.
 exists x. split. apply star_transitive_closure with (u := u); trivial.
 apply H1. apply H1. intros. case H. intro.
 apply one_step_reduction; trivial. intro.
 destruct H0. destruct H0. destruct H1. destruct H1. destruct H1.
 apply transitive_reduction with (u := t0); trivial.
 apply one_step_reduction; trivial.
 apply transitive_reduction with (u := t0); trivial.
 apply transitive_closure_composition with (u := u); trivial.
 apply one_step_reduction; trivial.
Qed.

Lemma star_transitive_derivation: forall (Red : pterm -> pterm -> Prop) (t u: pterm),
      star_closure Red t u <-> (t = u \/ trans_closure Red t u).
Proof.
 intros. split. intro. destruct H.
 left. reflexivity. right; trivial.
 intro. case H.
 clear H. intro H. rewrite H. apply reflexive_reduction.
 clear H. intro H. apply star_trans_reduction; trivial.
Qed.
*)
Lemma trans_R1_R2 : forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', trans_closure R1 t t' -> trans_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply one_step_reduction. apply H; trivial.
 apply transitive_reduction with u; trivial.
Qed.
(*
Lemma star_R1_R2: forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', star_closure R1 t t' -> star_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply reflexive_reduction.
 apply star_trans_reduction.
 apply trans_R1_R2 with (R1 := R1); trivial.
Qed.
*)


(*|
###########################
Equality on inductive types
###########################

:Link: https://stackoverflow.com/q/26246441
|*)

(*|
Question
********

How do I prove the following trivial lemma:
|*)

Require Import Vector.

Lemma t0_nil : forall A (x : t A 0), x = nil A.
Proof.
Abort.

(*|
FAQ recommends ``decide equality`` and ``discriminate`` tactics but I
could not find a way to apply either of them. For the reference, here
is inductive definition:
|*)

Print t. (* .unfold .messages *)

(*|
Answer
******

What you want to do is to invert on ``x``. Unfortunately, it turns out
that general inversion of dependently typed hypotheses is undecidable,
see Adam Chlipala's CPDT. You can pattern match on the structure
manually though, e.g. with:
|*)

Lemma t0_nil : forall A (x : t A 0), x = nil A.
Proof.
  intros.
  refine (match x with
          | nil _ => _
          | cons _ _ _ _ => _
          end).
  - reflexivity.
  - exact @id.
Qed.

(*|
In many cases you can also use `the tactic dep_destruct provided by
CPDT
<http://adam.chlipala.net/cpdt/repo/file/977b425331c3/src/CpdtTactics.v>`__.
In that case your proof simply becomes:

.. code-block:: coq

    Require Import CpdtTactics.

    Lemma t0_nil : forall A (x : t A 0), x = nil A.
      intros. dep_destruct x. reflexivity.
    Qed.

----

**A:** An elegant solution by Pierre Boutillier, taken from this
`Coq-club post
<http://coq-club.inria.narkive.com/wrDwvaNY/how-to-prove-that-all-vectors-of-0-length-are-equal-to-vector-nil#post2>`__:
|*)

Reset t0_nil. (* .none *)
Definition t0_nil A (x : t A 0) : x = nil A := match x with nil _ => eq_refl end.


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

From Coq Require Import
  Relation_Definitions
  RelationClasses
  Psatz
  Morphisms
  FunctionalExtensionality
.

From ClassesOfFunctors Require Import
  DictDerive
  FunctorPlus
  AppKleenePlus
  Laws
.

Require Export Transformers.PowerSet.

Require Import Tactics.Tactics.

Require Import GHC.Base.

(** * The [Applicative] transformer based on [PowerSet] *)

Section ParTransformer.

  (** [I] is the applicative functor that [PowerSet] transforms. *)
  Variable I : Type -> Type.
  Variable FI : Functor I.
  Variable AI : Applicative I.

  (** The equivalence relation on [I] and theorems that [I] satisfy
      certain laws. *)
  Variable EqI : forall (A : Type), relation (I A).
  Variable EqIEq : forall (A : Type), Equivalence (@EqI A).
  Variable ALI : @ApplicativeLaws I (@EqI) (@FI) (@AI).
  Variable ACI : @ApplicativeCongruenceLaws I (@EqI) (@FI) (@AI).

  (** The refinement relation on [I]. *)
  Variable RefinesI : forall (A : Type), relation (I A).
  Variable RefinesIPreOrder : forall (A : Type), PreOrder (@RefinesI A).

  Global Instance liftA2Proper :
    forall A B C, Proper (eq ==> @EqI A ==> @EqI B ==> @EqI C) liftA2.
  Proof.
    intros A B C f g -> a1 a2 HEqa b1 b2 HEqb.
    apply liftA2_cong; assumption.
  Qed.

  (** The equivalence relation on [PowerSet I]. *)
  Definition EqPowerSet {A} : relation (PowerSet I A) :=
    fun p q => forall a, p a <-> q a.

  (** An invariance that all [PowerSet I A] satisfies as long as they
      are constructed using functions that maintain the invariance. We
      also show in this section that all functions we define on this
      data type maintain the invariance. *)
  Definition Invariance {A} (p : PowerSet I A) :=
    forall a b, EqI a b -> p a <-> p b.

  (** The refinement relation on [PowerSet I]. *)
  Definition RefinesPowerSet {A} : relation (PowerSet I A) :=
    fun p q =>  forall a, p a -> q a.

  Global Instance Equiv__EqPowerSet {A} : Equivalence (@EqPowerSet A).
  constructor.
  - intros a. unfold EqPowerSet. tauto.
  - intros a b. unfold EqPowerSet. intros. split; apply H.
  - intros a b c. unfold EqPowerSet.
    intros; split.
    + intros. apply H0. apply H. assumption.
    + intros. apply H. apply H0. assumption.
  Qed.

  Global Instance PreOrder__RefinesPowerSet {A} : PreOrder (@RefinesPowerSet A).
  constructor.
  - intros a p q. assumption.
  - intros a b c Hab Hbc.
    unfold RefinesPowerSet in *. intros i Hi.
    specialize (Hab i Hi).  specialize (Hbc i Hab).
    assumption.
  Qed.

  Definition embedPowerSet {A} (a : I A) : PowerSet I A :=
    fun r => EqI r a.

  (** [embedPowerSet] maintains the invariance. *)
  Theorem embedInvariance {A} (a : I A) :
    Invariance (embedPowerSet a).
  Proof.
    intros x y Hxy. unfold embedPowerSet. split.
    - intros <-. symmetry. assumption.
    - intros <-. assumption.
  Qed.

  Definition purePowerSet {A} (a : A) : PowerSet I A :=
    fun r => EqI r (pure a).

  (** [purePowerSet] maintains the invariance. *)
  Theorem pureInvariance {A} (a : A) :
    Invariance (purePowerSet a).
  Proof.
    intros x y Hxy. unfold purePowerSet. split.
    - intros <-. symmetry. assumption.
    - intros <-. assumption.
  Qed.

  Definition liftA2Par {A B C}
    (f : A -> B -> C) (a : PowerSet I A) (b : PowerSet I B) : PowerSet I C :=
    fun r => exists a', a a' /\
                  exists b', b b' /\
                          (EqI (liftA2 f a' b') r \/ EqI (liftA2 (flip f) b' a') r).

  (** [liftA2Par] maintains the invariance. *)
  Theorem liftA2ParInvariance {A B C}
    (f : A -> B -> C) (a : PowerSet I A) (b : PowerSet I B) :
    Invariance (liftA2Par f a b).
  Proof.
    intros x y Hxy. unfold liftA2Par. split.
    - intros H0. destruct H0 as (a' & Ha & b' & Hb & HEq). destruct HEq.
      + exists a'. intuition. exists b'. intuition.
        left. transitivity x; assumption.
      + exists a'. intuition. exists b'. intuition.
        right. transitivity x; assumption.
    - intros H0. destruct H0 as (a' & Ha & b' & Hb & HEq). destruct HEq.
      + exists a'. intuition. exists b'. intuition.
        left. transitivity y; try assumption.
        symmetry; assumption.
      + exists a'. intuition. exists b'. intuition.
        right. transitivity y; try assumption.
        symmetry; assumption.
  Qed.

  (** [liftA2Par] is commutative. *)
  Lemma liftA2Par_comm : forall {A B C} (f : A -> B -> C)
                           (a : PowerSet I A) (b : PowerSet I B),
      EqPowerSet (liftA2Par f a b) (liftA2Par (flip f) b a).
  Proof.
    intros. unfold EqPowerSet, liftA2Par; intros.
    split; intros.
    - repeat destructs; subst.
      + exists x0. intuition. exists x. intuition.
      + exists x0. intuition. exists x. intuition.
    - repeat destructs; subst.
      + exists x0. intuition. exists x. intuition.
      + exists x0. intuition. exists x. intuition.
  Qed.

  Definition PowerSetApplicative__AppDict : Applicative__Dict (PowerSet I) :=
    {| liftA2__ := fun _ _ _ => liftA2Par ;
       op_zlztzg____ := fun _ _ => liftA2Par id ;
       op_ztzg____ := fun _ _ => liftA2Par (fun _ => id) ;
       pure__ := fun _ => @purePowerSet _
    |}.

  Instance Functor__PowerSetApplicative : Functor (PowerSet I) :=
    apdict_functor _ PowerSetApplicative__AppDict.

  Instance Applicative__PowerSetApplicative : Applicative (PowerSet I) :=
    apdict_applicative _ PowerSetApplicative__AppDict.

End ParTransformer.

(** We cannot show that all the [PowerSet I A] satisfy the laws we desire (like
    left identity law of applicative functors). This is because an arbitrary
    [PowerSet I A] might not maintain the invariance (the [Invariance] we
    defined in the previous section). Instead of proving that [PowerSet I A] are
    instances of [CommNonAsscoApplicativeLaws] and [ApplicativeCongruenceLaws],
    we show that all [PowerSet I A] that maintain the invariance are instances
    of them. We do that by using a subset type [PowerSetI] defined below. *)
Section CommNonAssocApplicativeLaws.

  (** [PowerSetI] is a subset of [PowerSet] where all elements satisfy the
      invariance defined by [Invariance]. *)
  Definition PowerSetI
    (I : Type -> Type) (EqI : forall A, relation (I A)) (A : Type) :=
    { p : PowerSet I A | Invariance EqI p }.

  Variable I : Type -> Type.
  Variable FI : Functor I.
  Variable AI : Applicative I.

  Variable EqI : forall (A : Type), relation (I A).
  Variable EqIEq : forall (A : Type), Equivalence (@EqI A).
  Variable ALI : @ApplicativeLaws I (@EqI) (@FI) (@AI).
  Variable ACI : @ApplicativeCongruenceLaws I (@EqI) (@FI) (@AI).

  Variable RefinesI : forall (A : Type), relation (I A).
  Variable RefinesIPreOrder : forall (A : Type), PreOrder (@RefinesI A).

  (* The rest are functions refined on [PowerSetI]. *)
  Program Definition EqPowerSetI {A} : relation (PowerSetI I (@EqI) A) :=
    EqPowerSet.

  Global Instance Equiv__EqPowerSetI {A} : Equivalence (@EqPowerSetI A).
  constructor.
  - intros a. unfold EqPowerSetI.
    destruct a. simpl. reflexivity.
  - intros a b. unfold EqPowerSetI. intros. split; apply H.
  - intros a b c. unfold EqPowerSet.
    intros; split.
    + intros. apply H0. apply H. assumption.
    + intros. apply H. apply H0. assumption.
  Qed.

  Program Definition embedPowerSetI {A} : I A -> PowerSetI I (@EqI) A :=
    (@embedPowerSet I (@EqI) A).
  Next Obligation.
    apply embedInvariance. apply (@EqIEq).
  Qed.

  Program Definition purePowerSetI {A} : A -> PowerSetI I (@EqI) A :=
    (@purePowerSet I (@FI) (@AI) (@EqI) A).
  Next Obligation.
    apply pureInvariance. apply (@EqIEq).
  Qed.

  Program Definition liftA2ParI {A B C} :
    (A -> B -> C) ->
    PowerSetI I (@EqI) A -> PowerSetI I (@EqI) B -> PowerSetI I (@EqI) C :=
    (@liftA2Par I (@FI) (@AI) (@EqI) A B C).
  Next Obligation.
    apply liftA2ParInvariance. apply (@EqIEq).
  Qed.

  Definition PowerSetIApplicative__AppDict :
    Applicative__Dict (PowerSetI I (@EqI)) :=
    {| liftA2__ := fun _ _ _ => liftA2ParI ;
       op_zlztzg____ := fun _ _ => liftA2ParI id ;
       op_ztzg____ := fun _ _ => liftA2ParI (fun _ => id) ;
       pure__ := fun _ => purePowerSetI
    |}.

  Global Instance Functor__PowerSetIApplicative : Functor (PowerSetI I (@EqI)) :=
    apdict_functor _ PowerSetIApplicative__AppDict.

  Global Instance Applicative__PowerSetIApplicative :
    Applicative (PowerSetI I (@EqI)) :=
    apdict_applicative _ PowerSetIApplicative__AppDict.

  (** * Core theorems. *)

  (** Lemma 3.7 *)
  Global Instance CommNonAssocApplicativeLaws__PowerSetApplicative :
    @CommNonAssocApplicativeLaws (PowerSetI I (@EqI)) (@EqPowerSetI) _ _.
  constructor.
  - (* liftA2_left_id *)
    intros. cbn. split.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct b as (b & HIb).
      intros (a' & Eqa' & b' & Hb & HEq). destruct HEq.
      * rewrite Eqa' in H. rewrite (@liftA2_left_id _ _ _ _ ALI) in H.
        simpl. simpl in Hb. specialize (HIb b' a0 H).
        apply HIb. assumption.
      * rewrite Eqa' in H. rewrite (@liftA2_right_id _ _ _ _ ALI) in H.
        simpl. simpl in Hb. specialize (HIb b' a0 H).
        apply HIb. assumption.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct b as (b & HIb). simpl. intros Hb.
      exists (pure a). split; [reflexivity|].
      exists a0. intuition. left. apply (@liftA2_left_id _ _ _ _ ALI).
  - (* liftA2_right_id *)
    intros. cbn. split.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct a as (a & HIa).
      intros (a' & Ha & b' & Eqb' & HEq). destruct HEq.
      * rewrite Eqb' in H. rewrite (@liftA2_right_id _ _ _ _ ALI) in H.
        simpl. simpl in Ha. specialize (HIa a' a0 H).
        apply HIa. assumption.
      * rewrite Eqb' in H. rewrite (@liftA2_left_id _ _ _ _ ALI) in H.
        simpl. simpl in Ha. specialize (HIa a' a0 H).
        apply HIa. assumption.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct a as (a & HIa). simpl. intros Ha.
      exists a0. intuition. exists (pure b). split; [reflexivity|].
      left. apply (@liftA2_right_id _ _ _ _ ALI).
  - (* commutativity *)
    intros. unfold EqPowerSetI.
    destruct a as [a HIa]. destruct b as [b HIb].
    simpl. apply (@liftA2Par_comm _ _ _ _).
  Qed.

  (** Lemma 3.7 *)
  Global Instance ApplicativeCongruenceLaws__PowerSetApplicative :
    @ApplicativeCongruenceLaws (PowerSetI I (@EqI)) (@EqPowerSetI) _ _.
  constructor. intros.
  destruct a1 as [a1 HIa1].
  destruct a2 as [a2 HIa2].
  destruct b1 as [b1 HIb1].
  destruct b2 as [b2 HIb2].
  unfold EqPowerSetI in *. simpl in *. split.
  - intros Hlift. destruct Hlift as (a' & Ha' & b' & Hb' & HEq).
    destruct HEq.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
  - intros Hlift. destruct Hlift as (a' & Ha' & b' & Hb' & HEq).
    destruct HEq.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
  Qed.
End CommNonAssocApplicativeLaws.


Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Strings.String.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Import ListNotations.

Module Type NAME_SYSTEM.

Parameter t: Type.
Parameter eq_dec: forall v1 v2: t, {v1 = v2} + {v1 <> v2}.
Parameter max: t -> t -> t.
Parameter next_name: t -> t.
Parameter le: t -> t -> Prop.
Parameter le_trans: Transitive le.
Parameter default: t.

Axiom next_name_new: forall v v_max, le v v_max -> v <> next_name v_max.
Axiom le_max_r: forall v1 v2, le v1 (max v1 v2).
Axiom le_max_l: forall v1 v2, le v2 (max v1 v2).
Axiom max_sym: forall v1 v2, max v1 v2 = max v2 v1.
Axiom max_comm: forall v1 v2 v3, max v1 (max v2 v3) = max (max v1 v2) v3.

End NAME_SYSTEM.

Module NAME_SYSTEM_EXT (Name:NAME_SYSTEM).
Include Name.

(** Max name of a list **)
Fixpoint list_max (xs:list t):=
  match xs with
  | nil => default
  | (x::xs') => max x (list_max xs')
  end.

(** Find a new name for a list **)
Definition list_new_name (xs:list t):= next_name (list_max xs).

Lemma list_max_correct: forall s xs,
  In s xs -> le s (list_max xs).
Proof.
  intros. induction xs. inversion H. simpl.  destruct H.
  + subst a. apply le_max_r.
  + assert (le (list_max xs) (max a (list_max xs))) by apply le_max_l. apply IHxs in H.
     pose proof le_trans. transitivity (list_max xs); tauto.
Qed.

Lemma list_new_name_new: forall s xs,
  In s xs -> s <> list_new_name xs.
Proof.
  intros. apply list_max_correct in H. apply next_name_new. tauto.
Qed.

Lemma list_max_Permuatation: forall l1 l2,
  Permutation l1 l2 -> list_max l1 = list_max l2.
Proof.
  intros. induction H.
  + reflexivity.
  + simpl. congruence.
  + simpl. assert (max x (list_max l)=max (list_max l) x) by apply max_sym.
      rewrite H. rewrite max_comm. apply max_sym.
  + congruence.
Qed.

Corollary list_new_name_Permutation: forall l1 l2,
  Permutation l1 l2  -> list_new_name l1 = list_new_name l2.
Proof.
  intros. apply list_max_Permuatation in H. unfold list_new_name. congruence.
Qed.

Definition eqb (x y:t) :bool:=
  if eq_dec x y then true else false.

Lemma eqb_eq: forall v1 v2,
  eqb v1 v2 = true <-> v1=v2.
Proof.
  unfold eqb.
  split.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ tauto.
     ++ easy.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ tauto.
     ++ easy.
Qed.
(* unfold eqb; split; intros; destruct (eq_dec v1 v2); easy. Qed. *)

Lemma eqb_neq: forall v1 v2,
  eqb v1 v2 = false <-> v1 <> v2.
Proof.
  unfold eqb.
  split.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ easy.
     ++ apply n.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ easy.
     ++ reflexivity.
Qed.
(* Proof. unfold eqb; split; intros; destruct (eq_dec v1 v2); easy. Qed. *)

(** Key-value pairs**)
Fixpoint look_up {A: Type} (x: t) (KV: list (t * A)): option A :=
  match KV with
  | nil => None
  | (x0, v0) :: KV0 =>
      if eqb x0 x then Some v0 else look_up x KV0
  end.

Fixpoint remove {A: Type} (x: t) (KV: list (t * A)): list (t * A) :=
  match KV with
  | nil => nil
  | (x0, v0) :: KV0 =>
      if eqb x0 x
      then remove x KV0
      else (x0, v0) :: remove x KV0
  end.

End NAME_SYSTEM_EXT.

(** Instantiate NAME_SYSTEM with string **)
Module StringSystem <: NAME_SYSTEM.

Definition t := string.

Definition eq_dec: forall v1 v2: t, {v1 = v2} + {v1 <> v2} :=
  string_dec.

Definition max (v1 v2: t): t :=
  match String_as_OT.cmp v1 v2 with
  | Lt => v2
  | _ => v1
  end.

(** New name: add a suffix ' at the end **)
Definition next_name (v: t): t :=
  append v (String (Ascii.Ascii true true true false false true false false) EmptyString).

Definition le := fun t1 t2 => String_as_OT.lt t1 t2 \/ t1 = t2.

Instance le_trans: Transitive le.
Proof.
  unfold Transitive. intros.
  destruct H; destruct H0; unfold le.
  + left. apply String_as_OT.lt_trans with y; tauto.
  + left. congruence.
  + left. congruence.
  + right. congruence.
Qed.

Lemma next_name_new: forall v v_max,
  le v v_max ->
  v <> next_name v_max.
Proof.
  unfold le, next_name.
  intros.
  assert (String_as_OT.lt v_max  (append v_max (String (Ascii.Ascii true true true false false true false false) EmptyString))).
  { clear v H. apply String_as_OT.cmp_lt. induction v_max.
     + reflexivity.
     + simpl. assert (a=a) by reflexivity. apply Ascii_as_OT.cmp_eq in H. unfold Ascii_as_OT.cmp in H. rewrite H. tauto. }
  remember  (append v_max (String (Ascii.Ascii true true true false false true false false) EmptyString)) as z. destruct H.
  + assert (String_as_OT.lt v z). eapply String_as_OT.lt_trans. apply H. tauto.
      destruct (eq_dec v z);[|tauto]. apply String_as_OT.cmp_lt in H1. apply String_as_OT.cmp_eq in e. congruence.
  + subst v_max.  destruct (eq_dec v z);[|tauto].  apply String_as_OT.cmp_lt in H0. apply String_as_OT.cmp_eq in e. congruence.
Qed.

Local Lemma compare_helper_gt {a b : string} (G : String_as_OT.cmp a b = Gt):
   String_as_OT.lt b a.
Proof.
  rewrite String_as_OT.cmp_antisym in G.
  rewrite CompOpp_iff in G.
  now apply String_as_OT.cmp_lt.
Qed.

Local Lemma compare_helper_lt_gt {a b: string} (H:String_as_OT.cmp a b = Lt):
  String_as_OT.cmp b a = Gt.
Proof.
  rewrite String_as_OT.cmp_antisym in H.
  rewrite CompOpp_iff in H. tauto.
Qed.

Local Lemma compare_helper_gt_lt {a b: string} (H:String_as_OT.cmp a b = Gt):
  String_as_OT.cmp b a = Lt.
Proof.
  rewrite String_as_OT.cmp_antisym in H.
  rewrite CompOpp_iff in H. tauto.
Qed.

Lemma le_max_r: forall (v1 v2:t), le v1 (max v1 v2).
Proof.
  unfold le, max; intros. destruct (String_as_OT.cmp v1 v2) eqn:E;try tauto.
  left. apply String_as_OT.cmp_lt. tauto.
Qed.

Lemma le_max_l: forall (v1 v2:t), le v2 (max v1 v2).
Proof.
  unfold le, max; intros. destruct (String_as_OT.cmp v1 v2) eqn:E.
  + right. apply String_as_OT.cmp_eq in E. congruence.
  + tauto.
  + apply compare_helper_gt in E. tauto.
Qed.

Lemma max_sym: forall v1 v2, max v1 v2 = max v2 v1.
Proof.
  intros. unfold max. destruct (String_as_OT.cmp v1 v2) eqn: E1; destruct (String_as_OT.cmp v2 v1) eqn: E2; try tauto .
  + apply String_as_OT.cmp_eq in E1. apply String_as_OT.cmp_eq in E2. congruence.
  + apply String_as_OT.cmp_eq. tauto.
  + apply compare_helper_lt_gt in E2. congruence.
  + apply String_as_OT.cmp_eq in E2. congruence.
  + apply compare_helper_gt_lt in E2. congruence.
Qed.

Lemma max_comm:  forall v1 v2 v3, max v1 (max v2 v3) = max (max v1 v2) v3.
Proof.
  intros. unfold max. destruct (String_as_OT.cmp v1 v2) eqn:E1; destruct (String_as_OT.cmp v2 v3) eqn:E2.
  + rewrite E1. rewrite String_as_OT.cmp_eq in E1. rewrite String_as_OT.cmp_eq in E2.
      subst v2. apply String_as_OT.cmp_eq in E2. rewrite E2. reflexivity.
  + rewrite String_as_OT.cmp_eq in E1. subst v2. rewrite E2. reflexivity.
  + rewrite String_as_OT.cmp_eq in E1. assert (E3:=E1). apply String_as_OT.cmp_eq in E3.
      rewrite E3. subst v2. rewrite E2. reflexivity.
  + rewrite E1. reflexivity.
  + rewrite String_as_OT.cmp_lt in E1. rewrite String_as_OT.cmp_lt in E2.
      assert (String_as_OT.cmp v1 v3=Lt). apply String_as_OT.cmp_lt. eapply String_as_OT.lt_trans.
      apply E1. tauto. rewrite H. reflexivity.
  + rewrite E1. reflexivity.
  + rewrite String_as_OT.cmp_eq in E2. subst v3. rewrite E1. reflexivity.
  + reflexivity.
  + rewrite E1. assert (String_as_OT.cmp v1 v3=Gt). apply compare_helper_lt_gt. apply String_as_OT.cmp_lt.
      apply compare_helper_gt in E1. apply compare_helper_gt in E2. eapply String_as_OT.lt_trans.
      apply E2. tauto. rewrite H. reflexivity.
Qed.

Definition default: t := "x"%string.

End StringSystem.

Module StringName:= NAME_SYSTEM_EXT StringSystem.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Trivial.
Require Import Logic.PropositionalLogic.Complete.Truth_Trivial.
Require Import Logic.PropositionalLogic.Complete.Complete_Trivial.
Require Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.
Require Logic.PropositionalLogic.DeepEmbedded.ProofTheories.
Require Logic.PropositionalLogic.DeepEmbedded.TrivialSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Local Open Scope kripke_model_class.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.
Import KripkeModelClass.

Section Complete.

Context {Sigma: PropositionalLanguage.PropositionalVariables}
        {CV: Countable PropositionalLanguage.Var}.

Existing Instances PropositionalLanguage.L PropositionalLanguage.minL PropositionalLanguage.pL.

Existing Instances TrivialSemantics.MD TrivialSemantics.SM TrivialSemantics.tminSM TrivialSemantics.tpSM.

Existing Instances ProofTheories.ClassicalPropositionalLogic.G ProofTheories.ClassicalPropositionalLogic.AX ProofTheories.ClassicalPropositionalLogic.minAX ProofTheories.ClassicalPropositionalLogic.ipG  ProofTheories.ClassicalPropositionalLogic.cpG.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC Axiomatization2SequentCalculus_cpSC.

Definition cP: context -> Prop := maximal consistent.

Lemma AL_MC: at_least (maximal consistent) cP.
Proof. solve_at_least. Qed.

Lemma LIN_CONSI: Lindenbaum_constructable consistent cP.
Proof.
  eapply Lindenbaum_constructable_Same_set.
  + rewrite Same_set_spec.
    intros Phi.
    apply consistent_spec.
  + apply Lindenbaum_constructable_suffice.
    - apply PropositionalLanguage.formula_countable; auto.
    - apply Lindenbaum_preserves_cannot_derive.
    - apply Lindenbaum_cannot_derive_ensures_max_consistent.
Qed.

Definition canonical_frame: Type := sig cP.

Definition canonical_eval: PropositionalLanguage.Var -> canonical_frame -> Prop :=
  fun p a => proj1_sig a (PropositionalLanguage.varp p).

Definition kMD: KripkeModel TrivialSemantics.MD :=
  Build_KripkeModel TrivialSemantics.MD
    unit (fun _ => canonical_frame) (fun u a v => canonical_eval v a).

Definition canonical_Kmodel: @Kmodel TrivialSemantics.MD kMD := tt.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Lemma TRUTH:
  forall x: expr, forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_andp cP rel AL_MC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_orp cP rel AL_MC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_impp cP rel AL_MC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_falsep cP rel AL_MC).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

Existing Instance kMD.

Theorem complete_Classical_Trivial:
  strongly_complete ProofTheories.ClassicalPropositionalLogic.G TrivialSemantics.SM (AllModel _).
Proof.
  assert (strongly_complete ProofTheories.ClassicalPropositionalLogic.G TrivialSemantics.SM
           (KripkeModelClass _ (fun _ => True))).
  Focus 2. {
    hnf; intros.
    apply (H Phi x).
    hnf; intros.
    apply H0; auto.
    hnf; auto.
  } Unfocus.
  apply (@general_completeness PropositionalLanguage.L _ _ ProofTheories.ClassicalPropositionalLogic.G _ _ _ _
           _ _ _ TrivialSemantics.SM _ _ _ _ rel LIN_CONSI TRUTH); auto.
Qed.

End Complete.


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Set Universe Polymorphism.

Inductive list@{i} (A : Type@{i}) : Type@{i}
:=  nil : list A | cons : A -> list A -> list A.

Arguments nil {A}.
Arguments cons {A} h tl.

Inductive list_R@{i} (A₁ A₂ : Type@{i})
  (A_R : A₁ -> A₂ -> Type@{i}) : list A₁ -> list A₂ -> Type@{i} :=
| nil_R : list_R A₁ A₂ A_R nil nil
| cons_R : forall (h : A₁) (h₂ : A₂),
    A_R h h₂ ->
    forall (tl : list A₁) (tl₂ : list A₂),
    list_R A₁ A₂ A_R tl tl₂ -> list_R A₁ A₂ A_R (cons h tl) (cons h₂ tl₂).

Fixpoint list_RF@{i} (A: Type@{i}) (A₂ : Type@{i}) (A_R : A -> A₂ -> Type@{i})
                                  (l : list@{i} A) (l₂ : list@{i} A₂) {struct l}
                                  : Type@{i} :=
   match l with
   | nil =>
       match l₂ with
       | nil => True
       | cons _ _ => False
       end
   | cons h tl =>
       match l₂ with
       | nil  => False
       | cons h₂ tl₂ =>
           (A_R h h₂ * list_RF A A₂ A_R tl tl₂)%type
       end
   end.

Check  ((list_R nat nat (fun _ _ => True) nil nil):Set).
Check  ((list_RF nat nat (fun _ _ => True) nil nil):Set).
Check  ((list_R Set Set (fun _ _ => True) nil nil):Type).
Check  ((list_RF Set Set (fun _ _ => True) nil nil):Type).
Fail Check  ((list_R Set Set (fun _ _ => True) nil nil):Set).
Fail Check  ((list_RF Set Set (fun _ _ => True) nil nil):Set).
Fail Check  ((list_R nat nat (fun _ _ => True) nil nil):Prop).
Fail Check  ((list_RF nat nat (fun _ _ => True) nil nil):Prop).

(* Check (@or_ind Prop Type (fun _ => True) (fun _ => False)). *)

Locate or.
Inductive prod@{i} (A B : Type@{i}) : Type@{i} :=  pair : A -> B -> prod A  B.

Inductive or@{i j} (A B : Type@{i}) : Type@{j} :=  or_introl : A -> or A  B | or_intror : B -> or A  B.

Definition or_rectp@{ui uj uo}
 (A B : Type@{ui}) (P:Type@{uo})
  (fa : A->P)
  (fb : B->P) (o : or@{ui uj} A B): P :=
match o as o0 return P with
| or_introl _ _ x => fa x
| or_intror _ _ x => fb x
end.

Check or.
Fail Check ((prod True True):Prop).

About list.

Fail Check  ((list_R nat nat (fun _ _ => True) [] []):Prop).


Require Import Equations.Prop.Equations.

Fixpoint slow n : unit := match n with O => tt | S n => match slow n with tt => slow n end end.

#[local]
Obligation Tactic := idtac.
Goal slow  1 = tt /\ True -> True. intros H. dependent elimination H. assumption. Qed.
Goal slow 20 = tt /\ True -> True. intros H. dependent elimination H. assumption. Qed.
Goal slow 300 = tt /\ True -> True. intros H. Timeout 1 dependent elimination H. assumption. Qed.
Goal slow 5000 = tt /\ True -> True. intros H. Timeout 1 dependent elimination H. assumption. Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From pcm Require Import options axioms pred prelude.
From pcm Require Import pcm autopcm unionmap heap.
From htt Require Import model.
Import Prenex Implicits.

(**************************************************************************)
(* This file implements automations (both unification- and tactics-based) *)
(* related to Hoare logic for heaps.                                      *)
(*                                                                        *)
(* First automation concerns selection of Hoare-style rule for symbolic   *)
(* evaluation. The first command of the program determines the applicable *)
(* rule uniquely. The implemented automation picks out this rule, and     *)
(* applies it, while using AC-theory of heaps to rearrange the goal, if   *)
(* necessary for the rule to apply.                                       *)
(*                                                                        *)
(* Second automation extends this mechanism for a common combination of   *)
(* invoking the ghost lemma together with the frame rule. This allows the *)
(* user to supply the "kernel" heap to frame on directly instead of       *)
(* rearranging the goal manually with AC-rewriting.                       *)
(*                                                                        *)
(* Third, a tactic for canceling common terms in disjoint unions.         *)
(* Currently, it doesn't deal with weak pointers. I.e. if it sees terms   *)
(* like x :-> v1 and x :-> v2, it will reduce to v1 = v2 only if v1, v2   *)
(* are of the same type. A more general tactic would emit obligation      *)
(* dyn v1 = dyn v2, but I don't bother with this now.                     *)
(*                                                                        *)
(**************************************************************************)

(****************************************************************)
(* First, the reflection mechanism for search-and-replace       *)
(* pattern-matching on heap expressions; the AC theory of heaps *)
(****************************************************************)

Section Partition.

Structure tagged_heap := Tag {untag :> heap}.

Definition right_tag := Tag.
Definition left_tag := right_tag.
Canonical Structure found_tag i := left_tag i.

Definition form_axiom k r (h : tagged_heap) := untag h = k \+ r.

Structure form (k r : heap) :=
  Form {heap_of :> tagged_heap;
        _ : form_axiom k r heap_of}.

Arguments Form : clear implicits.

Lemma formE r k (f : form k r) : untag f = k \+ r.
Proof. by case: f=>[[j]] /=; rewrite /form_axiom /= => ->. Qed.

Lemma found_pf k : form_axiom k Unit (found_tag k).
Proof. by rewrite /form_axiom unitR. Qed.

Canonical Structure heap_found k := Form k Unit (found_tag k) (found_pf k).

Lemma left_pf h r (f : forall k, form k r) k :
        form_axiom k (r \+ h) (left_tag (untag (f k) \+ h)).
Proof. by rewrite formE /form_axiom /= joinA. Qed.

Canonical Structure search_left h r (f : forall k, form k r) k :=
  Form k (r \+ h) (left_tag (untag (f k) \+ h)) (left_pf h f k).

Lemma right_pf h r (f : forall k, form k r) k :
        form_axiom k (h \+ r) (right_tag (h \+ f k)).
Proof. by rewrite formE /form_axiom /= joinCA. Qed.

Canonical Structure search_right h r (f : forall k, form k r) k :=
  Form k (h \+ r) (right_tag (h \+ f k)) (right_pf h f k).

End Partition.

(**********************************************************)
(* Reflective lemmas that apply modulo AC-theory of heaps *)
(**********************************************************)

(* We maintain three different kinds of lemmas *)
(* in order to streamline the stepping *)
(* The only important ones are the val lemmas, the bnd and try *)
(* are there just to remove some spurious hypotheses about validity, and make the *)
(* verification flow easier *)

(* Each call to some bnd_* or try_* lemma is really a call to bnd_seq or try_seq *)
(* followed by a val_* lemma. Except that doing things in such a sequence *)
(* actually gives us some additional, spurious, validity hypotheses, which we *)
(* always discard anyway. However the discarding interrupts automation, so we want to avoid it *)

(* However, we only need gR lemma *)
(* This one is always applied by hand, not automatically, so *)
(* if we need to prefix it with a call to bnd_seq or try_seq, we can *)
(* do that by hand *)

(* If we were to do this by hand, whenever *)
(* there should be a nicer way to do this *)
(* e.g., suppress all the spurious validity as a default *)
(* and let the user generate them by hand at the leaves, when necessary *)

Section EvalRetR.
Variables (A B : Type).

Definition val_retR := vrf_ret.

Lemma try_retR e1 e2 (v : A) i (r : post B) :
        vrf i (e1 v) r -> vrf i (try (ret v) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_retR. Qed.

Lemma bnd_retR e (v : A) i (r : post B) :
        vrf i (e v) r -> vrf i (bind (ret v) e) r.
Proof. by move=>H; apply/vrf_bind/val_retR. Qed.

End EvalRetR.

Section EvalThrowR.
Variables (A B : Type).

Definition val_throwR := vrf_throw.

Lemma try_throwR e e1 e2 i (r : post B) :
        vrf i (e2 e) r ->
        vrf i (try (@throw A e) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_throwR. Qed.

Lemma bnd_throwR e e1 i (r : post B) :
        (valid i -> r (Exn e) i) ->
        vrf i (bind (@throw A e) e1) r.
Proof. by move=>H; apply/vrf_bind/val_throwR. Qed.

End EvalThrowR.

Section EvalReadR.
Variables (A B : Type).

Lemma val_readR v x i (f : form (x :-> v) i) (r : post A) :
        (valid (untag f) -> r (Val v) f) ->
        vrf f (read x) r.
Proof. by rewrite formE; apply: vrf_read. Qed.

Lemma try_readR e1 e2 v x i (f : form (x :-> v) i) (r : post B) :
        vrf f (e1 v) r ->
        vrf f (try (@read A x) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_readR. Qed.

Lemma bnd_readR e v x i (f : form (x :-> v) i) (r : post B) :
        vrf f (e v) r ->
        vrf f (bind (@read A x) e) r.
Proof. by move=>H; apply/vrf_bind/val_readR. Qed.

End EvalReadR.

Section EvalWriteR.
Variables (A B C : Type).

Lemma val_writeR (v : A) (w : B) x i (f : forall k, form k i) (r : post unit) :
        (valid (untag (f (x :-> v))) -> r (Val tt) (f (x :-> v))) ->
        vrf (f (x :-> w)) (write x v) r.
Proof. by rewrite !formE; apply: vrf_write. Qed.

Lemma try_writeR e1 e2 (v : A) (w : B) x i
                 (f : forall k, form k i) (r : post C) :
        vrf (f (x :-> v)) (e1 tt) r ->
        vrf (f (x :-> w)) (try (write x v) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_writeR. Qed.

Lemma bnd_writeR e (v : A) (w : B) x i (f : forall k, form k i) (r : post C) :
        vrf (f (x :-> v)) (e tt) r ->
        vrf (f (x :-> w)) (bind (write x v) e) r.
Proof. by move=>H; apply/vrf_bind/val_writeR. Qed.

End EvalWriteR.

Section EvalAllocR.
Variables (A B : Type).

Definition val_allocR := vrf_alloc.

Lemma try_allocR e1 e2 (v : A) i (r : post B) :
        (forall x, vrf (x :-> v \+ i) (e1 x) r) ->
        vrf i (try (alloc v) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_allocR. Qed.

Lemma bnd_allocR e (v : A) i (r : post B) :
        (forall x, vrf (x :-> v \+ i) (e x) r) ->
        vrf i (bind (alloc v) e) r.
Proof. by move=>H; apply/vrf_bind/val_allocR. Qed.

End EvalAllocR.

Section EvalAllocbR.
Variables (A B : Type).

Definition val_allocbR := vrf_allocb.

Lemma try_allocbR e1 e2 (v : A) n i (r : post B) :
        (forall x, vrf (updi x (nseq n v) \+ i) (e1 x) r) ->
        vrf i (try (allocb v n) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_allocbR. Qed.

Lemma bnd_allocbR e (v : A) n i (r : post B) :
        (forall x, vrf (updi x (nseq n v) \+ i) (e x) r) ->
        vrf i (bind (allocb v n) e) r.
Proof. by move=>H; apply/vrf_bind/val_allocbR. Qed.

End EvalAllocbR.

Section EvalDeallocR.
Variables (A B : Type).

Lemma val_deallocR (v : A) x i (f : forall k, form k i) (r : post unit) :
        (valid (untag (f Unit)) -> r (Val tt) (f Unit)) ->
        vrf (f (x :-> v)) (dealloc x) r.
Proof. by rewrite !formE unitL=>H; apply: vrf_dealloc. Qed.

Lemma try_deallocR e1 e2 (v : A) x i (f : forall k, form k i) (r : post B) :
        vrf (f Unit) (e1 tt) r ->
        vrf (f (x :-> v)) (try (dealloc x) e1 e2) r.
Proof. by move=>H; apply/vrf_try/val_deallocR. Qed.

Lemma bnd_deallocR e (v : A) x i (f : forall k, form k i) (r : post B) :
        vrf (f Unit) (e tt) r ->
        vrf (f (x :-> v)) (bind (dealloc x) e) r.
Proof. by move=>H; apply/vrf_bind/val_deallocR. Qed.

End EvalDeallocR.

(****************************************************)
(* Automating the selection of which lemma to apply *)
(* (reflective implementation of the hstep tactic)  *)
(****************************************************)

(* Need to case-split on bnd_, try_, or a val_ lemma. *)
(* Hence, three classes of canonical structures.      *)

Structure val_form A i r (p : Prop):=
  ValForm {val_pivot :> ST A;
           _ : p -> vrf i val_pivot r}.

Structure bnd_form A B i (e : A -> ST B) r (p : Prop) :=
  BndForm {bnd_pivot :> ST A;
           _ : p -> vrf i (bind bnd_pivot e) r}.

Structure try_form A B i (e1 : A -> ST B)
                         (e2 : exn -> ST B) r (p : Prop) :=
  TryForm {try_pivot :> ST A;
           _ : p -> vrf i (try try_pivot e1 e2) r}.

(* The main lemma which triggers the selection. *)

Lemma hstep A i (r : post A) p (e : val_form i r p) :
        p -> vrf i e r.
Proof. by case:e=>[?]; apply. Qed.

(* First check if matching on bnd_ or try_. If so, switch to searching *)
(* for bnd_ or try_form, respectively. Otherwise, fall through, and    *)
(* continue searching for a val_form. *)

Lemma bnd_case_pf A B i (s : A -> ST B) r p (e : bnd_form i s r p) :
        p -> vrf i (bind e s) r.
Proof. by case:e=>[?]; apply. Qed.

Canonical Structure
  bnd_case_form A B i (s : A -> ST B) r p (e : bnd_form i s r p) :=
  ValForm (bnd_case_pf e).

Lemma try_case_pf A B i (s1 : A -> ST B) (s2 : exn -> ST B) r p
                        (e : try_form i s1 s2 r p) :
        p -> vrf i (try e s1 s2) r.
Proof. by case:e=>[?]; apply. Qed.

(* After that, find the form in the following list.  Notice that the list *)
(* can be extended arbitrarily in the future. There is no centralized     *)
(* tactic to maintain. *)

Canonical Structure val_ret_form A v i r :=
  ValForm (@val_retR A v i r).
Canonical Structure bnd_ret_form A B s v i r :=
  BndForm (@bnd_retR A B s v i r).
Canonical Structure try_ret_form A B s1 s2 v i r :=
  TryForm (@try_retR A B s1 s2 v i r).

Canonical Structure val_read_form A v x r j f :=
  ValForm (@val_readR A v x j f r).
Canonical Structure bnd_read_form A B s v x r j f :=
  BndForm (@bnd_readR A B s v x j f r).
Canonical Structure try_read_form A B s1 s2 v x r j f :=
  TryForm (@try_readR A B s1 s2 v x j f r).

Canonical Structure val_write_form A B v w x r j f :=
  ValForm (@val_writeR A B v w x j f r).
Canonical Structure bnd_write_form A B C s v w x r j f :=
  BndForm (@bnd_writeR A B C s v w x j f r).
Canonical Structure try_write_form A B C s1 s2 v w x r j f :=
  TryForm (@try_writeR A B C s1 s2 v w x j f r).

Canonical Structure val_alloc_form A v i r :=
  ValForm (@val_allocR A v i r).
Canonical Structure bnd_alloc_form A B s v i r :=
  BndForm (@bnd_allocR A B s v i r).
Canonical Structure try_alloc_form A B s1 s2 v i r :=
  TryForm (@try_allocR A B s1 s2 v i r).

Canonical Structure val_allocb_form A v n i r :=
  ValForm (@val_allocbR A v n i r).
Canonical Structure bnd_allocb_form A B s v n i r :=
  BndForm (@bnd_allocbR A B s v n i r).
Canonical Structure try_allocb_form A B s1 s2 v n i r :=
  TryForm (@try_allocbR A B s1 s2 v n i r).

Canonical Structure val_dealloc_form A v x r j f :=
  ValForm (@val_deallocR A v x j f r).
Canonical Structure bnd_dealloc_form A B s v x r j f :=
  BndForm (@bnd_deallocR A B s v x j f r).
Canonical Structure try_dealloc_form A B s1 s2 v x r j f :=
  TryForm (@try_deallocR A B s1 s2 v x j f r).

Canonical Structure val_throw_form A e Q i :=
  ValForm (@val_throwR A e Q i).
Canonical Structure bnd_throw_form A B e e1 i r :=
  BndForm (@bnd_throwR A B e e1 i r).
Canonical Structure try_throw_form A B e e1 e2 i r :=
  TryForm (@try_throwR A B e e1 e2 i r).

Ltac step := (apply: hstep=>/=).

(*****************************************************************)
(* Another reflection mechanism for splitting the heap into head *)
(* and tail expressions. Note that this is a restricted version  *)
(* of the partitioning mechanism (no right branching).           *)
(*****************************************************************)

Section Uncons.

Structure tagged_heapU := TagU {untagU :> heap}.

Definition head_tagU := TagU.
Canonical Structure left_tagU i := head_tagU i.

(* - k : output head *)
(* - r : output tail *)
Definition uform_axiom k r (h : tagged_heapU) :=
  untagU h = k \+ r.

Structure uform (k : heap) r :=
  UForm {heap_ofU :> tagged_heapU;
         _ : uform_axiom k r heap_ofU}.

Arguments UForm : clear implicits.

Lemma head_pfU k : uform_axiom k Unit (head_tagU k).
Proof. by rewrite /uform_axiom unitR. Qed.

Canonical Structure heap_headU k := UForm k Unit (head_tagU k) (head_pfU k).

Lemma left_pfU h k r (f : uform k r) :
        uform_axiom k (r \+ h) (left_tagU (untagU f \+ h)).
Proof.
case: f=>f; rewrite /uform_axiom /= =>->.
by rewrite joinA.
Qed.

Canonical Structure search_leftU h k r (f : uform k r) :=
  UForm k (r \+ h) (left_tagU (untagU f \+ h)) (left_pfU h f).

End Uncons.

(***************************)
(* Ghost lemma automations *)
(***************************)

(* This is the main automated ghost lemma, which corresponds to a common     *)
(* combination of gE + vrf_frame. It allows the user to manually supply a    *)
(* heap subexpression (here named `m`) to be "consumed" by the frame rule.   *)
(* For proving the postconditions, the automation replaces the first summand *)
(* in the provided expression by a fresh heap variable and drops the rest.   *)
(*                                                                           *)
(* It uses the following algorithm:                                          *)
(*                                                                           *)
(* 1. The subexpression `m` is split into a head part `m0` and a tail part.  *)
(* 2. The tail part is syntactified into a list of terms `tm`.               *)
(* 3. The goal heap is split into a PCM expression corresponding to `tm` and *)
(*    a residual term, using the `pullX` PCM automation.                     *)
(* 4. The residual term is further split into `m0` and the framed-out heap   *)
(*    expression `r2` using the higher-order partitioning automation, which  *)
(*    simultaneously splits the postcondition heap into `n + r2` (where `n`  *)
(*    is fresh and replaces the first expression of `m`).                    *)
(*                                                                           *)
(* There are two caveats for using this lemma and its variants:              *)
(*                                                                           *)
(* 1. It rewrites the goal into a right-biased form (i.e. `x + (y + z)`).    *)
(*    This happens because it quotes the goal into a list of terms, losing   *)
(*    the associativity information. Switching to tree-based AST for quoted  *)
(*    terms could solve this, but will make the implementation more complex. *)
(* 2. It will fail if the supplied subexpression is a singleton `Unit`. This *)
(*    happens because the unconsing mechanism introduces spurious Units into *)
(*    expressions which are later "garbage collected" by quoting & printing, *)
(*    dropping user-provided Units as well.                                  *)
(*                                                                           *)
(* These issues can be circumvented by falling back to simpler (automated)   *)
(* lemmas `gU`, `gR` and their variants.                                     *)

Lemma gX G A (s : spec G A) g (m : heapPCM) m0 j tm k wh r2
             (e : STspec G s)
             (fm : Syntactify.form (empx _) j tm)
             (fu : uform m0 (Syntactify.untag fm))
             (f : forall q, form q r2)
             (fg : PullX.rform j k tm wh (Some (untag (heap_of (f m0)))))
             (Q : post A) :
        untagU fu = m ->
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n ->
           valid (untag (f n)) -> Q (Val v) (f n)) ->
        (forall x n, (s g).2 (Exn x) n ->
           valid (untag (f n)) -> Q (Exn x) (f n)) ->
        vrf (fg : heapPCM) e Q.
Proof.
case: e=>e /= H; case: fu=>_ ->/= Em Hp Hv Hx; rewrite -{}Em in Hp.
rewrite (pullX (Syntactify.untag fm)) formE joinCA joinA.
apply: vrfV=>/validL/Hp/H V.
apply/vrf_frame/vrf_post/V.
by case=>[v|x] n _=>[/Hv|/Hx]; rewrite formE.
Qed.

Arguments gX [G A s] g m {m0 j tm k wh r2 e fm fu f fg Q} _ _ _ _.

Notation "[gX] @ m" := (gX tt m erefl) (at level 0).

Notation "[ 'gX' x1 , .. , xn ] @ m" :=
  (gX (existT _ x1 .. (existT _ xn tt) ..) m erefl)
  (at level 0, format "[ 'gX'  x1 ,  .. ,  xn ] @  m").

(* a combination of gX + vrf_bind *)
Lemma stepX G A B (s : spec G A) g (m : heapPCM) m0 j tm k wh r2
             (e : STspec G s) (e2 : A -> ST B)
             (fm : Syntactify.form (empx _) j tm)
             (fu : uform m0 (Syntactify.untag fm))
             (f : forall q, form q r2)
             (fg : PullX.rform j k tm wh (Some (untag (heap_of (f m0)))))
             (Q : post B) :
        untagU fu = m ->
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n -> vrf (f n) (e2 v) Q) ->
        (forall x n, (s g).2 (Exn x) n ->
           valid (untag (f n)) -> Q (Exn x) (f n)) ->
        vrf (fg : heapPCM) (bind e e2) Q.
Proof.
move=>Hm Hp Hv Hx.
by apply/vrf_bind/(gX _ _ Hm Hp)=>[v n H V|x n H V _]; [apply: Hv| apply: Hx].
Qed.

Arguments stepX [G A B s] g m {m0 j tm k wh r2 e e2 fm fu f fg Q} _ _ _ _.

Notation "[stepX] @ m" := (stepX tt m erefl) (at level 0).

Notation "[ 'stepX' x1 , .. , xn ] @ m" :=
  (stepX (existT _ x1 .. (existT _ xn tt) ..) m erefl)
  (at level 0, format "[ 'stepX'  x1 ,  .. ,  xn ] @  m").

(* a combination of gX + vrf_try *)
Lemma tryX G A B (s : spec G A) g (m : heapPCM) m0 j tm k wh r2
             (e : STspec G s) (e1 : A -> ST B) (e2 : exn -> ST B)
             (fm : Syntactify.form (empx _) j tm)
             (fu : uform m0 (Syntactify.untag fm))
             (f : forall q, form q r2)
             (fg : PullX.rform j k tm wh (Some (untag (heap_of (f m0)))))
             (Q : post B) :
        untagU fu = m ->
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n -> vrf (f n) (e1 v) Q) ->
        (forall x n, (s g).2 (Exn x) n -> vrf (f n) (e2 x) Q) ->
        vrf (fg : heapPCM) (try e e1 e2) Q.
Proof.
move=>Hm Hp Hv Hx.
by apply/vrf_try/(gX _ _ Hm Hp)=>[x|ex] n H V; [apply: Hv|apply: Hx].
Qed.

Arguments tryX [G A B s] g m {m0 j tm k wh r2 e e1 e2 fm fu f fg Q} _ _ _ _.

Notation "[tryX] @ m" := (stepX tt m erefl) (at level 0).

Notation "[ 'tryX' x1 , .. , xn ] @ m" :=
  (tryX (existT _ x1 .. (existT _ xn tt) ..) m erefl)
  (at level 0, format "[ 'tryX'  x1 ,  .. ,  xn ] @  m").

(**************************************)
(* Simplified ghost lemma automations *)
(**************************************)

(* A simpler version of an automated framing+ghost lemma which only works on *)
(* literal heap subexpressions (here `m`) but preserves associativity.       *)
Lemma gR G A (s : spec G A) g m r (e : STspec G s)
          (f : forall k, form k r) (Q : post A) :
        (valid m -> (s g).1 m) ->
        (forall v n, (s g).2 (Val v) n ->
           valid (untag (f n)) -> Q (Val v) (f n)) ->
        (forall x n, (s g).2 (Exn x) n ->
           valid (untag (f n)) -> Q (Exn x) (f n)) ->
        vrf (f m) e Q.
Proof.
case: e=>e /= H Hp Hv Hx; rewrite formE.
apply: vrfV=>/validL/Hp/H V.
apply/vrf_frame/vrf_post/V.
by case=>[x|ex] n _ =>[/Hv|/Hx]; rewrite formE.
Qed.

Arguments gR [G A s] g m {r e f Q} _ _ _.

Notation "[gR] @ m" := (gR tt m) (at level 0).

Notation "[ 'gR' x1 , .. , xn ] @ m" :=
  (gR (existT _ x1 .. (existT _ xn tt) ..) m)
  (at level 0, format "[ 'gR'  x1 ,  .. ,  xn ] @  m").

(* a combination of gR + vrf_bind *)
Lemma stepR G A B (s : spec G A) g i j (e : STspec G s) (e2 : A -> ST B)
             (f : forall k, form k j) (Q : post B) :
        (valid i -> (s g).1 i) ->
        (forall x m, (s g).2 (Val x) m -> vrf (f m) (e2 x) Q) ->
        (forall x m, (s g).2 (Exn x) m ->
           valid (untag (f m)) -> Q (Exn x) (f m)) ->
        vrf (f i) (bind e e2) Q.
Proof.
move=>Hi H1 H2.
apply/vrf_bind/(gR _ _ Hi)=>[x m H V|ex m H V _].
- by apply: H1 H.
by apply: H2.
Qed.

Arguments stepR [G A B s] g i [j e e2 f Q] _ _ _.

Notation "[stepR] @ i" := (stepR tt i) (at level 0).

Notation "[ 'stepR' x1 , .. , xn ] @ i" :=
  (stepR (existT _ x1 .. (existT _ xn tt) ..) i)
  (at level 0, format "[ 'stepR'  x1 ,  .. ,  xn ] @  i").

(* a combination of gR + vrf_try *)
Lemma tryR G A B (s : spec G A) g i j (e : STspec G s) (e1 : A -> ST B) (e2 : exn -> ST B)
             (f : forall k, form k j) (Q : post B) :
        (valid i -> (s g).1 i) ->
        (forall x m, (s g).2 (Val x) m -> vrf (f m) (e1 x) Q) ->
        (forall x m, (s g).2 (Exn x) m -> vrf (f m) (e2 x) Q) ->
        vrf (f i) (try e e1 e2) Q.
Proof.
move=>Hi H1 H2.
apply/vrf_try/(gR _ _ Hi)=>[x|ex] m H V.
- by apply: H1 H.
by apply: H2.
Qed.

Arguments tryR [G A B s] g i [j e e1 e2 f Q] _ _ _.

Notation "[tryR] @ i" := (tryR tt i) (at level 0).

Notation "[ 'tryR' x1 , .. , xn ] @ i" :=
  (tryR (existT _ x1 .. (existT _ xn tt) ..) i)
  (at level 0, format "[ 'tryR'  x1 ,  .. ,  xn ] @  i").

(* This is really brittle, but I didn't get around yet to substitute it *)
(* with Mtac or overloaded lemmas. So for now, let's stick with the hack *)
(* in order to support the legacy proofs *)

(* First cancelation in hypotheses *)

Section Cancellation.
Implicit Type (h : heap).

Lemma cexit1 h1 h2 h : h1 = h2 -> h1 \+ h = h \+ h2.
Proof. by move=>->; rewrite joinC. Qed.

Lemma cexit2 h1 h : h1 = Unit -> h1 \+ h = h.
Proof. by move=>->; rewrite unitL. Qed.

Lemma cexit3 h1 h : Unit = h1 -> h = h \+ h1.
Proof. by move=><-; rewrite unitR. Qed.

Lemma congUh A h1 h2 x (v1 v2 : A) :
        h1 = h2 -> v1 = v2 -> h1 \+ (x :-> v1) = h2 \+ (x :-> v2).
Proof. by move=>-> ->. Qed.

Lemma congeqUh h1 h2 h : h1 = h2 -> h1 \+ h = h2 \+ h.
Proof. by move=>->. Qed.

End Cancellation.

(* Cancellation in conclusions *)

Ltac congruencer t :=
  match goal with
  | |- ?h1 \+ t = ?h2 =>
     let j := fresh "j" in
     set j := {1}(h1 \+ t);
     rewrite -1?joinA /j {j};
     (apply: cexit1 || apply: cexit2)
  | |- t = ?h2 =>
     rewrite -1?joinA;
     (apply: cexit3 || apply: refl_equal)
  | |- (?h1 \+ (?x :-> ?v) = ?h2) =>
    let j := fresh "j" in
    set j := {1}(h1 \+ (x :-> v));
    (* if x appears in the second union, first bring it to the back *)
    rewrite 1?(joinC (x :-> _)) -?(joinAC _ _ (x :-> _)) /j {j};
    (* then one of the following must apply *)
    (* if x is in the second union then cancel *)
    ((apply: congUh; [congruencer t | idtac]) ||
    (* if not, rotate x in the first union *)
     (rewrite (joinC h1) ?joinA; congruencer t))
  (* if the heap is not a points-to relation, also try to cancel *)
  | |- (?h1 \+ ?h = ?h2) =>
    let j := fresh "j" in
    set j := {1}(h1 \+ h);
    (* if h appears in the second union, first bring it to the back *)
    rewrite 1?(joinC h) -?(joinAC _ _ h) /j {j};
    (* then one of the following must apply *)
    (* if h is in the second union then cancel *)
    (apply: congeqUh ||
    (* if not, rotate h in the first union *)
    rewrite (joinC h1) ?joinA);
    (* and proceed *)
    congruencer t
  | |- _ => idtac
  end.

Ltac heap_congr :=
  match goal with
  | |- ?h1 = ?h2 =>
    let t1 := fresh "t1" in
    let t2 := fresh "t2" in
    let t := fresh "t" in
      set t1 := {1}h1; set t2 := {1}h2;
      (* introduce terminators *)
      rewrite -(unitL t1) -(unitL t2) [Unit]lock;
      set t := locked Unit; rewrite /t1 /t2 {t1 t2};
      (* flatten the goal *)
      rewrite ?joinA;
      (* call the congruence routine and remove the terminator *)
      congruencer t=>{t}
  | |- _ => idtac
  end.

(* we keep some tactics to kill final goals, which *)
(* are usually full of existentials *)
Ltac vauto := (do ?econstructor=>//).
Ltac hhauto := (vauto; try by [heap_congr])=>//.
Ltac heval := do ![step | by hhauto].


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_sha_sel_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  forall T2 x2 L2 ss2 T', T2 = (t_sha_sel x2 L2 ss2 T') ->
                                     subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.global.workload.
Require Import prosa.classic.model.schedule.global.basic.schedule.
Require Import prosa.classic.model.schedule.apa.affinity.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Interference.

  Import Schedule ScheduleOfSporadicTask Priority Workload Affinity.

  (* In this section, we define the notion of a possible interfering task. *)
  Section PossibleInterferingTasks.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    (* Consider an APA platform with affinity alpha. *)
    Context {num_cpus: nat}.
    Variable alpha: task_affinity sporadic_task num_cpus.

    Section FP.

      (* Assume an FP policy. *)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* Let tsk be the task to be analyzed ... *)
      Variable tsk: sporadic_task.

      (* ...assuming a subaffinity alpha'. *)
      Variable alpha': affinity num_cpus.

      (* Let tsk_other be another task. *)
      Variable tsk_other: sporadic_task.

      (* Under FP scheduling with constrained deadlines, tsk_other can only interfere
         with tsk if it is a different task with higher or equal priority and
         intersecting affinity. *)
      Definition higher_priority_task_in :=
        higher_eq_priority tsk_other tsk &&
        (tsk_other != tsk) &&
        affinity_intersects alpha' (alpha tsk_other).

    End FP.

    Section JLFP.

      (* Let tsk be the task to be analyzed ... *)
      Variable tsk: sporadic_task.

      (* ...assuming a subaffinity alpha'. *)
      Variable alpha': affinity num_cpus.

      (* Let tsk_other be another task. *)
      Variable tsk_other: sporadic_task.

      (* Under JLFP/JLDP scheduling with constrained deadlines, tsk_other can only interfere
         with tsk if it is a different task with intersecting affinity. *)
      Definition different_task_in :=
        (tsk_other != tsk) &&
        affinity_intersects alpha' (alpha tsk_other).

    End JLFP.

  End PossibleInterferingTasks.

  Section InterferenceDefs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence...*)
    Context {arr_seq: arrival_sequence Job}.

    (* ... and any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* Assume that every job at any time has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* Consider any job j that incurs interference. *)
    Variable j: Job.

    (* Recall the definition of backlogged (pending and not scheduled). *)
    Let job_is_backlogged (t: time) := backlogged job_arrival job_cost sched j t.

    (* First, we define total interference. *)
    Section TotalInterference.

      (* The total interference incurred by job j during [t1, t2) is the
         cumulative time in which j is backlogged in this interval. *)
      Definition total_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2) job_is_backlogged t.

    End TotalInterference.

    (* Next, we define job interference. *)
    Section JobInterference.

      (* Let job_other be a job that interferes with j. *)
      Variable job_other: Job.

      (* The interference caused by job_other during [t1, t2) is the cumulative
         time in which j is backlogged while job_other is scheduled. *)
      Definition job_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            can_execute_on alpha (job_task j) cpu &&
            scheduled_on sched job_other cpu t).

    End JobInterference.

    (* Next, we define task interference. *)
    Section TaskInterference.

      (* Consider any interfering task tsk_other. *)
      Variable tsk_other: sporadic_task.

      (* The interference caused by tsk during [t1, t2) is the cumulative time
         in which j is backlogged while tsk is scheduled. *)
      Definition task_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            can_execute_on alpha (job_task j) cpu &&
            task_scheduled_on job_task sched tsk_other cpu t).

    End TaskInterference.

    (* Next, we define an approximation of the total interference based on
       each per-task interference. *)
    Section TaskInterferenceJobList.

      Variable tsk_other: sporadic_task.

      Definition task_interference_joblist (t1 t2: time) :=
        \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_other)
         job_interference j t1 t2.

    End TaskInterferenceJobList.

    (* Now we prove some basic lemmas about interference. *)
    Section BasicLemmas.

      (* Total interference cannot be larger than the considered time window. *)
      Lemma total_interference_le_delta :
        forall t1 t2,
          total_interference t1 t2 <= t2 - t1.
      Proof.
        unfold total_interference; intros t1 t2.
        apply leq_trans with (n := \sum_(t1 <= t < t2) 1);
          first by apply leq_sum; ins; apply leq_b1.
        by rewrite big_const_nat iter_addn mul1n addn0 leqnn.
      Qed.

      (* Job interference is bounded by the service of the interfering job. *)
      Lemma job_interference_le_service :
        forall j_other t1 t2,
          job_interference j_other t1 t2 <= service_during sched j_other t1 t2.
      Proof.
        intros j_other t1 t2; unfold job_interference, service_during.
        apply leq_sum; intros t _.
        unfold service_at; rewrite [\sum_(_ < _ | scheduled_on _ _ _  _)_]big_mkcond.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        destruct (can_execute_on alpha (job_task j) cpu); [rewrite andTb | by rewrite andFb].
        by destruct (scheduled_on sched j_other cpu t).
      Qed.

      (* Task interference is bounded by the workload of the interfering task. *)
      Lemma task_interference_le_workload :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= workload job_task sched tsk t1 t2.
      Proof.
        unfold task_interference, workload; intros tsk t1 t2.
        apply leq_sum; intros t _.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        destruct (can_execute_on alpha (job_task j) cpu); [rewrite andTb | by rewrite andFb].
        unfold task_scheduled_on, service_of_task.
        by destruct (sched cpu t).
      Qed.

    End BasicLemmas.

    (* Now we prove some bounds on interference for sequential jobs. *)
    Section InterferenceNoParallelism.

      (* If jobs are sequential, ... *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* ... then the interference incurred by a job in an interval
         of length delta is at most delta. *)
      Lemma job_interference_le_delta :
        forall j_other t1 delta,
          job_interference j_other t1 (t1 + delta) <= delta.
      Proof.
        rename H_sequential_jobs into SEQ.
        unfold job_interference, sequential_jobs in *.
        intros j_other t1 delta.
        apply leq_trans with (n := \sum_(t1 <= t < t1 + delta) 1);
          last by rewrite big_const_nat iter_addn mul1n addn0 addKn leqnn.
        apply leq_sum; intros t _.
        destruct ([exists cpu, scheduled_on sched j_other cpu t]) eqn:EX.
        {
          move: EX => /existsP [cpu SCHED].
          rewrite (bigD1 cpu) // /=.
          rewrite big_mkcond (eq_bigr (fun x => 0)) /=;
            first by simpl_sum_const; rewrite leq_b1.
          intros cpu' _; des_if_goal; last by done.
          destruct (scheduled_on sched j_other cpu' t) eqn:SCHED'; last by rewrite andbF.
          move: SCHED SCHED' => /eqP SCHED /eqP SCHED'.
          by specialize (SEQ j_other t cpu cpu' SCHED SCHED'); rewrite SEQ in Heq.
        }
        {
          apply negbT in EX; rewrite negb_exists in EX.
          move: EX => /forallP EX.
          rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const.
          by intros cpu _; specialize (EX cpu); apply negbTE in EX; rewrite EX andbF.
        }
      Qed.

    End InterferenceNoParallelism.

    (* Next, we show that the cumulative per-task interference bounds the total
       interference. *)
    Section BoundUsingPerTaskInterference.

      Lemma interference_le_interference_joblist :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= task_interference_joblist tsk t1 t2.
      Proof.
        intros tsk t1 t2.
        unfold task_interference, task_interference_joblist, job_interference, job_is_backlogged.
        rewrite [\sum_(_ <- _ sched _ _ | _) _]exchange_big /=.
        rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
        apply leq_sum; move => t /andP [LEt _].
        rewrite exchange_big /=.
        apply leq_sum; intros cpu _.
        destruct (backlogged job_arrival job_cost sched j t) eqn:BACK;
          last by rewrite andFb (eq_bigr (fun x => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
        rewrite andTb.
        destruct (task_scheduled_on job_task sched tsk cpu t) eqn:SCHED;
          [rewrite andbT | by rewrite andbF].
        unfold scheduled_on, task_scheduled_on in *.
        destruct (sched cpu t) as [j' |] eqn:SOME; last by done.
        rewrite big_mkcond /= (bigD1_seq j') /=; last by apply undup_uniq.
        {
          by rewrite SCHED eq_refl andbT leq_addr.
        }
        {
          unfold jobs_scheduled_between.
          rewrite mem_undup; apply mem_bigcat_nat with (j := t);
            first by done.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by unfold make_sequence; rewrite SOME mem_seq1 eq_refl.
        }
      Qed.

    End BoundUsingPerTaskInterference.

  End InterferenceDefs.

End Interference.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.orders.orders
               HoTT.Classes.interfaces.integers
               HoTT.Classes.interfaces.naturals
               HoTT.Classes.implementations.natpair_integers
               HoTT.Classes.theory.integers
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe UnivalenceImpliesFunext
               TruncType UnivalenceAxiom HIT.quotient
               Basics.FunextVarieties FunextAxiom
               Types.Prod HIT.Truncations HIT.unique_choice.

Require Import HoTTClasses.sierpinsky partiality dedekind.

(** * Dominance *)

(** Definition of dominance *)
Definition dominance (Σ : Type0) (is_top : Σ -> Type) :=
           forall (u:hProp) (s:Σ),
             (is_top s -> hexists (fun z:Σ => is_top z = u)) ->
             hexists (fun m:Σ => merely (is_top m)
                               = merely (u /\ (is_top s))).

Print LoadPath.

(** Sier is a dominance*)
Lemma dominance_sier : dominance Sier IsTop.
Proof.
intros p u.
revert u.
apply (partial_ind0 _ (fun a => _ -> _)).
+ intros t Ht; destruct t.
  assert (Htrue : IsTop (eta Unit tt)).
  red; apply top_greatest.
  specialize (Ht Htrue).
  unfold hexists in *;
  revert Ht; apply (Trunc_ind _).
  intros (z,Hz). apply tr.
  exists (meet (eta Unit tt) z).
  unfold meet; rewrite Hz.
  apply path_trunctype.
  apply equiv_iff_hprop.
  apply (Trunc_ind _); intros H; apply tr.
  split; trivial.
  apply (Trunc_ind _); intros (H,_);
  apply tr; trivial.
+ intros Hf; apply tr.
  exists (bot Unit).
  apply path_trunctype.
  apply equiv_iff_hprop.
  apply (Trunc_ind _); intros H;
  apply not_bot in H; case H.
  apply (Trunc_ind _); intros (_,H);
  apply tr; trivial.
+ intros f Hn Hf.
  assert (Hnn : forall n,
       hexists (fun m : Sier => merely m =
                  merely (p /\ IsTop (f n)))).
  intros n.
  specialize (Hn n).
  assert (H : IsTop (f n) ->
              hexists (fun z: Sier => IsTop z = p)).
  intros Hn'.
  assert (Ht : IsTop (sup Unit f)).
  apply top_le_sup; apply tr;
  exists n; trivial.
  specialize (Hf Ht); trivial.
  apply (Hn H).
  generalize (unique_choice (fun n =>
        (fun m:Sier => merely m = merely (p /\ IsTop (f n))))).
  intros Huc.
  assert (Hp : (forall (x : nat) (y : Sier),
     IsHProp (merely y = merely (p /\ IsTop (f x))))).
  apply _.
  specialize (Huc Hp).
  assert (Hu : (forall x : nat, hunique (fun m : Sier => merely m =
                        merely (p /\ IsTop (f x))))).
  intros n; split; try trivial.
  intros s1 s2 Hs1 Hs2.
  apply (antisymmetry le).
  - apply imply_le; intros H1.
    assert (He1 : merely s1 <-> s1).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    assert (He2 : merely s2 <-> s2).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    apply He2; apply He1 in H1.
    rewrite Hs2.
    rewrite Hs1 in H1; trivial.
  - apply imply_le; intros H2.
    assert (He1 : merely s1 <-> s1).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    assert (He2 : merely s2 <-> s2).
    split. apply (Trunc_ind _); trivial.
    intros I; apply tr; trivial.
    apply He1; apply He2 in H2.
    rewrite Hs1.
    rewrite Hs2 in H2; trivial.
  - specialize (Huc Hu).
    destruct Huc as (ff,Hff).
    assert (NatEnum : Enumerable nat).
    exists (fun n => n); apply _.
    pose (supf := EnumerableSup nat (fun n => ff n)).
    apply tr; exists supf.
    apply path_trunctype.
    apply equiv_iff_hprop.
    assert (Hff_eq : forall n : nat, merely (ff n) <->
                              merely (p /\ IsTop (f n))).
    intros n; rewrite Hff.
    split; trivial.
    apply (Trunc_ind _); intros HK.
    apply top_le_enumerable_sup in HK.
    revert HK; apply (Trunc_ind _); intros (x,Hx).
    assert (Hx2 : merely (ff x)).
    apply tr; trivial.
    apply Hff_eq in Hx2.
    revert Hx2; apply (Trunc_ind _);
    intros (H,H'); apply tr.
    split; trivial.
    apply top_le_sup; apply tr;
    exists x; trivial.
    assert (Hff_eq : forall n : nat, merely (ff n) <->
                              merely (p /\ IsTop (f n))).
    intros n; rewrite Hff.
    split; trivial. clear Hp Hu.
    apply (Trunc_ind _); intros (Hp,HK).
    apply top_le_sup in HK.
    revert HK; apply (Trunc_ind _); intros (x,Hx).
    assert (HU : merely (p /\ IsTop (f x))).
    apply tr; split; trivial.
    apply Hff_eq in HU.
    revert HU; apply (Trunc_ind _); intros HU.
    apply tr; apply top_le_enumerable_sup.
    apply tr; exists x; trivial.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(****************************************************************************

 Equifiers in bicategories

 Contents
 1. Cones
 2. The universal mapping property
 3. Alternative formulation of equifier via universal cones
 4. Bicategories with equifiers
 5. Equifiers are fully faithful

 ****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.

Local Open Scope cat.

Section Equifiers.
  Context {B : bicat}
          {b₁ b₂ : B}
          {f g : b₁ --> b₂}
          {α β : f ==> g}.

  (**
   1. Cones
   *)
  Definition equifier_cone
    : UU
    := ∑ (i : B)
         (m : i --> b₁),
       m ◃ α = m ◃ β.

  Definition make_equifier_cone
             (i : B)
             (m : i --> b₁)
             (α : m ◃ α = m ◃ β)
    : equifier_cone
    := i ,, m ,, α.

  Coercion equifier_cone_ob
           (cone : equifier_cone)
    : B
    := pr1 cone.

  Definition equifier_cone_pr1
             (cone : equifier_cone)
    : cone --> b₁
    := pr12 cone.

  Definition equifier_cone_eq
             (cone : equifier_cone)
    : equifier_cone_pr1 cone ◃ α = equifier_cone_pr1 cone ◃ β
    := pr22 cone.

  Definition equifier_1cell
             (cone₁ cone₂ : equifier_cone)
    : UU
    := ∑ (k : cone₁ --> cone₂),
       invertible_2cell
         (k · equifier_cone_pr1 cone₂)
         (equifier_cone_pr1 cone₁).

  Definition make_equifier_1cell
             {cone₁ cone₂ : equifier_cone}
             (k : cone₁ --> cone₂)
             (α : invertible_2cell
                    (k · equifier_cone_pr1 cone₂)
                    (equifier_cone_pr1 cone₁))
    : equifier_1cell cone₁ cone₂
    := k ,, α.

  Coercion equifier_1cell_mor
           {cone₁ cone₂ : equifier_cone}
           (u : equifier_1cell cone₁ cone₂)
    : cone₁ --> cone₂
    := pr1 u.

  Definition equifier_1cell_pr1
             {cone₁ cone₂ : equifier_cone}
             (u : equifier_1cell cone₁ cone₂)
    : invertible_2cell
        (u · equifier_cone_pr1 cone₂)
        (equifier_cone_pr1 cone₁)
    := pr2 u.

  Definition path_equifier_1cell
             {cone₁ cone₂ : equifier_cone}
             (φ ψ : equifier_1cell cone₁ cone₂)
             (p₁ : pr1 φ = pr1 ψ)
             (p₂ : pr12 φ = (idtoiso_2_1 _ _ p₁ ▹ _) • pr12 ψ)
    : φ = ψ.
  Proof.
    induction φ as [ φ₁ [ φ₂ φ₃ ]].
    induction ψ as [ ψ₁ [ ψ₂ ψ₃ ]].
    cbn in *.
    induction p₁.
    apply maponpaths.
    use subtypePath.
    {
      intro.
      apply isaprop_is_invertible_2cell.
    }
    cbn in p₂.
    rewrite id2_rwhisker, id2_left in p₂.
    exact p₂.
  Qed.

  (**
   2. The universal mapping property
   *)
  Section UniversalMappingProperty.
    Context (cone : equifier_cone).

    Definition has_equifier_ump_1
      : UU
      := ∏ (other_cone : equifier_cone),
         equifier_1cell other_cone cone.

    Definition has_equifier_ump_2
      : UU
      := ∏ (x : B)
           (u₁ u₂ : x --> cone)
           (α : u₁ · equifier_cone_pr1 cone
                ==>
                u₂ · equifier_cone_pr1 cone),
         ∑ (ζ : u₁ ==> u₂),
         ζ ▹ equifier_cone_pr1 cone = α.

    Definition has_equifier_ump_eq
      : UU
      := ∏ (x : B)
           (u₁ u₂ : x --> cone)
           (α : u₁ · equifier_cone_pr1 cone
                ==>
                u₂ · equifier_cone_pr1 cone)
           (φ₁ φ₂ : u₁ ==> u₂)
           (q₁ : φ₁ ▹ equifier_cone_pr1 cone = α)
           (q₂ : φ₂ ▹ equifier_cone_pr1 cone = α),
         φ₁ = φ₂.

    Definition has_equifier_ump
      : UU
      := has_equifier_ump_1 × has_equifier_ump_2 × has_equifier_ump_eq.
  End UniversalMappingProperty.

  Section Projections.
    Context {cone : equifier_cone}
            (H : has_equifier_ump cone).

    Definition equifier_ump_mor
               {i : B}
               (m : i --> b₁)
               (p : m ◃ α = m ◃ β)
      : i --> cone
      := pr1 H (make_equifier_cone i m p).

    Definition equifier_ump_mor_pr1
               {i : B}
               (m : i --> b₁)
               (p : m ◃ α = m ◃ β)
      : invertible_2cell
          (equifier_ump_mor m p · equifier_cone_pr1 cone)
          m
      := equifier_1cell_pr1 (pr1 H (make_equifier_cone i m p)).

    Definition equifier_ump_cell
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
      : u₁ ==> u₂
      := pr1 (pr12 H x u₁ u₂ ζ).

    Definition equifier_ump_cell_pr1
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
      : equifier_ump_cell ζ ▹ equifier_cone_pr1 cone = ζ
      := pr2 (pr12 H x u₁ u₂ ζ).

    Definition equifier_ump_eq
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
               (φ₁ φ₂ : u₁ ==> u₂)
               (q₁ : φ₁ ▹ equifier_cone_pr1 cone = ζ)
               (q₂ : φ₂ ▹ equifier_cone_pr1 cone = ζ)
      : φ₁ = φ₂
      := pr22 H x u₁ u₂ ζ φ₁ φ₂ q₁ q₂.

    Definition equifier_ump_eq_alt
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
               (φ₁ φ₂ : u₁ ==> u₂)
               (q : φ₁ ▹ equifier_cone_pr1 cone
                    =
                    φ₂ ▹ equifier_cone_pr1 cone)
      : φ₁ = φ₂.
    Proof.
      use equifier_ump_eq.
      - exact (φ₁ ▹ equifier_cone_pr1 cone).
      - apply idpath.
      - exact (!q).
    Qed.

    Definition is_invertible_equifier_ump_cell
               {x : B}
               {u₁ u₂ : x --> cone}
               (ζ : u₁ · equifier_cone_pr1 cone
                    ==>
                    u₂ · equifier_cone_pr1 cone)
               (Hζ : is_invertible_2cell ζ)
      : is_invertible_2cell (equifier_ump_cell ζ).
    Proof.
      use make_is_invertible_2cell.
      - exact (equifier_ump_cell (Hζ^-1)).
      - abstract
          (use (equifier_ump_eq_alt (id2 _)) ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !equifier_ump_cell_pr1 ;
           rewrite vcomp_rinv ;
           rewrite id2_rwhisker ;
           apply idpath).
      - abstract
          (use (equifier_ump_eq_alt (id2 _)) ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !equifier_ump_cell_pr1 ;
           rewrite vcomp_linv ;
           rewrite id2_rwhisker ;
           apply idpath).
    Defined.
  End Projections.

  (**
   3. Alternative formulation of equifier via universal cones
   *)
  Definition universal_equifier_cat
             (x : B)
    : category.
  Proof.
    refine (full_sub_category
              (hom x b₁)
              (λ h,
               make_hProp
                 (h ◃ α = h ◃ β)
                 _)).
    apply cellset_property.
  Defined.

  Definition univalent_universal_equifier_cat
             (HB_2_1 : is_univalent_2_1 B)
             (x : B)
    : univalent_category.
  Proof.
    use make_univalent_category.
    - exact (universal_equifier_cat x).
    - use is_univalent_full_subcat.
      use is_univ_hom.
      exact HB_2_1.
  Defined.

  Definition to_universal_equifier_cat_data
             (cone : equifier_cone)
             (x : B)
    : functor_data
        (hom x cone)
        (universal_equifier_cat x).
  Proof.
    use make_functor_data.
    - refine (λ h, h · equifier_cone_pr1 cone ,, _) ; cbn.
      abstract
        (use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ] ;
         rewrite <- !lwhisker_lwhisker ;
         apply maponpaths_2 ;
         apply maponpaths ;
         exact (equifier_cone_eq cone)).
    - exact (λ h₁ h₂ ζ, ζ ▹ _ ,, tt).
  Defined.

  Definition to_universal_equifier_cat_is_functor
             (cone : equifier_cone)
             (x : B)
    : is_functor (to_universal_equifier_cat_data cone x).
  Proof.
    split.
    - intro h ; cbn.
      use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      cbn.
      apply id2_rwhisker.
    - intros h₁ h₂ h₃ ζ₁ ζ₂ ; cbn.
      use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      cbn.
      refine (!_).
      apply rwhisker_vcomp.
  Qed.

  Definition to_universal_equifier_cat
             (cone : equifier_cone)
             (x : B)
    : hom x cone ⟶ universal_equifier_cat x.
  Proof.
    use make_functor.
    - exact (to_universal_equifier_cat_data cone x).
    - exact (to_universal_equifier_cat_is_functor cone x).
  Defined.

  Definition is_univeral_equifier_cone
             (cone : equifier_cone)
    : UU
    := ∏ (x : B),
       adj_equivalence_of_cats
         (to_universal_equifier_cat cone x).

  Section MakeUniversalEquifierCone.
    Context (cone : equifier_cone)
            (H : has_equifier_ump cone)
            (x : B).

    Definition make_is_universal_equifier_cone_full
      : full (to_universal_equifier_cat cone x).
    Proof.
      intros u₁ u₂ ζ.
      apply hinhpr.
      simple refine (_ ,, _).
      - use (equifier_ump_cell H).
        exact (pr1 ζ).
      - abstract
          (use subtypePath ; [ intro  ; apply isapropunit | ] ;
           apply (equifier_ump_cell_pr1 H)).
    Defined.

    Definition make_is_universal_equifier_cone_faithful
      : faithful (to_universal_equifier_cat cone x).
    Proof.
      intros u₁ u₂ ζ₁.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        apply homset_property.
      }
      use (equifier_ump_eq_alt H).
      - exact (pr1 ζ₁).
      - exact (maponpaths pr1 (pr2 φ₁ @ !(pr2 φ₂))).
    Qed.

    Definition make_is_universal_equifier_cone_essentially_surjective
      : essentially_surjective (to_universal_equifier_cat cone x).
    Proof.
      intros h.
      apply hinhpr.
      simple refine (_ ,, _).
      - use (equifier_ump_mor H).
        + exact (pr1 h).
        + exact (pr2 h).
      - cbn.
        use iso_in_sub_from_iso ; cbn.
        use inv2cell_to_z_iso.
        apply equifier_ump_mor_pr1.
    Defined.
  End MakeUniversalEquifierCone.

  Definition make_is_universal_equifier_cone
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
             (H : has_equifier_ump cone)
    : is_univeral_equifier_cone cone.
  Proof.
    intro x.
    use rad_equivalence_of_cats.
    - apply is_univ_hom.
      exact HB_2_1.
    - use full_and_faithful_implies_fully_faithful.
      split.
      + apply make_is_universal_equifier_cone_full.
        exact H.
      + apply make_is_universal_equifier_cone_faithful.
        exact H.
    - apply make_is_universal_equifier_cone_essentially_surjective.
      exact H.
  Defined.

  Section UniversalConeHasUMP.
    Context (cone : equifier_cone)
            (H : is_univeral_equifier_cone cone).

    Section UMP1.
      Context (q : equifier_cone).

      Let q' : universal_equifier_cat q
        := equifier_cone_pr1 q ,, equifier_cone_eq q.

      Definition universal_equifier_cone_has_ump_1_mor
        : q --> cone
        := right_adjoint (H q) q'.

      Definition universal_equifier_cone_has_ump_1_pr1
        : invertible_2cell
            (universal_equifier_cone_has_ump_1_mor · equifier_cone_pr1 cone)
            (equifier_cone_pr1 q).
      Proof.
        use z_iso_to_inv2cell.
        exact (iso_from_iso_in_sub
                 _ _ _ _
                 (nat_z_iso_pointwise_z_iso
                    (counit_nat_z_iso_from_adj_equivalence_of_cats (H q))
                    q')).
      Defined.
    End UMP1.

    Definition universal_equifier_cone_has_ump_1
      : has_equifier_ump_1 cone.
    Proof.
      intro q.
      use make_equifier_1cell.
      - exact (universal_equifier_cone_has_ump_1_mor q).
      - exact (universal_equifier_cone_has_ump_1_pr1 q).
    Defined.
  End UniversalConeHasUMP.

  Section UMP2.
    Context (cone : equifier_cone)
            (H : is_univeral_equifier_cone cone)
            {x : B}
            {u₁ u₂ : x --> cone}
            (ζ : u₁ · equifier_cone_pr1 cone
                 ==>
                 u₂ · equifier_cone_pr1 cone).

    Definition universal_equifier_cone_has_ump_2_cell
      : u₁ ==> u₂.
    Proof.
      apply (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))).
      simple refine (_ ,, _).
      - exact ζ.
      - exact tt.
    Defined.

    Definition universal_equifier_cone_has_ump_2_pr1
      : universal_equifier_cone_has_ump_2_cell ▹ equifier_cone_pr1 cone
        =
        ζ.
    Proof.
      exact (maponpaths
               pr1
               (homotweqinvweq
                  (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))
                  _)).
    Qed.
  End UMP2.

  Definition universal_equifier_cone_has_ump_2
             (cone : equifier_cone)
             (H : is_univeral_equifier_cone cone)
    : has_equifier_ump_2 cone.
  Proof.
    intros x u₁ u₂ ζ.
    simple refine (_ ,, _).
    - exact (universal_equifier_cone_has_ump_2_cell cone H ζ).
    - exact (universal_equifier_cone_has_ump_2_pr1 cone H ζ).
  Defined.

  Definition universal_equifier_cone_has_ump_eq
             (cone : equifier_cone)
             (H : is_univeral_equifier_cone cone)
    : has_equifier_ump_eq cone.
  Proof.
    intros x u₁ u₂ ζ φ₁ φ₂ p q.
    use (invmaponpathsweq
           (make_weq
              _
              (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))) ; cbn.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    cbn.
    exact (p @ !q).
  Qed.

  Definition universal_equifier_cone_has_ump
             (cone : equifier_cone)
             (H : is_univeral_equifier_cone cone)
    : has_equifier_ump cone.
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact (universal_equifier_cone_has_ump_1 cone H).
    - exact (universal_equifier_cone_has_ump_2 cone H).
    - exact (universal_equifier_cone_has_ump_eq cone H).
  Defined.

  Definition isaprop_has_equifier_ump
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
    : isaprop (has_equifier_ump cone).
  Proof.
    use invproofirrelevance.
    intros χ₁ χ₂.
    use pathsdirprod.
    - use funextsec.
      intro q.
      use path_equifier_1cell.
      + apply (isotoid_2_1 HB_2_1).
        use make_invertible_2cell.
        * use (equifier_ump_cell χ₁).
          exact (equifier_1cell_pr1 (pr1 χ₁ q) • (equifier_1cell_pr1 (pr1 χ₂ q))^-1).
        * use is_invertible_equifier_ump_cell.
          is_iso.
          apply property_from_invertible_2cell.
      + rewrite idtoiso_2_1_isotoid_2_1.
        cbn.
        rewrite equifier_ump_cell_pr1.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
    - use pathsdirprod.
      + use funextsec ; intro x.
        use funextsec ; intro u₁.
        use funextsec ; intro u₂.
        use funextsec ; intro φ.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        use (equifier_ump_eq χ₁).
        * exact φ.
        * exact (pr2 ((pr12 χ₁) x u₁ u₂ φ)).
        * exact (pr2 ((pr12 χ₂) x u₁ u₂ φ)).
      + do 8 (use funextsec ; intro).
        apply cellset_property.
  Qed.

  Definition isaprop_is_universal_equifier_cone
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
    : isaprop (is_univeral_equifier_cone cone).
  Proof.
    use impred.
    intro x.
    use isofhlevelweqf.
    - exact (@left_adjoint_equivalence
               bicat_of_univ_cats
               (univ_hom HB_2_1 x cone)
               (univalent_universal_equifier_cat HB_2_1 x)
               (to_universal_equifier_cat cone x)).
    - exact (@adj_equiv_is_equiv_cat
               (univ_hom HB_2_1 x cone)
               (univalent_universal_equifier_cat HB_2_1 x)
               (to_universal_equifier_cat cone x)).
    - apply isaprop_left_adjoint_equivalence.
      exact univalent_cat_is_univalent_2_1.
  Defined.

  Definition equifier_ump_weq_is_universal
             (HB_2_1 : is_univalent_2_1 B)
             (cone : equifier_cone)
    : has_equifier_ump cone ≃ is_univeral_equifier_cone cone.
  Proof.
    use weqimplimpl.
    - exact (make_is_universal_equifier_cone HB_2_1 cone).
    - exact (universal_equifier_cone_has_ump cone).
    - exact (isaprop_has_equifier_ump HB_2_1 cone).
    - exact (isaprop_is_universal_equifier_cone HB_2_1 cone).
  Defined.
End Equifiers.

Arguments equifier_cone {_ _ _} _ _.

(**
 4. Bicategories with equifiers
 *)
Definition has_equifiers
           (B : bicat)
  : UU
  := ∏ (b₁ b₂ : B)
       (f g : b₁ --> b₂)
       (α β : f ==> g),
     ∑ (i : B)
       (m : i --> b₁)
       (p : m ◃ α = m ◃ β),
     has_equifier_ump (make_equifier_cone i m p).

(**
 5. Equifiers are fully faithful
 *)
Definition equifier_faithful
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {α β : f ==> g}
           {i : B}
           (m : i --> b₁)
           (p :  m ◃ α = m ◃ β)
           (H : has_equifier_ump (make_equifier_cone i m p))
  : faithful_1cell m.
Proof.
  intros x g₁ g₂ β₁ β₂ q.
  use (equifier_ump_eq_alt H) ; cbn.
  - exact (β₁ ▹ m).
  - exact q.
Defined.

Definition equifier_fully_faithful
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {α β : f ==> g}
           {i : B}
           (m : i --> b₁)
           (p :  m ◃ α = m ◃ β)
           (H : has_equifier_ump (make_equifier_cone i m p))
  : fully_faithful_1cell m.
Proof.
  use make_fully_faithful.
  - exact (equifier_faithful m p H).
  - intros z g₁ g₂ βf.
    simple refine (_ ,, _).
    + exact (equifier_ump_cell H βf).
    + exact (equifier_ump_cell_pr1 H βf).
Defined.