Require Import general.
Require Import iterms.
Require Import lterms.

Inductive Subterm_i : iterm -> iterm -> Prop :=
| subterm_i_eq : forall x, Subterm_i x x
| subterm_i_lapp_l : forall x y1 y2, Subterm_i x y1 -> Subterm_i x (y1 @i y2)
| subterm_i_lapp_r : forall x y1 y2, Subterm_i x y2 -> Subterm_i x (y1 @i y2).

Ltac pose_subterm_i := pose subterm_i_eq; pose subterm_i_lapp_l; pose subterm_i_lapp_r.

Inductive Subterm : lterm -> lterm -> Prop :=
| subterm_i : forall x y, Subterm_i x y -> Subterm (itm x) (itm y)
| subterm_eq : forall x, Subterm x x
| subterm_lapp_l : forall x y1 y2, Subterm x y1 -> Subterm x (y1 @l y2)
| subterm_lapp_r : forall x y1 y2, Subterm x y2 -> Subterm x (y1 @l y2)
| subterm_ltup_0
  : forall x y1 y2 ys, Subterm x y1 -> Subterm x (ltup y1 y2 ys)
| subterm_ltup_1 : forall x y1 y2 ys, Subterm x y2 -> Subterm x (ltup y1 y2 ys)
| subterm_ltup_2 : forall x y1 y2 ys z, In z ys -> Subterm x z -> Subterm x (ltup y1 y2 ys).

Lemma lem_subterm_ltup_2_prime :
  forall a x y z l l', Subterm a z -> Subterm a (ltup x y (l ++ z :: l')).
Proof.
  pose subterm_ltup_2; eauto with datatypes.
Qed.

Ltac pose_subterm := pose subterm_i; pose subterm_eq; pose subterm_lapp_l; pose subterm_lapp_r;
                     pose subterm_ltup_0; pose subterm_ltup_1; pose subterm_ltup_2;
                     pose lem_subterm_ltup_2_prime.

Lemma lem_subterm_i_app : forall x y z, Subterm_i (x @i y) z -> Subterm_i x z /\ Subterm_i y z.
Proof.
  induction z; try yelles 1.
  intro H; yinversion H; pose_subterm_i; ycrush.
Qed.

Lemma lem_subterm_i_trans : forall x y z, Subterm_i x y -> Subterm_i y z -> Subterm_i x z.
Proof.
  induction x; induction y;
    solve [ yelles 1 |
            intros z H; yinversion H; pose lem_subterm_i_app; pose_subterm_i; ycrush ].
Qed.

Lemma lem_subterm_app : forall x y z, Subterm (x @l y) z -> Subterm x z /\ Subterm y z.
Proof.
  intros x y z; lterm_induction z; try yelles 1.
  intro H; yinversion H; pose_subterm; ycrush.
  intro H; yinversion H.
  pose_subterm; ycrush.
  pose_subterm; ycrush.
  assert (Subterm x z /\ Subterm y z) by auto.
  pose_subterm; ycrush.
  intros z0 H; yinversion H; pose_subterm; ycrush.
Qed.

Lemma lem_subterm_ltup : forall x y l z, Subterm (ltup x y l) z ->
                                         Subterm x z /\ Subterm y z /\
                                         (forall u, In u l -> Subterm u z).
Proof.
  intros until z; lterm_induction z; simp_hyps; try yelles 1.
  pose_subterm; yelles 2.
  intro H5; yinversion H5; pose_subterm; try yelles 1.
  assert (Subterm x z /\ Subterm y z /\ (forall u : lterm, In u l -> Subterm u z)) by auto.
  yelles 1.
  intros z0 HH; yinversion HH; pose_subterm; ycrush.
Qed.

Lemma lem_subterm_trans : forall x y z, Subterm x y -> Subterm y z -> Subterm x z.
Proof.
  Ltac mytac z :=
    intro z; lterm_induction z; simp_hyps; pose_subterm; try iauto 1; try iauto 2.
  induction x.
  induction y; try yelles 1.
  pose lem_subterm_i_trans; mytac z.
  mytac z.
  mytac z.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  intros z H; yinversion H.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
  mytac z.
  pose lem_subterm_app; simp_hyps; iauto 1.
  pose lem_subterm_ltup; simp_hyps; iauto 1.
Qed.

Lemma lem_subterm_lterm_of_tuple :
  forall l t u, Subterm t u -> In u l -> Subterm t (lterm_of_tuple l).
Proof.
  induction l.
  ycrush.
  ydestruct l; pose_subterm; ycrush.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.priority.
Require Import prosa.classic.model.arrival.jitter.job
               prosa.classic.model.arrival.jitter.arrival_sequence
               prosa.classic.model.arrival.jitter.task_arrival.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path div.

(* In this file, we prove bounds on the number of actual task arrivals, i.e,
   taking release jitter into account. *)
Module ArrivalBounds.

  Import JobWithJitter ArrivalSequenceWithJitter SporadicTaskset Priority
         TaskArrivalWithJitter.

  Section BoundingActualArrivals.

    Context {Task: eqType}.
    Variable task_period: Task -> time.
    Variable task_jitter: Task -> time.

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

    (* Consider any job arrival sequence with consistent, duplicate-free arrivals... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arrival_sequence_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* ...where the jitter of each job is bounded by the jitter of its task. *)
    Hypothesis H_job_jitter_bounded:
      forall j,
        arrives_in arr_seq j ->
        job_jitter_leq_task_jitter task_jitter job_jitter job_task j.

    (* For simplicity, let's define some local names. *)
    Let actual_job_arrival := actual_arrival job_arrival job_jitter.

    (* In this section, we prove an upper bound on the number of jobs with actual arrival time
       in a given interval. *)
    Section UpperBoundOn.

      (* Assume that jobs are sporadic. *)
      Hypothesis H_sporadic_tasks: sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider any time interval [t1, t2)... *)
      Variable t1 t2: time.

      (* ...and let tsk be any task with period > 0. *)
      Variable tsk: Task.
      Hypothesis H_period_gt_zero: task_period tsk > 0.

      (* Recall the jobs of tsk with actual arrival time in [t1, t2), along with the corresponding
         number of arrivals. *)
      Let actual_arrivals := actual_arrivals_of_task_between job_arrival job_jitter
                                                             job_task arr_seq tsk t1 t2.
      Let num_actual_arrivals := num_actual_arrivals_of_task job_arrival job_jitter job_task
                                                             arr_seq tsk t1 t2.

      (* We will establish an upper bound on the number of actual arrivals of tsk.
         The proof follows by case analysis. *)

      (* Case 1: Assume that there are no jobs of tsk with actual arrival time in the interval. *)
      Section NoJobs.

        (* If there are no actual arrivals in [t1, t2), ...*)
        Hypothesis H_no_jobs: num_actual_arrivals = 0.

        (* ...then the arrival bound trivially holds. *)
        Lemma sporadic_arrival_bound_no_jobs:
          num_actual_arrivals <= div_ceil (t2 + task_jitter tsk - t1) (task_period tsk).
        Proof.
          by rewrite H_no_jobs.
        Qed.

      End NoJobs.

      (* Case 2: Assume that a single job of tsk has actual arrival time in the interval. *)
      Section OneJob.

        (* First, note that since the interval is open at time t2,
           t2 must be larger than t1. *)
        Lemma sporadic_arrival_bound_more_than_one_point:
          num_actual_arrivals > 0 ->
          t1 < t2.
        Proof.
          unfold num_actual_arrivals, num_actual_arrivals_of_task in *; intros ONE.
          rewrite -/actual_arrivals in ONE *.
          destruct actual_arrivals as [| j l] eqn:EQ; first by done.
          have IN: j \in actual_arrivals by rewrite EQ in_cons eq_refl orTb.
          rewrite mem_filter in IN; move: IN => /andP [_ ARR].
          rewrite mem_filter in ARR; move: ARR => /andP [GE ARR].
          by move: GE => /andP [GE LE]; apply: (leq_ltn_trans GE).
        Qed.

        (* Therefore, if there is one job of tsk with actual arrival time in [t1, t2), ... *)
        Hypothesis H_no_jobs: num_actual_arrivals = 1.

        (* ...then (t2 - t1) > 0 and the arrival bound also holds. *)
        Lemma sporadic_arrival_bound_one_job:
          num_actual_arrivals <= div_ceil (t2 + task_jitter tsk - t1) (task_period tsk).
        Proof.
          rewrite H_no_jobs.
          rewrite ceil_neq0 // ltn_subRL addn0.
          apply leq_trans with (n := t2); last by apply leq_addr.
          apply sporadic_arrival_bound_more_than_one_point.
          by rewrite H_no_jobs.
        Qed.

      End OneJob.

      (* Case 3: There are at least two actual job arrivals. *)
      Section AtLeastTwoJobs.

        (* Assume that there are at least two jobs of tsk with actual arrival in [t1,t2). *)
        Hypothesis H_at_least_two_jobs: num_actual_arrivals >= 2.

        (* We prove the arrival bound by contradiction. *)
        Section DerivingContradiction.

          (* Suppose that the number of arrivals is larger than the bound. *)
          Hypothesis H_many_arrivals:
            div_ceil (t2 + task_jitter tsk - t1) (task_period tsk) < num_actual_arrivals.

          (* Consider the list of jobs ordered by arrival times. *)
          Let by_arrival_time j j' := job_arrival j <= job_arrival j'.
          Let sorted_jobs := sort by_arrival_time actual_arrivals.

          (* Based on the notation for the n-th job in the sorted list of arrivals, ... *)
          Variable elem: Job.
          Let nth_job := nth elem sorted_jobs.

          (* ...we identify the first and last jobs and their respective arrival times. *)
          Let j_first := nth_job 0.
          Let j_last := nth_job (num_actual_arrivals.-1).
          Let a_first := job_arrival j_first.
          Let a_last := job_arrival j_last.

          (* Next, we recall from task_arrival.v the properties of the n-th job in
             the sequence... *)
          Corollary sporadic_arrival_bound_properties_of_nth:
            forall idx,
              idx < num_actual_arrivals ->
              t1 <= actual_job_arrival (nth_job idx) < t2 /\
              job_task (nth_job idx) = tsk /\
              arrives_in arr_seq (nth_job idx).
          Proof.
            by intros idx LTidx; apply sorted_arrivals_properties_of_nth.
          Qed.

          (* ...and that the first and last jobs are separated by at least
             (num_actual_arrivals - 1) periods. *)
          Corollary sporadic_arrival_bound_distance_between_first_and_last:
            a_last >= a_first + (num_actual_arrivals - 1) * task_period tsk.
          Proof.
            rename H_at_least_two_jobs into TWO.
            apply sorted_arrivals_distance_between_first_and_last; try (by done).
            by apply leq_ltn_trans with (n := 1).
          Qed.

          (* Next, because the number of actual arrivals is larger than the ceiling term,
             it follows that the first and last jobs are separated by at least the
             length of the interval plus the jitter of the task, ... *)
          Lemma sporadic_arrival_bound_last_job_too_far:
            a_first + t2 + task_jitter tsk - t1 <= a_last.
          Proof.
            have DIST := sporadic_arrival_bound_distance_between_first_and_last.
            have MORE := sporadic_arrival_bound_more_than_one_point.
            rename H_many_arrivals into MANY, H_at_least_two_jobs into TWO.
            destruct num_actual_arrivals; first by rewrite ltn0 in TWO.
            destruct n; first by rewrite ltnn in TWO.
            rewrite subn1 /= in DIST.
            apply leq_trans with (n := a_first + n.+1*task_period tsk); last by done.
            rewrite -addnA -addnBA;
              last by apply leq_trans with (n := t2); [by apply ltnW, MORE | by apply leq_addr].
            rewrite leq_add2l.
            unfold div_ceil in MANY.
            destruct (task_period tsk %| t2 + task_jitter tsk - t1) eqn:DIV;
              first by rewrite ltnS leq_divLR in MANY.
            by rewrite ltnS ltn_divLR // in MANY; apply ltnW.
          Qed.

          (* ...which implies that the last job arrives after the interval. *)
          Lemma sporadic_arrival_bound_last_arrives_too_late:
            a_last >= t2.
          Proof.
            have NTH := sporadic_arrival_bound_properties_of_nth.
            have TOOFAR := sporadic_arrival_bound_last_job_too_far.
            apply leq_trans with (n := a_first + t2 + task_jitter tsk - t1); last by done.
            apply leq_trans with (n := t1 + t2 - t1); first by rewrite addKn.
            rewrite leq_sub2r // -addnA [t2 + _]addnC addnA leq_add2r.
            feed (NTH 0); [ by apply leq_ltn_trans with (n := 1) | des].
            apply leq_trans with (n := a_first + job_jitter j_first); first by done.
            by rewrite leq_add2l -NTH0; apply H_job_jitter_bounded.
          Qed.

          (* However, the actual arrival time of the last job must lie within [t1, t2).
             Contradiction! *)
          Lemma sporadic_arrival_bound_case_3_contradiction: False.
          Proof.
            have LATE := sporadic_arrival_bound_last_arrives_too_late.
            have NTH := sporadic_arrival_bound_properties_of_nth.
            rename H_at_least_two_jobs into TWO.
            feed (NTH num_actual_arrivals.-1);
              first by destruct num_actual_arrivals; first by rewrite ltn0 in TWO.
            move: NTH => [/andP [_ BUG] _].
            rewrite ltnNge in BUG; move: BUG => /negP BUG; apply: BUG.
            by apply leq_trans with (n := a_last); last by apply leq_addr.
          Qed.

        End DerivingContradiction.

        (* From the contradiction above, we prove that the arrival bound
           is correct for case 3 (i.e., at least two actual arrivals). *)
        Lemma sporadic_task_arrival_bound_at_least_two_jobs:
          num_actual_arrivals <= div_ceil (t2 + task_jitter tsk - t1) (task_period tsk).
        Proof.
          have CONTRA := sporadic_arrival_bound_case_3_contradiction.
          unfold num_actual_arrivals, num_actual_arrivals_of_task in *.
          rename H_at_least_two_jobs into TWO.
          set l := actual_arrivals_of_task_between _ _ _ _ _ _; fold l in TWO.
          apply contraT; rewrite -ltnNge; intro MANY; exfalso.
          have DUMMY: exists (j: Job), True.
          {
            destruct l eqn:EQ; first by rewrite /= ltn0 in TWO.
            by exists s.
          } destruct DUMMY as [elem _].
          by apply CONTRA; last by apply elem.
        Qed.

      End AtLeastTwoJobs.

      (* Using the case analysis above, we prove that the number of actual arrivals of tsk
         can be upper-bounded using the length of the interval as follows. *)
      Theorem sporadic_task_with_jitter_arrival_bound:
        num_actual_arrivals <= div_ceil (t2 + task_jitter tsk - t1) (task_period tsk).
      Proof.
        destruct num_actual_arrivals as [|n] eqn:CEIL;
          first by rewrite -CEIL; apply sporadic_arrival_bound_no_jobs.
        destruct n as [|num_arr]; rewrite -CEIL; first by apply sporadic_arrival_bound_one_job.
        by apply sporadic_task_arrival_bound_at_least_two_jobs; rewrite CEIL.
      Qed.

    End UpperBoundOn.

  End BoundingActualArrivals.

End ArrivalBounds.


Require Import String.
Require Import Names.
Require Import Arith.
Require Import Bool.
Require Import Functors.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType :+: BType.

  Definition tex1' : DType D := tnat' _. (* Nat *)
  Definition tex1 := proj1_sig tex1'.
  Definition tex2' : DType D := tbool' _. (* Bool *)
  Definition tex2 := proj1_sig tex2'.

  Eval compute in ("Evaluating 'tnat == tnat' as an 'TNat.").
  Eval compute in (eq_DType D tex1 tex1').
  Eval compute in ("Evaluating 'tbool == tbool' as an 'TBool.").
  Eval compute in (eq_DType D tex2 tex2').
  Eval compute in ("Evaluating 'tbool == tnat' as an 'TBool.").
  Eval compute in (eq_DType D tex2 tex1').

End Type_Test_Section.

Section Test_Section.

  Definition E := Arith :+: Bool.

  Definition ex_1 : Names.Exp E :=
    (add' _ (lit' _ 1) (lit' _ 2)).
  Definition ex_2 : Names.Exp E :=
    (add' _ (lit' _ 5) (lit' _ 0)).
  Definition ex_3 : Names.Exp E :=
    (cond' _ (blit' _ true) ex_1 ex_2).
  Definition ex_4 : Names.Exp E :=
    (cond' _ (blit' _ false) ex_1 ex_2).

  Definition test_typeof e :=
    match (typeof D E e) with
      | Some t1 => DTypePrint _ (proj1_sig t1)
      | None => "Type Error!"
    end.

  Eval compute in ("The type of '1 + 2' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_1)).
  Eval compute in ("The type of '145 + 2346' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_2)).
  Eval compute in ("The type of 'true' should be tbool.").
  Eval compute in (test_typeof (blit _ true)).
  Eval compute in ("The type of 'if true then (1 + 2) else (5 + 0)' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_3)).
  Eval compute in ("The type of 'if false then (1 + 2) else (5 + 0)' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_4)).

  Eval compute in (ExpPrint E (proj1_sig ex_1)).
  Eval compute in (ExpPrint E (proj1_sig ex_2)).
  Eval compute in (ExpPrint E (proj1_sig ex_3)).
  Eval compute in (ExpPrint E (proj1_sig ex_4)).

  Definition V := StuckValue :+: BotValue :+: NatValue :+: BoolValue.

  Eval compute in ("Evaluating '1 + 2'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_1) nil))).
  Eval compute in ("Evaluating '5 + 0'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_2) nil))).
  Eval compute in ("Evaluating 'if true then (1 + 2) else (5 + 0)'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_3) nil))).
  Eval compute in ("Evaluating 'if false then (1 + 2) else (5 + 0)'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_4) nil))).

  Definition WFV := (WFValue_Bot D V) ::+:: (WFValue_VI D V) ::+:: (WFValue_VB D V).

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D) E.
    intros; eauto 200 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T, FAlgebra EvalName T (evalR V) E.
    eauto 500 with typeclass_instances.
  Defined.

  Lemma Soundness_Alg typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (eval_alg_Soundness_P D V E WFV unit
      (fun _ _ => True) E (Functor_Plus Arith Bool) tt typeof_rec eval_rec
      f_algebra f_algebra))) E.
    eauto 100 with typeclass_instances.
  Defined.

  Lemma soundness : forall (e : Exp E),
    forall T, typeof D E (proj1_sig e) = Some T ->
      WFValueC D V WFV (eval V E (proj1_sig e) nil) T.
  Proof.
    intro; apply eval_Soundness with (eval_Soundness_alg_F := Soundness_Alg);
      eauto 550 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith :+: Bool Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import HoTT.

Set Universe Polymorphism.
Set Primitive Projections.

Definition eq_to_equiv A B : A = B -> A ≃ B :=
  fun e => e # (Equiv_id A).

Definition Funext := forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g).

(* The frawework relies on the univalence axiom and functional extensionality *)

Axiom univalence : forall A B, IsEquiv (eq_to_equiv A B).
Axiom funext : Funext.

Definition Fune {A : Type} {P : A-> Type} (f g : forall x:A, P x) :
  Equiv (f == g ) (f = g).
Proof.
  apply Equiv_inverse. unshelve econstructor.
  exact apD10. apply funext.
Defined.

Definition Univ {A B : Type} : Equiv (A = B) (Equiv A B).
Proof.
  unshelve econstructor. apply eq_to_equiv. apply univalence.
Defined.

Instance funext_isequiv A P (f g : forall x : A, P x) : IsEquiv (@apD10 _ _ f g) := funext _ _ _ _.

Instance univalence_isequiv A B : IsEquiv (eq_to_equiv A B) := univalence _ _.

Definition transport_apD10 A B (f g : forall x:A, B x)
           (P : forall x:A, B x -> Type)
           (e : f = g) x v: transport_eq (fun X => P x (X x))
                                                       e v
                                          = transport_eq (fun X => P x X)
                                                (apD10 e x) v.
  destruct e. reflexivity.
Defined.

Definition transport_funext {A B} {f g : forall x:A, B x}
           (P : forall x:A, B x -> Type) x
           (v : P x (f x)) (e : forall x, f x = g x)
            : transport_eq (fun X => P x (X x))
                                                       (e_inv apD10 e) v
                                          = transport_eq (fun X => P x X)
                                                (e x) v.
Proof.
  rewrite transport_apD10. rewrite e_retr. reflexivity.
Defined.

(* for minor differences between Prop and Type (coming from impredicativity)  *)
(* we need to state again univalence for Prop, even if in principle Prop is  *)
(* a subtype of Type *)

Definition Equiv_id_P (A:Prop) : A ≃ A :=
  BuildEquiv _ _ id (BuildIsEquiv _ _ _ id (fun _ => eq_refl) (fun _ => eq_refl) (fun _ => eq_refl)).

Definition eq_to_equiv_P (A B:Prop) : A = B -> A ≃ B :=
  fun e => @transport_eq Prop (fun X => A ≃ X) A B e (Equiv_id_P A).

Axiom univalence_P : forall (A B:Prop), IsEquiv (eq_to_equiv_P A B).

Definition UnivP {A B : Prop} : Equiv (A = B) (Equiv A B).
Proof.
  unshelve econstructor. apply eq_to_equiv_P. apply univalence_P.
Defined.

Definition transport_sigma_1 A (P : A -> Type) Q x y (e : x = y) X :
  (transport_eq (fun x => {y : P x & Q x y}) e X).1  =
  transport_eq P e X.1.
  destruct e. reflexivity.
Defined.

Definition transport_funext_aux {A B} {f g : forall x:A, B x}
           (P : forall x : A, B x -> Type) x
           (v : forall x, P x (f x)) (e : forall x, f x = g x)
            : (transport_eq (fun X => forall x, P x (X x)) (e_inv apD10 e) v x)
            = transport_eq (fun y => P x y) (e x) (v x).
Proof.
  rewrite <- transport_funext.
  generalize (e_inv apD10 e). destruct e0. reflexivity.
Defined.

(*** IsContr ***)

Definition IsContr (A:Type) := { x : A & forall y, x = y}.
Existing Class IsContr.

Fixpoint IsTrunc n A := match n with
                           | O => IsContr A
                           | S n => forall x y:A, IsTrunc n (x = y)
                           end.

Definition IsHProp A := IsTrunc 1 A.

Lemma IsEquivHProp {A B : Type} (f:A->B) : IsHProp (IsEquiv(f)).
Proof.
Admitted.

(* begin contractible is the lowest level of truncation *)

Definition path_contr {A} `{IsContrA : IsContr A} (x y : A) : x = y
  := let contr := IsContrA.2 in (contr x)^ @ (contr y).

Definition path2_contr {A} `{IsContr A} {x y : A} (p q : x = y) : p = q.
Proof.
  assert (K : forall (r : x = y), r = path_contr x y).
  intro r; destruct r. unfold path_contr.
  symmetry. apply concat_Vp.
  transitivity (path_contr x y). apply K. symmetry; apply K.
Defined.

Definition contr_paths_contr A `{IsContr A} (x y : A) : IsContr (x = y).
  unshelve econstructor.
  exact (path_contr x y).
  exact (path2_contr _).
Defined.

(* begin proof irrelevant is the same as IsHprop *)

Definition IsIrr A := forall x y : A, x = y.

Definition IsIrr_inhab_IsContr A (H: IsIrr A) : A -> IsContr A :=
  fun x => existT _ x (H x).

Definition IsHProp_to_IsIrr A : IsHProp A -> IsIrr A :=
  fun H x y => (H x y).1.

Definition IsIrr_to_IsHProp A : IsIrr A -> IsHProp A.
  unshelve econstructor.
  apply X.
  intro e. unshelve eapply path2_contr. apply IsIrr_inhab_IsContr; auto.
Defined.

Definition IsHProp_inhab_isContr A {H:A -> IsContr A} : IsHProp A.
  apply IsIrr_to_IsHProp. intros x y.
  exact (@path_contr _ (H x) _ _).
Defined.

Definition IsHProp_inhab_isContr' {A:Type} (a:A) (H : IsHProp A) : IsContr A.
Proof.
  eapply IsIrr_inhab_IsContr.
  apply (IsHProp_to_IsIrr A H).
  exact a.
Defined.

Definition IsWeakEmb {A B : Type} (f : A -> B) := forall x y, (f x = f y) -> (x = y).

Definition IsHProp_WeakEmb {A B:Type} (f : A -> B)
      (wemb : IsWeakEmb f) (C : IsContr B) :
      IsHProp A.
Proof.
  apply IsIrr_to_IsHProp. intros x y.
  apply (wemb x y).
  apply path_contr.
Defined.

Definition IsHPropIsContr {A} : IsHProp (IsContr A).
Admitted.

(* Preservation of homotopy level *)

Definition contr_equiv A B (f : A -> B)
  `{IsContr A} `{IsEquiv A B f}
  : IsContr B.
Proof.
  unshelve econstructor.
  - exact (f H.1).
  - intro b. eapply concat; try exact (e_retr f b).
    apply ap. apply H.2.
Defined.

Definition contr_equiv2 (A B : Type) (H : Equiv A B) : (IsContr A) -> (IsContr B).
Proof.
  destruct H. destruct e_isequiv. intros [x P]. econstructor. intro b.
  exact ((ap e_fun (P (e_inv b))) @ (e_retr b)).
Defined.

Definition ap_inv_equiv {A B} (f : A -> B) `{IsEquiv _ _ f} x y : f x = f y -> x = y.
Proof.
  intro X. exact ((e_sect f x)^@ ap (e_inv f) X @ e_sect f y).
Defined.

Definition ap_inv_equiv' {A B} (f : A -> B) `{IsEquiv _ _ f} x y : e_inv f x = e_inv f y -> x = y.
Proof.
  intro X. exact ((e_retr f x)^@ ap f X @ e_retr f y).
Defined.

Axiom admit : forall X, X.
Ltac cheat := apply admit.

Instance isequiv_ap A B {x y : A} (f:A->B) {H:IsEquiv f}
  : IsEquiv (@ap _ _ f x y).
Proof.
  unshelve econstructor; cbn.
  - apply ap_inv_equiv. auto.
  - intro e. destruct e. unfold ap_inv_equiv. cbn. rewrite concat_refl.
    apply concat_Vp.
  - cheat.
  - cheat.
Defined.

Definition trunc_equiv n A B (f : A -> B)
  `{IsTrunc n A} `{IsEquiv A B f}
  : IsTrunc n B.
Proof.
  generalize dependent B; generalize dependent A.
  induction n; cbn ; intros.
  - apply (contr_equiv A B f).
  - unshelve eapply (IHn ((e_inv f x = e_inv f y)) _ (x = y)).
    + apply IsTrunc0.
    + apply ap_inv_equiv. apply isequiv_inverse.
    + exact (@isequiv_inverse _ _ (ap (e_inv f)) (isequiv_ap B A (e_inv f))).
Defined.

Definition IsTrunc_Forall {funext:Funext} A (B : A -> Type) n
           (H : forall x, IsTrunc n (B x)) : IsTrunc n (forall x, B x).
Proof.
  revert A B H. induction n; intros.
  - unshelve econstructor.
    + intro a. apply (H a).1.
    + intro f. apply funext. intro a. apply (H a).2.
  - intros f g. cbn in H. unshelve eapply (trunc_equiv _ _ _ (e_inv (apD10))).
    + auto.
    + apply IHn. cbn in H. intro a. exact (H a (f a) (g a)).
    + apply isequiv_inverse.
Defined.

(*** lemma needing this file ***)

(* lemma needing funext *)

Definition ForallSigma {A : Type} {P : A -> Type} {Q : forall a:A, forall y:P a, Type} :
  Equiv (forall (a:A) (y:P a), Q a y) (forall z:{a:A & P a}, Q (z.1) (z.2)).
Proof.
  unshelve econstructor.
  * intro F. intro z. exact (F z.1 z.2).
  * unshelve eapply isequiv_adjointify.
    - intro G. intros a y. exact (G (a;y)).
    - intro F; cbn. reflexivity.
    - intro G; cbn. apply funext; intro z.
      destruct z as [a y]; cbn. reflexivity.
Defined.

Definition SigmaSigma {A:Type} (B: A -> Type) {Q : forall (a:A) (b:B a), Type} :
      Equiv ({a:A & {b: B a & Q a b}}) ({z:{a:A & B a} & Q z.1 z.2}).
Proof.
  unshelve econstructor.
  - intros [a [b c]]. exists (a;b). exact c.
  - unshelve eapply isequiv_adjointify.
    -- intros [[a b] c]. exists a, b. exact c.
    -- intros [a [b c]]. reflexivity.
    -- intros [[a b] c]. reflexivity.
Defined.

Definition EquivPtype {A : Type} {B B' : A -> Type} (h : forall (a:A), Equiv (B a) (B' a)) :
  Equiv (forall a, B a) (forall a, B' a).
Proof.
  unshelve econstructor.
  + intro f. intro a. exact ((e_fun (h a)) (f a)).
  + unshelve eapply isequiv_adjointify.
    - intro g. intro a. destruct (h a) as [e_fun hae]. destruct hae.
      exact (e_inv (g a)).
    - intro f. apply funext; intro a.
      destruct (h a) as [e_fun hae]; destruct hae; cbn. apply e_sect.
      - intro g. apply funext; intro a.
      destruct (h a) as [e_fun hae]; destruct hae; cbn. apply e_retr.
Defined.

(* Lemmas using IsContr *)
Instance IsContr_True : IsContr True.
Proof.
  unshelve econstructor. exact I.
  intro y; destruct y; reflexivity.
Defined.

Instance IsContr_unit : IsContr unit.
Proof.
  unshelve econstructor. exact tt.
  intro y; destruct y; reflexivity.
Defined.

Definition fib {A B : Type} (f:A->B) (b:B) : Type :=
  {a:A & f(a) = b}.

Definition IsContrMap {A B : Type} (f : A -> B) :=
  forall b:B, IsContr (fib f b).

Definition IsContrMap_IsShae {A B} (f:A->B) : IsContrMap f -> IsEquiv f.
Proof.
  intro H. unshelve eapply isequiv_adjointify.
  - intro b. exact (((H b).1).1).
  - intro a. exact (((H (f a)).2 (a; eq_refl))..1).
  - intro b. exact (((H b) .1) .2).
Defined.

Definition IsContrSingleton_r {A:Type} {a:A} : IsContr {a':A & a = a'}.
Proof.
    refine ((a; eq_refl);_); intros [a' p].
    apply path_sigma_uncurried; unshelve econstructor; cbn.
    exact p. apply transport_paths_r.
Defined.

Definition IsContrSingleton_l {A:Type} {a:A} : IsContr {a':A & a' = a}.
Proof.
    refine ((a; eq_refl);_); intros [a' p].
    apply path_sigma_uncurried; unshelve econstructor; cbn.
    exact p^. rewrite transport_paths_l. rewrite concat_refl. apply inv2.
Defined.

Definition IsContrForall_domain {A : Type} {B : A -> Type} (C : IsContr A) :
  Equiv (forall a : A, B a) (B C.1).
Proof.
  unshelve econstructor.
  + intro h. exact (h C.1).
  + unshelve eapply isequiv_adjointify.
    - intros y a. exact ((C.2 a) # y).
    - intro h. apply funext; intro a. destruct (C.2 a); cbn. reflexivity.
    - intro y. cbn. rewrite (@path2_contr _ C _ _ (C.2 C.1) eq_refl).
      cbn. reflexivity.
Defined.

Definition IsContrForall_codomain {A : Type} {B : A -> Type} (C : forall a:A, IsContr(B a)) :
Equiv (forall a : A, B a) True.
Proof.
  unshelve econstructor.
  - intro f; exact I.
  - unshelve eapply isequiv_adjointify.
    -- intro r. intro a. exact ((C a).1).
    -- intro f. cbn. apply funext; intro a. exact ((C a).2 (f a)).
    -- intro r; destruct r. reflexivity.
Defined.

Definition IsContrSigma_domain {A : Type} {B : A -> Type} (C : IsContr A) :
      Equiv {a:A & B a} (B C.1).
Proof.
  unshelve econstructor.
  - intros [a b]. exact ((C.2 a)^ # b).
  - unshelve eapply isequiv_adjointify.
    -- intro b. exact (C.1; b).
    -- intros [a b]. apply path_sigma_uncurried; unshelve econstructor; cbn.
       exact (C.2 a). apply transport_pV.
    -- intro x. cbn beta zeta iota.
        assert (C.2 C.1 = eq_refl). apply path2_contr.
        rewrite X. reflexivity.
Defined.

Definition IsContrSigma_codomain {A : Type} {B : A -> Type} (C :forall a :A, IsContr(B a)) :
  Equiv {a : A & B a} A.
  unshelve econstructor.
  - intros [a b]. exact a.
  - unshelve eapply isequiv_adjointify.
    -- intro a. unshelve econstructor. exact a. exact ((C a).1).
    -- intros [a b]. eapply EqSigma. unshelve econstructor; cbn. reflexivity.
       cbn. exact ((C a).2 b).
    -- cbn. reflexivity.
Defined.


(* This example checks the efficiency of the abstract machine used by ring *)
(* Expected time < 1.00s *)

Require Import BinInt Zbool.

Definition Zadd x y :=
match x with
| 0%Z => y
| Zpos x' =>
    match y with
    | 0%Z => x
    | Zpos y' => Zpos (x' + y')
    | Zneg y' =>
        match (x' ?= y')%positive with
        | Eq => 0%Z
        | Lt => Zneg (y' - x')
        | Gt => Zpos (x' - y')
        end
    end
| Zneg x' =>
    match y with
    | 0%Z => x
    | Zpos y' =>
        match (x' ?= y')%positive with
        | Eq => 0%Z
        | Lt => Zpos (y' - x')
        | Gt => Zneg (x' - y')
        end
    | Zneg y' => Zneg (x' + y')
    end
end.

Require Import Ring.

Lemma Zth : ring_theory Z0 (Zpos xH) Zadd Z.mul Z.sub Z.opp (@eq Z).
Admitted.

Ltac Zcst t :=
  match isZcst t with
    true => t
  | _ => constr:(NotConstant)
  end.

Add Ring Zr : Zth
  (decidable Zeq_bool_eq, constants [Zcst]).

Open Scope Z_scope.
Infix "+" := Zadd : Z_scope.

Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13.
Timeout 5 Time intro; ring.


Require Export Category.Core Functor.Core Category.Morphisms FunctorCategory FunctorCategory.Morphisms.
Require Import Common.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.
Local Open Scope morphism_scope.

Section iso_lemmas.
  Context `{Funext}.

  Variable C : PreCategory.

  Variables s d : C.
  Variables m1 m2 : Morphism C s d.
  Variable p : m1 = m2.

  Variable Fs : PreCategory.
  Variable Fd : PreCategory.
  Variable Fm : Morphism C s d -> Functor Fs Fd.

  Lemma transport_Fc_to_idtoiso
        s' d' u
  : @transport _ (fun m => Morphism _ (Fm m s') d') _ _ p u
    = u ∘ ComponentsOf (idtoiso [_, _] (ap Fm p) : Morphism _ _ _)^-1 s'.
  Proof.
    case p; clear p; simpl; autorewrite with morphism; reflexivity.
  Qed.

  Lemma transport_cF_to_idtoiso
        s' d' u
  : @transport _ (fun m => Morphism _ s' (Fm m d')) _ _ p u
    = ComponentsOf (idtoiso [_, _] (ap Fm p) : Morphism _ _ _) d' ∘ u.
  Proof.
    case p; clear p; simpl; autorewrite with morphism; reflexivity.
  Qed.
End iso_lemmas.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable eT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_3_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.

Variable lemma_TCreflexive_1 : (forall A B C : Universe, (triangle_ A B C -> cong_3_ A B C A B C)).
Variable axiom_congruentequal_2 : (forall A B C Ca Cb Cc : Universe, (cong_3_ A B C Ca Cb Cc -> eT_ A B C Ca Cb Cc)).

Theorem lemma_ETreflexive_3 : (forall A B C : Universe, (triangle_ A B C -> eT_ A B C A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Import ZArith Lia.

(***********************************)
(* SSReflect-like lemmas for Coq Z *)
(***********************************)

Declare Scope zarith_ext_scope.

Notation "`| x |" := (Z.abs x) : zarith_ext_scope.
Notation "'Z<=nat'" := (Z.of_nat) (at level 9) : zarith_ext_scope.
Notation "'| x |" := (Z.abs_nat x) : zarith_ext_scope.
Notation "'gcdZ'" := Z.gcd : zarith_ext_scope.
Notation "'sgZ'" := Z.sgn : zarith_ext_scope.
Notation "'divZ'" := Z.div : zarith_ext_scope.

Local Open Scope Z_scope.
Local Open Scope zarith_ext_scope.

Lemma eqZP : Equality.axiom Zeq_bool.
Proof. move=> x y; apply: (iffP idP) => H; by apply/Zeq_is_eq_bool. Qed.

Canonical Z_eqMixin := EqMixin eqZP.
Canonical Z_eqType := Eval hnf in EqType Z Z_eqMixin.

Arguments eqZP {x y}.

Definition addZ0 := Zplus_0_r.
Definition add0Z := Zplus_0_l.

Definition addZC : commutative Zplus := Zplus_comm.
Definition addZA : associative Zplus := Zplus_assoc.

Definition addZZ := Zplus_diag_eq_mult_2.

Definition subZ0 := Z.sub_0_r.
(* aka Zminus_0_r *)
Definition subZZ := Z.sub_diag.

Definition addZNE a b : a + - b = a - b := Z.add_opp_r a b.

Definition addZK n : cancel (Zplus^~ n) (Zminus^~ n).
Proof. move=> ?; exact: Z.add_simpl_r. Qed.

Definition addZN n : n + - n = 0 := Z.add_opp_diag_r n.
(* aka Zplus_opp_r *)

Lemma subZKC m n : m + (n - m) = n. Proof. exact: Zplus_minus. Qed.

Lemma eqZ_add2r p m n : (m + p = n + p) <-> (m = n).
Proof.
split; last by move=> ->.
rewrite -!(addZC p); exact: Z.add_reg_l.
Qed.
(* NB: Zplus_reg_l *)

Lemma eqZ_add2l p m n : (p + m = p + n) <-> (m = n).
Proof. split; [exact: Z.add_reg_l | by move=> ->]. Qed.

Lemma eqZ_opp x y : (- x = - y) <-> (x = y).
Proof. exact: Z.opp_inj_wd. Qed.

(* Z.leb_spec0 : forall x y : Z, Bool.reflect (x <= y) (x <=? y) *)
Lemma leZP {m n} : reflect (m <= n) (Zle_bool m n).
Proof. apply: (iffP idP); by apply Z.leb_le. Qed.

(* Z.ltb_spec0  forall x y : Z, reflect (x < y) (x <? y) *)
Lemma ltZP {m n} : reflect (m < n) (m <? n).
Proof. apply: (iffP idP); by apply Z.ltb_lt. Qed.

Lemma geZP {m n} : reflect (m >= n) (m >=? n).
Proof. apply: (iffP idP); rewrite /Z.ge /Zge_bool; by destruct (m ?= n). Qed.

Lemma gtZP {m n} : reflect (m > n) (m >? n).
Proof. apply: (iffP idP); rewrite /Z.gt /Zgt_bool; by destruct (m ?= n). Qed.

Lemma leZNgt n m : n <= m <-> ~ m < n.
Proof. split; [exact: Zle_not_lt | exact: Z.Private_Tac.not_gt_le]. Qed.
Definition leZNgt' := Z.leb_antisym.

Lemma ltZNge n m : n < m <-> ~ m <= n.
Proof. split; [exact: Zlt_not_le | exact: Z.Private_Tac.not_ge_lt]. Qed.
Definition ltZNge' := Z.ltb_antisym.

Definition ltZ_eqF := Z.lt_neq.
(* aka Zlt_not_eq *)

Lemma gtZ_eqF a b : a < b -> b <> a.
Proof. by move/ltZ_eqF/nesym. Qed.

Definition leZZ := Z.le_refl.
Definition leZZ' := Z.leb_refl.
Definition ltZZ := Z.lt_irrefl.
Definition ltZZ' := Z.ltb_irrefl.

Lemma leZ_trans {m n p} : n <= m -> m <= p -> n <= p.
Proof. exact: Z.le_trans. Qed.

Lemma ltZ_trans {m n p} : n < m -> m < p -> n < p.
Proof. exact: Z.lt_trans. Qed.

Lemma leZ_ltZ_trans {m n p} : n <= m -> m < p -> n < p.
Proof. exact: Z.le_lt_trans. Qed.

Lemma ltZ_leZ_trans {m n p} : n < m -> m <= p -> n < p.
Proof. exact: Z.lt_le_trans. Qed.

Definition oppZK := Z.opp_involutive.
Definition oppZ0 := Z.opp_0.

Definition ltZW {m n} : m < n -> m <= n := Z.lt_le_incl m n.
(* aka Zlt_le_weak *)
Lemma ltZW' {m n} : m <? n -> m <=? n.
Proof. by move/ltZP => ?; apply/leZP; lia. Qed.

Lemma leZ_eqVlt m n : (m <= n) <-> (m = n) \/ (m < n).
Proof.
split => [|[->|]].
  case/Zle_lt_or_eq => ?; by [right|left].
exact: leZZ.
exact: ltZW.
Qed.
Lemma leZ_eqVlt' m n : (m <=? n) = (m == n) || (m <? n).
Proof.
apply/idP/idP => [/leZP/leZ_eqVlt[/eqP -> //|/ltZP ->]|/orP[/eqP ->|/ltZP]].
  by rewrite orbT.
by rewrite leZZ'.
by move/ltZP/ltZW'.
Qed.

Lemma ltZ_neqAle m n : (m < n) <-> (m <> n) /\ (m <= n).
Proof.
split => [mn|[H]]; last by rewrite leZ_eqVlt => -[|].
split; [exact/nesym/gtZ_eqF | exact/ltZW].
Qed.
Lemma ltZ_neqAle' m n : (m <? n) = (m != n) && (m <=? n).
Proof.
apply/idP/idP => [/ltZP mn|].
  by apply/andP; split; [apply/eqP; lia | exact/ltZW'/ltZP].
by case/andP => /eqP H1 /leZP H2; apply/ltZP; lia.
Qed.

Definition mul0Z : left_zero 0 Z.mul := Zmult_0_l.
Definition mulZ0 : right_zero 0 Z.mul := Zmult_0_r.
Definition mul1Z : left_id 1 Z.mul := Zmult_1_l.
Definition mulZ1 : right_id 1 Z.mul := Zmult_1_r.
Definition mulZC : commutative Zmult := Zmult_comm.
Lemma mulN1Z n : -1 * n = - n.
Proof. by rewrite mulZC Zopp_eq_mult_neg_1. Qed.
Lemma mulZN1 n : n * -1 = - n.
Proof. by rewrite Z.opp_eq_mul_m1. Qed.

Definition mulZN x y : x * (- y) = - (x * y) := Z.mul_opp_r x y.
Definition mulNZ x y : (- x) * y = - (x * y) := Z.mul_opp_l x y.
Lemma mulZNN x y : (- x) * (- y) = x * y. Proof. by rewrite Z.mul_opp_opp. Qed.
(* NB: Z.mul_opp_comm : forall n m : Z, - n * m = n * - m *)
(* NB: Zopp_mult_distr_l : forall n m : Z, - (n * m) = - n * m *)

Lemma eqZ_mul2l p n m :  p <> 0 -> p * n = p * m <-> n = m.
Proof. move=> p0; split; [exact: Zmult_reg_l | by move=> ->]. Qed.

Lemma eqZ_mul2r p n m :  p <> 0 -> n * p = m * p <-> n = m.
Proof. move=> p0; split; [exact: Z.mul_reg_r | by move=> ->]. Qed.

Lemma mulZDl : left_distributive Zmult Zplus.
Proof. move=> *; by rewrite Z.mul_add_distr_r. (* aka Zmult_plus_distr_l *) Qed.
Lemma mulZDr : right_distributive Zmult Zplus.
Proof. move=> *; by rewrite Z.mul_add_distr_l. (* aka Zmult_plus_distr_r *) Qed.
Lemma mulZBl : left_distributive Zmult Zminus.
Proof. move=> *; by rewrite Z.mul_sub_distr_r. (* aka Zmult_minus_distr_r *) Qed.
Lemma mulZBr : right_distributive Zmult Zminus.
Proof. move=> *; by rewrite Zmult_minus_distr_l. Qed.

Lemma mulZ_eq0 (x y : Z) : (x * y == 0) = ((x == 0) || (y == 0)).
Proof.
apply/idP/idP => [/eqP/Zmult_integral[] ->| ]; try by rewrite eqxx // orbC.
case/orP => /eqP ->; by rewrite ?mulZ0 ?mul0Z.
Qed.

Definition mulZA : associative Zmult := Zmult_assoc.

Lemma leZ_oppr x y : (x <= - y) <-> (y <= - x).
Proof. by split=> /Z.opp_le_mono; rewrite oppZK. Qed.

Lemma leZ_oppl x y : (- x <= y) <-> (- y <= x).
Proof. by split=> /Z.opp_le_mono; rewrite oppZK. Qed.

Lemma ltZ_oppr x y : (x < - y) <-> (y < - x).
Proof. by split=> /Z.opp_lt_mono; rewrite oppZK. Qed.

Lemma ltZ_oppl x y : (- x < y) <-> (- y < x).
Proof. by split=> /Z.opp_lt_mono; rewrite oppZK. Qed.

Definition addZ_ge0 := Z.add_nonneg_nonneg. (* 0 <= n -> 0 <= m -> 0 <= n + m *)
(* aka Zplus_le_0_compat *)
Definition addZ_gt0 := Z.add_pos_pos.       (* 0 < n  -> 0 <= m -> 0 < n + m *)
Definition addZ_gt0wr := Z.add_nonneg_pos.  (* 0 <= n -> 0 < m  -> 0 < n + m  *)
Definition addZ_gt0wl := Z.add_pos_nonneg.  (* 0 < n  -> 0 <= m -> 0 < n + m *)

Definition leZ_add := Z.add_le_mono.        (* n <= m -> p <= q -> n + p <= m + q *)
(* aka Zplus_le_compat *)
Definition leZ_lt_add := Z.add_le_lt_mono.  (* x <= y -> z < t -> x + z < y + t *)
(* aka Zplus_le_lt_compat *)
Definition ltZ_le_add := Z.add_lt_le_mono.  (* x < y -> z <= t -> x + z < y + t *)

Lemma leZ_sub x y z t : x <= y -> t <= z -> x - z <= y - t.
Proof. exact: Z.sub_le_mono. Qed.

Lemma leZ_add2r {p m n} : m + p <= n + p <-> m <= n.
Proof. split; [exact: Zplus_le_reg_r | exact: Zplus_le_compat_r]. Qed.
Lemma leZ_add2r' p m n : (m + p <=? n + p) = (m <=? n).
Proof. by apply/idP/idP => [/leZP/leZ_add2r/leZP //|/leZP/leZ_add2r/leZP]. Qed.

Definition ltZ_add := Z.add_lt_mono.
(* aka Zplus_lt_compat *)

Lemma leZ_add2l {p m n} : p + m <= p + n <-> m <= n.
Proof. split; [exact: Zplus_le_reg_l | exact: Zplus_le_compat_l]. Qed.

Lemma leZ_addl a b c : 0 <= b -> a <= c -> a <= b + c.
Proof. move=> b0 ac; rewrite -(add0Z a); exact: leZ_add. Qed.

Lemma leZ_addr a b c : 0 <= c -> a <= b -> a <= b + c.
Proof. move=> b0 ac; rewrite -(addZ0 a); exact: leZ_add. Qed.

Lemma addr_leZ a b c : b <= 0 -> a <= c -> a + b <= c.
Proof. move=> b0 ab; rewrite -(addZ0 c); exact: leZ_add. Qed.

Lemma ltZ_add2r p {m n : Z} : (m + p < n + p) <-> (m < n).
Proof. split; [exact/Zplus_lt_reg_r | exact/Zplus_lt_compat_r]. Qed.
Lemma ltZ_add2r' (p m n : Z) : (m + p <? n + p) = (m <? n).
Proof. by apply/idP/idP => [/ltZP/ltZ_add2r/ltZP|/ltZP/(@ltZ_add2r p)/ltZP]. Qed.

Lemma ltZ_add2l p {m n : Z} : (p + m  < p + n) <-> (m < n).
Proof. split; [exact/Zplus_lt_reg_l | exact/Zplus_lt_compat_l]. Qed.
Lemma ltZ_add2l' p {m n} : (p + m  <? p + n) = (m <? n).
Proof. by rewrite 2!(addZC p) ltZ_add2r'. Qed.

(* TODO: Zmult_gt_0_lt_0_reg_r *)

(* TODO: Zmult_lt_0_reg_r *)

Lemma leZ_sub2r n {m p} : n <= m -> n - p <= m - p.
Proof. by move=> ?; lia. Qed.

Lemma ltZ_sub2r {n m p} : n < m -> n - p < m - p.
Proof. by move=> ?; lia. Qed.

Definition mulZ_gt0 := Z.mul_pos_pos.       (* 0 < n -> 0 < m -> 0 < n * m *)
(* aka Zmult_lt_0_compat *)
Definition mulZ_ge0 := Z.mul_nonneg_nonneg. (* 0 <= n -> 0 <= m -> 0 <= n * m *)
(* aka Zmult_le_0_compat *)

Lemma leZ_wpmul2r p n m : 0 <= p -> n <= m -> n * p <= m * p.
Proof. by move=> *; apply Zmult_le_compat_r. Qed.
Lemma leZ_wpmul2l p n m : 0 <= p -> n <= m -> p * n <= p * m.
Proof. by move=> *; apply Zmult_le_compat_l. Qed.
Lemma leZ_pmul m n p q : 0 <= n -> 0 <= m -> n <= p -> m <= q -> n * m <= p * q.
Proof. move=> *; exact/Zmult_le_compat. Qed.

Lemma ltZ_pmul m n p q : 0 < n -> 0 < m -> n <= p -> m < q -> n * m < p * q.
Proof. move=> *; exact: Zmult_lt_compat2. Qed.

Lemma leZ_pmul2r m n1 n2 : 0 < m -> n1 * m <= n2 * m <-> (n1 <= n2).
Proof.
move=> m0; split; first by apply: Zmult_le_reg_r; apply Z.lt_gt.
move=> *; apply leZ_wpmul2r => //; exact: ltZW.
Qed.
Lemma leZ_pmul2r' m n1 n2 : 0 < m -> n1 * m <=? n2 * m = (n1 <=? n2).
Proof. by move=> H; apply/idP/idP => /leZP/(leZ_pmul2r _ _ _ H)/leZP. Qed.

Lemma leZ_pmul2l m n1 n2 : 0 < m -> m * n1 <= m * n2 <-> (n1 <= n2).
Proof.
move=> m0; split; first by rewrite !(mulZC m); exact: Zmult_lt_0_le_reg_r.
move/Zmult_le_compat_l; apply; exact/ltZW.
Qed.
Lemma leZ_pmul2l' m n1 n2 : 0 < m -> m * n1 <=? m * n2 = (n1 <=? n2).
Proof. move=> ?; by rewrite -(mulZC n1) -(mulZC n2) leZ_pmul2r'. Qed.

Lemma ltZ_pmul2r m n1 n2 : 0 < m -> (n1 * m < n2 * m) <-> (n1 < n2).
Proof.
move=> ?; split; [exact/Zmult_gt_0_lt_reg_r/Z.lt_gt|exact/Zmult_lt_compat_r].
Qed.
Lemma ltZ_pmul2r' m n1 n2 : 0 < m -> n1 * m <? n2 * m = (n1 <? n2).
Proof. by move=> H; apply/idP/idP => /ltZP/(ltZ_pmul2r _ _ _ H)/ltZP. Qed.

Lemma ltZ_pmul2l m n1 n2 : 0 < m -> (m * n1 < m * n2) <-> (n1 < n2).
Proof. rewrite 2!(mulZC m); exact: ltZ_pmul2r. Qed.

Lemma pmulZ_rge0 x y : 0 < x -> (0 <= x * y) <-> (0 <= y).
Proof. exact: Z.mul_nonneg_cancel_l. Qed.
(* NB: Zmult_gt_0_le_0_compat *)

Lemma pmulZ_lgt0 x y : 0 < x -> (0 < y * x) <-> (0 < y).
Proof. by move=> x0; rewrite -{1}(mul0Z x) ltZ_pmul2r. Qed.

Lemma pmulZ_llt0 x y : 0 < x -> (y * x < 0) <-> (y < 0).
Proof. move=> x0; by rewrite -{1}(mul0Z x) ltZ_pmul2r. Qed.

Lemma mulZ_ge0_le0 a b : 0 <= a -> b <= 0 -> a * b <= 0.
Proof. move: a b => [|a|a] // b Ha Hb; by case: b Hb. Qed.

Lemma leZ_subLR m n p : (m - n <= p) <-> (m <= n + p).
Proof. by rewrite Zle_plus_swap Z.sub_opp_r addZC. Qed.

Lemma ltZ_subLR m n p : (m - n < p) <-> (m < n + p).
Proof. by rewrite Zlt_plus_swap Z.sub_opp_r addZC. Qed.

Lemma leZ_subRL m n p : (n <= p - m) <-> (m + n <= p).
Proof.
split => H.
- move/(@leZ_add2l m) : H; by rewrite subZKC.
- by apply (@leZ_add2l m); rewrite subZKC.
Qed.

Lemma ltZadd1 {m n} : m < n + 1 <-> m <= n. Proof. by lia. Qed.

Lemma leZsub1 a b : a <= b - 1 <-> a < b.
Proof. by rewrite leZ_subRL addZC -ltZadd1 ltZ_add2r. Qed.

Lemma ltZ_subRL m n p : (n < p - m) <-> (m + n < p).
Proof.
split => H.
- move/(@ltZ_add2l m) : H; by rewrite subZKC.
- by apply (@ltZ_add2l m); rewrite subZKC.
Qed.
(* NB: Z.lt_add_lt_sub_r : forall n m p : Z, n + p < m <-> n < m - p *)
Lemma ltZ_subRL' m n p : (n <? p - m) = (m + n <? p).
Proof. by apply/idP/idP => /ltZP/ltZ_subRL/ltZP. Qed.

Definition ltZ_addr_subl := ltZ_subRL.

Lemma Z_S n : Z_of_nat n.+1 = Z_of_nat n + 1.
Proof. by rewrite inj_S. Qed.

Lemma Z_of_nat_inj : forall x y, Z_of_nat x = Z_of_nat y -> x = y.
Proof. exact: Nat2Z.inj. Qed.

Lemma Z_of_nat_inj_neq x y : Z_of_nat x <> Z_of_nat y -> x <> y.
Proof. move=> H H'; by apply H; f_equal. Qed.

Lemma Z_of_nat_le n m : (n <= m)%nat = (Z<=nat n <=? Z<=nat m).
Proof.
case/boolP : (n <= m)%nat => H; first by apply/esym/leZP/Nat2Z.inj_le/leP.
apply/esym/negbTE; by apply: contra H => /leZP/Nat2Z.inj_le/leP.
Qed.

Lemma Z_of_nat_lt n m : (n < m)%nat = (Z<=nat n <? Z<=nat m).
Proof.
case/boolP : (n < m)%nat => H; first by apply/esym/ltZP/Nat2Z.inj_lt/ltP.
apply/esym/negbTE; by apply: contra H => /ltZP/Nat2Z.inj_lt/ltP.
Qed.

Definition normZ0 := Z.abs_0.

Lemma normZM : {morph Z.abs : x y / x * y : Z}. Proof. exact: Z.abs_mul. Qed.
(*Lemma Z.abs_mul : forall n m : Z, `|n * m| = `|n| * `|m|*)

Lemma geZ0_norm x : 0 <= x -> `|x| = x. Proof. exact: Z.abs_eq. Qed.

Lemma normZ_ge0 : forall z, 0 <= `| z |. Proof. by case. Qed.

Lemma ltZ_norml x y : `|x| < y <-> (- y < x < y).
Proof.
split => [H | [H1 H2] ].
- case: (Z_le_gt_dec x 0) => x0; first by rewrite Zabs_non_eq // in H; lia.
  rewrite Z.abs_eq // in H; last by lia.
  by split; [lia | by []].
- case: (Z_le_gt_dec 0 x) => x0; first by rewrite Z.abs_eq.
  by rewrite Zabs_non_eq; [lia | exact/ltZW/Z.gt_lt].
Qed.

Lemma leZ_norml x y : `|x| <= y <-> (- y <= x <= y).
Proof.
split => [H | [H1 H2] ].
- case: (Z_le_gt_dec x 0) => x0; first by rewrite Zabs_non_eq // in H; lia.
  rewrite Z.abs_eq // in H; last by lia.
  by split; [lia | by []].
- case: (Z_le_gt_dec 0 x) => x0; first by rewrite Z.abs_eq.
  by rewrite Zabs_non_eq; [lia | exact/ltZW/Z.gt_lt].
Qed.


(* ----------------------------------------------------------------- *)
(*               Transparent Computable Definitions                  *)
(* ----------------------------------------------------------------- *)

From Practice Require Import Base.

Set Implicit Arguments.
Unset Strict Implicit.
Generalizable All Variables.

(* Copy of unlockable to reflect definition from evaluable ones *)
#[universes(template)]
Structure evaluable T v := Evaluable {evaled : T; _ : evaled = v}.

Lemma evals T x C : @evaled T x C = x. by case: C. Qed.

Definition evidP (b: bool): reflect b b :=
  if b
  then ReflectT true is_true_true
  else ReflectF false not_false_is_true.
Arguments evidP {b}.

Program Canonical idP_eval b := Evaluable (_: @evidP b = @idP b).
Next Obligation.
  move: idP. case: b=> /= p;
  refine (match p with ReflectT _ => _ | ReflectF _ => _ end)=> //.
  all: f_equal; apply/proof_irrelevance.
Qed.

Section SubType.
Variable T: Type.
Variable P: pred T.
Variable sT: subType P.

Definition sembed x :=
  if evidP is ReflectT Px then Some (Sub (sT := sT) x Px) else None.

Program Canonical insub_eval v := Evaluable (_: sembed v = insub v).
Next Obligation. rewrite /sembed /insub evals //. Qed.

End SubType.
Arguments sembed {T P sT} x.

Section Ordinal.
Variable n: nat.

Definition enumOrd: seq (ordinal n) := pmap sembed (iota 0 n).

Program Canonical enum_ord_eval := Evaluable (_: enumOrd = enum 'I_n).
Next Obligation.
  rewrite /enumOrd enumT unlock /= /ord_enum.
  apply/eq_pmap=> ?. rewrite evals //.
Qed.

Program Definition tupleOrd: (n.-tuple 'I_n) := @Tuple _ _ enumOrd _.
Next Obligation. rewrite evals. apply/eqP/size_enum_ord. Qed.

Program Canonical ord_tuple_eval := Evaluable (_: tupleOrd = ord_tuple n).
Next Obligation. apply /val_inj. rewrite /= evals //. Qed.

Definition tupleOf `(f: 'I_n -> T) := map_tuple f tupleOrd.

Program Canonical mktuple_eval `(f: 'I_n -> T) := Evaluable (_: tupleOf f = mktuple f).
Next Obligation. rewrite /tupleOf evals //. Qed.

End Ordinal.

Notation "n '.-ord' i" := (Ordinal (n:=n) (m:=i) is_true_true) (at level 10).


(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect eqtype ssrbool ssrfun ssrnat.
From mathcomp Require Export seq.
Require Import Utf8.

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

Definition pair_inj {A B: Type} {a a': A} {b b': B} (e: (a, b) = (a', b')) :
  a = a' ∧ b = b' :=
  let 'Logic.eq_refl := e in conj Logic.eq_refl Logic.eq_refl.

(* -------------------------------------------------------------------- *)
Section Assoc.
Variable (T : eqType) (U : Type).

Fixpoint assoc (s : seq (T * U)) (x : T) : option U :=
  if s is (y, v) :: s then
    if x == y then Some v else assoc s x
  else None.

Lemma assoc_cat (s1 s2: seq (T * U)) x :
  assoc (s1 ++ s2) x =
    if assoc s1 x is Some _ then assoc s1 x else assoc s2 x.
Proof. by elim: s1 => [|[t u] s1 ih] //=; case: eqP. Qed.
End Assoc.

Lemma assocE (T: eqType) U (s : seq (T * U)) (x : T) : assoc s x =
  nth None [seq Some v.2 | v <- s] (seq.index x [seq v.1 | v <- s]).
Proof.
by elim: s => // [[/= u v] s ih]; rewrite [x==u]eq_sym; case: eqP.
Qed.

Lemma assoc_mem' (T: eqType) U (s: seq (T * U)) x w :
  assoc s x = Some w → List.In (x, w) s.
Proof.
  elim: s => // [ [t u] s ] ih /=; case: eqP; last by auto.
  by move => a /Some_inj; left; f_equal.
Qed.

Lemma mem_assoc (T: eqType) U (s: seq (T * U)) x w :
  List.In (x, w) s → ∃ w', assoc s x = Some w'.
Proof.
  elim: s => // [ [t u] s] ih [ /pair_inj [] -> -> | rec ] /=.
  by rewrite eq_refl; eauto.
  case: (_ == _); eauto.
Qed.

Lemma InP (T: eqType) (s: seq T) m :
  reflect (List.In m s) (m \in s).
Proof.
  elim: s. by constructor.
  move => a s ih. rewrite in_cons.
  case: (@eqP _ m a). by constructor; left.
  case ih; constructor. by right. simpl; intuition.
Qed.

Lemma mem_uniq_assoc (T: eqType) U (s: seq (T * U)) x w :
  List.In (x, w) s → uniq (map fst s) → assoc s x = Some w.
Proof.
  elim: s => // [ [t u] s] ih [ /pair_inj [] -> -> | rec ] /andP [nr un] /=.
  by rewrite eq_refl; eauto.
  case: eqP; last by eauto.
  fold (List.In (x, w) s) in rec.
  apply (List.in_map fst), (rwP (InP _ _)) in rec.
  move=> ?; subst. rewrite rec in nr. done.
Qed.

Lemma assoc_mem_dom' (T: eqType) U (s : seq (T * U)) x w :
  assoc s x = Some w -> x \in [seq v.1 | v <- s].
Proof. move => h; apply assoc_mem' in h. apply (rwP (InP _ _)), List.in_map_iff. eexists; split. 2: eassumption. reflexivity. Qed.

(* -------------------------------------------------------------------- *)
Section AssocInj.
Variables (T U: eqType).

Lemma assocP (s : seq (T * U)) (x : T) (w : U) : uniq (map fst s) ->
  reflect (assoc s x = Some w) ((x, w) \in s).
Proof.
elim: s => [|[t u] s ih] => uq; first by constructor.
move: uq => /andP[/= t_notin_s /ih {ih}]; move: t_notin_s.
case: eqP=> [->|/eqP ne_xt] t_notin_s; last first.
+ by rewrite in_cons eqE /= (negbTE ne_xt).
rewrite inE eqE /= eqxx /=; case: eqP => [->|ne_wu] _ /=.
+ by constructor.
suff ->: (t, w) \in s = false by constructor; case=> /esym.
by apply/negbTE; apply/contra: t_notin_s => /(map_f fst).
Qed.

Lemma assoc_mem (s : seq (T * U)) x w :
  assoc s x = Some w -> (x, w) \in s.
Proof.
elim: s => [|[t u] s ih] //=; case: eqP => [-> [->]|/eqP ne].
+ by rewrite in_cons eqxx orTb.
by rewrite in_cons eqE /= (negbTE ne).
Qed.

Lemma assoc_mem_dom (s : seq (T * U)) x w :
  assoc s x = Some w -> w \in [seq v.2 | v <- s].
Proof. by move/assoc_mem/(map_f snd). Qed.

Lemma assoc_inj (s : seq (T * U)) x y w :
     uniq [seq v.2 | v <- s]
  -> assoc s x = Some w
  -> assoc s y = Some w
  -> x = y.
Proof.
elim: s => [|[t u] s ih] //= /andP[u_notin_s uq_s xw yx].
move: xw yx ih u_notin_s; case: eqP => [-> [->]|ne_xt].
+ by case: eqP=> [->//|] ne_yt yw _ /negbTE; rewrite (assoc_mem_dom yw).
move=> xw; case: eqP=> [-> [->] _|].
+ by move/negbTE; rewrite (assoc_mem_dom xw).
by move=> ne_yt yw ih u_notin_s; apply: ih.
Qed.
End AssocInj.

(* -------------------------------------------------------------------- *)
Section InjAssoc.
Variables (T U : eqType) (f : T -> U).

Lemma inj_assoc (s : seq T) x y w :
     uniq s
  -> assoc [seq (f v, v) | v <- s] x = Some w
  -> assoc [seq (f v, v) | v <- s] y = Some w
  -> x = y.
Proof.
by move=> uq_s; apply: assoc_inj; rewrite -map_comp map_inj_uniq.
Qed.
End InjAssoc.

(* -------------------------------------------------------------------- *)
Section AssocMap.
Context (T: eqType) (U V: Type) (f: U → V) (g: T → U → V) (h: T * U → T * V).

Lemma assoc_mapE m n :
  (∀ n u, (h (n, u)).1 = n) →
  assoc (map h m) n = omap (λ u, (h (n, u)).2) (assoc m n).
Proof.
  move => E.
  elim: m => // - [] t u m /= ->.
  case htu: h (E t u) => [ ? v ] /= ?; subst.
  case: eqP => //= ->.
  by rewrite htu.
Qed.

Lemma assoc_map m (n: T) :
  assoc [seq (x.1, f x.2) | x <- m] n = omap f (assoc m n).
Proof.
  by elim: m n => // [[q r] m] ih n /=; case: eqP.
Qed.

Lemma assoc_map2 m (n: T) :
  assoc [seq (let: (k, v) := e in (k, g k v)) | e <- m ] n = omap (g n) (assoc m n).
Proof. by elim: m n => // - [k v] m ih n /=; case: eqP => // ->. Qed.

End AssocMap.

(* -------------------------------------------------------------------- *)
Section AssocFilter.
Context (T: eqType) (U: Type) (p: pred T).

Lemma assoc_filterI (m: seq (T * U)) (n: T) :
  assoc [seq x <- m | p x.1 ] n = if p n then assoc m n else None.
Proof.
  elim: m n.
  - by move => n /=; case: ifP.
  case => t u m ih n /=.
  case: ifP.
  - by move => /=; case: eqP => // -> ->.
  by case: eqP => // -> {n} h; rewrite ih h.
Qed.

Corollary assoc_filter (m: seq (T * U)) (n: T) :
  p n →
  assoc [seq x <- m | p x.1] n = assoc m n.
Proof.
  by move => h; rewrite assoc_filterI h.
Qed.

End AssocFilter.

(* -------------------------------------------------------------------- *)
Section InMap.
Context (A: Type) (B: eqType) (f: A → B).

Lemma in_map b m :
  reflect (exists2 a : A, List.In a m & b = f a) (b \in [seq f i | i <- m]).
Proof.
  elim: m; first by constructor => - [] _ [].
  move => a m ih /=.
  rewrite in_cons; case: eqP => [ -> | neq ] /=.
  - by constructor; exists a => //; left.
  case: ih => ih; constructor.
  - by case: ih => a' ??; exists a' => //; right.
  case => a' ha' ?; apply: ih; exists a' => //.
  case: ha' => //; congruence.
Qed.

End InMap.

(* -------------------------------------------------------------------- *)
Section InPmap.
Context (aT rT: eqType) (f: aT → option rT).

Lemma in_pmap a m :
  a \in m →
  match f a with None => true | Some r => r \in pmap f m end.
Proof.
  elim: m => // a' m ih.
  rewrite inE; case/orP.
  - move => /eqP <- {a'}; case h: f => [ r | // ].
    by rewrite /= h inE eqxx.
  move => /ih{ih}.
  case: f => // r h; rewrite /=.
  by case: f => //= ?; rewrite inE h orbT.
Qed.

End InPmap.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Import Basics OrdersTac.
Require Export Orders.

Set Implicit Arguments.
Unset Strict Implicit.

(** * Properties of [OrderedTypeFull] *)

Module OrderedTypeFullFacts (Import O:OrderedTypeFull').

 Module OrderTac := OTF_to_OrderTac O.
 Ltac order := OrderTac.order.
 Ltac iorder := intuition order.

 Instance le_compat : Proper (eq==>eq==>iff) le.
 Proof. repeat red; iorder. Qed.

 Instance le_preorder : PreOrder le.
 Proof. split; red; order. Qed.

 Instance le_order : PartialOrder eq le.
 Proof. compute; iorder. Qed.

 Instance le_antisym : Antisymmetric _ eq le.
 Proof. apply partial_order_antisym; auto with *. Qed.

 Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x.
 Proof. iorder. Qed.

 Lemma lt_not_ge_iff : forall x y, x<y <-> ~y<=x.
 Proof. iorder. Qed.

 Lemma le_or_gt : forall x y, x<=y \/ y<x.
 Proof. intros. rewrite le_lteq; destruct (O.compare_spec x y); auto. Qed.

 Lemma lt_or_ge : forall x y, x<y \/ y<=x.
 Proof. intros. rewrite le_lteq; destruct (O.compare_spec x y); iorder. Qed.

 Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x.
 Proof. iorder. Qed.

End OrderedTypeFullFacts.

(** * Properties of [OrderedType] *)

Module OrderedTypeFacts (Import O: OrderedType').

  Module OrderTac := OT_to_OrderTac O.
  Ltac order := OrderTac.order.

  Notation "x <= y" := (~lt y x) : order.
  Infix "?=" := compare (at level 70, no associativity) : order.

  Local Open Scope order.

  Tactic Notation "elim_compare" constr(x) constr(y) :=
   destruct (compare_spec x y).

  Tactic Notation "elim_compare" constr(x) constr(y) "as" ident(h) :=
   destruct (compare_spec x y) as [h|h|h].

  (** The following lemmas are either re-phrasing of [eq_equiv] and
      [lt_strorder] or immediately provable by [order]. Interest:
      compatibility, test of order, etc *)

  Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x.

  Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y.

  Definition eq_trans (x y z:t) : x==y -> y==z -> x==z :=
   Equivalence_Transitive x y z.

  Definition lt_trans (x y z:t) : x<y -> y<z -> x<z :=
   StrictOrder_Transitive x y z.

  Definition lt_irrefl (x:t) : ~x<x := StrictOrder_Irreflexive x.

  (** Some more about [compare] *)

  Lemma compare_eq_iff : forall x y, (x ?= y) = Eq <-> x==y.
  Proof.
   intros; elim_compare x y; intuition; try discriminate; order.
  Qed.

  Lemma compare_lt_iff : forall x y, (x ?= y) = Lt <-> x<y.
  Proof.
   intros; elim_compare x y; intuition; try discriminate; order.
  Qed.

  Lemma compare_gt_iff : forall x y, (x ?= y) = Gt <-> y<x.
  Proof.
   intros; elim_compare x y; intuition; try discriminate; order.
  Qed.

  Lemma compare_ge_iff : forall x y, (x ?= y) <> Lt <-> y<=x.
  Proof.
   intros; rewrite compare_lt_iff; intuition.
  Qed.

  Lemma compare_le_iff : forall x y, (x ?= y) <> Gt <-> x<=y.
  Proof.
   intros; rewrite compare_gt_iff; intuition.
  Qed.

  Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order.

  Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
  Proof.
  intros x x' Hxx' y y' Hyy'.
  elim_compare x' y'; autorewrite with order; order.
  Qed.

  Lemma compare_refl : forall x, (x ?= x) = Eq.
  Proof.
   intros; elim_compare x x; auto; order.
  Qed.

  Lemma compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y).
  Proof.
   intros; elim_compare x y; simpl; autorewrite with order; order.
  Qed.

  (** For compatibility reasons *)
  Definition eq_dec := eq_dec.

  Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
  Proof.
   intros x y; destruct (CompSpec2Type (compare_spec x y));
    [ right | left | right ]; order.
  Defined.

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

  Lemma if_eq_dec : forall x y (B:Type)(b b':B),
    (if eq_dec x y then b else b') =
    (match compare x y with Eq => b | _ => b' end).
  Proof.
  intros; destruct eq_dec; elim_compare x y; auto; order.
  Qed.

  Lemma eqb_alt :
    forall x y, eqb x y = match compare x y with Eq => true | _ => false end.
  Proof.
  unfold eqb; intros; apply if_eq_dec.
  Qed.

  Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb.
  Proof.
  intros x x' Hxx' y y' Hyy'.
  rewrite 2 eqb_alt, Hxx', Hyy'; auto.
  Qed.

End OrderedTypeFacts.

(** * Tests of the order tactic

    Is it at least capable of proving some basic properties ? *)

Module OrderedTypeTest (Import O:OrderedType').
  Module Import MO := OrderedTypeFacts O.
  Local Open Scope order.
  Lemma lt_not_eq x y : x<y -> ~x==y.  Proof. order. Qed.
  Lemma lt_eq x y z : x<y -> y==z -> x<z. Proof. order. Qed.
  Lemma eq_lt x y z : x==y -> y<z -> x<z. Proof. order. Qed.
  Lemma le_eq x y z : x<=y -> y==z -> x<=z. Proof. order. Qed.
  Lemma eq_le x y z : x==y -> y<=z -> x<=z. Proof. order. Qed.
  Lemma neq_eq x y z : ~x==y -> y==z -> ~x==z. Proof. order. Qed.
  Lemma eq_neq x y z : x==y -> ~y==z -> ~x==z. Proof. order. Qed.
  Lemma le_lt_trans x y z : x<=y -> y<z -> x<z. Proof. order. Qed.
  Lemma lt_le_trans x y z : x<y -> y<=z -> x<z. Proof. order. Qed.
  Lemma le_trans x y z : x<=y -> y<=z -> x<=z. Proof. order. Qed.
  Lemma le_antisym x y : x<=y -> y<=x -> x==y. Proof. order. Qed.
  Lemma le_neq x y : x<=y -> ~x==y -> x<y. Proof. order. Qed.
  Lemma neq_sym x y : ~x==y -> ~y==x. Proof. order. Qed.
  Lemma lt_le x y : x<y -> x<=y. Proof. order. Qed.
  Lemma gt_not_eq x y : y<x -> ~x==y. Proof. order. Qed.
  Lemma eq_not_lt x y : x==y -> ~x<y. Proof. order. Qed.
  Lemma eq_not_gt x y : x==y -> ~ y<x. Proof. order. Qed.
  Lemma lt_not_gt x y : x<y -> ~ y<x. Proof. order. Qed.
  Lemma eq_is_nlt_ngt x y : x==y <-> ~x<y /\ ~y<x.
  Proof. intuition; order. Qed.
End OrderedTypeTest.

(** * Reversed OrderedTypeFull.

   we can switch the orientation of the order. This is used for
   example when deriving properties of [min] out of the ones of [max]
   (see [GenericMinMax]).
*)

Module OrderedTypeRev (O:OrderedTypeFull) <: OrderedTypeFull.

Definition t := O.t.
Definition eq := O.eq.
Program Instance eq_equiv : Equivalence eq.
Definition eq_dec := O.eq_dec.

Definition lt := flip O.lt.
Definition le := flip O.le.

Instance lt_strorder: StrictOrder lt.
Proof. unfold lt; auto with *. Qed.
Instance lt_compat : Proper (eq==>eq==>iff) lt.
Proof. unfold lt; auto with *. Qed.

Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y.
Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition. Qed.

Definition compare := flip O.compare.

Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
Proof.
intros; unfold compare, eq, lt, flip.
destruct (O.compare_spec y x); auto with relations.
Qed.

End OrderedTypeRev.


Require Export base_mods SO_syntax ltac_SO.

Open Scope SO_scope.

(* List of predicates in given SecOrder formula. *)
Fixpoint preds_in (α:SecOrder) : list predicate :=
  match α with
    predSO P _ => cons P nil
  | relatSO _ _ => nil
  | eqFO _ _ => nil
  | allFO _ β => preds_in β
  | exFO _ β => preds_in β
  | negSO β => preds_in β
  | conjSO β1 β2 => (preds_in β1) ++ (preds_in β2)
  | disjSO β1 β2 => (preds_in β1) ++ (preds_in β2)
  | implSO β1 β2 => (preds_in β1) ++ (preds_in β2)
  | allSO P β => P :: (preds_in β)
  | exSO P β => P :: (preds_in β)
  end.

(* Function that quantifies over the predicates in the given list. *)
Fixpoint list_closed_SO (α:SecOrder) (l: list predicate) : SecOrder :=
  match l with
    nil => α
  | cons P ls => allSO P (list_closed_SO α ls)
  end.

(* Universally closes SO formulas. *)
Definition uni_closed_SO (alpha:SecOrder) : SecOrder :=
  list_closed_SO alpha (preds_in alpha).

Definition rem_pred l P := remove predicate_dec P l.

Lemma rem_pred_app : forall l1 l2 P,
  rem_pred (app l1 l2) P =
  app (rem_pred l1 P) (rem_pred l2 P).
Proof.
  induction l1; intros l2 P. auto. simpl.
  rewrite IHl1. destruct (predicate_dec P a); auto.
Qed.

Lemma is_in_pred_rem_pred_eq : forall l P,
  ~ In P (rem_pred l P).
Proof.
  induction l; intros P. auto.
  simpl. destruct (predicate_dec P a); firstorder.
Qed.

Lemma jj13 : forall l P Q,
    ~ P = Q ->
  In P (rem_pred l Q) <-> In P l.
Proof.
  induction l; intros P Q Hbeq. firstorder.
  simpl. destruct (predicate_dec Q a). subst.
    split; intros. firstorder. apply IHl. auto.
    destruct H. subst. firstorder. firstorder.

    simpl. firstorder.
Qed.

Lemma rem_pred_not_in : forall l P,
  ~ In P l -> rem_pred l P = l.
Proof.
  induction l; intros P H. auto.
  simpl in *. rewrite predicate_dec_r. rewrite IHl.
  all : firstorder.
Qed.

Lemma in_rem_pred : forall lP P Q,
  ~ P = Q ->  In Q (rem_pred lP P) <-> In Q lP.
Proof.
  induction lP; intros P Q Hneq. firstorder.
  simpl in *. specialize (IHlP _ _ Hneq).
  destruct (predicate_dec P a); subst; simpl; firstorder.
Qed.

Lemma incl_rem_pred : forall l1 l2 P,
  incl l1 l2 ->  incl (rem_pred l1 P) (rem_pred l2 P).
Proof.
  induction l1; intros l2 P H. firstorder.
  simpl in *. destruct (predicate_dec P a); subst.
  + apply incl_lcons in H. auto.
  + apply incl_cons. apply incl_hd in H.
    apply in_rem_pred; auto.
    apply incl_lcons in H. auto.
Qed.

Lemma rem_pred_cons_same : forall l P,
  rem_pred (cons P l) P = rem_pred l P.
Proof. intros l P. simpl. pred_dec_l_rep. Qed.

Lemma incl_rem_pred_cons : forall l1 l2 P Q,
  incl l1 (cons Q l2) ->
  incl (rem_pred l1 P) (cons Q (rem_pred l2 P)).
Proof.
  induction l1; intros l2 P Q H; simpl in *.
  if_then_else_hyp_dep. firstorder.
  destruct (predicate_dec P a); subst.
  + apply incl_lcons in H. auto.
  + pose proof (incl_hd _ _ _ _ H) as H2.
    apply incl_cons. simpl in *. destruct H2. firstorder.
    right. apply in_rem_pred; auto.
    apply IHl1; auto. simpl in *.
    pose proof ( in_rem_pred). firstorder.
Qed.

Lemma incl_rem_pred_l : forall l P,
  incl (rem_pred l P) l.
Proof.
  induction l; intros P. firstorder.
  simpl. destruct (predicate_dec P a). subst.
  firstorder. apply incl_cons_cons. auto.
Qed.

Fixpoint cap_pred_empty l1 l2 : bool :=
  match l1 with
  | nil => true
  | cons P l1' => if in_predicate_dec P l2 then false
                    else cap_pred_empty l1' l2
  end.

Fixpoint cap_pred l1 l2 :=
  match l1 with
  | nil => nil
  | cons P l1' => if in_predicate_dec P l2 then cons P (cap_pred l1' l2)
          else cap_pred l1' l2
  end.

Lemma in_cap_pred : forall l2 l1 P,
  ~ In P l1 ->  ~ In P (cap_pred l2 l1).
Proof.
  induction l2; intros l1 P H. auto.
  simpl. destruct (in_predicate_dec a l1).
  simpl. intros [H2 | H2]. subst. contradiction.
  apply IHl2 in H. contradiction.
  apply IHl2. auto.
Qed.

Lemma in_pred_cap_pred : forall l1 l2 P,
  In P l1 -> In P l2 -> In P (cap_pred l1 l2).
Proof.
  induction l1; intros l2 P H1 H2. contradiction.
  simpl in *. destruct (predicate_dec a P). subst.
  destruct (in_predicate_dec P l2); firstorder.
  destruct H1. firstorder. destruct (in_predicate_dec a l2); firstorder.
Qed.

Lemma in_pred_cap_pred_t : forall l1 l2 P,
  In P (cap_pred l1 l2) ->  (In P l1 /\ In P l2).
Proof.
  induction l1; intros l2 P H. contradiction.
  simpl in *. destruct (in_predicate_dec a l2) as [H2 | H2].
  simpl in H. destruct H. subst. firstorder. apply IHl1 in H.
  firstorder. apply IHl1 in H. firstorder.
Qed.

Lemma in_pred_cap_pred_f : forall l1 l2 P,
  ~ In P (cap_pred l1 l2) ->  ~ In P l1  \/ ~ In P l2.
Proof.
  induction l1; intros l2 P H. auto.
  simpl in *. destruct (in_predicate_dec a l2);
  simpl in *; specialize (IHl1 l2 P).  firstorder.
  firstorder. destruct (predicate_dec a P).
  subst. firstorder. firstorder.
Qed.

Lemma in_pred_cap_pred_f1 : forall l1 l2 P,
  ~ In P l1 -> ~ In P (cap_pred l1 l2).
Proof.
  induction l1; intros l2 P H. auto.
  simpl in *. destruct (in_predicate_dec a l2).
  simpl. specialize (IHl1 l2 P). firstorder. firstorder.
Qed.

Lemma in_pred_cap_pred_f2 : forall l1 l2 P,
  ~ In P l2 -> ~ In P (cap_pred l1 l2).
Proof.
  induction l1; intros l2 P H. auto.
  simpl in *. destruct (in_predicate_dec a l2).
  simpl. destruct (predicate_dec a P);
  subst; firstorder. auto.
Qed.

Lemma cap_pred_comm : forall l1 l2 P,
  In P (cap_pred l1 l2) <-> In P (cap_pred l2 l1).
Proof.
  intros. split; intros H;  apply in_pred_cap_pred_t in H;
   apply in_pred_cap_pred; firstorder.
Qed.

Lemma lem_b1 : forall lP alpha1 alpha2,
~ lP = nil ->
incl lP (preds_in (conjSO alpha1 alpha2)) ->
cap_pred lP (preds_in alpha1) = nil ->
~ cap_pred lP (preds_in alpha2) = nil.
Proof.
  induction lP; intros alpha1 alpha2 HlP Hin Hcap. contradiction.
  simpl in *. destruct (in_predicate_dec a (preds_in alpha1)). discriminate.
  destruct (in_predicate_dec a (preds_in alpha2)). firstorder.
  apply incl_hd in Hin. apply in_app_or in Hin. firstorder.
Qed.

Lemma lem_b1_l : forall lP alpha1 alpha2,
~ lP = nil ->
incl lP (preds_in (conjSO alpha1 alpha2)) ->
cap_pred lP (preds_in alpha2) = nil ->
~ cap_pred lP (preds_in alpha1) = nil.
Proof.
  induction lP; intros alpha1 alpha2 HlP Hin Hcap. contradiction.
  simpl in *. destruct (in_predicate_dec a (preds_in alpha1)). discriminate.
  destruct (in_predicate_dec a (preds_in alpha2)). discriminate.
  apply incl_hd in Hin. apply in_app_or in Hin. firstorder.
Qed.

Lemma incl_cap_pred : forall lP l1 l2,
incl lP (app l1 l2) -> cap_pred lP l1 = nil ->
incl lP l2 .
Proof.
  induction lP; intros l1 l2 Hin Hcap. firstorder.
  simpl in *.
  destruct (in_predicate_dec a l1). discriminate.
  apply incl_cons. apply incl_hd in Hin.
  apply in_app_or in Hin. firstorder.
  apply incl_lcons in Hin. firstorder.
Qed.

Lemma incl_cap_pred_l : forall lP l1 l2,
incl lP (app l1 l2)  ->
cap_pred lP l2 = nil ->
incl lP l1.
Proof.
  induction lP; intros l1 l2 Hin Hcap. firstorder.
  simpl in *.
  destruct (in_predicate_dec a l2). discriminate.
  apply incl_cons. apply incl_hd in Hin.
  apply in_app_or in Hin. firstorder.
  apply incl_lcons in Hin. firstorder.
Qed.

Lemma incl_cap_pred_f : forall lP l1 l2,
~ lP = nil ->
incl lP (app l1 l2) ->
cap_pred lP l1 = nil ->
~ incl lP l1.
Proof.
  induction lP; intros l1 l2 Hnot Hin Hcap. contradiction.
  simpl in *.
  destruct (in_predicate_dec a l1). discriminate.
  destruct lP. firstorder.
  intros HH. apply incl_lcons in HH. generalize HH.
  eapply IHlP; auto. discriminate.
  apply incl_lcons in Hin. apply Hin.
Qed.

Lemma incl_cap_pred_f_l : forall lP l1 l2,
~ lP = nil ->
incl lP (app l1 l2) ->
cap_pred lP l2 = nil ->
~ incl lP l2.
Proof.
  induction lP; intros l1 l2 Hnot Hin Hcap. contradiction.
  simpl in *.
  destruct (in_predicate_dec a l2). discriminate.
  destruct lP. firstorder.
  intros HH. apply incl_lcons in HH. generalize HH.
  eapply IHlP; auto. discriminate.
  apply incl_lcons in Hin. apply Hin.
Qed.

Lemma incl_cap_pred_add : forall l1 l2 l3,
  incl l2 l3  ->
  incl (cap_pred l1 l2) l3.
Proof.
  induction l1; intros l2 l3 Hin1. firstorder.
  simpl. destruct (in_predicate_dec a l2); auto. simpl.
  eapply in_incl in i. 2 : apply Hin1.
  apply incl_cons; auto.
Qed.

Lemma rem_pred_nil : forall lP P,
  rem_pred lP P = nil ->
  exists n, lP = repeat P n.
Proof.
  induction lP; intros P Hrem. exists 0. auto.
  simpl in *. destruct (predicate_dec P a). 2 : discriminate.
  subst. apply IHlP in Hrem. destruct Hrem as [mm Hmm].
  exists (S mm). simpl. rewrite Hmm. auto.
Qed.