Require Import Lia Term Convertibility.

Inductive type :=
| atm : nat -> type
| arr : type -> type -> type
| sum : type -> type -> type.

Inductive typing : list type -> term -> type -> Type :=
| typing_var : forall Γ A n, List.nth_error Γ n = Some A -> typing Γ (var n) A
| typing_lam : forall Γ A B t, typing (cons A Γ) t B -> typing Γ (lam t) (arr A B)
| typing_app : forall Γ A B t u, typing Γ t (arr A B) -> typing Γ u A -> typing Γ (app t u) B
| typing_lft : forall Γ A B t, typing Γ t A -> typing Γ (lft t) (sum A B)
| typing_rgt : forall Γ A B t, typing Γ t B -> typing Γ (rgt t) (sum A B)
| typing_cse : forall Γ A B C t u1 u2,
  typing Γ t (sum A B) -> typing (cons A Γ) u1 C -> typing (cons B Γ) u2 C ->
  typing Γ (cse t u1 u2) C
.

Notation "[ Γ ⊢ t : A ]" := (typing Γ t A) (t at level 0).

Module NF.

Inductive shape := nf | ne.

Inductive typing : shape -> list type -> term -> type -> Type :=
| typing_ne : forall Γ A t, typing ne Γ t A -> typing nf Γ t A
| typing_var : forall Γ A n, List.nth_error Γ n = Some A -> typing ne Γ (var n) A
| typing_lam : forall Γ A B t, typing nf (cons A Γ) t B -> typing nf Γ (lam t) (arr A B)
| typing_app : forall Γ A B t u, typing ne Γ t (arr A B) -> typing nf Γ u A -> typing ne Γ (app t u) B
| typing_lft : forall Γ A B t, typing nf Γ t A -> typing nf Γ (lft t) (sum A B)
| typing_rgt : forall Γ A B t, typing nf Γ t B -> typing nf Γ (rgt t) (sum A B)
| typing_cse : forall Γ A B C t u1 u2,
  typing ne Γ t (sum A B) -> typing nf (cons A Γ) u1 C -> typing nf (cons B Γ) u2 C ->
  typing ne Γ (cse t u1 u2) C
.

End NF.

Notation "[ Γ ⊢ne t : A ]" := (NF.typing NF.ne Γ t A) (t at level 0).
Notation "[ Γ ⊢nf t : A ]" := (NF.typing NF.nf Γ t A) (t at level 0).

Inductive typing_lift : lift -> list type -> list type -> Prop :=
| typing_ELID : forall Γ, typing_lift ELID Γ Γ
| typing_ELSHFT : forall el Γ Δ A,
  typing_lift el Γ Δ ->
  typing_lift (ELSHFT el) (cons A Γ) Δ
| typing_ELLFT : forall el Γ Δ A,
  typing_lift el Γ Δ ->
  typing_lift (ELLFT el) (cons A Γ) (cons A Δ)
.

Notation "[ Γ ⊢lift e : Δ ]" := (typing_lift e Γ Δ) (e at level 0).

Lemma typing_lift_rect :
  forall P : lift -> list type -> list type -> Type,
  (forall Γ : list type, P ELID Γ Γ) ->
  (forall (el : lift) (Γ Δ : list type) (A : type),
   [Γ ⊢lift el : Δ] -> P el Γ Δ -> P (ELSHFT el) (A :: Γ)%list Δ) ->
  (forall (el : lift) (Γ Δ : list type) (A : type),
   [Γ ⊢lift el : Δ] -> P el Γ Δ -> P (ELLFT el) (A :: Γ)%list (A :: Δ)%list) ->
  forall (l : lift) (l0 l1 : list type), [l0 ⊢lift l : l1] -> P l l0 l1.
Proof.
intros P f f0 f1.
fix F 1; intros e Γ Δ He; destruct e.
+ assert (Hrw : Γ = Δ).
  { inversion He; subst; reflexivity. }
  destruct Hrw; apply f.
+ destruct Γ as [|A Γ].
  { exfalso; inversion He. }
  assert (He' : [ Γ ⊢lift e : Δ ]).
  { inversion He; subst; assumption. }
  apply f0, F; apply He'.
+ destruct Γ as [|A Γ].
  { exfalso; inversion He. }
  destruct Δ as [|B Δ].
  { exfalso; inversion He. }
  assert (Hrw : A = B).
  { inversion He; subst; reflexivity. }
  destruct Hrw.
  assert (He' : [ Γ ⊢lift e : Δ ]).
  { inversion He; subst; assumption. }
  apply f1, F; apply He'.
Qed.

Lemma nth_error_app : forall A (l1 l2 : list A) n,
  List.nth_error (l1 ++ l2)%list (length l1 + n) = List.nth_error l2 n.
Proof.
induction l1 as [|x l1]; intros l2 n; cbn.
+ reflexivity.
+ apply IHl1.
Defined.

Lemma typing_lift_reloc : forall Γ Δ A n el,
  List.nth_error Γ n = Some A ->
  typing_lift el Δ Γ -> List.nth_error Δ (reloc n el) = Some A.
Proof.
intros Γ Δ A n el e Hel.
revert n A e.
induction Hel; cbn in *; intros n B e.
+ assumption.
+ apply IHHel; assumption.
+ destruct n; cbn in *.
  - assumption.
  - apply IHHel; assumption.
Qed.

Lemma typing_lift_compat : forall Γ Δ A t el,
  typing Γ t A -> typing_lift el Δ Γ -> typing Δ (lift_term el t) A.
Proof.
intros Γ Δ A t el Ht; revert Δ el; induction Ht; intros Δ el Hel; cbn.
+ apply typing_var.
  apply typing_lift_reloc with (Γ := Γ); assumption.
+ apply typing_lam.
  apply IHHt.
  apply (typing_ELLFT _ _ _ A); assumption.
+ apply typing_app with A.
  - apply IHHt1; assumption.
  - apply IHHt2; assumption.
+ apply typing_lft, IHHt; assumption.
+ apply typing_rgt, IHHt; assumption.
+ apply typing_cse with A B.
  - apply IHHt1; assumption.
  - apply IHHt2; constructor; assumption.
  - apply IHHt3; constructor; assumption.
Qed.

Lemma NF_typing_lift_compat : forall s Γ Δ A t el,
  NF.typing s Γ t A -> typing_lift el Δ Γ -> NF.typing s Δ (lift_term el t) A.
Proof.
intros s Γ Δ A t el Ht; revert Δ el; induction Ht; intros Δ el Hel; cbn.
+ apply NF.typing_ne, IHHt, Hel.
+ apply NF.typing_var.
  apply typing_lift_reloc with (Γ := Γ); assumption.
+ apply NF.typing_lam.
  apply IHHt.
  apply (typing_ELLFT _ _ _ A); assumption.
+ apply NF.typing_app with A.
  - apply IHHt1; assumption.
  - apply IHHt2; assumption.
+ apply NF.typing_lft, IHHt; assumption.
+ apply NF.typing_rgt, IHHt; assumption.
+ apply NF.typing_cse with A B.
  - apply IHHt1; assumption.
  - apply IHHt2; constructor; assumption.
  - apply IHHt3; constructor; assumption.
Qed.

Lemma typing_lift_compose : forall Γ Δ Ξ e1 e2,
  [ Γ ⊢lift e1 : Δ ] -> [ Δ ⊢lift e2 : Ξ ] -> [ Γ ⊢lift (lift_compose e1 e2) : Ξ ].
Proof.
intros Γ Δ Ξ e1 e2 He1; revert Ξ e2; induction He1; cbn in *; intros Ξ e2 He2.
+ assumption.
+ constructor; eauto.
+ destruct e2; cbn.
  - inversion He2; subst.
    constructor; assumption.
  - inversion He2; subst.
    constructor; apply IHHe1; assumption.
  - inversion He2; subst.
    constructor; apply IHHe1; assumption.
Qed.

Inductive typing_subs : subs term -> list type -> list type -> Type :=
| typing_ESID : forall Γ, typing_subs ESID Γ Γ
| typing_CONS : forall Γ Δ s t A, typing_subs s Γ Δ -> typing Γ t A -> typing_subs (CONS t s) Γ (cons A Δ)
| typing_SHFT : forall Γ Δ s A, typing_subs s Γ Δ -> typing_subs (SHFT s) (cons A Γ) Δ
| typing_LIFT : forall Γ Δ s A, typing_subs s Γ Δ -> typing_subs (LIFT s) (cons A Γ) (cons A Δ)
.

Notation "[ Γ ⊢subs e : Δ ]" := (typing_subs e Γ Δ) (e at level 0).

Lemma typing_wkn_n : forall Γ Δ A B t,
  typing (Δ ++ Γ) t A -> typing (Δ ++ cons B Γ) (lift_term (ELLFTn (length Δ) (ELSHFT ELID)) t) A.
Proof.
intros Γ Δ A B t Ht.
remember (Δ ++ Γ)%list as Ξ; revert Γ Δ B HeqΞ.
induction Ht; cbn; intros Δ Ξ X ->.
+ constructor.
  revert n Δ e X; induction Ξ as [|D Ξ]; intros n Δ e X; cbn.
  - assumption.
  - destruct n as [|n]; cbn in *; [assumption|].
    apply IHΞ; assumption.
+ apply typing_lam.
  change (A :: (Ξ ++ X :: Δ))%list with ((cons A nil) ++ (Ξ ++ X :: Δ))%list.
  rewrite List.app_assoc.
  apply IHHt; reflexivity.
+ eapply typing_app; intuition eauto.
+ apply typing_lft; intuition eauto.
+ apply typing_rgt; intuition eauto.
+ apply typing_cse with A B.
  - intuition eauto.
  - change (A :: (Ξ ++ X :: Δ))%list with ((cons A nil) ++ (Ξ ++ X :: Δ))%list.
    rewrite List.app_assoc.
    apply IHHt2; reflexivity.
  - change (B :: (Ξ ++ X :: Δ))%list with ((cons B nil) ++ (Ξ ++ X :: Δ))%list.
    rewrite List.app_assoc.
    apply IHHt3; reflexivity.
Qed.

Lemma typing_wkn : forall Γ A B t,
  typing Γ t A -> typing (cons B Γ) (lift_term (ELSHFT ELID) t) A.
Proof.
intros.
apply typing_wkn_n with (Δ := nil); assumption.
Qed.

Lemma typing_subs_compat : forall Γ Δ A s t,
  typing Γ t A -> typing_subs s Δ Γ -> typing Δ (subs_term s t) A.
Proof.
intros Γ Δ A s t Ht; revert Δ s; induction Ht; intros Δ s Hs; cbn.
+ revert n A e; induction Hs; cbn; intros n B e.
  - constructor; assumption.
  - destruct n as [|n]; cbn in *.
    * injection e; intros ->. eapply typing_lift_compat; try eassumption.
      constructor.
    * apply IHHs; assumption.
  - specialize (IHHs _ _ e).
    unfold expand_term in *; cbn.
    destruct (expand s n) as [[v k]|m].
    change (ELSHFTn (S k) ELID) with (lift_compose (ELSHFT ELID) (ELSHFTn k ELID)).
    rewrite lift_term_compose.
    apply typing_wkn; assumption.
    constructor; inversion IHHs; subst; assumption.
  - destruct n as [|n]; cbn.
   * constructor; assumption.
   * specialize (IHHs _ _ e).
    unfold expand_term in *; cbn.
    destruct (expand s n) as [[v k]|m].
    { change (ELSHFTn (S k) ELID) with (lift_compose (ELSHFT ELID) (ELSHFTn k ELID)).
      rewrite lift_term_compose.
      apply typing_wkn; assumption. }
    { constructor; inversion IHHs; subst; assumption. }
+ constructor; apply IHHt; constructor; apply Hs.
+ apply typing_app with A; intuition.
+ apply typing_lft; intuition.
+ apply typing_rgt; intuition.
+ apply typing_cse with A B.
  - intuition.
  - apply IHHt2; constructor; assumption.
  - apply IHHt3; constructor; assumption.
Qed.

Lemma typing_subs_compose : forall Γ Δ Ξ σ1 σ2,
  [ Γ ⊢subs σ1 : Δ ] -> [ Δ ⊢subs σ2 : Ξ ] -> [ Γ ⊢subs (subs_compose subs_term σ1 σ2) : Ξ ].
Proof.
intros Γ Δ Ξ σ1 σ2 Hσ1; revert Ξ σ2; induction Hσ1; cbn in *; intros Ξ σ2 Hσ2.
+ assumption.
+ remember (A :: Δ)%list as Ω in *.
  induction Hσ2; subst.
  - constructor; assumption.
  - constructor; [apply IHHσ2; reflexivity|].
    apply typing_subs_compat with (cons A Δ); [assumption|].
    constructor; assumption.
  - apply IHHσ1.
    injection HeqΩ; intros -> ->; assumption.
  - injection HeqΩ; intros -> ->.
    constructor; [|assumption].
    apply IHHσ1; assumption.
+ constructor.
  apply IHHσ1; assumption.
+ remember (A :: Δ)%list as Ω in *.
  induction Hσ2; subst.
  - constructor; assumption.
  - constructor; [apply IHHσ2; reflexivity|].
    apply typing_subs_compat with (cons A Δ); [assumption|].
    constructor; assumption.
  - injection HeqΩ; intros -> ->.
    constructor; apply IHHσ1; assumption.
  - injection HeqΩ; intros -> ->.
    constructor.
    apply IHHσ1; assumption.
Qed.


Require Export prosa.behavior.all.
Require Export prosa.util.all.

(** * Arrival Sequence *)

(** In this section, we relate job readiness to [has_arrived]. *)
Section Arrived.

  (** Consider any kinds of jobs and any kind of processor state. *)
  Context {Job : JobType} {PState : Type}.
  Context `{ProcessorState Job PState}.

  (** Consider any schedule... *)
  Variable sched : schedule PState.

  (** ...and suppose that jobs have a cost, an arrival time, and a
      notion of readiness. *)
  Context `{JobCost Job}.
  Context `{JobArrival Job}.
  Context `{JobReady Job PState}.

  (** First, we note that readiness models are by definition consistent
      w.r.t. [pending]. *)
  Lemma any_ready_job_is_pending:
    forall j t,
      job_ready sched j t -> pending sched j t.
  Proof.
    move: H5 => [is_ready CONSISTENT].
    move=> j t READY.
    apply CONSISTENT.
    by exact READY.
  Qed.

  (** Next, we observe that a given job must have arrived to be ready... *)
  Lemma ready_implies_arrived:
    forall j t, job_ready sched j t -> has_arrived j t.
  Proof.
    move=> j t READY.
    move: (any_ready_job_is_pending j t READY).
    by rewrite /pending => /andP [ARR _].
  Qed.

  (** ...and lift this observation also to the level of whole schedules. *)
  Lemma jobs_must_arrive_to_be_ready:
    jobs_must_be_ready_to_execute sched ->
    jobs_must_arrive_to_execute sched.
  Proof.
    rewrite /jobs_must_be_ready_to_execute /jobs_must_arrive_to_execute.
    move=> READY_IF_SCHED j t SCHED.
    move: (READY_IF_SCHED j t SCHED) => READY.
    by apply ready_implies_arrived.
  Qed.

End Arrived.

(** In this section, we establish useful facts about arrival sequence prefixes. *)
Section ArrivalSequencePrefix.

  (** Assume that job arrival times are known. *)
  Context {Job: JobType}.
  Context `{JobArrival Job}.

  (** Consider any job arrival sequence. *)
  Variable arr_seq: arrival_sequence Job.

  (** We begin with basic lemmas for manipulating the sequences. *)
  Section Composition.

    (** First, we show that the set of arriving jobs can be split
         into disjoint intervals. *)
    Lemma arrivals_between_cat:
      forall t1 t t2,
        t1 <= t ->
        t <= t2 ->
        arrivals_between arr_seq t1 t2 =
        arrivals_between arr_seq t1 t ++ arrivals_between arr_seq t t2.
    Proof.
      unfold arrivals_between; intros t1 t t2 GE LE.
        by rewrite (@big_cat_nat _ _ _ t).
    Qed.

    (** Second, the same observation applies to membership in the set of
         arrived jobs. *)
    Lemma arrivals_between_mem_cat:
      forall j t1 t t2,
        t1 <= t ->
        t <= t2 ->
        j \in arrivals_between arr_seq t1 t2 =
        (j \in arrivals_between arr_seq t1 t ++ arrivals_between arr_seq t t2).
    Proof.
        by intros j t1 t t2 GE LE; rewrite (arrivals_between_cat _ t).
    Qed.

    (** Third, we observe that we can grow the considered interval without
         "losing" any arrived jobs, i.e., membership in the set of arrived jobs
         is monotonic. *)
    Lemma arrivals_between_sub:
      forall j t1 t1' t2 t2',
        t1' <= t1 ->
        t2 <= t2' ->
        j \in arrivals_between arr_seq t1 t2 ->
        j \in arrivals_between arr_seq t1' t2'.
    Proof.
      intros j t1 t1' t2 t2' GE1 LE2 IN.
      move: (leq_total t1 t2) => /orP [BEFORE | AFTER];
                                  last by rewrite /arrivals_between big_geq // in IN.
      rewrite /arrivals_between.
      rewrite -> big_cat_nat with (n := t1); [simpl | by done | by apply: (leq_trans BEFORE)].
      rewrite mem_cat; apply/orP; right.
      rewrite -> big_cat_nat with (n := t2); [simpl | by done | by done].
        by rewrite mem_cat; apply/orP; left.
    Qed.

  End Composition.

  (** Next, we relate the arrival prefixes with job arrival times. *)
  Section ArrivalTimes.

    (** Assume that job arrival times are consistent. *)
    Hypothesis H_consistent_arrival_times:
      consistent_arrival_times arr_seq.

    (** First, we prove that if a job belongs to the prefix
         (jobs_arrived_before t), then it arrives in the arrival sequence. *)
    Lemma in_arrivals_implies_arrived:
      forall j t1 t2,
        j \in arrivals_between arr_seq t1 t2 ->
        arrives_in arr_seq j.
    Proof.
      rename H_consistent_arrival_times into CONS.
      intros j t1 t2 IN.
      apply mem_bigcat_nat_exists in IN.
      move: IN => [arr [IN _]].
        by exists arr.
    Qed.

    (** Next, we prove that if a job belongs to the prefix
         (jobs_arrived_between t1 t2), then it indeed arrives between t1 and
         t2. *)
    Lemma in_arrivals_implies_arrived_between:
      forall j t1 t2,
        j \in arrivals_between arr_seq t1 t2 ->
        arrived_between j t1 t2.
    Proof.
      rename H_consistent_arrival_times into CONS.
      intros j t1 t2 IN.
      apply mem_bigcat_nat_exists in IN.
      move: IN => [t0 [IN /= LT]].
        by apply CONS in IN; rewrite /arrived_between IN.
    Qed.

    (** Similarly, if a job belongs to the prefix (jobs_arrived_before t),
           then it indeed arrives before time t. *)
    Lemma in_arrivals_implies_arrived_before:
      forall j t,
        j \in arrivals_before arr_seq t ->
        arrived_before j t.
    Proof.
      intros j t IN.
      have: arrived_between j 0 t by apply in_arrivals_implies_arrived_between.
        by rewrite /arrived_between /=.
    Qed.

    (** Similarly, we prove that if a job from the arrival sequence arrives
         before t, then it belongs to the sequence (jobs_arrived_before t). *)
    Lemma arrived_between_implies_in_arrivals:
      forall j t1 t2,
        arrives_in arr_seq j ->
        arrived_between j t1 t2 ->
        j \in arrivals_between arr_seq t1 t2.
    Proof.
      rename H_consistent_arrival_times into CONS.
      move => j t1 t2 [a_j ARRj] BEFORE.
      have SAME := ARRj; apply CONS in SAME; subst a_j.
        by apply mem_bigcat_nat with (j := (job_arrival j)).
    Qed.

    (** Next, we prove that if the arrival sequence doesn't contain duplicate
         jobs, the same applies for any of its prefixes. *)
    Lemma arrivals_uniq :
      arrival_sequence_uniq arr_seq ->
      forall t1 t2, uniq (arrivals_between arr_seq t1 t2).
    Proof.
      rename H_consistent_arrival_times into CONS.
      unfold arrivals_up_to; intros SET t1 t2.
      apply bigcat_nat_uniq; first by done.
      intros x t t' IN1 IN2.
        by apply CONS in IN1; apply CONS in IN2; subst.
    Qed.

    (** Also note there can't by any arrivals in an empty time interval. *)
    Lemma arrivals_between_geq:
      forall t1 t2,
        t1 >= t2 ->
        arrivals_between arr_seq t1 t2  = [::].
    Proof.
        by intros ? ? GE; rewrite /arrivals_between big_geq.
    Qed.

  End ArrivalTimes.

End ArrivalSequencePrefix.


(** * Utils/seq_ext.v
-----------------

 A set of utility functions and lemmas on sequences and finite
 sequences.*)

From mathcomp.ssreflect
     Require Import ssreflect ssrbool ssrnat eqtype fintype choice ssrfun seq path.

From mathcomp.ssreflect
     Require Import tuple.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

From ProbHash.Utils Require Import InvMisc.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma xcons_eqE {A: eqType} {l: nat} (h  h': A) (t t': l.-tuple A): ((cons_tuple h t) == (cons_tuple h' t')) = (h == h') && (t == t').
Proof.
    by rewrite /cons_tuple//=.
Qed.

Lemma   beheadE (E: eqType) (m: nat) (x: E) (xs: (m.-tuple E)):
  behead_tuple [tuple of x :: xs] = xs.
Proof.
  case: xs => xs Hxs; rewrite /behead_tuple; move: (behead_tupleP _) => //= Hxs'.
    by rewrite (proof_irrelevance _ Hxs Hxs').
Qed.

Lemma behead_tupleE n' A p (ps: n'.-tuple A) : (Tuple (behead_tupleP [tuple of p :: ps]) = ps).
    by case: ps (behead_tupleP _ ) => //= xs H H'; rewrite (proof_irrelevance _ H H').
Qed.

Lemma tuple_eq_inj (A: eqType) l (xs ys: seq A) (Hxs: size xs == l) (Hys: size ys == l) :
  (Tuple Hxs == Tuple Hys) = (xs == ys).
Proof.
    by move=> //=.
Qed.

Lemma size_ncons_nil (A : Type) (a : A) (n : nat): (size (ncons n a [::])) == n.
Proof.
  rewrite size_ncons => //=.
    by rewrite addn0.
Qed.

Lemma negb_consP (A: eqType) (x y: A) (xs ys: seq A) : x :: xs != y :: ys = ((x != y) || (xs != ys)).
Proof.
    by rewrite eqseq_cons Bool.negb_andb.
Qed.

Lemma nth_filter (B: eqType) (f:B) (fs ys: seq B) ind: ind < length (filter (fun f => f \notin ys) fs) -> nth f (filter (fun f => f \notin ys) fs) ind \in ys = false.
Proof.  {
    elim: fs ind => [//=| r rs IHrs //=] ind.
    case Hinr: (r \in ys) => //=; first  by move=> /IHrs.
    case: ind => [|ind] /ltn_SnnP Hlen; first by [].
      by move=>//=; apply IHrs.
  }
Qed.

Lemma nth_mem_filter (B: eqType) (f:B) (fs: seq B) P ind: ind < length (filter P fs) -> nth f (filter P fs) ind \in fs.
Proof.  {
    elim: fs ind => [//= | r rs IHrs] ind //=; case: (P r) => //=.
    case: ind => [//= _ | ind ]; rewrite ?in_cons ?eq_refl ?Bool.orb_true_l  //=.
      by move=>/ltn_SnnP/IHrs ->; rewrite Bool.orb_true_r.
        by rewrite in_cons =>/IHrs ->; rewrite Bool.orb_true_r.
  }
Qed.

Lemma mem_len (B: eqType) (f:B) (fs: seq B): f \notin fs -> index f fs = length fs.
Proof.  {
    elim: fs f => [//=| r rs IHrs] f.
    rewrite in_cons Bool.negb_orb =>/andP [Hfnr /IHrs Hind]//=.
      by rewrite eq_sym; move/Bool.negb_true_iff: Hfnr ->; rewrite Hind.
  }
Qed.

Lemma filter_leq_size (B: eqType) (fs: seq B) P: length (filter P fs) <= length fs.
Proof.  {
    elim: fs => [//=| f fs IHf] //=.
    case: (P f) => //=; by apply ltnW.
  }
Qed.

Lemma filter_size (B: eqType) (fs: seq B) P: length (filter P fs) = length fs - (length (filter (fun f => ~~ P f) fs)).
Proof.  {
    elim: fs P => [//=| f  fs IHf] P //=.
    case: (P f) => //=.
    rewrite subSn; first rewrite IHf //=; last by apply filter_leq_size.
      by rewrite subSS IHf.
  }
Qed.

Lemma uniq_filter (B: eqType) (fs: seq B) P: uniq  fs -> uniq (filter P fs).
Proof.  {
    elim: fs => [//= | f fs IHf] //= /andP [ Hnin Huniq].
    case Hpf: (P f) => //=; last by apply IHf.
    rewrite IHf //= Bool.andb_true_r.
      by rewrite mem_filter Bool.negb_andb; apply/orP; right.
  }
Qed.

Lemma len_eq (B: eqType) (fs gs: seq B): uniq fs -> uniq gs -> length fs = length gs -> length (filter (fun f =>  f \notin gs) fs) = length (filter (fun g => g \notin fs) gs).
Proof.  {
    move=>Huniqfs Huniqgs Heqsize.
    rewrite filter_size [length (filter _ gs)]filter_size Heqsize; apply f_equal.
    transitivity  (length (filter (fun f => f \in gs) fs)).
      by do ?apply f_equal; apply eq_in_filter => fs' Hin //=; rewrite Bool.negb_involutive.
      apply Logic.eq_sym; transitivity (length (filter (fun g => g \in fs) gs)).
        by do ?apply f_equal; apply eq_in_filter => fs' Hin //=; rewrite Bool.negb_involutive.
        rewrite -!length_sizeP.
        apply perm_size; rewrite/perm_eq.
        apply uniq_perm; try by apply uniq_filter.
          by move=> g; rewrite !mem_filter andbC //=.
  }
Qed.

Lemma cons_sizeP T l (x : T) xs : (size (x :: xs) == l.+1) -> (size xs == l).
    by [].
Qed.

Lemma mem_zip (S T : eqType) (ss : seq S) (ts: seq T) (s: S) (t: T):
  ((s,t) \in (zip ss ts)) -> ((s \in ss) && (t \in ts)).
Proof.
  elim: ss ts => [|s' ss IHss] ts //=.
  - by case: ts =>//=.
  - case: ts => [//=|t' ts].
    move=>//=; rewrite !in_cons //= xpair_eqE =>/orP[/andP[ -> -> //=]| ].
      by move=>/IHss/andP[-> ->]; rewrite !Bool.orb_true_r.
Qed.

Lemma zip_empty_r (S T: eqType) (ts: seq T) : (@zip S _ [::] ts) = ([::]).
Proof.
    by case: ts.
Qed.
Fixpoint swap_vec {A: finType} (m:nat) (ps qs: seq A) (list: m.-tuple A) : m.-tuple A :=
  match m as m' return (m = m' -> m'.-tuple A -> m'.-tuple A) with
  | 0 => (fun (Hm: m = 0) (list: 0.-tuple A) => list)
  | m'.+1 => (fun (Hm: m = m'.+1) (list: (m'.+1).-tuple A) =>
                let head := thead list in
                let tail := behead_tuple list in
                let new_head := (if (head \in ps) && (head \in qs) then
                                   head
                                 else if (head \in ps) then
                                        nth
                                          head
                                          (filter (fun p => p \notin qs) ps)
                                          (index head (filter (fun q => q \notin ps) qs))
                                      else if (head \in qs) then
                                             nth
                                               head
                                               (filter (fun q => q \notin ps) qs)
                                               (index head (filter (fun p => p \notin qs) ps))
                                           else head) in
                [tuple of new_head :: (swap_vec  ps qs tail)] )
  end (erefl m) list.

Lemma substitute_vec_inv (A: finType) (m: nat) (ps qs: seq A) :
  uniq ps -> uniq qs -> length ps = length qs ->
  forall x : m.-tuple A,
    swap_vec  qs ps (swap_vec ps qs x) = x.
Proof.
  move=> Hinjp  Hinjq. rewrite -!length_sizeP=> Hlength.
  elim: m => [//= | m IHm x] .
  rewrite (tuple_eta x) //=.
  rewrite !theadE !beheadE !IHm.
  case Hinp: (thead x \in ps); case Hinq: (thead x \in qs) => //=.
  - by rewrite Hinp Hinq //=.
  - rewrite mem_len.
    rewrite nth_default.
    rewrite Hinq //= Hinp mem_len.
    rewrite nth_default //=.
      by rewrite length_sizeP len_eq.
        by rewrite mem_filter Bool.negb_andb Hinp //=.
          by rewrite length_sizeP len_eq.
            by rewrite mem_filter Bool.negb_andb Hinp //=.
  - rewrite mem_len.
    rewrite nth_default.
    rewrite Hinp Hinq //=.
    rewrite mem_len.
    rewrite nth_default //=.
      by rewrite length_sizeP len_eq.
        by rewrite mem_filter Bool.negb_andb Hinp Bool.orb_true_r //=.
          by rewrite length_sizeP len_eq.
            by rewrite mem_filter Bool.negb_andb Hinp Bool.orb_true_r //=.
  - rewrite Hinp Hinq //=.
Qed.

Lemma swap_vec_bij (A: finType) (m: nat) (ps qs: seq A) :
  uniq ps -> uniq qs -> length ps = length qs ->
  bijective (@swap_vec _ m ps qs).
Proof.
  move=> Huniqps Huniqqs Hleneq.
  split with (swap_vec qs ps); move=>x; by rewrite substitute_vec_inv.
Qed.
Definition tuple_split (A:finType) (m l: nat) (xs: (m * l + l).-tuple A) : (l.-tuple A * (m * l).-tuple A).
  split.
  move: (take_tuple l xs); rewrite minn_mult=>V; exact V.
  move: (drop_tuple l xs); rewrite mult_subn=>V; exact V.
Defined.
Definition tuple_split_mult (A:finType) (m l: nat) (xs: (m.+1 * l).-tuple A) : (l.-tuple A * (m * l).-tuple A).
  have H: (m.+1 * l = m * l + l); first by rewrite mulSnr.
  rewrite H in xs.
  exact (tuple_split xs).
Defined.

Lemma tcast_tval_eq (A: finType) (n' m : nat) (Hm: m = n') (v: m.-tuple A) (w: seq A) :
  w = tval v ->
  tval (tcast Hm v) = w.
Proof.
  move=> -> //=.
  rewrite <-Hm.
    by rewrite tcast_id.
Qed.

Lemma tuple_split_valid (A: finType) (m l:nat) :  bijective (fun (x: [finType of (m.-tuple A * (l * m).-tuple A)]) => let (b,a) := x in cat_tuple b a).
  split with (fun (xs : (m + l * m).-tuple A) =>  @tuple_split A l m (tcast (addnC m (l * m)) xs)) => [[p ps]| x].
  apply/eqP; rewrite xpair_eqE; apply/andP; split=>//=; apply/eqP.
  - {
      rewrite/take_tuple; move: (take_tupleP  _ _); rewrite/cat_tuple.
      erewrite (@tcast_tval_eq A (l * m + m) (m + l * m) (addnC m (muln l m))
                               (Tuple (cat_tupleP p ps)) (cat p ps)).
      rewrite take_cat //= size_tuple ltnn subnn take0 cats0 //=.
      move: (minn_mult _ _) => //=; rewrite minn_mult /eq_rect_r //= => Hm'.
      move: Hm' (Logic.eq_sym _ ) => _ H1.
      rewrite -(@Eq_rect_eq.eq_rect_eq nat m (fun y :nat => y.-tuple A -> m.-tuple A) id H1) //=.
      case: p => //= p' H4 H5; rewrite (proof_irrelevance _ H4 H5) //=.
        by move=>//=.
    }
  - {
      rewrite /drop_tuple; move: (drop_tupleP _ _); rewrite/cat_tuple.
      erewrite (@tcast_tval_eq A (l * m + m) (m + l * m) (addnC m (muln l m))
                               (Tuple (cat_tupleP p ps)) (cat p ps)).
      rewrite drop_cat //= size_tuple ltnn subnn drop0 //=.
      move: (mult_subn _ _) => //=; rewrite mult_subn /eq_rect_r //= => Hm'.
      move: Hm' (Logic.eq_sym _ ) => _ H1.
      rewrite -(@Eq_rect_eq.eq_rect_eq nat (l * m) (fun y :nat => y.-tuple A -> (l*m).-tuple A) id H1) //=.
      case: ps => //= p' H4 H5; rewrite (proof_irrelevance _ H4 H5) //=.
        by move=>//=.
    }
  - {
      move=> //=; rewrite /take_tuple/drop_tuple //=.
      rewrite/cat_tuple //=;      move: (cat_tupleP _ _).
      move: (take_tupleP _ _) (drop_tupleP _ _) => //=.
      move: (minn_mult _ _) (mult_subn _ _) => //=.
      rewrite minn_mult mult_subn //= => H1 H2.
      rewrite /eq_rect_r.
      move: (Logic.eq_sym H1) => //=;clear H1=> H1.
      move: (Logic.eq_sym H2) => //=;clear H2=> H2.
      rewrite -(@Eq_rect_eq.eq_rect_eq nat m (fun y :nat => y.-tuple A -> m.-tuple A) id H1) //=.
      rewrite -(@Eq_rect_eq.eq_rect_eq nat (l * m) (fun y :nat => y.-tuple A -> (l * m).-tuple A) id H2) //=.
      rewrite cat_take_drop.
      move=> _ _; move: x  (addnC _ _) .
      rewrite addnC => x Heq; rewrite tcast_id; case: x => //= x H3 H4 .
        by rewrite (proof_irrelevance _ H3 H4).
    }
Qed.

Lemma tnth_nseq_eq (A: Type)  l a ind:
  tnth (@nseq_tuple l A a) ind = a.
Proof.
    by rewrite/nseq_tuple/tnth; rewrite nth_nseq; case: ind => [ m Hm] //=; rewrite Hm.
Qed.

Lemma unzip_tupleP (n : nat) (T U : Type) (xs: seq (T * U)%type):
  size xs == n -> (size (unzip1 xs) == n) && (size (unzip2 xs) == n).
Proof.
  move=>/eqP<-;clear n.
    by elim: xs => [//=| x xs /andP [Hl Hr]] //=.
Qed.

Lemma unzip_tuplePL (n : nat) (T U : Type) (xs: seq (T * U)%type):
  size xs == n -> size (unzip1 xs) == n.
Proof. by move=>/unzip_tupleP/andP[]. Qed.

Lemma unzip_tuplePR (n : nat) (T U : Type) (xs: seq (T * U)%type):
  size xs == n -> size (unzip2 xs) == n.
Proof. by move=>/unzip_tupleP/andP[]. Qed.

Definition unzip_tuple (n : nat) (T U : Type) (xs: n.-tuple (T * U)%type):
  (n.-tuple T * n.-tuple U)%type :=
  let: (Tuple _ hprf) := xs in (Tuple (unzip_tuplePL hprf), Tuple (unzip_tuplePR hprf)).

Lemma seq_neqP (A:eqType) (x y: seq A) : (exists (v:A), (v \in x) && (v \notin y)) -> (x != y).
Proof.
  move=> [x'/andP[]]; move: x' y.
  elim: x => [| x xs IHx] x' [|y ys] //=.
  rewrite !in_cons Bool.negb_orb negb_consP.
  move=>/orP [/eqP -> | Hx']/andP[]; first by move=>-> //=.
  move=> Hxs' Hxs.
    by move: Hxs =>/IHx Hxs; move: (Hxs Hx') ->; rewrite Bool.orb_true_r.
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.schedulability.
Require Import prosa.classic.model.schedule.global.basic.schedule prosa.classic.model.schedule.global.basic.platform
               prosa.classic.model.schedule.global.basic.interference.
Require Import prosa.classic.analysis.global.parallel.workload_bound
               prosa.classic.analysis.global.parallel.interference_bound_fp
               prosa.classic.analysis.global.parallel.bertogna_fp_comp.
Require Import prosa.classic.implementation.job prosa.classic.implementation.task
               prosa.classic.implementation.arrival_sequence.
Require Import prosa.classic.implementation.global.basic.schedule. (* Use sequential scheduler. *)
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq bigop div.

Module ResponseTimeAnalysisFP.

  Import Job Schedule SporadicTaskset Priority Schedulability Platform
         Interference InterferenceBoundFP WorkloadBound
         ResponseTimeIterationFP.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  (* In this section, we instantiate a simple example to show that the theorems
     contain no contradictory assumptions. *)
  Section ExampleRTA.

    Let tsk1 := {| task_id := 1; task_cost := 2; task_period := 6; task_deadline := 6|}.
    Let tsk2 := {| task_id := 2; task_cost := 3; task_period := 8; task_deadline := 6|}.
    Let tsk3 := {| task_id := 3; task_cost := 2; task_period := 12; task_deadline := 12|}.

    (* Let ts be a task set containing these three tasks (sorted by rate-monotonic priority). *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    Section FactsAboutTaskset.

      Fact ts_has_valid_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

      Fact ts_has_constrained_deadlines:
        forall tsk,
          tsk \in ts ->
          task_deadline tsk <= task_period tsk.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

    End FactsAboutTaskset.

    (* Assume there are two processors. *)
    Let num_cpus := 2.

    (* Recall the FP RTA schedulability test. *)
    Let schedulability_test :=
      fp_schedulable task_cost task_period task_deadline num_cpus.

    (* Now we show that the schedulability test returns true. *)
    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      unfold schedulability_test, fp_schedulable, fp_claimed_bounds; simpl.
      unfold total_interference_bound_fp, div_floor.
      rewrite big_nil div0n addn0 /=.
      unfold div_floor; simpl.
      set I2 := total_interference_bound_fp task_cost task_period [:: (tsk1, 2)].
      assert (H1: I2 3 = 2).
      {
        by rewrite /I2 /total_interference_bound_fp big_cons big_nil; compute.
      }
      assert (H2: I2 4 = 2).
      {
        by rewrite /I2 /total_interference_bound_fp big_cons big_nil; compute.
      }
      rewrite H1 H2.
      have H3: 3 + 2 %/ num_cpus = 4 by compute.
      rewrite H3 H2 H3 H2 H3.
      have H4: 3 < 6 by compute.
      rewrite H4; clear H4 H2 H1 I2.
      unfold fp_bound_of_task.
      have H5: per_task_rta task_cost task_period num_cpus tsk3 [:: (tsk1, 2); (tsk2, 4)] (max_steps task_cost task_deadline tsk3) = 4.
      {
        Ltac g := rewrite /total_interference_bound_fp /interference_bound_generic
          /W /max_jobs /div_floor /div_ceil !big_cons big_nil /= /higher_priority_task /= ?addn0; compute.
        rewrite /per_task_rta iterSr /div_floor.
        set x10 := total_interference_bound_fp  _ _ _ _.
        have I10: x10 = 5 by unfold x10; g.
        rewrite I10 iterSr.
        set x9 := total_interference_bound_fp  _ _ _ _.
        have I9: x9 = 5 by unfold x9; g.
        rewrite I9 iterSr.
        set x8 := total_interference_bound_fp  _ _ _ _.
        have I8: x8 = 5 by unfold x8; g.
        rewrite I8 iterSr.
        set x7 := total_interference_bound_fp  _ _ _ _.
        have I7: x7 = 5 by unfold x7; g.
        rewrite I7 iterSr.
        set x6 := total_interference_bound_fp  _ _ _ _.
        have I6: x6 = 5 by unfold x6; g.
        rewrite I6 iterSr.
        set x5 := total_interference_bound_fp  _ _ _ _.
        have I5: x5 = 5 by unfold x5; g.
        rewrite I5 iterSr.
        set x4 := total_interference_bound_fp  _ _ _ _.
        have I4: x4 = 5 by unfold x4; g.
        rewrite I4 iterSr.
        set x3 := total_interference_bound_fp  _ _ _ _.
        have I3: x3 = 5 by unfold x3; g.
        rewrite I3 iterSr.
        set x2 := total_interference_bound_fp  _ _ _ _.
        have I2: x2 = 5 by unfold x2; g.
        rewrite I2 iterSr.
        set x1 := total_interference_bound_fp  _ _ _ _.
        have I1: x1 = 5 by unfold x1; g.
        rewrite I1 iterSr.
        set x0 := total_interference_bound_fp  _ _ _ _.
        have I0: x0 = 5 by unfold x0; g.
        by rewrite /= I0; compute.
      }
      by rewrite H5.
    Qed.

    (* Let arr_seq be the periodic arrival sequence from ts. *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* Assume rate-monotonic priorities. *)
    Let higher_priority := FP_to_JLDP job_task (RM task_period).

    Section FactsAboutPriorityOrder.

      Lemma ts_has_unique_priorities :
        FP_is_antisymmetric_over_task_set (RM task_period) ts.
      Proof.
        unfold RM; intros tsk tsk' IN IN' HP HP'.
        have EQ: task_period tsk = task_period tsk' by apply/eqP; rewrite eqn_leq HP HP'.
        clear HP HP'.
        rewrite !in_cons 2!in_nil 2!orbF in IN IN'; des; rewrite IN IN'; try (by done);
        subst tsk tsk'; simpl in *; by done.
      Qed.

      Lemma priority_is_total :
        FP_is_total_over_task_set (RM task_period) ts.
      Proof.
        unfold RM; intros tsk tsk' IN IN'.
        destruct (leqP (task_period tsk) (task_period tsk'));
          [by left | by right; apply ltnW].
      Qed.

    End FactsAboutPriorityOrder.

    (* Let sched be the work-conserving RM scheduler. *)
    Let sched := scheduler job_arrival job_cost num_cpus arr_seq higher_priority.

    (* Recall the definition of deadline miss. *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* Next, we prove that ts is schedulable with the result of the test. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      intros tsk IN.
      have VALID := periodic_arrivals_valid_job_parameters ts ts_has_valid_parameters.
      have TSVALID := ts_has_valid_parameters.
      unfold valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_fp_rta with (task_cost := task_cost)
       (task_period := task_period) (task_deadline := task_deadline)
       (ts0 := ts) (higher_priority0 := RM task_period); try (by done).
      - by apply ts_has_constrained_deadlines.
      - by apply ts_has_unique_priorities.
      - by apply priority_is_total.
      - by apply RM_is_transitive.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply scheduler_jobs_come_from_arrival_sequence.
      - by apply scheduler_jobs_must_arrive_to_execute.
      - apply scheduler_completed_jobs_dont_execute.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - by apply scheduler_work_conserving, periodic_arrivals_are_consistent.
      - apply scheduler_respects_policy.
        -- by apply periodic_arrivals_are_consistent.
        -- by intros t; apply RM_is_transitive.
        -- by intros t x y; apply leq_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisFP.


(* In this file we show that for any category C,
   the monoidal category of pointed functors of C is equivalent to
   the monoidal category of monoidal-pointed objects in the monoidal category of pointed functors of C.

   By equivalence, we mean that these two monoidal categories
   are (internally) equivalent as objects in the bicategory of monoidal categories
*)

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.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal.
Require Import UniMath.CategoryTheory.coslicecat.

Require Import UniMath.Bicategories.Core.Bicat.

(* The monoidal categories of endofunctors that we compare are defined in the following files: *)
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects.
Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsWhiskeredMonoidal.
Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal.

(* The notion of internal adjoint equivalences in a bicategory is defined in: *)
Require Import UniMath.Bicategories.Morphisms.Adjunctions.

(* The necessary bicategories *)
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.
Require Import UniMath.Bicategories.MonoidalCategories.BicatOfWhiskeredMonCats.

Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.

Local Open Scope cat.

Section PointedFunctorsIdempotentGeneralMonoidalCats.

  Context {V : category} (Mon_V : monoidal V).

  Definition adj_equivalence_ptdfunctor_in_cat
    : adjoint_equivalence
        (B := bicat_of_cats)
        (coslice_cat_total V (monoidal_unit Mon_V))
        (coslice_cat_total (coslice_cat_total V (monoidal_unit Mon_V)) (monoidal_unit (monoidal_pointed_objects Mon_V))).
  Proof.
    use make_adjoint_equivalence.
    - exact (ptdob_to_ptdptdob Mon_V).
    - exact (ptdptdob_to_ptdob Mon_V).
    - exact (unit_ptdob Mon_V).
    - exact (counit_ptdob Mon_V).
    - use nat_trans_eq.
      { apply homset_property. }
      intro.
      use total2_paths_f.
      2: { apply homset_property. }
      use total2_paths_f.
      2: { apply homset_property. }
      simpl.
      rewrite ! id_right.
      apply idpath.
    - use nat_trans_eq.
      { apply homset_property. }
      intro.
      use total2_paths_f.
      2: { apply homset_property. }
      simpl.
      rewrite ! id_right.
      apply idpath.
    - repeat (use tpair).
      + intro.
        exists (identity _).
        apply id_right.
      + intro ; intros.
        use total2_paths_f.
        2: { apply homset_property. }
        etrans. { apply id_right. }
        apply (! id_left _).
      + apply nat_trans_eq.
        { apply homset_property. }
        intro.
        use total2_paths_f.
        2: { apply homset_property. }
        apply id_right.
      + apply nat_trans_eq.
        { apply homset_property. }
        intro.
        use total2_paths_f.
        2: { apply homset_property. }
        apply id_right.
    - repeat (use tpair).
      + intro.
        exists (identity _).
        use total2_paths_f.
        2: { apply homset_property. }
        simpl.
        rewrite (! pr22 x).
        rewrite id_left.
        apply id_right.
      + intro ; intros.
        use total2_paths_f.
        2: { apply homset_property. }
        etrans. { apply id_right. }
        apply (! id_left _).
      + apply nat_trans_eq.
        { apply homset_property. }
        intro.
        use total2_paths_f.
        2: { apply homset_property. }
        apply id_right.
      + apply nat_trans_eq.
        { apply homset_property. }
        intro.
        use total2_paths_f.
        2: { apply homset_property. }
        apply id_right.
  Defined.

  Definition disp_left_adjoint_data_ptdfunctor_in_moncat
    : disp_left_adjoint_data
            (D := bidisp_monbicat_disp_prebicat)
            adj_equivalence_ptdfunctor_in_cat
            (ptdob_to_ptdptdob_fmonoidal Mon_V).
  Proof.
    exists (ptdptdob_to_ptdob_fmonoidal Mon_V).
    split.
      + use tpair.
        * intro ; intros.
          abstract (
              use total2_paths_f ;
              [
                simpl ;
                rewrite (bifunctor_leftid Mon_V) ;
                rewrite (bifunctor_rightid Mon_V) ;
                rewrite ! id_right ;
                apply idpath
              | apply homset_property
              ]
            ).
        * abstract (use total2_paths_f ; [apply idpath | apply homset_property ]).
      + use tpair.
        * intro ; intros.
          abstract (
              use total2_paths_f ;
              [
                use total2_paths_f ;
                [
                  simpl ;
                  rewrite (bifunctor_leftid Mon_V) ;
                  rewrite (bifunctor_rightid Mon_V) ;
                  rewrite ! id_right ;
                  apply idpath
                | apply homset_property
                ]
              | apply homset_property
              ]
            ).
        * abstract (
              use total2_paths_f ;
              [
                use total2_paths_f ;
                [
                  simpl ;
                  rewrite ! id_right ;
                  apply idpath
                | apply homset_property
                ]
              | apply homset_property
              ]
            ).
  Defined.

  Lemma disp_left_adjoint_axioms_ptdfunctor_in_moncat
    :  disp_left_adjoint_axioms
         adj_equivalence_ptdfunctor_in_cat
         disp_left_adjoint_data_ptdfunctor_in_moncat.
  Proof.
    split.
        * use total2_paths_f.
          2: { apply homset_property. }
          repeat (apply funextsec ; intro).
          apply homset_property.
        * use total2_paths_f.
          2: { apply homset_property. }
          repeat (apply funextsec ; intro).
          apply homset_property.
  Qed.

  Lemma disp_left_equivalence_axioms_ptdfunctor_in_moncat
    :  disp_left_equivalence_axioms
         adj_equivalence_ptdfunctor_in_cat
         disp_left_adjoint_data_ptdfunctor_in_moncat.
  Proof.
    repeat (use tpair).
    - intro ; intro.
      use total2_paths_f.
      2: { apply homset_property. }
      simpl.
      rewrite (bifunctor_rightid Mon_V).
      rewrite (bifunctor_leftid Mon_V).
      apply idpath.
    - use total2_paths_f.
      2: { apply homset_property. }
      simpl.
      rewrite ! id_right.
      apply idpath.
    - use total2_paths_f.
      2: { apply homset_property. }
      repeat (apply funextsec ; intro).
      apply homset_property.
    - use total2_paths_f.
      2: { apply homset_property. }
      repeat (apply funextsec ; intro).
      apply homset_property.
    - intro ; intro.
      use total2_paths_f.
      2: { apply homset_property. }
      repeat (apply funextsec ; intro).
      use total2_paths_f.
      2: { apply homset_property. }
      simpl.
      rewrite (bifunctor_rightid Mon_V).
      rewrite (bifunctor_leftid Mon_V).
      rewrite ! id_right.
      apply idpath.
    - use total2_paths_f.
      2: { apply homset_property. }
      use total2_paths_f.
      2: { apply homset_property. }
      simpl.
      apply idpath.
    - use total2_paths_f.
      2: { apply homset_property. }
      repeat (apply funextsec ; intro).
      apply homset_property.
    - use total2_paths_f.
      2: { apply homset_property. }
      repeat (apply funextsec ; intro).
      apply homset_property.
  Qed.

  Definition disp_adj_equivalence_ptdfunctor_in_moncat
    : disp_left_adjoint_equivalence
            (D := bidisp_monbicat_disp_prebicat)
            adj_equivalence_ptdfunctor_in_cat
             (ptdob_to_ptdptdob_fmonoidal Mon_V).
  Proof.
    exists disp_left_adjoint_data_ptdfunctor_in_moncat.
    exists disp_left_adjoint_axioms_ptdfunctor_in_moncat.
    exact disp_left_equivalence_axioms_ptdfunctor_in_moncat.
  Defined.

  Definition adj_equivalence_ptdfunctor_in_moncat
    : adjoint_equivalence
        (B := monbicat)
        (_ ,, monoidal_pointed_objects Mon_V)
        (_ ,, monoidal_pointed_objects (monoidal_pointed_objects Mon_V)).
  Proof.
    use (invmap (adjoint_equivalence_total_disp_weq _ _) _).
    exists adj_equivalence_ptdfunctor_in_cat.
    exists (ptdob_to_ptdptdob_fmonoidal Mon_V).
    exact disp_adj_equivalence_ptdfunctor_in_moncat.
  Defined.

End PointedFunctorsIdempotentGeneralMonoidalCats.

Definition adj_equivalence_ptdfunctor (C : category)
  : adjoint_equivalence
      (B := monbicat)
      (_ ,, pointedfunctors_moncat C)
      (_ ,, monoidal_pointed_objects (pointedfunctors_moncat C))
  := adj_equivalence_ptdfunctor_in_moncat (monoidal_of_endofunctors C).


Require Import Morphisms Setoid.
Require Import Utf8.

Add LoadPath "../theories" as CatQ.
From CatQ.Structures Require Import Structures.
Require Import CatQ.Categories.FunCat.
Require Import CatQ.Functors.Bifunctor.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Universe Polymorphism.

Program Definition yoneda {C : Category} : Functor C (PSh[C]) :=
  [fmap: fun _ _ f => homFunctor[-,f]n with fun a => (homFunctor[-,a] : PSh[C]) ].
Next Obligation.
  unfold Proper, respectful.
  intros.
  unfold Bifunctor_apply_R.
  simpl.
  rewrite H.
  reflexivity.
Defined.
Next Obligation.
  rewrite right_id_of.
  rewrite left_id_of.
  reflexivity.
Defined.
Next Obligation.
  rewrite right_id_of.
  rewrite right_id_of.
  rewrite right_id_of.
  apply assoc_of.
Defined.

Program Definition YonedaLemma_right {C : Category} {a : C} {F : PSh[C]} : @morphism PSh[C] (yoneda a) F -⇒ F a
  := [mapoid: fun yaF => yaF a identity].
Next Obligation.
  solve_proper.
Defined.

Program Definition YonedaLemma_left {C : Category} {a : C} {F : PSh[C]} : F a -⇒ @morphism (PSh[C]) (yoneda a) F
  := [mapoid: fun Fa => [Nat: fun (b : opposite C) => [mapoid: fun (ba : opposite_obj b ⟶ a) => fmap F ba Fa] ] ].
Next Obligation.
  unfold Proper, respectful.
  intros.
  apply mapoid_apply.
  rewrite H.
  reflexivity.
Defined.
Next Obligation.
  constructor.
  simpl.
  intros.

  refine
    (`begin
      (fmap F f) (fmap F x Fa)
     ↑⟨ Setoids_comp Fa ⟩
      (fmap F f ∘ fmap F x) Fa
     =⟨ _ ⟩
      fmap F (f ∘{opposite C} (x ∘{opposite C} identity)) Fa
     =⟨ _ ⟩
      fmap F ((identity ∘ x) ∘ f) Fa
     `end).
  - reflexivity.
  - apply mapoid_apply.
    rewrite <- fmap_compose.
    rewrite right_id_of.
    reflexivity.
Defined.
Next Obligation.
  unfold Proper, respectful.
  simpl.
  intros.
  rewrite H.
  reflexivity.
Defined.

Lemma Yoneda {C : Category} {a : C} {F : PSh[C]} : @morphism (PSh[C]) (yoneda a) F ≃ F a in Setoids.
Proof.
  refine [iso: (YonedaLemma_right : @hom Setoids _ _) with (YonedaLemma_left : @hom Setoids _ _) ].
  constructor.
  - unfold YonedaLemma_right, YonedaLemma_left.
    simpl.
    intros.

    refine
      (`begin
        fmap F x0 ((x a) identity)
       =⟨ ltac: (apply Setoids_comp; reflexivity) ⟩
        (fmap F x0 ∘ x a) identity
       =⟨ mapoid_apply identity (naturality_of x) ⟩
        (x A ∘ fmap (homFunctor[-,a]) x0) identity
       =⟨ ltac: (apply Setoids_comp; reflexivity) ⟩
        (x A) (fmap (homFunctor[-,a]) x0 identity)
       =⟨ mapoid_cong (x A) hom_refl ⟩
        (x A) ((identity ∘ identity) ∘ x0)
       =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
        (x A) (identity ∘ x0)
       =⟨ ltac: (rewrite left_id_of; reflexivity) ⟩
        (x A) x0
       `end).

  - unfold YonedaLemma_right, YonedaLemma_left.
    simpl.
    intros.

    refine
      (`begin
        (fmap F identity) x
       =⟨ mapoid_apply x (fmap_identity F) ⟩
        @identity Setoids _ x
       =⟨ _ ⟩
        x
       `end).

    reflexivity.
Qed.

Program Definition yF {C : Category} {F : PSh[C]} : Functor (opposite C) Setoids :=
  [fmap: fun a b f => [mapoid: fun yaF => yaF ∘ fmap yoneda (opposite_hom f) by _]
   with fun a => (morphism (yoneda (opposite_obj a)) F : object Setoids)].
Next Obligation.
  unfold opposite_obj, opposite_hom.
  solve_proper.
Defined.
Next Obligation.
  unfold opposite_obj, opposite_hom.
  unfold Proper, respectful.
  simpl.
  intros.
  rewrite H.
  reflexivity.
Defined.
Next Obligation.
  unfold opposite_hom.
  rewrite left_id_of.
  rewrite right_id_of.
  reflexivity.
Defined.
Next Obligation.
  apply mapoid_cong.
  rewrite right_id_of.
  rewrite right_id_of.
  rewrite right_id_of.
  simpl.
  rewrite <- assoc_of.
  reflexivity.
Defined.

Program Definition yoneda_lemma_nat {C : Category} {F : PSh[C]} : Nat yF F :=
  [Nat: fun a => @YonedaLemma_right C a F].
Next Obligation.
  constructor.
  unfold YonedaLemma_right.
  simpl.
  intros.

  refine
    (`begin
      fmap F f (x a identity)
     =⟨ ltac: (apply Setoids_comp) ⟩
      (fmap F f ∘ x a) identity
     =⟨ ltac: (apply mapoid_apply; apply naturality_of) ⟩
      (x b ∘ fmap (homFunctor[-,opposite_obj a]) f) identity
     =⟨ ltac: (apply Setoids_comp) ⟩
      (x b) (fmap (homFunctor[-,opposite_obj a]) f identity)
     =⟨ mapoid_cong (x b) hom_refl ⟩
      x b ((identity ∘{C} identity) ∘{C} opposite_hom f)
     =⟨ ltac: (rewrite left_id_of; rewrite left_id_of; reflexivity) ⟩
      x b (opposite_hom f)
     ↑⟨ ltac: (rewrite right_id_of; rewrite right_id_of; reflexivity) ⟩
      x b ((opposite_hom f ∘{C} identity) ∘{C} identity)
      `end).
Defined.

Theorem yoneda_ff {C : Category} : ff (@yoneda C).
Proof.
  unfold ff.
  intros.

  generalize (@Yoneda C a (yoneda b)).
  intro.
  destruct X as [X1 X2 Xprop].

  refine [iso: X2 with X1].
  destruct Xprop.
  constructor.
  - apply iso_on_right.
  - apply iso_on_left.
Qed.

(*
Corollary yoneda_ff_on_hom {C : Category} {a b : C} : (natiso : yoneda a x -≃→ yoneda b x) → isomorphic a b
*)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import
     Functor.Functor Functor.Const_Func Functor.Functor_Ops.
From Categories Require Import
     Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.Operations NatTrans.NatIso.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Limits.Limit Limits.Pointwise.
From Categories Require Import Ext_Cons.Arrow.
From Categories Require Import
     Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.GenProd.

(**
  This file shows that if a category is complete, then for any pair of objects
  x and y, we have (Arrow C) (Hom C x y) is isomorphic to
  Hom C x (Limit_of (Discr_Func Arr_y)).
  This of course would be a contradiction as soon as we have some objects c and
  d for which
  (Hom C c d) has more than one element. In other words, any complete category
   is a preorder category!!!

  The proof is precisely the proof that is given in Awodey's book
  "Category Theory" to show that any small and complete category is a preorder
  category. In deed, the constraints on universe variables generated by this
  proof, restricts C such that the level of its objects is less than or
  equal to the level of its arrows (Remember that in this development smallness
  and largeness is relative to universe levels).
*)

Section Complete_Preorder.
  Context (C : Category) (CC : Complete C) (x y : C).

  Local Definition Arr_y := (fun w : (Arrow C) => y).

  Local Definition LimOf_Arr_y := (LimitOf (Discr_Func Arr_y)).

  Local Definition GenProd_of_const_Hom_x_y :=
    Type_Cat_GenProd
      _
      (((@Fix_Bi_Func_1
           (C^op) _ _ x (Hom_Func.Hom_Func C)) ∘ (Discr_Func Arr_y)) _o)%object.

  Local Hint Extern 1 => cbn : core.

  Local Program Definition Func_Iso :
    (
      (Discr_Func
         (((@Fix_Bi_Func_1
              (C^op) _ _ x (Hom_Func.Hom_Func C))
             ∘ (Discr_Func Arr_y)) _o)%object
      )
        ≃ ((@Fix_Bi_Func_1
              (C^op) _ _ x (Hom_Func.Hom_Func C)) ∘ (Discr_Func Arr_y))%functor
    )%natiso
    :=
    {|
      iso_morphism := {|Trans := fun c h => h|};
      inverse_morphism := {|Trans := fun c h => h|}
    |}.

  Local Definition
        Local_Right_KanExt_Iso_Limits_Pointwise_LimOf_Arr_y__ISO__GenProd_of_const_Hom_x_y :
    (Local_Right_KanExt_Iso
      Func_Iso
      (Rep_Preserve_Limits _ x LimOf_Arr_y)
      ≃≃
      GenProd_of_const_Hom_x_y
      ::> LoKan_Cone_Cat _ _)%isomorphism
    := Local_Right_KanExt_unique _ _ _ _.

  Local Definition Hom_x_LimOf_Arr_y_ISO_Arrow_C_to_Hom_x_y :
    (((x --> ((LimOf_Arr_y _o) tt))%object%morphism)
       ≃≃ (Arrow C → x --> y)%morphism ::> Type_Cat)%isomorphism :=
    LoKan_Cone_Iso_object_Iso
      _
      _
      Local_Right_KanExt_Iso_Limits_Pointwise_LimOf_Arr_y__ISO__GenProd_of_const_Hom_x_y
      tt.

End Complete_Preorder.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export sequents_tacs.
Require Export Classical_Prop.
Require Export per_props_union.
Require Export per_props_equality.
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(* begin hide *)

(* end hide*)

(**

  Using the axiom of excluded middle from [Classical_Prop], we can
  easily prove the following squashed excluded middle rule:
<<
   H |- squash(P \/ ~P) ext Ax

     By SquashedEM

     H |- P in Type(i) ext Ax
>>

  where [mk_squash] is defined as
  [Definition mk_squash T := mk_image T (mk_lam nvarx mk_axiom)], i.e.,
  we map all the elements of [T] to [mk_axiom].
  The only inhabitant of [mk_squash T] is [mk_axiom],
  and we can prove that [mkc_axiom] is a member of [mkc_squash T] iff
  [T] is inhabited.  However, in the theory, there is in general no
  way to know which terms inhabit [T].

 *)

Definition rule_squashed_excluded_middle {o}
           (P : NTerm)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_squash (mk_or P (mk_not P)))))
    [ mk_baresequent H (mk_conclax (mk_member P (mk_uni i)))
    ]
    [].

Lemma rule_squashed_excluded_middle_true {o} :
  forall lib (P : NTerm),
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_squashed_excluded_middle P i H).
Proof.
  unfold rule_squashed_excluded_middle, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp  as [wf1 hyp1].
  destseq; allsimpl; proof_irr; GC.

  unfold closed_extract; simpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  rw @tequality_mkc_squash.
  rw @tequality_mkc_or.
  rw @tequality_not.
  rw @member_eq.
  rw @equality_in_mkc_squash.

  assert (tequality lib (lsubstc P w0 s1 c0) (lsubstc P w0 s2 c4)) as teq.
  (* begin proof of assert *)
  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2 eqh sim); clear hyp1; intro hyp1; exrepnd.
  lsubst_tac.
  rw @member_eq in hyp1.
  rw <- @member_member_iff in hyp1.
  apply member_in_uni in hyp1.
  apply tequality_in_uni_implies_tequality in hyp0; auto.
  (* end proof of assert *)

  dands; auto; try (spcast; computes_to_value_refl).

  generalize (classic (inhabited_type lib (lsubstc P w0 s1 c0))); intro inh.
  destruct inh as [inh | ninh].

  (* First, we assume that P is inhabited *)
  destruct inh as [t inh].
  exists (mkc_inl t).
  rw @equality_mkc_union; dands; auto;
  try (complete (allapply @tequality_refl; auto));
  try (complete (rw @tequality_not; allapply @tequality_refl; auto)).
  left.
  exists t t; auto; dands; try (spcast; computes_to_value_refl); auto.

  (* Now, we assume that P is not inhabited *)
  exists (@mkc_inr o mkc_axiom).
  rw @equality_mkc_union; dands; auto;
  try (complete (allapply @tequality_refl; auto));
  try (complete (rw @tequality_not; allapply @tequality_refl; auto)).
  right.
  exists (@mkc_axiom o) (@mkc_axiom o); auto; dands; try (spcast; computes_to_value_refl); auto.
  rw @equality_in_not; dands; auto; allapply @tequality_refl; auto.
Qed.

(* begin hide *)

(* end hide *)

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import OrderedRing.
Require Import RingMicromega.
Require Import Refl.
Require Import QArith.
Require Import Qfield.
(*Declare ML Module "micromega_plugin".*)

Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq  Qle Qlt.
Proof.
  constructor; intros ; subst ; try (intuition (subst; auto with qarith)).
  apply Q_Setoid.
  rewrite H ; rewrite H0 ; reflexivity.
  rewrite H ; rewrite H0 ; reflexivity.
  rewrite H ; auto ; reflexivity.
  rewrite <- H ; rewrite <- H0 ; auto.
  rewrite H ; rewrite H0 ; auto.
  rewrite <- H ; rewrite <- H0 ; auto.
  rewrite H ; rewrite  H0 ; auto.
  apply Qsrt.
  eapply Qle_trans ; eauto.
  apply (Qlt_not_eq n m H H0) ; auto.
  destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto.
  apply (Qplus_le_compat  p p n m  (Qle_refl p) H).
  generalize (Qmult_lt_compat_r 0 n m H0 H).
  rewrite Qmult_0_l.
  auto.
  compute in H.
  discriminate.
Qed.

Lemma QSORaddon :
  SORaddon 0 1 Qplus Qmult Qminus Qopp  Qeq  Qle (* ring elements *)
  0 1 Qplus Qmult Qminus Qopp (* coefficients *)
  Qeq_bool Qle_bool
  (fun x => x) (fun x => x) (pow_N 1 Qmult).
Proof.
  constructor.
  constructor ; intros ; try reflexivity.
  apply Qeq_bool_eq; auto.
  constructor.
  reflexivity.
  intros x y.
  apply Qeq_bool_neq ; auto.
  apply Qle_bool_imp_le.
Qed.

(*Definition Zeval_expr :=  eval_pexpr 0 Zplus Zmult Zminus Zopp  (fun x => x) (fun x => Z_of_N x) (Zpower).*)
Require Import EnvRing.

Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
  match e with
    | PEc c =>  c
    | PEX j =>  env j
    | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
    | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
    | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
    | PEopp pe1 => - (Qeval_expr env pe1)
    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z_of_N n)
  end.

Lemma Qeval_expr_simpl : forall env e,
  Qeval_expr env e =
  match e with
    | PEc c =>  c
    | PEX j =>  env j
    | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
    | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
    | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
    | PEopp pe1 => - (Qeval_expr env pe1)
    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z_of_N n)
  end.
Proof.
  destruct e ; reflexivity.
Qed.

Definition Qeval_expr' := eval_pexpr  Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult).

Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n.
Proof.
  destruct n ; reflexivity.
Qed.

Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e.
Proof.
  induction e ; simpl ; subst ; try congruence.
  reflexivity.
  rewrite IHe.
  apply QNpower.
Qed.

Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop :=
match o with
| OpEq =>  Qeq
| OpNEq => fun x y  => ~ x == y
| OpLe => Qle
| OpGe => fun x y => Qle y x
| OpLt => Qlt
| OpGt => fun x y => Qlt y x
end.

Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) :=
  let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs).

Definition Qeval_formula' :=
  eval_formula  Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).

Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f.
Proof.
  intros.
  unfold Qeval_formula.
  destruct f.
  repeat rewrite Qeval_expr_compat.
  unfold Qeval_formula'.
  unfold Qeval_expr'.
  split ; destruct Fop ; simpl; auto.
Qed.

Definition Qeval_nformula :=
  eval_nformula 0 Qplus Qmult  Qeq Qle Qlt (fun x => x) .

Definition Qeval_op1 (o : Op1) : Q -> Prop :=
match o with
| Equal => fun x : Q => x == 0
| NonEqual => fun x : Q => ~ x == 0
| Strict => fun x : Q => 0 < x
| NonStrict => fun x : Q => 0 <= x
end.

Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
Proof.
  exact (fun env d =>eval_nformula_dec Qsor (fun x => x)  env d).
Qed.

Definition QWitness := Psatz Q.

Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool.

Require Import List.

Lemma QWeakChecker_sound :   forall (l : list (NFormula Q)) (cm : QWitness),
  QWeakChecker l cm = true ->
  forall env, make_impl (Qeval_nformula env) l False.
Proof.
  intros l cm H.
  intro.
  unfold Qeval_nformula.
  apply (checker_nf_sound Qsor QSORaddon l cm).
  unfold QWeakChecker in H.
  exact H.
Qed.

Require Import Tauto.

Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.

Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness)  : bool :=
  @tauto_checker (Formula Q) (NFormula Q)
  Qnormalise
  Qnegate QWitness QWeakChecker f w.

Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f  (Qeval_formula env)  f.
Proof.
  intros f w.
  unfold QTautoChecker.
  apply (tauto_checker_sound  Qeval_formula Qeval_nformula).
  apply Qeval_nformula_dec.
  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now  apply (cnf_normalise_correct Qsor QSORaddon).
  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon).
  intros t w0.
  apply QWeakChecker_sound.
Qed.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


Require Import VST.msl.sepalg.
Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.

Import ListNotations.

Inductive list_join {A} {JA: Join A} {SA: Sep_alg A} {SI: Sing_alg A}:
  list A -> A -> Prop :=
| join_nil: forall it: A, list_join [] the_unit
| join_cons: forall l lj it c,
    list_join l lj -> join it lj c -> list_join (it :: l) c.

Lemma list_join_perm {A} {JA: Join A} {PA: Perm_alg A}
      {SA: Sep_alg A} {SI: Sing_alg A}:
  forall l1 l2 c, Permutation l1 l2 -> list_join l1 c -> list_join l2 c.
Proof.
  intros until c. intro. revert c. induction H; intros; auto.
  - inversion H0; subst. apply (join_cons l' lj); auto.
  - inversion H. subst; clear H. inversion H2; subst; clear H2.
    apply join_comm in H4. destruct (join_assoc H5 H4) as [lj0y [? ?]].
    apply join_cons with lj0y; auto. apply join_cons with lj0; auto.
Qed.

Lemma list_join_single {A} {JA: Join A} {PA: Perm_alg A}
      {SA: Sep_alg A} {SI: Sing_alg A}:
  forall x l c, In x l -> list_join l c ->
                exists l1 l2 y, l = l1 ++ x :: l2 /\
                                list_join (l1 ++ l2) y /\ join x y c.
Proof.
  intros until l. induction l; intros. 1: inversion H. simpl in H. destruct H.
  - subst. inversion H0; subst. exists [], l, lj. simpl; auto.
  - inversion H0; subst; clear H0. specialize (IHl _ H H3).
    destruct IHl as [l1 [l2 [y [? [? ?]]]]]. subst. apply join_comm in H5.
    destruct (join_assoc H2 H5) as [al1l2 [? ?]]. exists (a :: l1), l2, al1l2.
    repeat split; auto. simpl. apply join_cons with y; auto.
Qed.

Lemma list_join_cons_inv {A} {JA: Join A} {PA: Perm_alg A}
      {SA: Sep_alg A} {SI: Sing_alg A}:
  forall x l c, list_join (x :: l) c ->
                exists y, list_join l y /\ join x y c.
Proof. intros. inversion H. subst. exists lj. now split. Qed.


(**************************************************************************************************
* Preservation and Progress for STLC with Subtyping                                                 *
* Based on original code by: Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1
* Modifications by Bruno C. d. S. Oliveira, Shaobo Cui and Baber Rehman, January 2020, Coq v8.7.0   *
***************************************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibLN.
Implicit Types x : var.
Implicit Types X : var.

(* ***********************************************************************)
(** * Description of the Language *)

(** Representation of pre-types *)

Inductive typ : Set :=
  | typ_top   : typ
  | typ_int   : typ
  | typ_arrow : typ -> typ -> typ.

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm.

(** Opening up a term binder occuring in a term *)

Fixpoint open_ee_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x     => trm_fvar x
  | trm_abs V e1  => trm_abs V (open_ee_rec (S k) f e1)
  | trm_app e1 e2 => trm_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "t 'open_ee_var' x" := (open_ee t (trm_fvar x)) (at level 67).

(** Terms as locally closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_abs V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2).

(** Binding are mapping type term variables.
 [x ~: T] is a typing assumption *)

Notation "x ~: T" := (x ~ T)
  (at level 23, left associativity) : env_scope.

(** Environment is an associative list of bindings. *)

Definition env := LibEnv.env typ.

(** A environment E is well-formed if it contains no duplicate bindings *)

Inductive okt : env -> Prop :=
  | okt_empty :
      okt empty
  | okt_typ : forall E x T,
      okt E-> x # E -> okt (E & x ~: T).

(** Subtyping relation *)

Inductive sub : typ -> typ -> Prop :=
  | sub_top : forall S, sub S typ_top
  | sub_int : sub typ_int typ_int
  | sub_arrow : forall S1 S2 T1 T2, sub T1 S1 -> sub S2 T2 ->
      sub (typ_arrow S1 S2) (typ_arrow T1 T2).

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x T E ->
      typing E (trm_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_sub : forall S E e T,
      typing E e S ->
      sub S T ->
      typing E e T.

(** Values *)

Inductive value : trm -> Prop :=
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_ee e1 v2).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E e e' T,
  typing E e T ->
  red e e' ->
  typing E e' T.

Definition progress := forall e T,
  typing empty e T ->
     value e
  \/ exists e', red e e'.

(** Computing free term variables in terms *)

Fixpoint fv_ee (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs V e1  => (fv_ee e1)
  | trm_app e1 e2 => (fv_ee e1) \u (fv_ee e2)
  end.

(** Substitution for free term variables in terms. *)

Fixpoint subst_ee (z : var) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs V e1  => trm_abs V (subst_ee z u e1)
  | trm_app e1 e2 => trm_app (subst_ee z u e1) (subst_ee z u e2)
  end.

(* ********************************************************************** *)
(** * Tactics *)

(** Constructors as hints. *)

Hint Constructors term ok okt value red.

Hint Resolve
  sub_top sub_int sub_arrow
  typing_var typing_app typing_sub.

(** Gathering free names already used in the proofs *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let D := gather_vars_with (fun x : trm => fv_ee x) in
  let F := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u D \u F).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- sub ?E _ _  => E
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

Tactic Notation "apply_empty" constr(F) :=
  apply_empty_bis (get_env) F.

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; autos*.

(* ********************************************************************** *)
(** * Properties of Substitutions *)

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_ee_rec_term : forall u e,
  term e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_ee. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (trm_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_ee_fresh : forall x u e,
  x \notin fv_ee e -> subst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_ee_open_ee : forall t1 t2 u x, term u ->
  subst_ee x u (open_ee t1 t2) =
  open_ee (subst_ee x u t1) (subst_ee x u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_ee_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_ee_open_ee_var : forall x y u e, y <> x -> term u ->
  (subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall x u e,
  x \notin fv_ee e -> term u ->
  open_ee e u = subst_ee x u (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_ee_term : forall e1 Z e2,
  term e1 -> term e2 -> term (subst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
Qed.

Hint Resolve subst_ee_term.

(* ********************************************************************** *)
(** * Relations between well-formed environment and types well-formed
  in environments *)

(** If an environment is well-formed, then it does not contain duplicated keys. *)

Lemma ok_from_okt : forall E,
  okt E -> ok E.
Proof.
  induction 1; auto.
Qed.

Hint Extern 1 (ok _) => apply ok_from_okt.

(* ********************************************************************** *)
(** ** Properties of well-formedness of an environment *)

(** Inversion lemma *)

Lemma okt_push_inv : forall E x T,
  okt (E & x ~: T) -> okt E /\ x # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. autos.
Qed.

(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
  introv O. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_inv O).
  rewrite concat_assoc in *.
  apply okt_push_inv in O.
  destruct O. apply IHF in H.
  apply okt_typ; autos*.
Qed.

(** Automation *)

Hint Immediate okt_strengthen.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** The subtyping relation is restricted to well-formed objects. *)

(** The typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ term e.
Proof.

  induction 1; try splits*.
   pick_fresh y. specializes H0 y. destructs~ H0.
  apply okt_push_inv in H0. destruct H0. auto.
   apply_fresh* term_abs as y.
      specializes H0 y. destructs~ H0.
Qed.

(** The value relation is restricted to well-formed objects. *)

Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; autos*.
Qed.

(** The reduction relation is restricted to well-formed objects. *)

Lemma red_regular : forall t t',
  red t t' -> term t /\ term t'.
Proof.
  induction 1; split; autos* value_regular.
  inversions H. pick_fresh y. rewrite* (@subst_ee_intro y).
Qed.

(** Automation *)

Hint Extern 1 (okt ?E) =>
  match goal with
  | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (term ?e) =>
  match goal with
  | H: typing _ ?e _ |- _ => apply (proj32 (typing_regular H))
  | H: red ?e _ |- _ => apply (proj1 (red_regular H))
  | H: red _ ?e |- _ => apply (proj2 (red_regular H))
  end.

(* ********************************************************************** *)
(** * Properties of Subtyping *)

(* ********************************************************************** *)
(** Reflexivity (1) *)

Lemma sub_reflexivity : forall T,
  sub T T .
Proof.
  induction T; eauto.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity (3) *)

(*Definition transitivity_on Q := forall S T,
  sub S Q -> sub Q T -> sub S T.

Hint Unfold transitivity_on.*)

Require Import Program.Equality.

Lemma sub_transitivity : forall B A C, sub A B -> sub B C -> sub A C.
Proof.
  induction B; intros;
  generalize H0 H; clear H0; clear H; generalize A; clear A;
  intros; dependent destruction H0; auto;
  induction A; try (inversion H); eauto.
Qed.

(*Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof.
  induction Q; unfold transitivity_on; intros.
  generalize H0 H; clear H0; clear H; generalize S; clear S;
  intros; dependent destruction H0; auto;
  induction S; try (inversion H); eauto.
Qed.*)

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply* typing_app.
  apply* typing_sub.
Qed.

(************************************************************************ *)
(** Preservation by Term Substitution (8) *)

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
   introv TypT TypU. inductions TypT; introv; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  apply typing_regular in TypU. destruct TypU. auto.
  apply* typing_app.
  apply* typing_sub.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing (13) *)

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  forall U1 U2, sub T (typ_arrow U1 U2) ->
     sub U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ sub S2 U2.
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub.
  apply IHTyp. auto.
  eapply sub_transitivity. apply H. auto.
Qed.

(* ********************************************************************** *)
(** Preservation Result (20) *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  - inversions Red; try solve [ apply* typing_app ].
  destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2).
       autos*.
    apply* value_regular.
  (* case sub *)
  - apply* typing_sub.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)
(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ. gen_eq E: (@empty typ).
  gen_eq T: (typ_arrow U1 U2). gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H. autos*.
Qed.

(* ********************************************************************** *)
(** Progress Result (16) *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty typ). lets Typ': Typ.
  induction Typ; intros EQ; subst.
  left*.
  (* case: var *)
  false* binds_empty_inv.
  (* case: abs *)
  left*. apply value_abs. apply* typing_regular.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_ee e3 e2).  apply red_abs.
        apply* typing_regular. auto.
        exists (trm_app e1' e2). apply red_app_1. apply* typing_regular.
        auto.
  (* case: sub *)
  autos*.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith.

From Undecidability.Synthetic
  Require Import Definitions
                 ReducibilityFacts
                 InformativeDefinitions
                 InformativeReducibilityFacts.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils decidable discernable
                 fol_ops fo_sig fo_terms fo_logic
                 fo_sat fo_sat_dec

                 red_utils

                 Sig_Sig_fin
                 Sig_rem_props
                 Sig_rem_constants
                 Sig0
                 Sig1
                 Sig1_1
                 Sig_discernable.

Set Default Proof Using "Type".

Set Implicit Arguments.

Local Infix "≢" := discernable (at level 70, no associativity).

(* * Collection of high-level synthetic decidability results *)

Section Sig_MONADIC_Sig_11.

  Variable (Σ : fo_signature)
           (HΣ1 : forall s, ar_syms Σ s <= 1)
           (HΣ2 : forall r, ar_rels Σ r <= 1).

  Theorem FSAT_FULL_MONADIC_FSAT_11 : FSAT Σ ⪯ᵢ FSAT (Σ11 (syms Σ) (rels Σ)).
  Proof using HΣ2 HΣ1.
    apply ireduces_transitive with (Q := FSAT (Σno_props Σ)).
    + exists (Σrem_props HΣ2 0); intros A.
      apply exists_equiv; intro; apply Σrem_props_correct.
    + assert (forall s, ar_syms (Σno_props Σ) s <= 1) as H1.
      { simpl; auto. }
      exists (Σrem_constants H1 0); intros A.
      apply exists_equiv; intro; apply Σrem_constants_correct.
  Qed.

End Sig_MONADIC_Sig_11.

Section Sig_MONADIC_PROP.

  (* FSAT Σ(X,Y) and FSAT Σ(ø,Y) are inter-reducible
     is the arities on rels/Y are all 0, ie Propositional case

     Σ0 maps Σ into a signature with no function symbols and
     the same relation symbols, all of arity 0
   *)

  Variable (Σ : fo_signature)
           (HΣ : forall r, ar_rels Σ r = 0).

  Theorem FSAT_PROP_FSAT_x0 : FSAT Σ ⪯ᵢ FSAT (Σ0 Σ).
  Proof using HΣ. exists (@Σ_Σ0 Σ); exact (Σ_Σ0_correct HΣ). Qed.

  Theorem FSAT_x0_FSAT_PROP : FSAT (Σ0 Σ) ⪯ᵢ FSAT Σ.
  Proof using HΣ. exists (Σ0_Σ HΣ); exact (Σ0_Σ_correct HΣ). Qed.

End Sig_MONADIC_PROP.

(* Check FSAT_FULL_MONADIC_FSAT_11.
Print Assumptions FSAT_FULL_MONADIC_FSAT_11. *)

Section FSAT_MONADIC_DEC.

  (* No variables and uniform arity of 1 is decidable
      Signature must be discrete  *)

  Variable (F P : Type)
           (H1 : F -> False)
           (H2 : discrete P)
           (A : fol_form (Σ11 F P)).

  Theorem FSAT_MONADIC_DEC : decidable (FSAT _ A).
  Proof using H2 H1.
    destruct Sig_discrete_to_pos with (A := A)
      as (n & m & i & j & B & HB).
    + simpl; intros s; destruct (H1 s).
    + apply H2.
    + assert (n = 0) as ->.
      { destruct n; auto.
        destruct (H1 (i pos0)). }
      simpl in *.
      destruct FSAT_ΣP1_dec with (V := pos 0) (A := B)
        as [ H | H ].
      * intros p; invert pos p.
      * left; apply HB; auto.
      * right; rewrite HB; auto.
  Qed.

End FSAT_MONADIC_DEC.

Section FSAT_MONADIC_11_FSAT_MONADIC_1.

  Variable (n : nat) (Y : Type) (HY : finite_t Y).

  Theorem FSAT_MONADIC_11_FSAT_MONADIC_1 :
            FSAT (Σ11 (pos n) Y) ⪯ᵢ FSAT (Σ11 Empty_set (list (pos n)*Y + Y)).
  Proof using HY.
    apply ireduces_dependent, Σ11_Σ1_reduction; auto.
  Qed.

End FSAT_MONADIC_11_FSAT_MONADIC_1.

Section FSAT_Σ11_DEC.

  Variable (n : nat)
           (P : Type)
           (HP1 : finite_t P)
           (HP2 : discrete P)
           (A : fol_form (Σ11 (pos n) P)).

  Theorem FSAT_Σ11_DEC : decidable (FSAT _ A).
  Proof using HP2 HP1.
    destruct FSAT_MONADIC_11_FSAT_MONADIC_1 with (n := n) (1 := HP1)
      as (f & Hf).
    specialize (Hf A).
    destruct FSAT_MONADIC_DEC with (A := f A) as [ H | H ]; simpl; auto; try easy.
    + left; revert H; apply Hf.
    + right; contradict H; revert H; apply Hf.
  Qed.

End FSAT_Σ11_DEC.

Section FSAT_FULL_Σ11_DEC.

  Variable (F P : Type) (HF : discrete F) (HP : discrete P)
           (A : fol_form (Σ11 F P)).

  Hint Resolve finite_t_pos : core.

  Theorem FSAT_FULL_Σ11_DEC : decidable (FSAT _ A).
  Proof using HP HF.
    destruct Sig_discrete_to_pos with (A := A)
      as (n & m & i & j & B & HB); auto.
    destruct FSAT_Σ11_DEC with (A := B) as [ H | H ]; auto.
    + left; apply HB; auto.
    + right; contradict H; apply HB; auto.
  Qed.

End FSAT_FULL_Σ11_DEC.

Section FSAT_FULL_MONADIC_DEC.

  (* We can be (a bit) more general here, see discernable.v
     However, decidable discernability is required
     for showing FSAT is decidable *)

  Variable (Σ : fo_signature)
           (H1 : discrete (syms Σ))
           (H2 : discrete (rels Σ))
           (H3 : forall s, ar_syms Σ s <= 1)
           (H4 : forall r, ar_rels Σ r <= 1).

  Theorem FSAT_FULL_MONADIC_DEC A : decidable (FSAT Σ A).
  Proof using H4 H3 H2 H1.
    destruct FSAT_FULL_MONADIC_FSAT_11 with Σ as (f & Hf); auto.
    destruct FSAT_FULL_Σ11_DEC with (A := f A) as [ H | H ]; auto.
    + left; apply Hf, H.
    + right; contradict H; apply Hf, H.
  Qed.

  (* The case where ar_rels Σ r = 0 for any r also gives
     decidability regardless of syms arities because formulas
     contain no terms *)

End FSAT_FULL_MONADIC_DEC.

(* Check FSAT_FULL_MONADIC_DEC.
Print Assumptions FSAT_FULL_MONADIC_DEC. *)

Section FSAT_PROP_ONLY_DEC.

  Variable (Σ : fo_signature)
           (H1 : discrete (rels Σ))
           (H2 : forall r, ar_rels Σ r = 0).

  Theorem FSAT_PROP_ONLY_DEC A : decidable (FSAT Σ A).
  Proof using H2 H1.
    destruct (FSAT_PROP_FSAT_x0 H2) as (f & Hf).
    destruct FSAT_FULL_MONADIC_DEC with (A := f A)
      as [ H | H ]; auto.
    + intros [].
    + left; revert H; apply Hf; auto.
    + right; contradict H; revert H; apply Hf; auto.
  Qed.

End FSAT_PROP_ONLY_DEC.

(* Check FSAT_PROP_ONLY_DEC.
Print Assumptions FSAT_PROP_ONLY_DEC. *)

Theorem FULL_MONADIC (Σ : fo_signature) :
          { _ : discrete (syms Σ) &
          { _ : discrete (rels Σ)
              | (forall s, ar_syms Σ s <= 1)
             /\ (forall r, ar_rels Σ r <= 1) } }
        + { _ : discrete (rels Σ)
              | forall r, ar_rels Σ r = 0 }
       -> forall A, decidable (FSAT Σ A).
Proof.
  intros [ (H1 & H2 & H3 & H4) | (H1 & H2) ].
  + apply FSAT_FULL_MONADIC_DEC; auto.
  + apply FSAT_PROP_ONLY_DEC; auto.
Qed.

Theorem Σ11_discernable_dec_FSAT X Y :
          (forall u v : X, decidable (u ≢ v))
       -> (forall u v : Y, decidable (u ≢ v))
       -> forall A, decidable (FSAT (Σ11 X Y) A).
Proof.
  intros H0 H1 A.
  destruct (Sig_discernable_dec_to_discrete H0 H1 A)
    as (DX & DY & ? & ? & ? & ? & B & HB); auto.
  destruct FSAT_FULL_MONADIC_DEC with (A := B); simpl; auto.
  + left; tauto.
  + right; tauto.
Qed.

Section FSAT_FULL_MONADIC_discernable.

  Variable (Σ : fo_signature)
           (H1 : forall u v : syms Σ, decidable (u ≢ v))
           (H2 : forall u v : rels Σ, decidable (u ≢ v))
           (H3 : forall s, ar_syms Σ s <= 1)
           (H4 : forall r, ar_rels Σ r <= 1).

  Theorem FSAT_FULL_MONADIC_discernable A : decidable (FSAT Σ A).
  Proof using H4 H3 H2 H1.
    destruct (FSAT_FULL_MONADIC_FSAT_11 H3 H4) as (f & Hf).
    destruct (Σ11_discernable_dec_FSAT H1 H2 (f A)) as [ H | H ].
    + left; apply Hf; auto.
    + right; contradict H; apply Hf; auto.
  Qed.

End FSAT_FULL_MONADIC_discernable.

Section FSAT_PROP_ONLY_discernable.

  Variable (Σ : fo_signature)
           (H1 : forall u v : rels Σ, decidable (u ≢ v))
           (H2 : forall r, ar_rels Σ r = 0).

  Theorem FSAT_PROP_ONLY_discernable A : decidable (FSAT Σ A).
  Proof using H2 H1.
    destruct (FSAT_PROP_FSAT_x0 H2) as (f & Hf).
    destruct FSAT_FULL_MONADIC_discernable with (A := f A)
      as [ H | H ]; auto.
    + intros [].
    + left; revert H; apply Hf; auto.
    + right; contradict H; revert H; apply Hf; auto.
  Qed.

End FSAT_PROP_ONLY_discernable.

Theorem FULL_MONADIC_discernable (Σ : fo_signature) :
          { _ : forall u v : syms Σ, decidable (u ≢ v) &
          { _ : forall u v : rels Σ, decidable (u ≢ v)
              | (forall s, ar_syms Σ s <= 1)
             /\ (forall r, ar_rels Σ r <= 1) } }
        + { _ : forall u v : rels Σ, decidable (u ≢ v)
              | forall r, ar_rels Σ r = 0 }
       -> forall A, decidable (FSAT Σ A).
Proof.
  intros [ (H1 & H2 & H3 & H4) | (H1 & H2) ].
  + apply FSAT_FULL_MONADIC_discernable; auto.
  + apply FSAT_PROP_ONLY_discernable; auto.
Qed.

(* For a monadic signature Σ (arity 0 or 1) with at least one unary relation,

   FSAT is decidable iff both syms and rels have decidable discernability
*)

Theorem FULL_MONADIC_discernable_dec_FSAT_dec_equiv Σ r :
            ar_rels Σ r = 1
         -> (forall s, ar_syms Σ s <= 1)
         -> (forall r, ar_rels Σ r <= 1)
         -> ( (forall u v : syms Σ, decidable (u ≢ v))
            * (forall u v : rels Σ, decidable (u ≢ v)) )
          ≋ forall A, decidable (FSAT Σ A).
Proof.
  intros Hr H1 H2.
  split.
  + intros (? & ?); apply FSAT_FULL_MONADIC_discernable; auto.
  + intros H3; split.
    * apply FSAT_dec_implies_discernable_syms_dec with r; auto.
    * apply FSAT_dec_implies_discernable_rels_dec; auto.
Qed.

(* For a signature with only constant relations (arity 0),
   FSAT is decidable iff relations have decidable discernability *)

Theorem MONADIC_PROP_discernable_dec_FSAT_dec_equiv (Σ : fo_signature) :
            (forall r, @ar_rels Σ r = 0)
        ->  (forall u v : rels Σ, decidable (u ≢ v))
          ≋  forall A, decidable (FSAT Σ A).
Proof.
  intros H; split.
  + intros; apply FULL_MONADIC_discernable; eauto.
  + intros H1.
    assert (forall A, decidable (FSAT (Σ0 Σ) A)) as H2.
    { revert H1; apply ireduction_decidable, FSAT_x0_FSAT_PROP; auto. }
    exact (FSAT_dec_implies_discernable_rels_dec H2).
Qed.


Require Import EqStuff.
Require Import Contexts.

Definition sigEqFix A (B:A->Type) a b p : (existT B a b = p)->(existT _ a b = existT _ (projT1 p) (projT2 p)).
	destruct p as (a',b').
	intro.
	exact H.
Defined.
Implicit Arguments sigEqFix [A B a b p].

Fixpoint natEq n m := match n,m with
	O,O => unit |
	S n,S m => natEq n m |
	_,_ => False
end.

Definition natEqEC n m : (n = m)->natEq n m.
	intro.
	apply (tr _ H).
	clear m H.
	revert n.
	exact (fix natEqRefl n : natEq n n := match n with
		O => tt |
		S n => natEqRefl n
	end).
Defined.
Implicit Arguments natEqEC [n m].

Definition natEqDC : forall n m,natEq n m->(n = m).
	refine (fix natEqDC n m : natEq n m->(n = m) := match n,m with
		O,O => fun _=>eq_refl _ |
		S n0,S m0 => fun c=>_ |
		_,_ => fun x=>match x with end
	end).
	simpl in c.
	apply (tr (fun _=>_) (natEqDC _ _ c)).
	reflexivity.
Defined.
Implicit Arguments natEqDC [n m].

Lemma natEqECDC n : forall m (e:natEq n m),natEqEC (natEqDC e) = e.
	induction n;intro;destruct m;intro;simpl in e.

	simpl.
	destruct e.
	reflexivity.

	destruct e.

	destruct e.

	set (e' := e) at 2.
	replace e' with (natEqEC (natEqDC e));[| apply IHn].
	clear e'.
	simpl.
	rewrite <- (natEqDC e).
	reflexivity.
Qed.

Lemma natEqDCEC n m (e:n = m) : natEqDC (natEqEC e) = e.
	rewrite <- e.
	clear m e.
	induction n.

	reflexivity.

	change (tr (fun m=>S n = S m) (natEqDC (natEqEC (eq_refl n))) (eq_refl (S n)) = eq_refl (S n)).
	rewrite IHn.
	reflexivity.
Qed.

Definition eqZipO D G C GL GR : ZipCtx D G C O GL GR->(existT (fun G=>forall d,G d->Type) G C = existT _ GL GR).
	intro.
	apply (zipCtxOInv X (fun _ _ _ _=>_)).
	reflexivity.
Defined.
Implicit Arguments eqZipO [D G C GL GR].

Definition zipOEq D G C GL GR : (existT _ G C = existT _ GL GR)->ZipCtx D G C O GL GR.
	intro.
	apply (tr (fun p:sigT (fun G=>forall d,G d->Type)=>match p with existT GL GR => ZipCtx D G C O GL GR end) H).
	apply zipCtxO.
Defined.
Implicit Arguments zipOEq [D G C GL GR].

Lemma ezInv D (G:D->Type) C GL GR (e:existT _ G C = existT _ GL GR) : eqZipO (zipOEq e) = e.
	refine (match e as e return eqZipO (zipOEq (sigEqFix e)) = sigEqFix e with eq_refl => _ end).
	reflexivity.
Qed.

Lemma zeInv D G C GL GR (z:ZipCtx D G C O GL GR) : zipOEq (eqZipO z) = z.
	pose (P n := ZipCtx D G C n GL GR).
	assert (forall e:O = O,zipOEq (eqZipO (tr P e z)) = tr P e z);[| exact (H (eq_refl _))].
	revert P.
	apply (zipCtxOInv z (fun n GL GR z=>let P n := ZipCtx D G C n GL GR in
		forall e:n = O,zipOEq (eqZipO (tr P e z)) = tr P e z)).
	clear GL GR z.
	intros.
	rewrite <- (natEqDCEC _ _ e).
	reflexivity.
Qed.

Remark eqZipO_zipO D G C : eqZipO (zipCtxO D G C) = eq_refl _.
	reflexivity.
Qed.

Lemma foo D G C : (forall z:ZipCtx D G C O G C,z = zipCtxO D G C)->
forall e:existT (fun G=>forall d,G d->Type) G C = existT _ G C,e = eq_refl _.
	intros.
	rewrite <- ezInv with (e := e).
	rewrite (H (zipOEq e)).
	reflexivity.
Qed.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics.
Require Import WildCat.Core.

(** ** Indexed product of categories *)

Global Instance isgraph_forall (A : Type) (B : A -> Type)
  `{forall a, IsGraph (B a)}
  : IsGraph (forall a, B a).
Proof.
  srapply Build_IsGraph.
  intros x y; exact (forall (a : A), x a $-> y a).
Defined.

Global Instance is01cat_forall (A : Type) (B : A -> Type)
  `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)}
  : Is01Cat (forall a, B a).
Proof.
  srapply Build_Is01Cat.
  + intros x a; exact (Id (x a)).
  + intros x y z f g a; exact (f a $o g a).
Defined.

Global Instance is0gpd_forall (A : Type) (B : A -> Type)
  (* Apparently when there's a [forall] there, Coq can't automatically add the [Is01Cat] instance from the [Is0Gpd] instance. *)
  `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)} `{forall a, Is0Gpd (B a)}
  : Is0Gpd (forall a, B a).
Proof.
  constructor.
  intros f g p a; exact ((p a)^$).
Defined.

Global Instance is2graph_forall (A : Type) (B : A -> Type)
  `{forall a, IsGraph (B a)} `{forall a, Is2Graph (B a)}
  : Is2Graph (forall a, B a).
Proof.
  intros x y; srapply Build_IsGraph.
  intros f g; exact (forall a, f a $-> g a).
Defined.

Global Instance is1cat_forall (A : Type) (B : A -> Type)
  `{forall a, IsGraph (B a)} `{forall a, Is01Cat (B a)}
  `{forall a, Is2Graph (B a)} `{forall a, Is1Cat (B a)}
  : Is1Cat (forall a, B a).
Proof.
  srapply Build_Is1Cat.
  + intros x y z h; srapply Build_Is0Functor.
    intros f g p a.
    exact (h a $@L p a).
  + intros x y z h; srapply Build_Is0Functor.
    intros f g p a.
    exact (p a $@R h a).
  + intros w x y z f g h a; apply cat_assoc.
  + intros x y f a; apply cat_idl.
  + intros x y f a; apply cat_idr.
Defined.