Require Import Coq.Setoids.Setoid.
Require Export PredMonad.OrderedType.

Import ProperTermNotations.

(***
 *** The Monad Typeclass
 ***)

Class MonadOps (M : OrderedType -> OrderedType) : Type :=
  { returnM : forall {A : OrderedType}, ProperTerm (A -o> M A);
    bindM : forall {A B : OrderedType}, ProperTerm (M A -o> (A -o> M B) -o> M B) }.

Class Monad M {MonadOps:MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall A B x (f: ProperTerm (A -o> M B)),
        bindM @ (returnM @ x) @ f =o= f @ x;
    monad_bind_return :
      forall A (m:M A),
        bindM @ m @ returnM =o= m;
    monad_assoc :
      forall A B C m (f:A -o> M B) (g:B -o> M C),
        bindM @ (bindM @ m @ f) @ g
        =o= bindM @ m @ (pfun (x ::: _) ==> !bindM @ (!f @ pvar x) @ !g)
  }.

(***
 *** The Identity Monad
 ***)

Definition Identity (A: OrderedType) : OrderedType := A.
Instance MonadOps_Identity : MonadOps Identity :=
  { returnM := fun A => (pfun (x ::: A) ==> pvar x)%pterm;
    bindM := fun A B =>
               (pfun (m:::A) ==> pfun (f:::A -o> B) ==>
                     pvar f @ pvar m)%pterm }.

Instance Monad_Identity : Monad Identity.
  constructor; intros.
  destruct x as [x1 x2 pf_x]; destruct f as [f1 f2 pf_f]; compute.
  destruct pf_f as [ pf_f1 pf_f2 pf_f3 ].
  destruct pf_x as [ pf_x1 pf_x2 pf_x3 ].
  split.
  apply pf_f1; repeat constructor; apply pf_x1; repeat constructor.
  apply pf_f1; repeat constructor; apply pf_x1; repeat constructor.
  destruct m as [m1 m2 pf_m].
  destruct pf_m as [ pf_m1 pf_m2 pf_m3 ].
  compute; split; apply pf_m1; repeat constructor.
  destruct m as [m1 m2 pf_m];
    destruct pf_m as [ pf_m1 pf_m2 pf_m3 ].
  destruct f as [f1 f2 pf_f];
    destruct pf_f as [ pf_f1 pf_f2 pf_f3 ].
  destruct g as [g1 g2 pf_g];
    destruct pf_g as [ pf_g1 pf_g2 pf_g3 ].
  compute; split; apply pf_g1; repeat constructor;
    apply pf_f1; repeat constructor; apply pf_m1; repeat constructor.
Qed.

(***
 *** The Set Monad
 ***)

(* The downward-closed sets, as an OrderedType *)
Definition SetM (A: OrderedType) : OrderedType := ~o~ A -o> OTProp.

(* Mapping the elements of a downward-closed set; this is the functor map
operation for SetM *)
Program Definition SetM_map {ctx} {A} {B}
        (f: OTPairInCtx ctx (A -o> B))
        (s: OTPairInCtx ctx (SetM A)) : OTPairInCtx ctx (SetM B) :=
  pfun (y ::: ~o~ B) ==>
       map3_OTPairInCtx
         (ctx:= ~o~ B::ctx)
         (A:= A -o> B) (B:=SetM A) (C:=~o~ B) (D:=OTProp)
         (fun f s y =>
            exists x, ot_R A x x /\ s x /\ ot_R B y (f x))
         _ (!f) (!s) (pvar y).
Next Obligation.
  unfold Basics.impl.
  intros f1 f2 pf_f s1 s2 pf_s y1 y2 pf_y.
  destruct pf_f as [ pf_f1 pf_f2 pf_f3 ].
  destruct pf_s as [ pf_s1 pf_s2 pf_s3 ].
  destruct pf_y as [ pf_y1 pf_y2 pf_y3 ].
  split; intro; try assumption.
  repeat (destruct H); destruct H0.
  exists x; repeat split.
  assumption.
  apply (pf_s3 x); try assumption.
  split; assumption.
  apply (semitransitivity (SemiTransitive:=B) _ y1); try assumption.
  apply pf_f2; split; assumption.
  apply (semitransitivity (SemiTransitive:=B) _ (f1 x)); try assumption.
  apply pf_f1; split; assumption.
  apply pf_f2; split; assumption.
  apply pf_f3; split; assumption.
Qed.

(* Take the union of a set of sets; this is the join operation for SetM *)
Program Definition SetM_union {ctx} {A}
        (s: OTPairInCtx ctx (SetM (SetM A))) : OTPairInCtx ctx (SetM A) :=
  pfun (x ::: ~o~ A) ==>
       map2_OTPairInCtx (A:=SetM (SetM A)) (B:=~o~ A) (C:=OTProp)
       (fun s x => exists s', ot_R (SetM A) s' s' /\ s s' /\ s' x) _ (!s) (pvar x).
Next Obligation.
  intros s1 s2 pf_s x1 x2 pf_x.
  destruct pf_s as [ pf_s1 pf_s2 pf_s3 ].
  destruct pf_x as [ pf_x1 pf_x2 pf_x3 ].
  split; intro; try assumption.
  destruct H as [ s' H ]; destruct H; destruct H0.
  exists s'; repeat split.
  apply H.
  unfold Basics.impl in pf_s3; apply (pf_s3 s'); try assumption.
  split; apply H; assumption.
  unfold Basics.impl in H; apply (H x1).
  split; assumption.
  assumption.
Qed.

Instance MonadOps_SetM : MonadOps SetM :=
  { returnM := fun A => (pfun (x ::: A) ==>
                         pfun (y ::: ~o~ A) ==>
                         proper_leq (pvar y) (pvar x))%pterm;
    bindM := fun A B =>
               (pfun (m:::SetM A) ==> pfun (f::: A -o> SetM B) ==>
                  SetM_union (SetM_map (pvar f) (pvar m)))%pterm }.

(*
Instance Monad_SetM : Monad SetM.
*)


(*****************************************************************************)
(*                                                                           *)
(*  Tensor.v                                                                 *)
(*                                                                           *)
(*  A tensor of type 't' (where 't' is a tuple) is defined as a 'PreTensor'  *)
(*  that satisfies the domain predicate 'PreDomainP t'. This means that a    *)
(*  a tensor of type 't' is defined for all tuples that are below 't' (when  *)
(*  tuples are compared with '.<=.').                                        *)
(*                                                                           *)
(*  This file also defines common operations on tensors. Note that these     *)
(*  definitions require proofs that the defined object is indeed a 'Tensor', *)
(*  i.e. satisfies the precidate 'PreDomainP' with a suitable tuple that     *)
(*  specifies the type of the tensor resulting from the defined operation.   *)
(*                                                                           *)
(*****************************************************************************)

Require Import List.

Require Import TensorIR.Equations.Deep.PreTensor.

Require Export TensorIR.Equations.Deep.PreTensor.

(* A 'Tensor' of type 't' is a map from 'Tuple' to 'Value'
   (aka. a 'PreTensor') together with a proof that the domain
   of the map is given by 't':                                *)

Definition Tensor (t : Tuple) := {x : PreTensor | PreDomainP t x}.

Definition pre {t : Tuple} : Tensor t -> PreTensor :=
  fun tens => proj1_sig tens.

(* In the following, tensor operations are defined.
   The definitions always follow the same pattern:
     (1) Define the operation on tensors, yielding a 'PreTensor'.
     (2) Prove a lemma that the domain of the 'PreTensor' from (1)
         is suitably bounded.
     (3) Combine the results from (1) and (2) to define a 'Tensor'. *)

Open Scope list_scope.
Open Scope pre_scope.
Open Scope val_scope.

(* Some tactics for proof steps that are commonly
   applied in proving the lemmata about domains:  *)

Ltac tens_unfold op := unfold op, pre, pre_access.

Ltac tens_destruct pre Hdom :=
  match goal with
    | t : Tensor _ |- _ => destruct t as [pre Hdom]
  end.

Ltac tens_domain_1 op pre Hdom :=
  tens_unfold op;
  tens_destruct pre Hdom;
  simpl;
  (* Rewrite PreDomainP into PreDomainP': *)
  autorewrite with core in *;
  try (unfold PreDomainP' in *); try (unfold pre_access in *);
  split.

Ltac tens_domain_2 op pre1 Hdom1 pre2 Hdom2 :=
  tens_unfold op;
  tens_destruct pre1 Hdom1; tens_destruct pre2 Hdom2;
  simpl;
  (* Rewrite PreDomainP into PreDomainP': *)
  autorewrite with core in *;
  try (unfold PreDomainP' in *); try (unfold pre_access in *);
  split.

(* Addition of tensors: *)

Definition tens_add_pre {t : Tuple} : Tensor t -> Tensor t -> PreTensor :=
  fun t1 t2 i => (pre t1).[i] + (pre t2).[i].

Lemma tens_add_domain {t : Tuple} :
  forall (t1 t2 : Tensor t), PreDomainP t (tens_add_pre t1 t2).
Proof with auto.
  intros t1 t2; tens_domain_2 @tens_add_pre p2 H2 p1 H1.
  + destruct 1 as [r Hr].
    apply val_plus_some_inv in Hr; destruct Hr as [rv [rw [Hrv Hrw]]].
    apply H1.
    exists rv...
  + intro le.
    apply H1 in le as H1'; destruct H1' as [rv Hv].
    apply H2 in le as H2'; destruct H2' as [rw Hw].
    exists (rv + rw)%R.
    rewrite Hv, Hw...
Qed.

Definition tens_add {t : Tuple} : Tensor t -> Tensor t -> Tensor t :=
  fun t1 t2 => exist _ (tens_add_pre t1 t2) (tens_add_domain t1 t2).

(* Projection of a tensor, restricting the
   first dimension to a fixed index 'i':   *)

Definition tens_proj_pre {t : Tuple} {d : nat} : nat -> Tensor (d::t) ->
                                                 PreTensor :=
  fun m t1 i => (pre t1).[m::i].

Lemma tens_proj_domain {t : Tuple} {d m : nat} :
  (m <= d) -> forall (t' : Tensor (d::t)), PreDomainP t (tens_proj_pre m t').
Proof with auto.
  intros le t'; tens_domain_1 @tens_proj_pre p' H'.
  + destruct 1 as [r Hr].
    specialize H' with (m::i).
    assert (HEx: exists r, p'(m::i) = Some r) by (exists r; auto).
    apply H' in HEx; destruct HEx...
  + intro le'; apply H'; constructor...
Qed.

Definition tens_proj {t : Tuple} {d m : nat} (le : m <= d) :
  Tensor (d::t) -> Tensor t :=
    fun t => exist _ (tens_proj_pre m t) (tens_proj_domain le t).

(* Tensor product (aka. outer product of two tensors): *)

Definition tens_prod_pre {t1 t2 : Tuple} :
  Tensor t1 -> Tensor t2 -> PreTensor :=
    fun t1' t2' i => (pre t1').[firstn (length t1) i]
                     * (pre t2').[skipn (length t1) i].

Lemma tens_prod_domain {t1 t2 : Tuple} :
  forall (t1' : Tensor t1) (t2' : Tensor t2),
    PreDomainP (t1++t2) (tens_prod_pre t1' t2').
Proof with auto.
  intros t1' t2'; tens_domain_2 @tens_prod_pre p2 H2 p1 H1;
  specialize H1 with (firstn (length t1) i);
  specialize H2 with (skipn (length t1) i).
  + destruct 1 as [r Hr]; apply val_mult_some_inv in Hr.
    destruct Hr as [rv [rw [Hrv Hrw]]].
    assert (HExv: exists r, p1 (firstn (length t1) i) = Some r)
      by (exists rv; auto); apply H1 in HExv.
    assert (HExw: exists r, p2 (skipn (length t1) i) = Some r)
      by (exists rw; auto); apply H2 in HExw.
    rewrite <- firstn_skipn with (n := length t1) (l := i).
    apply tup_append_preserves_le...
  + intro le.
    apply tup_firstn_preserves_le in le as le1; apply H1 in le1;
      destruct le1 as [rv Hv].
    apply tup_skipn_preserves_le in le as le2; apply H2 in le2;
      destruct le2 as [rw Hw].
    apply val_mult_some_some with (x := rv) (y := rw)...
Qed.

Definition tens_prod {t1 t2 : Tuple} :
  Tensor t1 -> Tensor t2 -> Tensor (t1++t2) :=
    fun t1' t2' => exist _ (tens_prod_pre t1' t2') (tens_prod_domain t1' t2').

(* Multiplication of a tensor with a scalar (from the ring/field 'R'): *)

Definition tens_smul_pre {t : Tuple} : R -> Tensor t -> PreTensor :=
  fun r t' i => (Some r) * (pre t' i).

Lemma tens_smul_domain {t : Tuple} :
  forall (r : R) (t' : Tensor t), PreDomainP t (tens_smul_pre r t').
Proof with auto.
  intros r t'; tens_domain_1 @tens_smul_pre p' H'.
  + destruct 1 as [v Hv].
    destruct (p' i) as [w |] eqn:?.
    * apply H'.
      exists w...
    * inversion Hv.
  + intro le.
    apply H' in le.
    destruct le as [rv Hv].
    exists (r * rv)%R.
    rewrite Hv...
Qed.

Definition tens_smul {t : Tuple} : R -> Tensor t -> Tensor t :=
  fun r t' => exist _ (tens_smul_pre r t') (tens_smul_domain r t').

(* Expansion of a tensor along the first dimension: *)

Definition tens_expa_pre {t : Tuple} : nat -> Tensor t -> PreTensor :=
  fun d t' i => match i with
                  | [] => None
                  | m::j => if m <=? d then (pre t' j) else None
              end.

Lemma tens_expa_domain {t : Tuple}:
  forall (t' : Tensor t) (d : nat), PreDomainP (d::t) (tens_expa_pre d t').
Proof with auto.
  intros t' d; tens_domain_1 @tens_expa_pre p' H'; destruct i.
  1,2: destruct 1 as [r Hr].
  3,4: intro le.
  + inversion Hr.
  + revert Hr.
    pose proof (Nat.leb_spec0 n d) as H; inversion H.
    * intros Hr.
      assert(HEx: exists r, p' i = Some r) by (exists r; auto).
      apply H' in HEx.
      constructor...
    * inversion 1.
  + inversion le.
  + pose proof (Nat.leb_spec0 n d) as H; inversion H; inversion le.
    * apply H'...
    * contradiction.
Qed.

Definition tens_expa {t : Tuple} (d : nat) : Tensor t -> Tensor (d::t) :=
  fun t' => exist _ (tens_expa_pre d t') (tens_expa_domain t' d).

(* The diagonal along the first two dimensions: *)

Definition tens_diag_pre {t : Tuple} : Tensor t -> PreTensor :=
  fun t' i => match i with
                | []   => None
                | m::j => pre t' (m::m::j)
              end.

Lemma tens_diag_domain {t : Tuple} {d : nat} :
  forall (t' : Tensor (d::d::t)), PreDomainP (d::t) (tens_diag_pre t').
Proof with auto.
  intros t'; tens_domain_1 @tens_diag_pre p' H'; destruct i.
  1,2: destruct 1 as [r Hr].
  3,4: intros le; inversion le...
  + inversion Hr.
  + specialize H' with (n::n::i); apply H'.
    exists r...
  + apply H'; constructor...
Qed.

Definition tens_diag {t : Tuple} {d: nat} :
  Tensor (d::d::t) -> Tensor (d::t) :=
    fun t' => exist _ (tens_diag_pre t') (tens_diag_domain t').

(* Transposition between adjacent dimensions: *)

Definition tens_transp_pre {t : Tuple} : nat -> Tensor t -> PreTensor :=
  fun m t' i => match tup_swap m i with
                  | None => None
                  | Some i' => pre t' i'
                end.

Lemma tens_transp_domain {t0 t1: Tuple}
                         {m : nat} (eq : tup_swap m t0 = Some t1) :
  forall (t' : Tensor t0), PreDomainP t1 (tens_transp_pre m t').
Proof with auto.
  intros t'; tens_domain_1 @tens_transp_pre p' H';
  remember (tup_swap m i) as tsi; destruct tsi; try (rename t into j).
  3,4: intro le.
  1,2: destruct 1 as [r Hr]; inversion Hr...
  + assert(HEx: exists r, p' j = Some r) by (exists r; auto).
    apply H' in HEx.
    symmetry in Heqtsi; apply tup_swap_idempotent in Heqtsi.
    pose proof (tup_swap_preserves_le m _ _ _ _ Heqtsi eq HEx)...
  + apply tup_swap_idempotent in eq.
    symmetry in Heqtsi.
    apply (tup_swap_preserves_le m _ _ _ _ Heqtsi eq) in le.
    apply H'...
  + apply tup_le_length_eq in le.
    assert(Hnn: tup_swap m t0 <> None) by (rewrite eq; inversion 1).
    rewrite <- (tup_swap_preserves_length m _ _ eq) in le.
    pose proof (tup_length_eq_swap_defined' m t0 i (eq_sym le) Hnn) as H.
    rewrite Heqtsi in H; contradiction.
Qed.

Definition tens_transp {t0 t1 : Tuple}
                       {m : nat} (eq : tup_swap m t0 = Some t1) :
  Tensor t0 -> Tensor t1 :=
    fun t'' => exist _ (tens_transp_pre m t'') (tens_transp_domain eq t'').

(* Reduction along the first dimension,
   based on addition (aka. contraction): *)

Fixpoint tens_red_pre {t : Tuple} {d : nat} (k : nat) (t' : Tensor (d::t)) :
  PreTensor :=
    fun i => match k with
               | 0    => pre t' (0::i)
               | S k' => pre t' (k::i) + tens_red_pre k' t' i
             end.

Lemma tens_red_defined_1 {t : Tuple} {d : nat} :
  forall (k : nat) (i : Tuple), (k::i).<=.(d::t) ->
    forall (t' : Tensor (d::t)), exists r : R, tens_red_pre k t' i = Some r.
Proof with auto.
  intros k i le t'; destruct t' as [p' H'].
  induction k.
  + tens_unfold @tens_red_pre; simpl.
    apply H' in le; unfold pre_access in le.
    destruct (p' (0::i)).
    * exists r...
    * contradiction.
  + (* effectively unfold 'tens_red_pre' once: *)
    unfold tens_red_pre; fold (@tens_red_pre t).
    unfold pre; simpl.
    destruct (IHk (tup_le_Sn_le _ _ _ _ le)) as [s Hs]; rewrite Hs;
      clear Hs; clear IHk.
    autorewrite with core in H'; apply H' in le; destruct le as [r Hr].
    unfold pre_access in Hr; rewrite Hr.
    exists (r+s)%R...
Qed.

Lemma tens_red_defined_2 {t : Tuple} {d : nat} :
  forall (k : nat) (i : Tuple) (t' : Tensor (d::t)),
    (exists r : R, tens_red_pre k t' i = Some r) -> ((k::i).<=.(d::t)).
Proof with auto.
  intros k i t'; destruct t' as [p' H'].
  induction k.
  + tens_unfold @tens_red_pre; simpl; autorewrite with core in H'.
    intro HEx; apply H' in HEx...
  + (* effectively unfold 'tens_red_pre' once: *)
    unfold tens_red_pre; fold (@tens_red_pre t).
    unfold pre; simpl.
    destruct 1 as [r Hr]; apply val_plus_some_inv in Hr;
      destruct Hr as [rv [rw [Hv Hw]]].
    split.
    * clear IHk; clear Hw; autorewrite with core in H'.
      assert(HEx: exists r, p' (S k::i) = Some r) by (exists rv; auto).
      apply H' in HEx; destruct HEx...
    * rewrite Hw in IHk.
      assert (HEx: exists r, Some rw = Some r) by (exists rw; auto).
      apply IHk in HEx; inversion HEx...
Qed.

Lemma tens_red_domain {t : Tuple} {d : nat} :
  forall (t' : Tensor (d::t)), PreDomainP t (tens_red_pre d t').
Proof.
  intros t'; autorewrite with core; split.
  + apply tens_red_defined_2.
  + intro.
    assert(le: (d::i).<=.(d::t)) by (constructor; auto).
    apply (@tens_red_defined_1 t d d i le).
Qed.

Definition tens_red {t : Tuple} {d : nat} : Tensor (d::t) -> Tensor t :=
  fun t' => exist _ (tens_red_pre d t') (tens_red_domain t').

(* Convolution along the first two dimensions: *)

Fixpoint tens_conv_pre {t : Tuple} (k : nat) (t' : Tensor t) : PreTensor :=
  fun i => match i with
             | [] => None
             | j::i' => match k with
                          | 0    => pre t' (j::0::i')
                          | S k' => (pre t' ((j+(S k'))%nat::(S k')::i'))
                                    + tens_conv_pre k' t' (j::i')
                        end
          end.

Lemma tens_conv_defined_1 {t : Tuple} {m n : nat} (le_nm : n <= m) :
  forall (k : nat), (k <= n) ->
    forall (t' : Tensor (m::n::t)) (i : Tuple), i.<=.(m-k::t) ->
      exists r : R, tens_conv_pre k t' i = Some r.
Proof with auto.
  intros k le_kn t' i le_tup; destruct t' as [p' H'].
  induction k; destruct i; inversion le_tup; simpl.
  + autorewrite with core in H'.
    rewrite Nat.sub_0_r in *.
    assert(le: (n0::0::i).<=.(m::n::t)). constructor... constructor...
    apply H' in le...
  + apply tup_le_minus_Sk_le_minus_k in le_tup.
    2: exact (Nat.le_trans _ _ _ le_kn le_nm).
    destruct (IHk (le_Sn_le _ _ le_kn) le_tup) as [r Hr]; clear IHk;
      rewrite Hr; clear Hr.
    assert(le: ((n0 + S k)%nat::(S k)::i).<=.(m::n::t)).
      constructor; pose proof (plus_le_compat_r _ _ (S k) H);
        rewrite (Nat.sub_add _ _ (Nat.le_trans _ _ _ le_kn le_nm)) in H1...
        constructor...
    autorewrite with core in H'; apply H' in le; destruct le as [s Hs];
      unfold pre_access in Hs; rewrite Hs.
    exists (s+r)%R...
Qed.

Lemma tens_conv_defined_2 {t : Tuple} {m n : nat} (le_nm : n <= m) :
  forall (k : nat), (k <= n) ->
    forall (t' : Tensor (m::n::t)) (i : Tuple),
      (exists r : R, tens_conv_pre k t' i = Some r) -> i.<=.(m-k::t).
Proof with auto.
  intros k le_kn t' i H.
  induction k; simpl in H; destruct i;
    destruct t' as [p' H']; unfold pre in *; simpl in *;
    autorewrite with core in H'.
  1,3: destruct H as [r Hr]; inversion Hr.
  + apply H' in H; inversion H as [H0 H1]; inversion H1; intuition.
  + destruct H as [r Hr]; apply val_plus_some_inv in Hr;
      destruct Hr as [rv [rw [Hv Hw]]].
    rewrite Hw in IHk; clear Hw.
    destruct (IHk (le_Sn_le _ _ le_kn)) as [rx Hx].
    * exists rw...
    * intuition...
      assert(HEx: exists r, p' ((n0 + S k)%nat::S k::i) = Some r)
        by (exists rv; auto).
      autorewrite with core in H'; apply H' in HEx; inversion HEx.
      apply Nat.le_add_le_sub_r...
Qed.

Lemma tens_conv_domain {t : Tuple} {m n : nat} (le_nm : n <= m) :
  forall (t' : Tensor (m::n::t)), PreDomainP (m-n::t) (tens_conv_pre n t').
Proof with auto.
  intros t'; autorewrite with core; split.
  + apply (tens_conv_defined_2 le_nm)...
  + apply tens_conv_defined_1...
Qed.

Definition tens_conv {t : Tuple} {m n : nat} (le_nm : n <= m) :
  Tensor (m::n::t) -> Tensor (m-n::t) :=
    fun t' => exist _ (tens_conv_pre n t') (tens_conv_domain le_nm t').

Close Scope val_scope.
Close Scope pre_scope.
Close Scope list_scope.


CoInductive CoNat : Type :=
| Z : CoNat
| S : CoNat -> CoNat.

Definition pred (x : CoNat) : CoNat :=
  match x with
    | Z => Z
    | S x' => x'
  end.

Definition decomp (x : CoNat) : CoNat :=
  match x with
    | Z => Z
    | S x' => S x'
  end.

Lemma decomp_eql : forall x, x = decomp x.
  intro x. case x. simpl. auto.
  intros. simpl. auto.
Defined.

CoInductive CoEq : CoNat -> CoNat -> Prop :=
| coeq_base : CoEq Z Z
| coeq_next : forall x y, CoEq x y ->
  CoEq (S x) (S y).

Hint Constructors CoEq.

Infix "~=" := CoEq (at level 90).

Lemma coeq_refl : forall x, x ~= x.
  cofix.
  intro x. rewrite (decomp_eql x).
  destruct x. simpl. apply coeq_base.
  simpl. apply coeq_next.
  apply coeq_refl.
Defined.

Lemma coeq_sym : forall x y, x ~= y -> y ~= x.
  cofix.
  intros x y Hxy. rewrite (decomp_eql x) in *.
  rewrite (decomp_eql y) in *.
  destruct x ; destruct y.
  simpl in *. exact Hxy.
  simpl in Hxy. inversion Hxy.
  simpl in Hxy. inversion Hxy.
  simpl in *. apply coeq_next.
  apply coeq_sym. inversion Hxy as [H1|]; subst. exact H1.
Defined.

Lemma coeq_trans : forall x y z, x ~= y -> y ~= z -> x ~= z.
  cofix.
  intros x y z Hxy Hyz.
  destruct x ; destruct y ; destruct z ; inversion Hxy ; inversion Hyz ; subst.
  apply coeq_base.
  apply coeq_next. eapply coeq_trans. eauto. eauto.
Defined.

Hint Resolve coeq_refl coeq_sym coeq_trans.

Require Import Setoid.

Add Relation CoNat CoEq
  reflexivity proved by coeq_refl
  symmetry proved by coeq_sym
  transitivity proved by coeq_trans
as coeq_relation.

CoFixpoint inf : CoNat := S(inf).

CoFixpoint add (x:CoNat) (y:CoNat) : CoNat :=
  match y with
    | Z => x
    | S y' => S (add x y')
  end.

Infix "+" := add.

Lemma add_x_z : forall x, x + Z ~= x.
  intros. destruct x.
  (* Z *)
  rewrite (decomp_eql (Z + Z)) ; simpl ; auto.
  (* x *)
  rewrite (decomp_eql (S x + Z)). simpl. auto.
Defined.

Lemma add_z_x : forall x, Z + x ~= x.
  cofix.
  intros x. destruct x.
  (* Z *)
  rewrite (decomp_eql (Z + Z)) ; simpl ; auto.
  (* x *)
  rewrite (decomp_eql (Z + S x)) ; simpl.
  apply coeq_next (* guard *). auto.
Defined.

Lemma add_x_s : forall x y, x + (S y) = S (x + y).
  intros x y. rewrite (decomp_eql (add x (S y))). simpl. auto.
Defined.

Ltac co_unfold elt :=
  match goal with
    | |- context f [add ?x ?y] =>
      rewrite (decomp_eql (add x y)) ; simpl
  end.

Lemma add_s_x : forall x y, ((S x) + y) ~= (S (x + y)).
  cofix.
  intros x y.
  destruct x ; destruct y.
  (* Z, Z *)
  clear add_s_x. repeat co_unfold add. auto.
  (* Z, y *)
  co_unfold add. apply coeq_next. (* guard *)
  rewrite (decomp_eql (Z + S y)). simpl. auto.
  (* x, Z *)
  co_unfold add. apply coeq_next. (* guard *)
  rewrite (decomp_eql (S x + Z)). simpl. auto.
  (* x, y *)
  co_unfold add. apply coeq_next. (* guard *)
  rewrite (decomp_eql (S x + S y)). simpl. auto.
Defined.

Definition inf_eq : inf = (S inf).
  apply (decomp_eql inf).
Defined.

Lemma add_x_inf : forall x, (x+inf) ~= inf.
  cofix.
  intros x. rewrite (decomp_eql inf).
  simpl. rewrite add_x_s.
  apply coeq_next. auto.
Defined.

Lemma add_inf_x : forall x, (inf+x) ~= inf.
  cofix.
  intros x. destruct x.
  (* Z *)
  rewrite add_x_z. reflexivity.
  (* x *)
  rewrite (decomp_eql inf). simpl.
  co_unfold add.
  apply coeq_next. (* guard *)
  rewrite <- inf_eq. auto.
Defined.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_interior5.
Require Import ProofCheckingEuclid.lemma_onray_orderofpoints_any.
Require Import ProofCheckingEuclid.lemma_equalitysymmetric.
Require Import ProofCheckingEuclid.lemma_s_right_triangle.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_right_triangle_leg_change :
	forall A B C D,
	RightTriangle A B C ->
	OnRay B C D ->
	RightTriangle A B D.
Proof.
	intros A B C D.
	intros RightTriangle_ABC.
	intros OnRay_BC_D.

	assert (RightTriangle_ABC2 := RightTriangle_ABC).
	destruct RightTriangle_ABC2 as (E & BetS_A_B_E & Cong_AB_EB & Cong_AC_EC & neq_B_C).

	pose proof (cn_congruencereflexive B C) as Cong_BC_BC.
	pose proof (cn_congruencereflexive C D) as Cong_CD_CD.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AB_EB) as (Cong_BA_BE & _ & _).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AC_EC) as (Cong_CA_CE & _ & _).

	pose proof (lemma_onray_orderofpoints_any _ _ _ OnRay_BC_D) as [BetS_B_D_C|[eq_C_D|BetS_B_C_D]].
	{
		(* case BetS_B_D_C *)
		pose proof (cn_congruencereflexive B D) as Cong_BD_BD.
		pose proof (cn_congruencereflexive D C) as Cong_DC_DC.
		pose proof (
			lemma_interior5
			_ D _ A
			_ D _ E
			BetS_B_D_C
			BetS_B_D_C
			Cong_BD_BD
			Cong_DC_DC
			Cong_BA_BE
			Cong_CA_CE
		) as Cong_DA_DE.
		pose proof (lemma_congruenceflip _ _ _ _ Cong_DA_DE) as (Cong_AD_ED & _ & _).
		pose proof (lemma_betweennotequal _ _ _ BetS_B_D_C) as (_ & neq_B_D & _).

		pose proof (lemma_s_right_triangle _ _ _ _ BetS_A_B_E Cong_AB_EB Cong_AD_ED neq_B_D) as RightTriangle_ABD.

		exact RightTriangle_ABD.
	}
	{
		(* case eq_C_D *)
		pose proof (lemma_equalitysymmetric _ _ eq_C_D) as eq_D_C.
		assert (RightTriangle A B D) as RightTriangle_ABD by (rewrite eq_D_C; exact RightTriangle_ABC).

		exact RightTriangle_ABD.
	}
	{
		(* case BetS_B_C_D *)
		pose proof (
			axiom_5_line
			B C D A
			B C D E
			Cong_BC_BC
			Cong_CA_CE
			Cong_AB_EB

			BetS_B_C_D
			BetS_B_C_D

			Cong_AC_EC
			Cong_CD_CD
		) as Cong_DA_DE.
		pose proof (lemma_congruenceflip _ _ _ _ Cong_DA_DE) as (Cong_AD_ED & _ & _).
		pose proof (lemma_betweennotequal _ _ _ BetS_B_C_D) as (_ & _ & neq_B_D).
		pose proof (lemma_s_right_triangle _ _ _ _ BetS_A_B_E Cong_AB_EB Cong_AD_ED neq_B_D) as RightTriangle_ABD.

		exact RightTriangle_ABD.
	}
Qed.

End Euclid.


(*---------------------------------------------------------------------------
    Various helpers for halving, double and powers of 2
  ---------------------------------------------------------------------------*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.ssrnat Ssreflect.seq Ssreflect.tuple Ssreflect.zmodp Ssreflect.fintype Ssreflect.div.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma half_ltn_double m n : m < n.*2 -> m./2 < n.
Proof. move => H.
rewrite -ltn_double. rewrite -(odd_double_half m) in H.
rewrite -(ltn_add2l (odd m)).
by apply ltn_addl.
Qed.

Lemma half_double_subn1 a : ((a.*2).-1)./2 = a.-1.
Proof. case a. done. move => a'. simpl; apply uphalf_double. Qed.

Lemma uphalf_double_subn1 a : uphalf ((a.*2).-1) = a.
Proof. case a. done. move => a'. simpl; by rewrite half_double. Qed.

Lemma half_subn1 : forall a b, (b - a.+1)./2 = (uphalf (b - a)).-1.
Proof. induction a.
+ case => //. move => b. by rewrite subn1.
+ move => b. specialize (IHa (b.-1)).
rewrite -subn1 in IHa. by rewrite -!subnDA !add1n in IHa.
Qed.

(* Strictly speaking we don't need the precondition *)
Lemma half_sub a : forall b, a <= b.*2 -> (b.*2 - a)./2 = b - uphalf a.
Proof.
induction a => b H.
+ by rewrite !subn0 doubleK.
+ rewrite half_subn1. rewrite uphalf_half. rewrite IHa.
  rewrite odd_sub. rewrite odd_double/=. rewrite -subn1.
  rewrite uphalf_half.
case ODD: (odd a).
  by rewrite add1n subn1.
  by rewrite !add0n/= -subnDA addn1.
apply (ltnW H). apply (ltnW H).
Qed.

Lemma odd_oddsubn1 : forall n, n > 0 -> odd n.-1 = ~~odd n.
Proof. induction n => //. destruct n => //. simpl. by case (odd n). Qed.

Lemma odd_power2 n : odd (2^(n.+1)) = false.
Proof. by rewrite expnS mul2n odd_double. Qed.

Lemma odd_power2subn1 n : odd ((2^(n.+1)).-1) = true.
Proof. induction n => //.
rewrite expnS mul2n odd_oddsubn1.
by rewrite odd_double.
rewrite -mul2n -expnS. apply expn_gt0.
Qed.

Lemma leq_subn a b : 0 < b -> a < b -> a <= b.-1.
Proof. by case b. Qed.

Lemma pow2_gt1 n : 1 < 2^n.+1.
Proof. rewrite expnS.
suff: 2*1 <= 2*2^n => //.
rewrite leq_mul2l/=.
apply expn_gt0.
Qed.

Lemma nat_lt0_succ m : (0 < m) = true -> exists m', m = m'+1.
Proof. destruct m => //. move => _. exists m. by rewrite addn1.
Qed.

Lemma pow2_sub_ltn n x : (2^n)-(x.+1) < 2^n.
Proof. have H := expn_gt0 2 n. simpl in H.
destruct (nat_lt0_succ H) as [m' HH]. rewrite HH.
rewrite addn1 subSS. by rewrite ltnS leq_subr.
Qed.

Lemma modn_sub : forall N x y, 0 < N -> x < N -> y < N -> N <= x+y ->
   (x + y) %% N + N = x+y.
Proof.
move => N x y B H1 H2 H3.
assert (H4:= divn_eq (x+y) N).
rewrite {2}H4.
rewrite addnC.
assert (LT:(x + y) %/ N < 2).
rewrite ltn_divLR. rewrite mul2n -addnn.
rewrite -(ltn_add2r y) in H1.
apply (ltn_trans H1).
by rewrite ltn_add2l.
done.
assert (GT:0 < (x + y) %/ N).
by rewrite divn_gt0. rewrite ltnS in LT.
assert (1 <= (x+y) %/ N <= 1). by rewrite GT LT.
rewrite -eqn_leq in H. rewrite -(eqP H).
by rewrite mul1n.
Qed.

(* Good ol' induction over natural numbers: *)
Fixpoint nat_ind (P : nat -> Type)
                   (bc : P 0)
                   (ih : forall n, P n -> P n.+1)
                   (n: nat) : P n :=
  match n with
    | 0 => bc
    | n.+1 => ih n (nat_ind bc ih n)
  end.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.
Require Import Coq.Program.Basics.

Require Import basics.
Require Import categories.

Delimit Scope preord_scope with preord.
Open Scope preord_scope.

(**  * Preordered types and monotone functions.

     A preorder is a type equipped with a transitive,
     reflexive relation.  Unlike standard domain theory,
     we will be concentrating on preorders rather than
     partial orders as the basis of order theory.

     As compared to partial orders, preorders lack the
     axiom of antisymmetry.  Instead, we work (almost) always
     up to the equivalence relation induced by the preorder.
     On a preorder, we automatically define a setoid
     by setting [x ≈ y] iff [x ≤ y /\ y ≤ x].  Thus, we
     "recover" antisymmetry by convention.
  *)
Module Preord.
  Record mixin_of (T:Type) :=
    Mixin
    { ord : T -> T -> Prop
    ; refl : forall x, ord x x
    ; trans : forall {x y z},
             ord x y -> ord y z -> ord x z
    }.
  Structure type : Type :=
    Pack { carrier :> Type ; mixin : mixin_of carrier }.

  Definition ord_op T := ord _ (mixin T).

  Record hom (X Y:type) := Hom
    { map :> carrier X -> carrier Y
    ; axiom : forall (a b:carrier X), ord_op X a b -> ord_op Y (map a) (map b)
    }.

  Program Definition ident (X:type) : hom X X := Hom X X (fun x => x) _.
  Program Definition compose (X Y Z:type) (g:hom Y Z) (f:hom X Y)
    := Hom X Z (fun x => g (f x)) _.
  Next Obligation.
    apply axiom. apply axiom. auto.
  Qed.

  Definition comp_mixin := Comp.Mixin type hom ident compose.

  Definition eq (X:type) (a b:X) := ord_op X a b /\ ord_op X b a.

  Definition hom_ord (X Y:type) (f g:hom X Y) := forall x, ord_op Y (f x) (g x).
  Definition hom_eq (X Y:type) (f g:hom X Y) := forall x, eq Y (f x) (g x).

  Program Definition ord_mixin X Y := Mixin (hom X Y) (hom_ord X Y) _ _.
  Next Obligation.
    red; intro. apply refl.
  Qed.
  Next Obligation.
    red; intro. eapply trans; eauto.
    apply (H x0). apply (H0 x0).
  Qed.

  Program Definition eq_mixin X Y := Eq.Mixin (hom X Y) (hom_eq X Y) _ _ _.
  Next Obligation.
    red; intros. red. split; apply refl.
  Qed.
  Next Obligation.
    red; intros. red. split.
    destruct (H x0); auto.
    destruct (H x0); auto.
  Qed.
  Next Obligation.
    intro.
    destruct (H x0). destruct (H0 x0).
    split; eapply trans; eauto.
  Qed.

  Lemma cat_axioms : Category.axioms type hom eq_mixin comp_mixin.
    constructor.

    repeat intro. split. simpl. red. apply refl.
    repeat intro. simpl. red. apply refl.

    repeat intro. split. simpl. red. apply refl.
    simpl. red. apply refl.

    repeat intro. split; simpl; red; apply refl.
    repeat intro. split; simpl; red.
    apply trans with (f (g' x)).
    apply axiom.
    destruct (H0 x); auto.
    destruct (H (g' x)); auto.
    apply trans with (f (g' x)).
    destruct (H (g' x)); auto.
    apply axiom.
    destruct (H0 x); auto.
  Qed.

  Program Definition ord_eq (T:type) : Eq.mixin_of T :=
    Eq.Mixin T (eq T) _ _ _.
  Next Obligation.
    split; apply refl.
  Qed.
  Next Obligation.
    destruct H; split; auto.
  Qed.
  Next Obligation.
    destruct H; destruct H0.
    split; eapply trans; eauto.
  Qed.
End Preord.
Notation preord := Preord.type.

Notation "x ≤ y" := (@Preord.ord_op _ x y) : preord_scope.
Notation "y ≥ x" := (@Preord.ord_op _ x y) (only parsing) : preord_scope.
Notation "x ≰ y" := (~ (@Preord.ord_op _ x y)) : preord_scope.
Notation "y ≱ x" := (~ (@Preord.ord_op _ x y)) (only parsing) : preord_scope.

(**  Here we set up the category PREORD of preorders with montone functions
     and the canonical structure magic that makes notation work.
  *)
Coercion Preord.carrier : Preord.type >-> Sortclass.
Coercion Preord.map : Preord.hom >-> Funclass.

Canonical Structure hom_order X Y := Preord.Pack (Preord.hom X Y) (Preord.ord_mixin X Y).
Canonical Structure Preord_Eq (X:preord) : Eq.type :=
  Eq.Pack (Preord.carrier X) (Preord.ord_eq X).

Canonical Structure PREORD :=
  Category preord Preord.hom _ _ Preord.cat_axioms.

Canonical Structure preord_hom_eq (A B:preord):=
  Eq.Pack (Preord.hom A B) (Preord.eq_mixin A B).
Canonical Structure preord_comp :=
  Comp.Pack preord Preord.hom Preord.comp_mixin.

(**  The preorder axioms and their relation to equality.
  *)
Lemma ord_refl : forall (T:preord) (x:T), x ≤ x.
Proof.
  intros. destruct T. destruct mixin. apply refl.
Qed.

Lemma ord_trans : forall (T:preord) (x y z:T), x ≤ y -> y ≤ z -> x ≤ z.
Proof.
  intros. destruct T. destruct mixin. eapply trans; eauto.
Qed.

Lemma ord_antisym : forall (T:preord) (x y:T), x ≤ y -> y ≤ x -> x ≈ y.
Proof.
  intros. split; auto.
Qed.

Lemma eq_ord : forall (T:preord) (x y:T), x ≈ y -> x ≤ y.
Proof.
  intros; destruct H; auto.
Qed.

Lemma eq_ord' : forall (T:preord) (x y:T), x ≈ y -> y ≤ x.
Proof.
  intros; destruct H; auto.
Qed.

(**  Set up setoid rewriting
  *)
Add Parametric Relation (A:preord) : (Preord.carrier A) (@Preord.ord_op A)
  reflexivity proved by (ord_refl A)
  transitivity proved by (ord_trans A)
    as ord_rel.

Add Parametric Morphism (A:preord) :
  (@Preord.ord_op A)
    with signature (Preord.ord_op A) -->
                   (Preord.ord_op A) ++>
                   impl
     as ord_morphism.
Proof.
  repeat intro.
  transitivity x; auto.
  transitivity x0; auto.
Qed.

Add Parametric Morphism (A:preord) :
  (@Preord.ord_op A)
    with signature (eq_op (Preord_Eq A)) ==>
                   (eq_op (Preord_Eq A)) ==>
                   iff
     as ord_eq_morphism.
Proof.
  intros.
  destruct H; destruct H0.
  split; intros.
  transitivity x; auto.
  transitivity x0; auto.
  transitivity y; auto.
  transitivity y0; auto.
Qed.

Add Parametric Morphism (A B:preord) :
  (@Preord.map A B)
   with signature (Preord.ord_op (hom_order A B)) ++>
                  (Preord.ord_op A) ++>
                  (Preord.ord_op B)
    as preord_map_morphism.
Proof.
  intros.
  transitivity (x y0).
  apply Preord.axiom. auto.
  apply H.
Qed.

Add Parametric Morphism (A B:preord) :
  (@Preord.map A B)
   with signature (eq_op (Preord_Eq (hom_order A B))) ==>
                  (eq_op (Preord_Eq A)) ==>
                  (eq_op (Preord_Eq B))
    as preord_map_eq_morphism.
Proof.
  intros.
  transitivity (x y0).
  destruct H0; split; apply Preord.axiom; auto.
  destruct H; split; auto.
Qed.

(**  This lemma is handy for using an equality in the context to prove a goal
     by transitivity on both sides.
  *)
Lemma use_ord (A:preord) (a b c d:A) :
  b ≤ c -> a ≤ b -> c ≤ d -> a ≤ d.
Proof.
  intros.
  transitivity b; auto.
  transitivity c; auto.
Qed.
Arguments use_ord [A] [a] [b] [c] [d] _ _ _.

(**  PREORD is a concrete category.
  *)
Program Definition PREORD_concrete : concrete PREORD :=
  Concrete PREORD
  Preord.carrier
  (fun X => Eq.mixin (Preord_Eq X))
  Preord.map _ _.
Next Obligation.
  split.
  apply ord_trans with (Preord.map A B f y).
  apply Preord.axiom. destruct H0; auto.
  destruct (H y); auto.
  apply ord_trans with (Preord.map A B f y).
  destruct (H y); auto.
  apply Preord.axiom. destruct H0; auto.
Qed.
Next Obligation.
  split; apply Preord.refl.
Qed.

Canonical Structure PREORD_concrete.

(**  Monotone functions respect equality and order.
  *)
Lemma preord_eq : forall (X Y:preord) (f:X → Y) (x y:X), x ≈ y -> f x ≈ f y.
Proof.
  intros. rewrite H. auto.
Qed.

Lemma preord_ord : forall (X Y:preord) (f:X → Y) (x y:X), x ≤ y -> f x ≤ f y.
Proof.
  intros. apply Preord.axiom. auto.
Qed.

Hint Resolve ord_refl ord_trans ord_antisym preord_ord preord_eq eq_ord eq_ord'.

Add Parametric Morphism (X Y:preord) :
  (@hommap PREORD PREORD_concrete X Y)
  with signature (eq_op (CAT_EQ PREORD X Y)) ==>
                 (eq_op (Preord_Eq X)) ==>
                 (eq_op (Preord_Eq Y))
  as preord_apply_eq_morphism.
Proof.
  intros.
  transitivity (x#y0).
  apply preord_eq; auto.
  apply H.
Qed.

Add Parametric Morphism (X Y:preord) :
  (@hommap PREORD PREORD_concrete X Y)
  with signature (eq_op (CAT_EQ PREORD X Y)) ++>
                 (eq_op (Preord_Eq X)) ++>
                 (Preord.ord_op Y)
  as preord_apply_eqord_morphism.
Proof.
  intros.
  transitivity (x#y0).
  apply preord_eq; auto.
  apply H.
Qed.

Add Parametric Morphism (X Y:preord) :
  (@hommap PREORD PREORD_concrete X Y)
  with signature (fun (x y:hom PREORD X Y) => Preord.ord_op (hom_order X Y) x y) ==>
                 (Preord.ord_op X) ==>
                 (Preord.ord_op Y)
  as preord_apply_ord_morphism.
Proof.
  intros.
  transitivity (x#y0).
  apply preord_ord. auto.
  apply H.
Qed.

(** PREORD is termianted. *)

Program Definition unitpo := Preord.Pack unit (Preord.Mixin _ (fun _ _ => True) _ _).
Canonical Structure unitpo.

Program Definition preord_terminate (A:preord) : A → unitpo :=
  Preord.Hom A unitpo (fun x => tt) _.

Program Definition preord_terminated_mixin :=
  Terminated.Mixin
     preord Preord.hom
     Preord.eq_mixin
     unitpo preord_terminate
     _.
Next Obligation.
  split; simpl; hnf; auto.
Qed.

Canonical Structure preord_terminated :=
  Terminated
     preord Preord.hom
     Preord.eq_mixin
     Preord.comp_mixin
     Preord.cat_axioms
     preord_terminated_mixin.

(** PREORD is initialized. *)
Program Definition emptypo :=
  Preord.Pack False (Preord.Mixin _ (fun _ _ => False) _ _).
Canonical Structure emptypo.

Program Definition preord_initiate (A:preord) : emptypo → A :=
  Preord.Hom emptypo A (fun x => False_rect _ x) _.
Next Obligation. elim a. Qed.

Program Definition preord_initialized_mixin :=
  Initialized.Mixin
     preord Preord.hom
     Preord.eq_mixin
     emptypo preord_initiate
     _.
Next Obligation.
  split; simpl; elim x.
Qed.

Canonical Structure preord_initialized :=
  Initialized
     preord Preord.hom
     Preord.eq_mixin
     Preord.comp_mixin
     Preord.cat_axioms
     preord_initialized_mixin.

(**  The preorder on products, defined pointwise. *)
Definition prod_ord (A B:preord) (x y:A*B):=
  (fst x) ≤ (fst y) /\ (snd x) ≤ (snd y).

Program Definition prod_preord (A B:preord) : preord :=
  Preord.Pack (A*B) (Preord.Mixin _ (prod_ord A B) _ _).
Next Obligation.
  hnf. simpl; auto.
Qed.
Next Obligation.
  destruct H; destruct H0; split; simpl in *.
  eapply ord_trans; eauto.
  eapply ord_trans; eauto.
Qed.

Canonical Structure prod_preord.

(** PREORD is a cartesian category. *)
Program Definition pi1 {A B:preord} : prod_preord A B → A :=
  Preord.Hom (prod_preord A B) A (fun x => fst x) _.
Next Obligation.
  destruct H; simpl; auto.
Qed.

Program Definition pi2 {A B:preord} : prod_preord A B → B :=
  Preord.Hom (prod_preord A B) B (fun x => snd x) _.
Next Obligation.
  destruct H; simpl; auto.
Qed.

Program Definition mk_pair {C A B:preord} (f:C → A) (g:C → B) : C → prod_preord A B :=
  Preord.Hom C (prod_preord A B) (fun c => (f c, g c)) _.
Next Obligation.
  intros. split; simpl; apply Preord.axiom; auto.
Qed.

Program Definition preord_cartesian_mixin
  := Cartesian.Mixin
      Preord.type Preord.hom
      Preord.eq_mixin
      Preord.comp_mixin
      prod_preord (@pi1) (@pi2) (@mk_pair) _.
Next Obligation.
  constructor.

  intros. split; simpl; auto.
  intros. split; simpl; auto.

  intros. intro. split. simpl.
  split; simpl.
  destruct (H x); auto.
  destruct (H0 x); auto.
  split; simpl.
  destruct (H x); auto.
  destruct (H0 x); auto.
Qed.

Canonical Structure preord_cartesian : cartesian :=
  Cartesian Preord.type Preord.hom
      Preord.eq_mixin
      Preord.comp_mixin
      Preord.cat_axioms
      preord_terminated_mixin
      preord_cartesian_mixin.

(** Further, PREORD is a cartesian closed category. *)
Program Definition preord_curry (C A B:preord) (f:C×A → B) : C → hom_order A B :=
  Preord.Hom C (hom_order A B) (fun c => Preord.Hom A B (fun a => f (c,a)) _) _.
Next Obligation.
  apply preord_ord. split; auto.
Qed.
Next Obligation.
  intro x. simpl.
  apply preord_ord. split; auto.
Qed.

Program Definition preord_apply (A B:preord) : (hom_order A B × A) → B :=
  Preord.Hom (hom_order A B × A) B (fun fx => fst fx (snd fx)) _.
Next Obligation.
  simpl. destruct H; simpl in *.
  apply preord_map_morphism; auto.
Qed.

Program Definition preord_ccc_mixin
   := CartesianClosed.Mixin
       Preord.type Preord.hom
       Preord.eq_mixin
       Preord.comp_mixin
       Preord.cat_axioms
       preord_terminated_mixin
       preord_cartesian_mixin
       hom_order preord_curry preord_apply
       _.
Next Obligation.
  constructor.

  simpl. intros.
  split; simpl; destruct x; simpl; auto.

  simpl. intros.
  split; intro z; simpl.
  rewrite <- H. simpl; auto.
  rewrite <- H. simpl; auto.
Qed.

Canonical Structure preord_ccc : cartesian_closed :=
  CartesianClosed
       Preord.type Preord.hom
       Preord.eq_mixin
       Preord.comp_mixin
       Preord.cat_axioms
       preord_cartesian_mixin
       preord_terminated_mixin
       preord_ccc_mixin.

(** The preorder on sums, defined in the standard way.
  *)
Definition sum_ord (A B:preord) (x y:A+B):=
  match x, y with
  | inl x', inl y' => x' ≤ y'
  | inr x', inr y' => x' ≤ y'
  | _, _ => False
  end.

Program Definition sum_preord (A B:preord) : preord :=
  Preord.Pack (A+B) (Preord.Mixin _ (sum_ord A B) _ _).
Next Obligation.
  hnf. destruct x; auto.
Qed.
Next Obligation.
  hnf. destruct x; destruct y; destruct z; simpl in *; intuition.
  eapply ord_trans; eauto.
  eapply ord_trans; eauto.
Qed.

Canonical Structure sum_preord.

(**  Preorders with an [ord_dec] structure have a decidable order relation.
  *)
Record ord_dec (A:preord) :=
  OrdDec
  { orddec :> forall x y:A, {x ≤ y}+{x ≰ y} }.

Arguments orddec [A] [o] x y.

(**  Preorders with decidable ordering also have decidable equality.
  *)
Canonical Structure PREORD_EQ_DEC (A:preord) (OD:ord_dec A) :=
  EqDec (Preord_Eq A) (fun (x y:A) =>
      match @orddec A OD x y with
      | left H1 =>
          match @orddec A OD y x with
          | left H2 => left _ (conj H1 H2)
          | right H => right _ (fun HEQ => H (proj2 HEQ))
          end
      | right H => right (fun HEQ => H (proj1 HEQ))
      end).

(** The "lift" preorder, which adjoins a new bottom element.
    The lift construction gives rise to an endofunctor on PREORD.
  *)
Definition lift_ord (A:preord) (x:option A) (y:option A) : Prop :=
   match x with None => True | Some x' =>
     match y with None => False | Some y' => x' ≤ y' end end.

Program Definition lift_mixin (A:preord) : Preord.mixin_of (option A) :=
  Preord.Mixin (option A) (lift_ord A) _ _.
Next Obligation.
  destruct x; simpl; auto.
Qed.
Next Obligation.
  destruct x; destruct y; destruct z; simpl in *; intuition. eauto.
Qed.

Canonical Structure lift (A:preord) : preord :=
  Preord.Pack (option A) (lift_mixin A).

Program Definition liftup (A:preord) : A → lift A :=
  Preord.Hom A (lift A) (@Some A) _.

Program Definition lift_map {A B:preord} (f:A → B) : lift A → lift B :=
  Preord.Hom (lift A) (lift B) (option_map (Preord.map A B f)) _.
Next Obligation.
  red; intros. destruct a; destruct b; simpl in *; auto.
Qed.

Lemma lift_map_id (A:preord) : lift_map id(A) ≈ id(lift A).
Proof.
  split; hnf; destruct x; simpl; auto.
Qed.

Lemma lift_map_compose (A B C:preord) (g:B → C) (f:A → B) :
  lift_map (g ∘ f) ≈ lift_map g ∘ lift_map f.
Proof.
  split; hnf; destruct x; simpl; auto.
Qed.

Lemma lift_map_eq (A B:preord) (f f':A → B) : f ≈ f' -> lift_map f ≈ lift_map f'.
Proof.
  intros.
  split; hnf; destruct x; simpl; auto.
  apply H. apply H.
Qed.

Program Definition liftF : functor PREORD PREORD :=
  (Functor PREORD PREORD lift (@lift_map) _ _ _).
Next Obligation.
  transitivity (lift_map id(A)).
  apply lift_map_eq; auto.
  apply lift_map_id.
Qed.
Next Obligation.
  transitivity (lift_map (f ∘ g)).
  apply lift_map_eq; auto.
  apply lift_map_compose.
Qed.
Next Obligation.
  apply lift_map_eq. auto.
Qed.


(*|
######################################################
Proving ``False`` with negative inductive types in Coq
######################################################

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

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

The third chapter of CPDT briefly discusses why negative inductive
types are forbidden in Coq. If we had
|*)

Fail Inductive term : Set :=
| App : term -> term -> term
| Abs : (term -> term) -> term. (* .fails *)

(*|
then we could easily define a function

.. code-block:: coq

    Definition uhoh (t : term) : term :=
      match t with
      | Abs f => f t
      | _ => t
      end.

so that the term ``uhoh (Abs uhoh)`` would be non-terminating, with
which "we would be able to prove every theorem".

I understand the non-termination part, but I don't get how we can
prove anything with it. How would one prove ``False`` using ``term``
as defined above?
|*)

(*|
Answer
******

Reading your question made me realize that I didn't quite understand
Adam's argument either. But inconsistency in this case results quite
easily from Cantor's usual `diagonal argument
<https://en.wikipedia.org/wiki/Cantor%27s_diagonal_argument>`__ (a
never-ending source of paradoxes and puzzles in logic). Consider the
following assumptions:
|*)

Section Diag.

  Variable T : Type.
  Variable test : T -> bool.
  Variables x y : T.

  Hypothesis xT : test x = true.
  Hypothesis yF : test y = false.

  Variable g : (T -> T) -> T.
  Variable g_inv : T -> (T -> T).

  Hypothesis gK : forall f, g_inv (g f) = f.

  Definition kaboom (t : T) : T :=
    if test (g_inv t t) then y else x.

  Lemma kaboom1 : forall t, kaboom t <> g_inv t t.
  Proof using T test x y xT yF g_inv.
    intros t H.
    unfold kaboom in H.
    destruct (test (g_inv t t)) eqn:E; congruence.
  Qed.

  Lemma kaboom2 : False.
  Proof using T test x y xT yF g g_inv gK.
    assert (H := @kaboom1 (g kaboom)).
    rewrite -> gK in H.
    congruence.
  Qed.

End Diag.

(*|
This is a generic development that could be instantiated with the
``term`` type defined in CPDT: ``T`` would be ``term``, ``x`` and
``y`` would be two elements of ``term`` that we can test discriminate
between (e.g. ``App (Abs id) (Abs id)`` and ``Abs id``). The key point
is the last assumption: we assume that we have an invertible function
``g : (T -> T) -> T`` which, in your example, would be ``Abs``. Using
that function, we play the usual diagonalization trick: we define a
function ``kaboom`` that is by construction different from every
function ``T -> T``, including itself. The contradiction results from
that.
|*)


(**

This module provides an [order] tactic that solves
goals involving the operations of a lawful [Ord] type class.

It is inspired by [Coq.Structures.OrdersTac], but does not use
the module system.
**)

Require Import GHC.Base.
Require Import Proofs.GHC.Base.
Set Bullet Behavior "Strict Subproofs".

Class OrdLaws (t : Type) {HEq : Eq_ t} {HOrd : Ord t} {HEqLaw : EqLaws t} :=
  { (* The axioms *)
    Ord_antisym  : forall a b, a <= b = true -> b <= a = true -> a == b = true;
    Ord_trans_le : forall a b c, a <= b = true -> b <= c = true -> a <= c = true;
    Ord_total    : forall a b, a <= b = true \/ b <= a = true;
    (* The other operations, in terms of <= or == *)
    Ord_compare_Lt : forall a b, compare a b = Lt <-> b <= a = false;
    Ord_compare_Eq : forall a b, compare a b = Eq <-> a == b = true;
    Ord_compare_Gt : forall a b, compare a b = Gt <-> a <= b = false;
    Ord_lt_le : forall a b, a < b = negb (b <= a);
    Ord_ge_le : forall a b, a >= b = (b <= a);
    Ord_gt_le : forall a b, a >  b = negb (a <= b);
  }.

Module Lemmas.
Section Lemmas.
  Context {t : Type} {HEq : Eq_ t} {HOrd : Ord t} {HEqLaw : EqLaws t} {HOrdLaw : OrdLaws t}.

  Lemma Eq_neq_sym (x y : t) : (x == y) = false -> (y == x) = false.
  Proof. rewrite Eq_sym; auto. Qed.

  Lemma Eq_ne_eq (x y : t) : (x /= y) = negb (x == y).
  Proof. rewrite Eq_inv, negb_involutive; auto. Qed.

  Lemma Eq_eq_refl (x : t) : (x == x) = true.
  Proof. rewrite Eq_refl; auto. Qed.

  Lemma Ord_le_refl (x : t) : (x <= x) = true.
  Proof. destruct (Ord_total x x); auto. Qed.

  Lemma Eq_trans_l (x y z : t) : (x == y) = true -> (x == z) = (y == z).
  Proof.
    intros Exy; specialize (Eq_trans y x z Exy).
    destruct (y == z) eqn:Eyz.
    - intros H; rewrite H; auto. apply Eq_refl.
    - destruct (x == z) eqn:Exz; auto.
      exfalso.
      rewrite Eq_sym in Exz.
      specialize (Eq_trans _ _ _ Exz Exy); rewrite Eq_sym, Eyz.
      auto.
  Qed.

  Lemma Eq_trans_r (x y z : t) : (x == y) = true -> (z == x) = (z == y).
  Proof. rewrite (Eq_sym z x), (Eq_sym z y); apply Eq_trans_l. Qed.

  Lemma Eq_le_l (x y z : t) : (x == y) = true -> (x <= z) = (y <= z).
  Proof.
    intros Exy.
    rewrite <-Ord_compare_Eq in Exy;
      (destruct (x <= z) eqn:LExz; [|rename LExz into GTxz]);
      (destruct (y <= z) eqn:LEyz; [|rename LEyz into GTyz]);
      auto; exfalso.
    - apply not_true_iff_false in GTyz; apply GTyz; clear GTyz.
      apply Ord_trans_le with x; auto.
      rewrite <-not_false_iff_true, <-Ord_compare_Lt.
      congruence.
    - apply not_true_iff_false in GTxz; apply GTxz; clear GTxz.
      apply Ord_trans_le with y; auto.
      rewrite <-not_false_iff_true, <-Ord_compare_Gt.
      congruence.
  Qed.

  Lemma Eq_le_r (x y z : t) : (x == y) = true -> (z <= x) = (z <= y).
  Proof.
    intros Exy.
    rewrite <-Ord_compare_Eq in Exy;
      (destruct (z <= x) eqn:LEzx; [|rename LEzx into GTzx]);
      (destruct (z <= y) eqn:LEzy; [|rename LEzy into GTzy]);
      auto; exfalso.
    - apply not_true_iff_false in GTzy; apply GTzy; clear GTzy.
      apply Ord_trans_le with x; auto.
      rewrite <-not_false_iff_true, <-Ord_compare_Gt.
      congruence.
    - apply not_true_iff_false in GTzx; apply GTzx; clear GTzx.
      apply Ord_trans_le with y; auto.
      rewrite <-not_false_iff_true, <-Ord_compare_Lt.
      congruence.
  Qed.

  Lemma NEq_le_l (x y : t) : (x == y) = false -> (x <= y) = true -> (y <= x) = false.
  Proof.
    intros Nxy LExy.
    apply not_true_iff_false; intros LEyx.
    specialize (Ord_antisym _ _ LExy LEyx); rewrite Nxy; auto.
  Qed.

  Lemma NEq_le_r (x y : t) : (x == y) = false -> (y <= x) = true -> (x <= y) = false.
  Proof.
    intros Nxy LEyx.
    apply not_true_iff_false; intros LExy.
    specialize (Ord_antisym _ _ LExy LEyx); rewrite Nxy; auto.
  Qed.

  Lemma Ord_trans_lt (x y z : t) : y <= x = false -> z <= y = false -> z <= x = false.
  Proof.
    intros GTyx GTzy;
      apply not_true_iff_false in GTyx;
      apply not_true_iff_false in GTzy;
      apply not_true_iff_false;
      intros LEzx.
    destruct (Ord_total y x) as [? | LEyx]; try tauto.
    specialize (Ord_trans_le _ _ _ LEzx LEyx); auto.
  Qed.

  Lemma Ord_trans_lt_le (x y z : t) : y <= x = false -> y <= z = true -> z <= x = false.
  Proof.
    intros GTyx LEyz;
      apply not_true_iff_false in GTyx;
      apply not_true_iff_false;
      intros LEzx.
    specialize (Ord_trans_le _ _ _ LEyz LEzx); auto.
  Qed.

  Lemma Ord_trans_le_lt (x y z : t) : x <= y = true -> z <= y = false -> z <= x = false.
  Proof.
    intros LExy GTzy;
      apply not_true_iff_false in GTzy;
      apply not_true_iff_false;
      intros LEzx.
    specialize (Ord_trans_le _ _ _ LEzx LExy); auto.
  Qed.
End Lemmas.
End Lemmas.

(* Translate `bool` manipulation to `Prop` manipulation, and get rid of ssreflect *)

Ltac not_bool_const b :=
  match b with
  | true  => fail 1
  | false => fail 1
  | _     => idtac
  end.

Ltac nonconst_bool_eq_to_iff :=
  repeat match goal with
  | H : context[?b1 = ?b2 :> bool] |- _ =>
    not_bool_const b1; not_bool_const b2; rewrite ->eq_iff_eq_true in H
  | |- context[?b1 = ?b2 :> bool] =>
    not_bool_const b1; not_bool_const b2; rewrite ->eq_iff_eq_true
  end.

Hint Rewrite -> andb_true_iff : bool_to_prop.
Hint Rewrite -> orb_true_iff  : bool_to_prop.
Hint Rewrite -> negb_true_iff : bool_to_prop.

Ltac bool_to_prop :=
  nonconst_bool_eq_to_iff;
  unfold is_true in *;
  autorewrite with bool_to_prop in *.

(* `order` tactic *)

Ltac order_prepare t :=
 lazymatch goal with
 | H : ?A -> False |- _ => change (~A) in H; order_prepare t
 | H : _ <> true   |- _ => rewrite not_true_iff_false in H; order_prepare t
 | H : _ <> false  |- _ => rewrite not_false_iff_true in H; order_prepare t
 | H : negb ?b = true |- _ => rewrite negb_true_iff in H; order_prepare t
 | H : negb ?b = false |- _ => rewrite negb_false_iff in H; order_prepare t
 | H : @op_zsze__ t _   ?x ?y = ?b |- _ => rewrite Lemmas.Eq_ne_eq in H; order_prepare t
 | H : @op_zl__   t _ _ ?x ?y = ?b |- _ => rewrite Ord_lt_le in H; order_prepare t
 | H : @op_zgze__ t _ _ ?x ?y = ?b |- _ => rewrite Ord_ge_le in H; order_prepare t
 | H : @op_zg__   t _ _ ?x ?y = ?b |- _ => rewrite Ord_gt_le in H; order_prepare t
 | H : @compare   t _ _ ?x ?y = Eq |- _ => rewrite Ord_compare_Eq in H; order_prepare t
 | H : @compare   t _ _ ?x ?y = Lt |- _ => rewrite Ord_compare_Lt in H; order_prepare t
 | H : @compare   t _ _ ?x ?y = Gt |- _ => rewrite Ord_compare_Gt in H; order_prepare t
 | |- @compare   t _ _ ?x ?y = Eq => rewrite Ord_compare_Eq; order_prepare t
 | |- @compare   t _ _ ?x ?y = Lt => rewrite Ord_compare_Lt; order_prepare t
 | |- @compare   t _ _ ?x ?y = Gt => rewrite Ord_compare_Gt; order_prepare t
 (* reorient *)
 | H : true  = @op_zeze__ t _   ?x ?y |- _ => symmetry in H; order_prepare t
 | H : false = @op_zeze__ t _   ?x ?y |- _ => symmetry in H; order_prepare t
 | |-  true  = @op_zeze__ t _   ?x ?y      => symmetry;      order_prepare t
 | |-  false = @op_zeze__ t _   ?x ?y      => symmetry;      order_prepare t
 | H : true  = @op_zlze__ t _ _ ?x ?y |- _ => symmetry in H; order_prepare t
 | H : false = @op_zlze__ t _ _ ?x ?y |- _ => symmetry in H; order_prepare t
 | |-  true  = @op_zlze__ t _ _ ?x ?y      => symmetry;      order_prepare t
 | |-  false = @op_zlze__ t _ _ ?x ?y      => symmetry;      order_prepare t
 (* pull things out of the conclusion *)
 | |- _ = true  => apply not_false_is_true; intro; order_prepare t
 | |- _ = false => apply not_true_is_false; intro; order_prepare t
 (* otherwise, hope it's contradictory *)
 | _ => exfalso
 end.

Definition HIDE (P : Prop) := P.
Lemma hide : forall {P : Prop},  P -> HIDE P. Proof. intuition. Qed.
Lemma unhide : forall {P : Prop},  HIDE P -> P. Proof. intuition. Qed.

Ltac order_eq t x y Heq :=
  apply hide in Heq;
  repeat lazymatch goal with
  | H : @op_zeze__ t _ x ?z = ?b |- _ =>
    rewrite (@Lemmas.Eq_trans_l t _ _ x y z (unhide Heq)) in H
  | H : @op_zeze__ t _ ?z x = ?b |- _ =>
    rewrite (@Lemmas.Eq_trans_r t _ _ x y z (unhide Heq)) in H
  | H : @op_zlze__ t _ _ x ?z = ?b |- _ =>
    rewrite (@Lemmas.Eq_le_l t _ _ _ _ x y z (unhide Heq)) in H
  | H : @op_zlze__ t _ _ ?z x = ?b |- _ =>
    rewrite (@Lemmas.Eq_le_r t _ _ _ _ x y z (unhide Heq)) in H
  end;
  clear Heq.

Ltac pose_new prf :=
  let prop := type of prf in
  match goal with
    | [ H : prop |- _] => fail 1
    | _ => pose proof prf
  end.

Ltac order_loop t :=
 lazymatch goal with
 | H1 : ?x = true, H2 : ?x = false |- _  => congruence
 (* First, successful situations *)
 | H : @op_zeze__ t _   ?x ?x = false |- _ => rewrite Lemmas.Eq_eq_refl in H; congruence
 | H : @op_zlze__ t _ _ ?x ?x = false |- _ => rewrite Lemmas.Ord_le_refl in H; congruence
 (* Second, useless hyps *)
 | H : @op_zeze__ t _   ?x ?x = true |- _ => clear H; order_loop t
 | H : @op_zlze__ t _ _ ?x ?x = true |- _ => clear H; order_loop t
 (* Third, we eliminate equalities *)
 | H : @op_zeze__ t _ ?x ?y = true |- _ =>
     order_eq t x y H; order_loop t
 (* Simultaneous le and ge is eq *)
 | H1 : @op_zlze__ t _ _ ?x ?y = true, H2 : @op_zlze__ t _ _  ?y ?x = true |- _ =>
     pose proof (@Ord_antisym t _ _ _ _ x y H1 H2); clear H1 H2; order_loop t
 (* Simultaneous le and ~eq is lt *)
 | H1 : @op_zeze__ t _ ?x ?y = false, H2 : @op_zlze__ t _ _  ?x ?y = true |- _ =>
     apply (@Lemmas.NEq_le_l t _ _ _ _ x y H1) in H2; order_loop t
 | H1 : @op_zeze__ t _ ?x ?y = false, H2 : @op_zlze__ t _ _  ?y ?x = true |- _ =>
     apply (@Lemmas.NEq_le_r t _ _ _ _ x y H1) in H2; order_loop t
 | _ => match goal with
   (* Transitivity of lt and le *)
   (* Here we need back-tracking, because we expect [pose_new] to fail.
      I would love if once [pose_new] succeeds, no backtracking happens
      even when the recursive call fails, but I do not know how to do that. *)
   | H1 : @op_zlze__ t _ _ ?x ?y = true, H2 : @op_zlze__ t _ _ ?y ?z = true |- _ =>
       pose_new (@Ord_trans_le t _ _ _ _ x y z H1 H2); order_loop t
   | H1 : @op_zlze__ t _ _ ?y ?x = false, H2 : @op_zlze__ t _ _ ?z ?y = false |- _ =>
       pose_new (@Lemmas.Ord_trans_lt t _ _ _ _ x y z H1 H2); order_loop t
   | H1 : @op_zlze__ t _ _ ?x ?y = true, H2 : @op_zlze__ t _ _ ?z ?y = false |- _ =>
       pose_new (@Lemmas.Ord_trans_le_lt t _ _ _ _ x y z H1 H2); order_loop t
   | H1 : @op_zlze__ t _ _ ?y ?x = false, H2 : @op_zlze__ t _ _ ?y ?z = true |- _ =>
       pose_new (@Lemmas.Ord_trans_lt_le t _ _ _ _ x y z H1 H2); order_loop t
   (* Nothing left to do *)
   | _ => idtac
   end
end.

(* TODO: Can't handle disjunctions *)
Ltac order t :=
 solve [ repeat (intros; try red);
         bool_to_prop;
         intuition (solve [try subst; try easy;
                           order_prepare t; order_loop t])
       | fail 1 "order can't solve this system" ].

(** Flipping comparisons **)

Definition flip_comparison (c : comparison) := match c with
  | Lt => Gt
  | Eq => Eq
  | Gt => Lt
  end.

Theorem compare_flip {t : Type} `{OrdLaws t} (x y : t) :
  compare x y = flip_comparison (compare y x).
Proof.
  destruct (compare x y) eqn:Cxy; destruct (compare y x) eqn:Cyx; simpl; auto; order t.
Qed.

Theorem flip_comparison_involutive :
  ssrfun.involutive flip_comparison.
Proof. now repeat red; destruct 0. Qed.

Theorem flip_comparison_injective :
  ssrfun.injective flip_comparison.
Proof. now repeat red; repeat destruct 0. Qed.

Theorem compare_flip_iff {A} `{OrdLaws A} (x y : A) (c : comparison) :
  compare x y = c <-> compare y x = flip_comparison c.
Proof.
  split.
  - now intro; subst; rewrite compare_flip.
  - rewrite compare_flip; apply flip_comparison_injective.
Qed.

(** Lawfulness of [ord_default] *)

Section GoodCompare.
Context {t : Type} {HEq : Eq_ t} {HEqLaw : EqLaws t}.
Variable (compare : t -> t -> comparison).

Record GoodCompare :=
  { Good_compare_Eq : forall a b, compare a b = Eq <-> a == b = true;
    Good_compare_sym : forall a b, compare a b = flip_comparison (compare b a);
    Good_compare_trans_1 : forall a b c, compare a b = Lt -> compare b c = Lt -> compare a c = Lt;
    Good_compare_trans_2 : forall a b c, compare a b = Lt -> compare b c = Eq -> compare a c = Lt;
    Good_compare_trans_3 : forall a b c, compare a b = Eq -> compare b c = Lt -> compare a c = Lt;
  }.

Lemma Good_compare_sym_Eq (HGood : GoodCompare) : forall a b, compare a b = Eq <-> compare b a = Eq.
Proof. intros. rewrite (Good_compare_sym HGood). destruct (compare b a); simpl; intuition congruence. Qed.

Lemma  OrdLaws_ord_default (HGood : GoodCompare) : OrdLaws t (HOrd := ord_default compare).
Proof.
  split.
  * intros.
    unfold op_zlze__, ord_default, op_zlze____ in *.
    rewrite <- (Good_compare_Eq HGood).
    rewrite (Good_compare_sym HGood) in H.
    destruct (compare a b); simpl in *; congruence.
  * intros.
    unfold op_zlze__, ord_default, op_zlze____ in *.
    destruct (compare b a) eqn:H1, (compare c b) eqn:H2, (compare c a) eqn:H3; simpl in *;
        try congruence; exfalso.
    - rewrite (Good_compare_Eq HGood) in H1, H2.
      enough (compare c a = Eq) by congruence.
      rewrite (Good_compare_Eq HGood).
      eapply Eq_trans; eassumption.
    - enough (compare c b = Lt) by congruence.
      rewrite (Good_compare_sym_Eq HGood) in H1.
      eapply (Good_compare_trans_2 HGood); try eassumption.
    - enough (compare b a = Lt) by congruence.
      rewrite (Good_compare_sym_Eq HGood) in H2.
      eapply (Good_compare_trans_3 HGood); try eassumption.
    - assert (compare b c = Lt) by (rewrite (Good_compare_sym HGood); destruct (compare c b); simpl in *; congruence).
      enough (compare b a = Lt) by congruence.
      eapply (Good_compare_trans_1 HGood); try eassumption.
  * intros.
    unfold op_zlze__, ord_default, op_zlze____ in *.
    rewrite (Good_compare_sym HGood).
    destruct (compare a b); simpl; intuition.
  * intros.
    unfold op_zlze__, Base.compare, ord_default, op_zlze____, compare__ in *.
    destruct (compare a b); simpl; intuition congruence.
  * intros.
    unfold op_zlze__, Base.compare, ord_default, op_zlze____, compare__ in *.
    rewrite (Good_compare_Eq HGood).
    reflexivity.
  * intros.
    unfold op_zlze__, Base.compare, ord_default, op_zlze____, compare__ in *.
    rewrite (Good_compare_sym HGood).
    destruct (compare b a); simpl; intuition congruence.
  * intros.
    unfold op_zlze__, op_zl__, Base.compare, ord_default, op_zlze____, op_zl____, compare__ in *.
    destruct (compare a b); simpl; intuition congruence.
  * intros.
    unfold op_zgze__, op_zlze__, Base.compare, ord_default, op_zgze____, op_zlze____, compare__ in *.
    destruct (compare a b); simpl; intuition congruence.
  * intros.
    unfold op_zg__, op_zlze__, Base.compare, ord_default, op_zg____, op_zlze____, compare__ in *.
    rewrite (Good_compare_sym HGood).
    destruct (compare a b); simpl; intuition congruence.
Qed.
End GoodCompare.

(** good comparison functions transfer *)

Section GoodCompareImage.
Context (t1 : Type) {HEq1 : Eq_ t1} {HEqLaw1 : EqLaws t1}.
Context (t2 : Type) {HEq2 : Eq_ t2}  (* {HEqLaw2 : EqLaws t2} *).
Context (f : t2 -> t1).
Context (Eq_t2 : forall x y, (x == y) = (f x == f y)).
Context {compare : t1 -> t1 -> comparison}.
Context (HGood : GoodCompare compare).

Lemma GoodCompare_image : GoodCompare (fun x y => compare (f x) (f y)).
Proof.
  split.
  * intros. rewrite Eq_t2. rewrite (Good_compare_Eq _ HGood). reflexivity.
  * intros. rewrite (Good_compare_sym _ HGood). reflexivity.
  * intros. eapply (Good_compare_trans_1 _ HGood); eassumption.
  * intros. eapply (Good_compare_trans_2 _ HGood); eassumption.
  * intros. eapply (Good_compare_trans_3 _ HGood); eassumption.
Qed.

End GoodCompareImage.

(** Lawfulness of the list instance *)
Section ListOrd.
Context  a {HEq : Eq_ a} {HOrd : Ord a} {HEqLaw : EqLaws a} {HOrdLaw : OrdLaws a}.

Lemma GoodCompare_compare_list : GoodCompare compare_list.
Proof.
  constructor.
  - unfold "==", Eq_list; simpl.
    intros xs; induction xs as [|x xs IH]; intros [|y ys]; simpl;
      try solve [tauto | split; discriminate].
    destruct (compare x y) eqn:Cxy.
    all: try (split; [discriminate|]).
    all: try (rewrite andb_true_iff, <-Ord_compare_Eq; intros [? ?]; congruence).
    rewrite Ord_compare_Eq in Cxy.
    rewrite IH, Cxy; tauto.
  - intros xs; induction xs as [|x xs IH]; intros [|y ys]; simpl;
      try tauto.
    rewrite compare_flip; destruct (compare y x) eqn:Cyx; simpl; auto.
  - intros xs; induction xs as [|x xs IH]; intros [|y ys] [|z zs]; simpl;
      try solve [tauto | discriminate].
    idtac;
      destruct (compare x y) eqn:Cxy; try discriminate;
      destruct (compare y z) eqn:Cyz; try discriminate;
      destruct (compare x z) eqn:Cxz; try discriminate;
      auto; try apply IH;
      order a.
  - intros xs; induction xs as [|x xs IH]; intros [|y ys] [|z zs]; simpl;
      try solve [tauto | discriminate].
    idtac;
      destruct (compare x y) eqn:Cxy; try discriminate;
      destruct (compare y z) eqn:Cyz; try discriminate;
      destruct (compare x z) eqn:Cxz; try discriminate;
      auto; try apply IH;
      order a.
  - intros xs; induction xs as [|x xs IH]; intros [|y ys] [|z zs]; simpl;
      try solve [tauto | discriminate].
    idtac;
      destruct (compare x y) eqn:Cxy; try discriminate;
      destruct (compare y z) eqn:Cyz; try discriminate;
      destruct (compare x z) eqn:Cxz; try discriminate;
      auto; try apply IH;
      order a.
Qed.

Global Instance OrdLaws_list  : OrdLaws (list a)
  := OrdLaws_ord_default _ GoodCompare_compare_list.
End ListOrd.

Ltac unfoldN := unfold
  op_zeze__, op_zgze__, op_zlze__, op_zl__, op_zg__, compare,
  Eq_Integer___, Ord_Char___,
  op_zeze____, op_zgze____, op_zlze____, op_zl____, op_zg____, compare__
  in *.

Instance OrdLaws_N : OrdLaws N.
Proof.
  constructor.
  all: intros; unfoldN;
    rewrite ?N.eqb_eq, ?N.leb_le in *;
    try apply eq_iff_eq_true;
    rewrite ?negb_true_iff, ?N.eqb_eq, ?N.eqb_neq, ?N.leb_le,  ?N.leb_gt, ?N.ltb_lt,
            ?N.compare_eq_iff, ?N.compare_lt_iff, ?N.compare_gt_iff in *;
    try (zify;omega).
Qed.

Ltac unfoldZ := unfold
  op_zeze__, op_zgze__, op_zlze__, op_zl__, op_zg__, compare,
  Eq_Integer___, Ord_Integer___,
  op_zeze____, op_zgze____, op_zlze____, op_zl____, op_zg____, compare__
  in *.

Instance OrdLaws_Z : OrdLaws Z.
Proof.
  constructor.
  all: intros; unfoldZ;
    rewrite ?Z.eqb_eq, ?Z.leb_le in *;
    try apply eq_iff_eq_true;
    rewrite ?negb_true_iff, ?Z.eqb_eq, ?Z.eqb_neq, ?Z.leb_le,  ?Z.leb_gt, ?Z.ltb_lt,
            ?Z.compare_eq_iff, ?Z.compare_lt_iff, ?Z.compare_gt_iff in *;
    try omega.
Qed.

Module Tests.
Goal forall x : Z, x == x = true.
Proof. order Z. Qed.

Goal forall x : Z, (x /= x) = true -> False.
Proof. order Z. Qed.

Goal forall x : Z, ~ (x /= x = false) -> False.
Proof. order Z. Qed.

Goal forall x : Z, (x <= x) = false -> False.
Proof. order Z. Qed.

Goal forall x : Z, x < x = false.
Proof. order Z. Qed.

Goal forall x y : Z, x <= y = true -> y <= x = true -> x == y = true.
Proof. order Z. Qed.

Goal forall x y z : Z, x <= y = true -> y <= z = true -> x <= z = true.
Proof. order Z. Qed.

Goal forall x y z : Z, x <= y = true -> x == y = false -> y <= x = false.
Proof. order Z. Qed.

Goal forall x y z : Z, x <= y = true -> y <= x = true -> y <= z = true -> x <= z = true.
Proof. order Z. Qed.

Goal forall x y z : Z, x < y = true -> y < z = true -> x < z = true.
Proof. order Z. Qed.

Goal forall x y z : Z, x < y = true -> x <= y = true.
Proof. order Z. Qed.

Goal forall x y z a: Z, x < y = true -> y <= z = true -> z < a = true -> x < a = true.
Proof. order Z. Qed.

Goal forall x y z a: Z, x < y = true -> y <= z = true -> z < a = true -> a <= x = true -> False.
Proof. order Z. Qed.

Goal forall x y : Z, compare x y = Eq <-> x == y = true.
Proof. order Z. Qed.

Goal forall x y z : Z, x < y = true -> y > x = true.
Proof. order Z. Qed.

End Tests.


(** *** Advanced exercise sheet for lecture 4: Tactics in Coq. *)

(** Some exercises about equivalences - recall from the course that associativity
    for products of types is not available "on the nose", i.e., just with equality.

    Exercises originally suggested by Benedikt Ahrens and Anders Mörtberg
    (for UniMath school 2017) and elaborated by Ralph Matthes (CNRS, IRIT,
    Univ. Toulouse, France)
*)
Require Import UniMath.Foundations.PartA.

Locate "≃". (** written in Agda mode as [\simeq] *)
Print weq.
Print isweq.
Print hfiber.

Section weqdef.

Variables X Y: UU.
Eval compute in (X ≃ Y).
(** there is a function [f] so that for given image [y] on can find the preimage [x] uniquely, but not only as element of [X] but even the pair consisting of the preimage and the proof that it is the preimage is unique. *)
End weqdef.

(** Prove that the identity function is an equivalence *)
Lemma idisweq (X : UU) : isweq (idfun X).
Abort.

(** Package this up as an equivalence *)
Definition idweq (X : UU) : X ≃ X.
Abort.

(** consider finding an alternative proof with [isweq_iso] that is extremely useful in the UniMath library *)

(** Prove that any map to empty is an equivalence *)
Lemma isweqtoempty {X : UU} (f : X -> ∅) : isweq f.
Abort.

(** Package this up as an equivalence *)
Definition weqtoempty {X : UU} (f : X -> ∅) : X ≃ ∅.
Abort.

(** Prove that the composition of equivalences is an equivalence.

This is rather difficult to do directly from the definition. Important lemmas
to reason on equality of pairs in a sigma type are given by [base_paths] and
[fiber_paths] that are elimination rules (that use given equality of pairs)
and [total2_paths2_f] that is an introduction rule allowing to establish an
equation between pairs. There, transport arises, but transport along the
identity path is always the identity, and this already computationally, which
means that [cbn] gets rid of it. *)
Theorem compisweq {X Y Z : UU} (f : X -> Y) (g : Y -> Z)
        (isf : isweq f) (isg : isweq g) : isweq (g ∘ f).
Abort.

(** Package this up as an equivalence *)
Definition weqcomp {X Y Z : UU} (w1 : X ≃ Y) (w2 : Y ≃ Z) : X ≃ Z.
Abort.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                   ps.v                                   *)
(****************************************************************************)

Require Import Classical.

Require Import Ensembles.
Require Import Relations_1.
Require Import Relations_1_facts.
Require Import podefs.
Require Import podefs_1.

Section The_power_set_partial_order.
   Variable U : Type.

   Inductive Power_set (A : Ensemble U) : Ensemble (Ensemble U) :=
       Definition_of_Power_set :
         forall X : Ensemble U,
         Included U X A -> In (Ensemble U) (Power_set A) X.
   Hint Resolve Definition_of_Power_set.

   (* Consider a set A, and its powerset P  *)
   Variable A : Ensemble U.

   Theorem Empty_set_minimal :
    forall X : Ensemble U, Included U (Empty_set U) X.
   Proof.
   red in |- *; intros X x H'; elim H'.
   Qed.
   Hint Resolve Empty_set_minimal.

   Theorem Power_set_non_empty :
    forall A : Ensemble U, Non_empty (Ensemble U) (Power_set A).
   Proof.
   intro A'; apply Non_empty_intro with (Empty_set U); auto.
   Qed.
   Hint Resolve Power_set_non_empty.

   Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U).
   Proof.
   auto 8.
   Qed.
   Hint Resolve Inclusion_is_an_order.

   Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U).
   elim Inclusion_is_an_order; auto.
   Qed.
   Hint Resolve Inclusion_is_transitive.

   Theorem Same_set_equivalence : Equivalence (Ensemble U) (Same_set U).
   Proof.
   generalize (Equiv_from_order (Ensemble U) (Included U)); intro H'; elim H';
    auto.
   Qed.

   Theorem Same_set_reflexive : Reflexive (Ensemble U) (Same_set U).
   Proof.
   elim Same_set_equivalence; auto.
   Qed.
   Hint Resolve Same_set_reflexive.

   Theorem Power_set_PO : PO (Ensemble U).
   Proof.
   apply Definition_of_PO with (Power_set A) (Included U); auto.
   Defined.

   Theorem Union_minimal :
    forall a b X : Ensemble U,
    Included U a X -> Included U b X -> Included U (Union U a b) X.
   Proof.
   intros a b X H' H'0; red in |- *; (intros x H'1; elim H'1); auto.
   Qed.
   Hint Resolve Union_minimal.

   Theorem Intersection_maximal :
    forall a b X : Ensemble U,
    Included U X a -> Included U X b -> Included U X (Intersection U a b).
   Proof.
   auto.
   Qed.

   Theorem Union_increases_l :
    forall a b : Ensemble U, Included U a (Union U a b).
   Proof.
   auto.
   Qed.

   Theorem Union_increases_r :
    forall a b : Ensemble U, Included U b (Union U a b).
   Proof.
   auto.
   Qed.

   Theorem Intersection_decreases_l :
    forall a b : Ensemble U, Included U (Intersection U a b) a.
   Proof.
   intros a b; red in |- *; auto.
   intros x H'; elim H'; auto.
   Qed.

   Theorem Intersection_decreases_r :
    forall a b : Ensemble U, Included U (Intersection U a b) b.
   Proof.
   intros a b; red in |- *; auto.
   intros x H'; elim H'; auto.
   Qed.
   Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l
     Intersection_decreases_r.

   Theorem Empty_set_is_Bottom :
    Bottom (Ensemble U) Power_set_PO (Empty_set U).
   Proof.
   apply Bottom_definition; simpl in |- *; auto.
   Qed.
   Hint Resolve Empty_set_is_Bottom.

   Theorem Union_is_Lub :
    forall a b : Ensemble U,
    Included U a A ->
    Included U b A ->
    Lub (Ensemble U) Power_set_PO (Couple (Ensemble U) a b) (Union U a b).
   Proof.
   intros a b H' H'0.
   apply Lub_definition; simpl in |- *.
   apply Upper_Bound_definition; simpl in |- *.
   auto.
   intros y H'1; elim H'1; auto.
   intros y H'1; elim H'1; simpl in |- *; auto.
   Qed.

   Theorem Intersection_is_Glb :
    forall a b : Ensemble U,
    Included U a A ->
    Included U b A ->
    Glb (Ensemble U) Power_set_PO (Couple (Ensemble U) a b)
      (Intersection U a b).
   Proof.
   intros a b H' H'0.
   apply Glb_definition.
   apply Lower_Bound_definition; simpl in |- *.
   apply Definition_of_Power_set; auto.
   generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a;
    auto.
   intros y H'1; elim H'1; auto.
   intros y H'1; elim H'1; simpl in |- *; auto.
   Qed.

   Theorem Empty_set_zero :
    forall X : Ensemble U, Union U (Empty_set U) X = X.
   Proof.
   auto 10.
   Qed.

   Theorem Union_commutative :
    forall A B : Ensemble U, Union U A B = Union U B A.
   Proof.
   auto.
   Qed.

   Theorem Union_associative :
    forall A B C : Ensemble U,
    Union U (Union U A B) C = Union U A (Union U B C).
   Proof.
   auto 20.
   Qed.

   Theorem Non_disjoint_union :
    forall (X : Ensemble U) (x : U),
    In U X x -> Union U (Singleton U x) X = X.
   Proof.
   intros X x H'; try assumption; auto 10.
   apply Extensionality_Ensembles; unfold Same_set in |- *; split;
    auto.
   red in |- *; auto 10.
   intros x0 H'0; elim H'0; auto 10.
   intros x1 H'1; elim H'1; auto 10.
   Qed.

   Theorem Finite_plus_one_is_finite :
    forall (X : Ensemble U) (x : U),
    Finite U X -> Finite U (Union U (Singleton U x) X).
   Proof.
   intros X x H'.
   generalize (classic (In U X x)); intro h; elim h;
    [ intro H'0; clear h; try exact H'0 | clear h; intro H'0 ];
    auto 10.
   generalize (Non_disjoint_union X x); intro h; lapply h;
    [ intro H'1; rewrite H'1; clear h | clear h ];
    auto.
   Qed.
   Hint Resolve Finite_plus_one_is_finite.

   Theorem Singleton_is_finite : forall x : U, Finite U (Singleton U x).
   Proof.
   intro x; generalize (Empty_set_zero (Singleton U x)); intro h;
    rewrite <- h; clear h.
   generalize (Union_commutative (Empty_set U) (Singleton U x)); intro h;
    rewrite h; clear h; auto.
   Qed.
   Hint Resolve Singleton_is_finite.

   Theorem Union_of_finite_is_finite :
    forall X Y : Ensemble U,
    Finite U X -> Finite U Y -> Finite U (Union U X Y).
   Proof.
   intros X Y H'; elim H'.
   generalize (Empty_set_zero Y); intro h; rewrite h; clear h; auto.
   clear A.
   intros AA H'0 H'1 x H'2 H'3.
   generalize (Union_associative (Singleton U x) AA Y); intro h; rewrite h;
    clear h; auto.
   Qed.

End The_power_set_partial_order.
Hint Resolve Empty_set_minimal.
Hint Resolve Power_set_non_empty.
Hint Resolve Inclusion_is_an_order.
Hint Resolve Inclusion_is_transitive.
Hint Resolve Same_set_reflexive.
Hint Resolve Union_minimal.
Hint Resolve Same_set_reflexive.
Hint Resolve Union_increases_l.
Hint Resolve Union_increases_r.
Hint Resolve Intersection_decreases_l.
Hint Resolve Intersection_decreases_r.
Hint Resolve Empty_set_is_Bottom.
Hint Resolve Empty_set_zero.
Hint Resolve Finite_plus_one_is_finite.
Hint Resolve Singleton_is_finite.


Require Import Arith.
Require Import  prosa.classic.util.all
                prosa.classic.model.arrival.basic.job
                prosa.classic.model.arrival.basic.task_arrival
                prosa.classic.model.schedule.uni.schedulability
                prosa.classic.model.schedule.uni.schedule_of_task
                prosa.classic.model.schedule.uni.response_time
                prosa.classic.analysis.uni.basic.tdma_wcrt_analysis.
Require Import  prosa.classic.model.schedule.uni.basic.platform_tdma
                prosa.classic.model.schedule.uni.end_time.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div.

Set Bullet Behavior "Strict Subproofs".

Module ResponseTimeAnalysisTDMA.

  Import Job  TaskArrival ScheduleOfTask  ResponseTime Platform_TDMA end_time Schedulability
        WCRT_OneJobTDMA.

  (* In this section, we establish that the computed value WCRT of the exact response-time analysis
     yields an upper bound on the response time of a task under TDMA scheduling policy on an uniprocessor,
     assuming that such value is no larger than the task period. *)

  Section ResponseTimeBound.

    (** System model *)
    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

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

    (* Consider any arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_sporadic_tasks:
    sporadic_task_model task_period job_arrival job_task arr_seq.

    (* ...and any uniprocessor... *)
    Variable sched: schedule Job.
    (* ... where jobs do not execute before their arrival times nor after completion. *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Consider any TDMA slot assignment... *)
    Variable task_time_slot: TDMA_slot sporadic_task.
    (* ... and any slot order. *)
    Variable slot_order: TDMA_slot_order sporadic_task.

    (* Consider any task set ts. *)
    Variable ts: {set sporadic_task}.
    Hypothesis H_valid_task_parameters:
    valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Consider any task in task set. *)
    Variable tsk:sporadic_task.
    Hypothesis H_task_in_task_set: tsk \in ts.

    (* For simplicity, let us use local names for some definitions and refer them to local variables. *)
    (* Recall definition: whether a job can be scheduled at time t *)
    Let is_scheduled_at j t:=
      scheduled_at sched j t.
    (* Recall definition: whether a task is in its own time slot at time t *)
    Let in_time_slot_at j t:=
        Task_in_time_slot ts slot_order (job_task j) task_time_slot t.

   (* Recall the definition of response-time bound. *)
    Let response_time_bounded_by :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched.

    (* Let (RT j) denote the computed response-time of job j according to the TDMA analysis.
       Note that this computation assumes that there is only one pending job of each task.
       Still, this assumption doesn't break the generality of the proof. There cannot be
       multiple jobs of the same task because:
       (a) assumption: the computed value WCRT is bounded by its task's period; and
       (b) the lemma: "jobs_finished_before_WCRT" in file tdma_wcrt_analysis.v. *)
    Hypothesis WCRT_le_period:
      WCRT task_cost task_time_slot ts tsk <= task_period tsk.
    Let RT j:= job_response_time_tdma_in_at_most_one_job_is_pending job_arrival job_cost
         task_time_slot slot_order ts tsk j.

    (* Next, recall the definition of deadline miss of tasks and jobs. *)
    Let no_deadline_missed_by_task :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.
    Let no_deadline_missed_by_job :=
      job_misses_no_deadline job_arrival job_cost job_deadline sched.

    (* Then, we define a valid TDMA bound. *)
    (* Bound is valid bound iff it is less than or equal to task's deadline *)
    Definition is_valid_tdma_bound bound :=
         (bound <= task_deadline tsk).

    (* Now, let's assume that the schedule respects TDMA scheduling policy... *)
    Hypothesis TDMA_policy:
      Respects_TDMA_policy job_arrival job_cost job_task arr_seq sched ts task_time_slot slot_order.

    (* ..., that task time slot is valid... *)
    Hypothesis H_valid_time_slot:
      is_valid_time_slot tsk task_time_slot.

    (* ... and that any job in arrival sequence is a valid job. *)
    Hypothesis H_valid_job_parameters:
      forall j, arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Assume that job cost is less than or equal to its task cost. *)
    Hypothesis H_job_cost_le_task_cost:
      forall j, arrives_in arr_seq j ->
      job_cost_le_task_cost task_cost job_cost job_task j.

    (* Let BOUND be the computed WCRT of tsk. *)
    Let BOUND := WCRT task_cost task_time_slot ts tsk.

    (** Two basic lemmas  *)
    (* Having assumed that the computed BOUND <= task_period tsk, we first prove that
       any job of task tsk must have completed by its period. *)
    Lemma any_job_completed_before_period:
      forall j,
        arrives_in arr_seq j ->
        job_task j = tsk ->
        completed_by job_cost sched j (job_arrival j + task_period  (job_task j) ).
    Proof.
      intros j [t ARR]. generalize dependent j.
      induction t as [ t IHt ] using (well_founded_induction lt_wf).
      case t eqn:GT;intros.
      - have INJ: arrives_in arr_seq j by exists 0.
        (apply completion_monotonic with (t0:=job_arrival j + WCRT task_cost task_time_slot ts tsk )
        ;trivial;try by rewrite leq_add2l H); apply job_completed_by_WCRT
        with (task_deadline0:=task_deadline)
                 (arr_seq0:=arr_seq)(job_deadline0:=job_deadline)
                 (job_task0:=job_task)(slot_order0:=slot_order);eauto 2.
        intros. apply H_arrival_times_are_consistent in ARR. ssromega.
      - have INJ: arrives_in arr_seq j by exists n.+1.
        apply completion_monotonic
          with (t0:=job_arrival j + WCRT task_cost task_time_slot ts tsk);auto.
        by rewrite leq_add2l H. apply job_completed_by_WCRT
        with (task_deadline0:=task_deadline)
                 (arr_seq0:=arr_seq)(job_deadline0:=job_deadline)
                 (job_task0:=job_task)(slot_order0:=slot_order);auto.
        intros.
        have PERIOD: job_arrival j_other + task_period (job_task j_other)<= job_arrival j.
        apply H_sporadic_tasks;auto. case (j==j_other)eqn: JJ;move/eqP in JJ;last auto.
        have JO:job_arrival j_other = job_arrival j by f_equal. ssromega.
        apply completion_monotonic with (t0:= job_arrival j_other +
           task_period (job_task j_other)); auto.
        have ARRJ: job_arrival j = n.+1 by auto.
        apply (IHt (job_arrival j_other));auto. ssromega.
        destruct H0 as [tj AAJO]. have CONSIST: job_arrival j_other =tj by auto.
        by subst. by subst.
    Qed.

    (* Based on the lemma above and the fact that jobs arrive sporadically, we can conclude that
       all the previous jobs of task tsk must have completed before the analyzed job j. *)
    Lemma all_previous_jobs_of_same_task_completed :
      forall j j_other,
        arrives_in arr_seq j ->
        job_task j = tsk ->
        arrives_in arr_seq j_other ->
        job_task j = job_task j_other ->
        job_arrival j_other < job_arrival j ->
        completed_by job_cost sched j_other (job_arrival j).
    Proof.
      intros.
      have PERIOD: job_arrival j_other + task_period (job_task j_other)<= job_arrival j.
      apply H_sporadic_tasks;auto. case (j==j_other)eqn: JJ;move/eqP in JJ;last auto.
      have JO:job_arrival j_other = job_arrival j by f_equal. ssromega.
      apply completion_monotonic with (t:=job_arrival j_other + task_period (job_task j_other));auto.
      apply any_job_completed_before_period;auto. by subst.
    Qed.

    (** Main Theorem *)
    (* Therefore, we proved that the reponse time of task tsk is bouned by the
       BOUND i.e., the computed value WCRT according to TDMA scheduling policy on an uniprocessor.
      ( for more details, see
        response_time_le_WCRT: .
        completed_by_end_time: model/schedule/uni/end_time.v
        completes_at_end_time: model/schedule/uni/end_time.v
      ) *)
    Theorem uniprocessor_response_time_bound_TDMA: response_time_bounded_by tsk BOUND.
    Proof.
      intros j arr_seq_j JobTsk.
      apply completion_monotonic with (t:=job_arrival j + RT j); try done.
      - rewrite leq_add2l /BOUND.
        apply (response_time_le_WCRT)
        with (task_cost0:=task_cost) (task_deadline0:=task_deadline)(sched0:=sched)
             (job_arrival0:=job_arrival)(job_cost0:=job_cost)(job_deadline0:=job_deadline)
             (job_task0:=job_task)(ts0:=ts)(arr_seq0:=arr_seq)
             (slot_order0:=slot_order)(Job0:=Job)(tsk0:=tsk); try done;auto;try (intros;
        by apply all_previous_jobs_of_same_task_completed).
      - apply completed_by_end_time
        with (sched0:=sched)(job_arrival0:=job_arrival)
             (job_cost0:=job_cost); first exact.
        apply completes_at_end_time
        with
             (job_arrival0:=job_arrival)(task_cost0:=task_cost)(arr_seq0:=arr_seq)
             (job_task0:=job_task)(job_deadline0:=job_deadline)(task_deadline0:=task_deadline)
             (sched0:=sched)(ts0:=ts)(slot_order0:=slot_order)
             (tsk0:=tsk) (j0:=j); try auto;try (intros;
        by apply all_previous_jobs_of_same_task_completed).
    Qed.

    (** Sufficient Analysis *)
    (* Finally, we show that the RTA is a sufficient schedulability analysis. *)
    Section AnalysisIsSufficient.

      (* Assume that BOUND is a valid tdma bound *)
      Hypothesis H_is_valid_bound:
        is_valid_tdma_bound BOUND.

      (* We can prove the theorem: there is no deadline miss of task tsk *)
      Theorem taskset_schedulable_by_tdma : no_deadline_missed_by_task tsk.
      Proof.
        apply task_completes_before_deadline with (task_deadline0:=task_deadline) (R:=BOUND)
        ;try done.
        move => j arr_seqJ.
        - by apply H_valid_job_parameters.
        - apply uniprocessor_response_time_bound_TDMA.
      Qed.

      (* Based on the theorem above, we can prove that
         any job of the arrival sequence are spawned by task tsk won't miss its deadline. *)
      Theorem jobs_schedulable_by_tdma_rta :
        forall j,
          arrives_in arr_seq j /\ job_task j =tsk ->
          no_deadline_missed_by_job j.
      Proof.
        intros j [arr_seqJ Jtsk].
        by apply taskset_schedulable_by_tdma.
      Qed.

    End AnalysisIsSufficient.

  End ResponseTimeBound.

End ResponseTimeAnalysisTDMA.