Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Coq.Setoids.Setoid.
Require Coq.Lists.List.
Import List.ListNotations.
Require Import Cosa.Lib.Axioms.
Require Import Cosa.Lib.Algebra.
Require Import Cosa.Lib.Tactics.
Require Import Cosa.Lib.Finite.
Require Import Cosa.Lib.MapReduce.

Open Scope list_scope.

Local Ltac crush ::=
  simpl in *;
  solve [
      reflexivity |
      intuition eauto |
      firstorder eauto
    ]
.

(** n-ary relations as complete lattices. *)

Definition rel (Γ:list Type) : Type :=
  List.fold_right (fun A T => A -> T) Prop Γ
.

(** pointwise impliciation (aka sub-relation). *)
Fixpoint sub {Γ:list Type} : rel Γ -> rel Γ -> Prop :=
  match Γ with
  | [] => fun p q => p -> q
  | A::Γ => fun p q => forall x:A, sub (p x) (q x)
  end
.

Instance sub_preorder Γ : PreOrder (@sub Γ).
Proof.
  split; unfold Reflexive,Transitive.
  - by induction Γ.
  - by induction Γ.
Qed.

Lemma sub_cons {A Γ} : forall p q, sub (Γ:=A::Γ) p q = forall x, sub (p x) (q x).
Proof. reflexivity. Qed.

Lemma sub_one {A} : forall p q, sub (Γ:=[A]) p q = forall x, p x -> q x.
Proof. reflexivity. Qed.

(** Pointwise logical equivalence. *)
Fixpoint equiv {Γ:list Type} : rel Γ -> rel Γ -> Prop :=
  match Γ with
  | [] => fun p q => p <-> q
  | A::Γ => fun p q => forall x:A, equiv (p x) (q x)
  end
.

Instance equiv_equivalence Γ : Equivalence (@equiv Γ).
Proof.
  split; unfold Reflexive, Symmetric, Transitive.
  - by induction Γ.
  - by induction Γ.
  - by induction Γ.
Qed.

Instance sub_antisymmetric_equiv Γ : Antisymmetric (rel Γ) equiv sub.
Proof.
  unfold Antisymmetric.
  by induction Γ.
Qed.

(** equivalence is, in fact, equality thanks to the extensionality
    axioms of [Coq.Lib.Axioms]. *)
Lemma equiv_eq Γ (p q:rel Γ) : equiv p q -> p=q.
Proof.
  induction Γ as [ | A Γ hΓ ]; simpl in *.
  - apply prop_extensionality.
  - intros h₁.
    by extensionality x.
Qed.

Instance sub_antisymmetric_eq Γ : Antisymmetric (rel Γ) eq sub.
Proof.
  unfold Antisymmetric.
  intros **.
  apply equiv_eq.
  by apply sub_antisymmetric_equiv.
Qed.

Lemma eq_equiv Γ (p q:rel Γ) : p=q -> equiv p q.
Proof.
  intros <-.
  reflexivity.
Qed.

(** Tactics to convert betwwen [eq] and [equiv]. From there on, we
    prefer refering to equalitity rather than equivalence. *)

Ltac cast_to_type A :=
  lazymatch type of A with
  | Type => constr:(A)
  | _ => constr:(A:Type)
  end
.

Ltac push_rel A Γ k :=
  let A := cast_to_type A in
  k (A::Γ)
.

Ltac reify c k:=
  lazymatch c with
  | Prop => k (@nil Type)
  | ?A -> ?T =>
      let k' T' := push_rel A T' k in
      reify T k'
  | rel ?Γ => k Γ
  | _ => fail "Not a relation"
  end
.

Ltac equiv_eq_concl :=
  lazymatch goal with
  | |- ?l = _ =>
      let k Γ := (apply (equiv_eq Γ)) in
      let T := type of l in
      reify T k; simpl
  end
.

Ltac equiv_eq_hyp h :=
  lazymatch type of h with
  | ?l = _ =>
    let k Γ := (apply (eq_equiv Γ) in h) in
      let T := type of l in
      reify T k; simpl in h
  end
.

Ltac equiv_eq_hyps :=
  rewrite_defs;
  repeat match goal with
  | h:_ = _ |- _ => equiv_eq_hyp h
  end
.

Ltac equiv_eq := equiv_eq_hyps; try equiv_eq_concl.

Lemma double_sub Γ (p q:rel Γ) : sub p q -> sub q p -> p=q.
Proof.
  intros **.
  equiv_eq.
  by induction Γ.
Qed.

Ltac double_sub :=
  lazymatch goal with
  | |- ?l = _ =>
      let k Γ := (apply (double_sub Γ)) in
      let T := type of l in
      reify T k; simpl
  end
.

(** Top. *)
Fixpoint top {Γ} : rel Γ :=
  match Γ with
  | [] => True
  | A::Γ => fun _ => top
end.

Lemma top_is_top Γ : forall p:rel Γ, sub p top.
Proof.
  by induction Γ.
Qed.

(** Empty relation *)
Fixpoint bottom {Γ} : rel Γ :=
  match Γ with
  | [] => False
  | A::Γ => fun _ => bottom
  end
.

Lemma bottom_is_bottom Γ : forall p:rel Γ, sub bottom p.
Proof.
  by induction Γ.
Qed.

(** Binary join *)
Fixpoint join {Γ} : rel Γ -> rel Γ -> rel Γ :=
  match Γ with
  | [] => fun p q => p \/ q
  | A::Γ => fun p q x => join (p x) (q x)
  end
.

Instance join_associative Γ : Associative (@eq (rel Γ)) join.
Proof.
  unfold Associative; intros **.
  equiv_eq.
  by induction Γ.
Qed.

Instance join_commutative Γ : Commutative (@eq (rel Γ)) join.
Proof.
  unfold Commutative; intros **.
  equiv_eq.
  by induction Γ.
Qed.

Instance join_bottom_neutral Γ : LeftNeutral (@eq (rel Γ)) join bottom.
Proof.
  unfold LeftNeutral; intros **.
  equiv_eq.
  by induction Γ.
Qed.

Instance join_monotone Γ : Proper (sub ==> sub ==> sub) (@join Γ).
Proof.
  autounfold; intros **.
  by induction Γ.
Qed.

(** Arbitrary join *)

Fixpoint Join {Γ I} : (I->rel Γ) -> rel Γ :=
  match Γ with
  | [] => fun p => exists i, p i
  | A::Γ => fun p x => Join (fun i => p i x)
  end
.

Lemma Join_supremum Γ I (p:I->rel Γ) (q:rel Γ) : (forall i, sub (p i) q) <-> sub (Join p) q.
Proof.
  by induction Γ.
Qed.

Lemma Join_sup Γ I (p:I->rel Γ) : forall i, sub (p i) (Join p).
Proof.
  by rewrite Join_supremum.
Qed.
Lemma Join_sup_sig Γ (P:rel Γ->Prop) p : P p -> sub p (Join (fun q:{q|P q} => proj1_sig q)).
Proof.
  intros h.
  change p with ((fun q:{q|P q} => proj1_sig q) (exist _ p h)).
  apply Join_sup.
Qed.

Lemma Join_intro {Γ I} {p:I->rel Γ} {q} : forall i, sub q (p i) -> sub q (Join p).
Proof.
  intros **.
  simplify_transitivity.
  apply Join_sup.
Qed.

Lemma Join_unique Γ I (p:I->rel Γ) (q:rel Γ) :
  (forall (r:rel Γ), (forall i, sub (p i) r) <-> sub q r) -> q = Join p.
Proof.
  intros h.
  double_sub.
  - apply h.
    apply Join_sup.
  - rewrite <- Join_supremum.
    by apply h.
Qed.

Lemma Join_member Γ I (p:I->rel Γ) i : (forall j, sub (p j) (p i)) -> p i = Join p.
Proof.
  intro h.
  apply Join_unique.
  intro r.
  split.
  - crush.
  - intros **.
    solve_transitivity.
Qed.

Lemma Join_increasing Γ I : Proper (@sub (I::Γ) ==> sub) Join.
Proof.
  autounfold; simpl.
  intros p q p_sub_q.
  rewrite <- Join_supremum.
  intros i.
  by apply Join_intro with i.
Qed.

Lemma Join_associative Γ I J (f:I->J->rel Γ) :
  Join (fun i:I => Join (fun j:J => f i j)) = Join (fun α:I*J => f (fst α) (snd α)).
Proof.
  double_sub.
  - rewrite <- Join_supremum; intros i.
    rewrite <- Join_supremum; intros j.
    set (α := (i,j)).
    change i with (fst α).
    change j with (snd α).
    generalize α; clear i j α.
    by rewrite Join_supremum.
  - rewrite <- Join_supremum; intros [ i j ].
    revert j; rewrite Join_supremum.
    revert i; rewrite Join_supremum.
    reflexivity.
Qed.

Lemma Join_empty_set Γ (f:Empty_set -> rel Γ) : Join f = bottom.
Proof.
  double_sub.
  - induction Γ as [ | A Γ hΓ ]; simpl in *.
    + (* Γ = [] *)
      intros [ [] _ ].
    + (* Γ = A::Γ *)
      eauto.
  - apply bottom_is_bottom.
Qed.

Lemma bottom_is_Join Γ : bottom = Join (fun i:Empty_set => match i return rel Γ with end).
Proof.
  symmetry; apply Join_empty_set.
Qed.

Lemma Join_unit Γ (f:unit -> rel Γ) : Join f = f tt.
Proof.
  equiv_eq.
  induction Γ as [ | A Γ hΓ ]; simpl in *.
  - (* Γ = [] *)
    split.
    + intros [ [] ? ]; eauto.
    + decompose_goal; eauto.
  - (* Γ = A::Γ *)
    intros x.
    by specialize (hΓ (fun i => f i x)).
Qed.

Lemma Join_of_option Γ A (f:option A -> rel Γ) :
  Join f = join (f None) (Join (fun i => f (Some i))).
Proof.
  equiv_eq; revert f.
  induction Γ as [ | B Γ hΓ ]; simpl in *.
  - (* Γ = [] *)
    intros f.
    split.
    + intros [ [ x | ] ? ].
      * by right.
      * by left.
    + intros [ h | [ x h ]].
      * by exists None.
      * by exists (Some x).
  - (* Γ = B::Γ *)
    intros f x.
    apply hΓ.
Qed.

Lemma Join_of_finite Γ n (f:fin n -> rel Γ) : Join f = list_reduce join bottom (listify f).
Proof.
  induction n as [ | n hn ].
  - (* n = 0 *)
    apply Join_empty_set.
  - (* n = S n *)
    change (listify f) with (f None::listify (fun i => f (Some i))).
    rewrite list_reduce_cons; [ | typeclasses eauto ..].
    simpl in *.
    rewrite (Join_of_option Γ _ f).
    by rewrite hn.
Qed.

Lemma Join_of_list Γ (l:list (rel Γ)) :
  list_reduce join bottom l = Join (access l).
  rewrite Join_of_finite.
  rewrite listify_access.
  reflexivity.
Qed.

(** Binary meet. *)
Fixpoint meet {Γ} : rel Γ -> rel Γ -> rel Γ :=
  match Γ with
  | [] => fun p q => p /\ q
  | A::Γ => fun p q x => meet (p x) (q x)
  end
.

Instance meet_associative Γ : Associative (@eq (rel Γ)) meet.
Proof.
  unfold Associative; intros **.
  equiv_eq.
  by induction Γ.
Qed.

Instance meet_commutative Γ : Commutative (@eq (rel Γ)) meet.
Proof.
  unfold Commutative; intros **.
  equiv_eq.
  by induction Γ.
Qed.

Instance meet_top_neutral Γ : LeftNeutral (@eq (rel Γ)) meet top.
Proof.
  unfold LeftNeutral; intros **.
  equiv_eq.
  by induction Γ.
Qed.

Instance meet_monotone Γ : Proper (sub ==> sub ==> sub) (@meet Γ).
Proof.
  autounfold; intros **.
  by induction Γ.
Qed.

Lemma meet_infimum_intro Γ (p q r:rel Γ) : sub r p -> sub r q -> sub r (meet p q).
Proof.
  by induction Γ.
Qed.

Lemma meet_infimum_elim_left Γ (p q r:rel Γ) : sub r (meet p q) -> sub r p.
Proof.
  by induction Γ.
Qed.

Lemma meet_infimum_elim_right Γ (p q r:rel Γ) : sub r (meet p q) -> sub r q.
Proof.
  by induction Γ.
Qed.

Lemma meet_sub_left Γ (p q:rel Γ) : sub (meet p q) p.
Proof.
  by induction Γ.
Qed.

Lemma meet_sub_right Γ (p q:rel Γ) : sub (meet p q) q.
Proof.
  by induction Γ.
Qed.

(** Arbitrary meet. *)

Fixpoint Meet {Γ I} : (I->rel Γ) -> rel Γ :=
  match Γ with
  | [] => fun p => forall i, p i
  | A::Γ => fun p x => Meet (fun i => p i x)
  end
.

Lemma Meet_infimum Γ I (p:I->rel Γ) (q:rel Γ) : (forall i, sub q (p i)) <-> sub q (Meet p).
Proof.
  by induction Γ.
Qed.

Lemma Meet_sub Γ I (p:I->rel Γ) : forall i, sub (Meet p) (p i).
Proof.
  by rewrite Meet_infimum.
Qed.
Lemma Meet_sub_sig Γ (P:rel Γ->Prop) p : P p -> sub (Meet (fun q:{q|P q} => proj1_sig q)) p.
Proof.
  intros h.
  change p with ((fun q:{q|P q} => proj1_sig q) (exist _ p h)).
  apply Meet_sub.
Qed.

Lemma Meet_intro_left Γ I (p:I->rel Γ) q : forall i, sub (p i) q -> sub (Meet p) q.
Proof.
  intros **.
  simplify_transitivity.
  apply Meet_sub.
Qed.

Lemma Meet_unique Γ I (p:I->rel Γ) (q:rel Γ) :
  (forall (r:rel Γ), (forall i, sub r (p i)) <-> sub r q) -> q = Meet p.
Proof.
  intros h.
  double_sub.
  - rewrite <- Meet_infimum.
    by apply h.
  - apply h.
    apply Meet_sub.
Qed.

Lemma Meet_member Γ I (p:I->rel Γ) i : (forall j, sub (p i) (p j)) -> p i = Meet p.
Proof.
  intro h.
  apply Meet_unique.
  intro r.
  split.
  - crush.
  - intros **.
    solve_transitivity.
Qed.

Lemma Meet_increasing Γ I : Proper (@sub (I::Γ) ==> sub) Meet.
Proof.
  autounfold; simpl.
  intros p q p_sub_q.
  rewrite <- Meet_infimum.
  intros i.
  by apply Meet_intro_left with i.
Qed.

Lemma Meet_associative Γ I J (f:I->J->rel Γ) :
  Meet (fun i:I => Meet (fun j:J => f i j)) = Meet (fun α:I*J => f (fst α) (snd α)).
Proof.
  double_sub.
  - rewrite <- Meet_infimum; intros [ i j ].
    revert j; rewrite Meet_infimum.
    revert i; rewrite Meet_infimum.
    reflexivity.
  - rewrite <- Meet_infimum; intros i.
    rewrite <- Meet_infimum; intros j.
    set (α := (i,j)).
    change i with (fst α).
    change j with (snd α).
    generalize α; clear i j α.
    by rewrite Meet_infimum.
Qed.

Lemma Meet_empty_set Γ (f:Empty_set -> rel Γ) : Meet f = top.
Proof.
  double_sub.
  - apply top_is_top.
  - induction Γ as [ | A Γ hΓ ]; simpl in *.
    + (* Γ = [] *)
      intros [ [] _ ].
    + (* Γ = A::Γ *)
      eauto.
Qed.

Lemma top_is_Meet Γ : top = Meet (fun i:Empty_set => match i return rel Γ with end).
Proof.
  symmetry; apply Meet_empty_set.
Qed.

Lemma Meet_unit Γ (f:unit -> rel Γ) : Meet f = f tt.
Proof.
  equiv_eq.
  induction Γ as [ | A Γ hΓ ]; simpl in *.
  - (* Γ = [] *)
    split.
    + eauto.
    + intros ? []; eauto.
  - (* Γ = A::Γ *)
    intros x.
    by specialize (hΓ (fun i => f i x)).
Qed.

Lemma Meet_of_option Γ A (f:option A -> rel Γ) :
  Meet f = meet (f None) (Meet (fun i => f (Some i))).
Proof.
  equiv_eq; revert f.
  induction Γ as [ | B Γ hΓ ]; simpl in *.
  - (* Γ = [] *)
    intros f.
    split.
    + intros h.
      split; eauto.
    + intros [ h₁ h₂ ].
      intros [ x | ]; eauto.
  - (* Γ = B::Γ *)
    intros f x.
    apply hΓ.
Qed.

Lemma Meet_of_finite Γ n (f:fin n -> rel Γ) : Meet f = list_reduce meet top (listify f).
Proof.
  induction n as [ | n hn ].
  - (* n = 0 *)
    apply Meet_empty_set.
  - (* n = S n *)
    change (listify f) with (f None::listify (fun i => f (Some i))).
    rewrite list_reduce_cons; [ | typeclasses eauto ..].
    simpl in *.
    rewrite (Meet_of_option Γ _ f).
    by rewrite hn.
Qed.

Lemma Meet_of_list Γ (l:list (rel Γ)) :
  list_reduce meet top l = Meet (access l).
  rewrite Meet_of_finite.
  rewrite listify_access.
  reflexivity.
Qed.

(** Pointwise application (right adjoint to binary [meet]). *)
Fixpoint arrow {Γ} : rel Γ -> rel Γ -> rel Γ :=
  match Γ with
  | [] => fun p q => p -> q
  | A::Γ => fun p q x => arrow (p x) (q x)
  end
.

Lemma meet_arrow_adjunction Γ :
  forall (p q r:rel Γ), sub (meet p q) r <-> sub p (arrow q r).
Proof.
  induction Γ as [|A Γ h].
  - simpl.
    firstorder.
  - simpl.
    firstorder.
Qed.

(** Least fixed point of increasing functions. *)

Definition postfixed_points {Γ} (F:rel Γ->rel Γ) (p:rel Γ) : Prop := sub (F p) p.

Lemma postfixed_points_apply Γ (F:rel Γ->rel Γ) (p:rel Γ) :
  Proper (sub==>sub) F -> postfixed_points F p -> postfixed_points F (F p).
Proof.
  autounfold; unfold postfixed_points.
  crush.
Qed.

Definition lfp {Γ} (F:rel Γ->rel Γ) : rel Γ :=
  Meet (fun p : { p | postfixed_points F p } => proj1_sig p)
.

Lemma lfp_sub_postfixed_point Γ (F:rel Γ->rel Γ) :
  forall p, postfixed_points F p -> sub (lfp F) p.
Proof.
  intros **; unfold lfp.
  by apply Meet_sub_sig.
Qed.

Lemma lfp_postfixed_point Γ (F:rel Γ->rel Γ) {incr:Proper (sub==>sub) F} :
  postfixed_points F (lfp F).
Proof.
  unfold postfixed_points.
  apply -> Meet_infimum.
  intros [ p pfp ]; simpl.
  transitivity (F p).
  - apply incr.
    now apply lfp_sub_postfixed_point.
  - apply pfp.
Qed.

Lemma lfp_fixed_point Γ (F:rel Γ->rel Γ) {incr:Proper (sub==>sub) F} :
  F (lfp F) = lfp F.
Proof.
  double_sub.
  - now eapply lfp_postfixed_point.
  - apply lfp_sub_postfixed_point.
    apply postfixed_points_apply, lfp_postfixed_point; eauto.
Qed.

Section InductionPrinciple.

  Context Γ (F:rel Γ->rel Γ) {incr:Proper (sub==>sub) F}.

  Local Notation inductive P := (forall (p:rel Γ), sub p (lfp F) -> sub p P -> sub (F p) P).

  Lemma inductive_meet (P Q:rel Γ) : inductive P -> inductive Q -> inductive (meet P Q).
  Proof.
    intros ind_P ind_Q p sub_lfp sub_PQ.
    apply meet_infimum_intro.
    - apply ind_P.
      + assumption.
      + apply meet_infimum_elim_left in sub_PQ.
        assumption.
    - apply ind_Q.
      + assumption.
      + apply meet_infimum_elim_right in sub_PQ.
        assumption.
  Qed.

  Lemma inductive_lfp : inductive (lfp F).
  Proof.
    intros p h _.
    apply incr in h.
    rewrite lfp_fixed_point in h; [|typeclasses eauto].
    apply h.
  Qed.

  Lemma inductive_postfixed_point (P:rel Γ) :
    sub P (lfp F) -> inductive P -> postfixed_points F P.
  Proof.
    unfold postfixed_points; firstorder.
  Qed.

  Lemma lfp_ind (P:rel Γ) : inductive P -> sub (lfp F) P.
  Proof.
    intros ind.
    assert (inductive (meet P (lfp F))) as ind'.
    { apply inductive_meet.
      - assumption.
      - apply inductive_lfp. }
    apply inductive_postfixed_point in ind'; [|apply meet_sub_right].
    transitivity (meet P (lfp F)).
    - now apply lfp_sub_postfixed_point.
    - apply meet_sub_left.
  Qed.

End InductionPrinciple.


Require Import Arith List CpdtTactics.

CoInductive tree (A : Type) : Type :=
| Node : A -> tree A -> tree A -> tree A.

Arguments Node {A} _ _ _.

CoFixpoint everywhere {A : Type} (v : A) : tree A :=
  Node v (everywhere v) (everywhere v).

CoFixpoint map {A B C: Type} (f : A -> B -> C) (t1 : tree A) (t2 : tree B) : tree C :=
  match t1, t2 with
  | Node v1 l1 r1, Node v2 l2 r2 => Node (f v1 v2) (map f l1 l2) (map f r1 r2)
  end.

Definition falses := everywhere false.

CoFixpoint true_falses := Node true
                               (Node false true_falses true_falses)
                               (Node false true_falses true_falses).

CoInductive tree_eq {A : Type} : tree A -> tree A -> Prop :=
| teqi : forall l1 l2 r1 r2 v1 v2,
    v1 = v2 -> tree_eq l1 l2 -> tree_eq r1 r2 -> tree_eq (Node v1 l1 r1) (Node v2 l2 r2).

Definition run {A : Type} (t : tree A) : tree A :=
  match t with
  | Node v l r => Node v l r
  end.

Lemma run_is_dummy : forall A (t : tree A),
    t = run t.
Proof.
  intros.
  destruct t.
  reflexivity.
Qed.

Theorem or_mapping :
  tree_eq (map orb true_falses falses) true_falses.
Proof.
  cofix.
  rewrite (run_is_dummy bool (map orb true_falses falses)).
  rewrite (run_is_dummy bool true_falses).
  simpl.
  constructor.
  reflexivity.
  rewrite (run_is_dummy bool (map orb (Node false true_falses true_falses) (everywhere false))).
  rewrite (run_is_dummy bool (Node false true_falses true_falses)).
  simpl.
  constructor; crush.
  rewrite (run_is_dummy bool (map orb (Node false true_falses true_falses) (everywhere false))).
  rewrite (run_is_dummy bool (Node false true_falses true_falses)).
  simpl.
  constructor; crush.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Fairness.OrderedTypeLow.
Require Import ZArith_base.
Require Import PeanoNat.
Require Import Ascii String.
Require Import NArith Ndec.
Require Import Compare_dec.

(** * Examples of Ordered Type structures. *)

(** First, a particular case of [OrderedType] where
    the equality is the usual one of Coq. *)

Module Type UsualOrderedType.
 Parameter Inline t : Type.
 Definition eq := @eq t.
 Parameter Inline lt : t -> t -> Prop.
 Definition eq_refl := @eq_refl t.
 Definition eq_sym := @eq_sym t.
 Definition eq_trans := @eq_trans t.
 Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
 Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Parameter compare : forall x y : t, Compare lt eq x y.
 Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
End UsualOrderedType.

(** a [UsualOrderedType] is in particular an [OrderedType]. *)

Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U.

(** [nat] is an ordered type with respect to the usual order on natural numbers. *)

Module Nat_as_OT <: UsualOrderedType.

  Definition t := nat.

  Definition eq := @eq nat.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := lt.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof. unfold lt; intros; apply lt_trans with y; auto. Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof. unfold lt, eq; intros ? ? LT ->; revert LT; apply Nat.lt_irrefl. Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (Nat.compare x y); intro.
    - apply EQ. now apply nat_compare_eq.
    - apply LT. now apply nat_compare_Lt_lt.
    - apply GT. now apply nat_compare_Gt_gt.
  Defined.

  Definition eq_dec := eq_nat_dec.

End Nat_as_OT.

(** [Z] is an ordered type with respect to the usual order on integers. *)

Local Open Scope Z_scope.

Module Z_as_OT <: UsualOrderedType.

  Definition t := Z.
  Definition eq := @eq Z.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt (x y:Z) := (x<y).

  Lemma lt_trans : forall x y z, x<y -> y<z -> x<z.
  Proof. exact Z.lt_trans. Qed.

  Lemma lt_not_eq : forall x y, x<y -> ~ x=y.
  Proof. intros x y LT ->; revert LT; apply Z.lt_irrefl. Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (x ?= y); intro.
    - apply EQ. now apply Z.compare_eq.
    - apply LT. assumption.
    - apply GT. now apply Z.gt_lt.
  Defined.

  Definition eq_dec := Z.eq_dec.

End Z_as_OT.

(** [positive] is an ordered type with respect to the usual order on natural numbers. *)

Local Open Scope positive_scope.

Module Positive_as_OT <: UsualOrderedType.
  Definition t:=positive.
  Definition eq:=@eq positive.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := Pos.lt.

  Definition lt_trans := Pos.lt_trans.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros x y H. contradict H. rewrite H. apply Pos.lt_irrefl.
  Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
  case_eq (x ?= y); intros H.
  - apply EQ. now apply Pos.compare_eq.
  - apply LT; assumption.
  - apply GT. now apply Pos.gt_lt.
  Defined.

  Definition eq_dec := Pos.eq_dec.

End Positive_as_OT.

(** [N] is an ordered type with respect to the usual order on natural numbers. *)

Module N_as_OT <: UsualOrderedType.
  Definition t:=N.
  Definition eq:=@eq N.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt := N.lt.
  Definition lt_trans := N.lt_trans.
  Definition lt_not_eq := N.lt_neq.

  Definition compare x y : Compare lt eq x y.
  Proof.
  case_eq (x ?= y)%N; intro.
  - apply EQ. now apply N.compare_eq.
  - apply LT. assumption.
  - apply GT. now apply N.gt_lt.
  Defined.

  Definition eq_dec := N.eq_dec.

End N_as_OT.

(** From two ordered types, we can build a new OrderedType
   over their cartesian product, using the lexicographic order. *)

Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
 Module MO1:=OrderedTypeFacts(O1).
 Module MO2:=OrderedTypeFacts(O2).

 Definition t := prod O1.t O2.t.

 Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).

 Definition lt x y :=
    O1.lt (fst x) (fst y) \/
    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).

 Lemma eq_refl : forall x : t, eq x x.
 Proof.
 intros (x1,x2); red; simpl; auto with ordered_type.
 Qed.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
 Qed.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type.
 Qed.

 Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
 left; eauto with ordered_type.
 left; eapply MO1.lt_eq; eauto.
 left; eapply MO1.eq_lt; eauto.
 right; split; eauto with ordered_type.
 Qed.

 Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition.
 apply (O1.lt_not_eq H0 H1).
 apply (O2.lt_not_eq H3 H2).
 Qed.

 Definition compare : forall x y : t, Compare lt eq x y.
 intros (x1,x2) (y1,y2).
 destruct (O1.compare x1 y1).
 apply LT; unfold lt; auto.
 destruct (O2.compare x2 y2).
 apply LT; unfold lt; auto.
 apply EQ; unfold eq; auto.
 apply GT; unfold lt; auto with ordered_type.
 apply GT; unfold lt; auto.
 Defined.

 Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
 Proof.
 intros; elim (compare x y); intro H; [ right | left | right ]; auto.
 auto using lt_not_eq.
 assert (~ eq y x); auto using lt_not_eq, eq_sym.
 Defined.

End PairOrderedType.

(** Even if [positive] can be seen as an ordered type with respect to the
  usual order (see above), we can also use a lexicographic order over bits
  (lower bits are considered first). This is more natural when using
  [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)

Module PositiveOrderedTypeBits <: UsualOrderedType.
  Definition t:=positive.
  Definition eq:=@eq positive.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Fixpoint bits_lt (p q:positive) : Prop :=
   match p, q with
   | xH, xI _ => True
   | xH, _ => False
   | xO p, xO q => bits_lt p q
   | xO _, _ => True
   | xI p, xI q => bits_lt p q
   | xI _, _ => False
   end.

  Definition lt:=bits_lt.

  Lemma bits_lt_trans :
    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
  Proof.
  induction x.
  induction y; destruct z; simpl; eauto; intuition.
  induction y; destruct z; simpl; eauto; intuition.
  induction y; destruct z; simpl; eauto; intuition.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
  exact bits_lt_trans.
  Qed.

  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
  Proof.
  induction x; simpl; auto.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
  intros; intro.
  rewrite <- H0 in H; clear H0 y.
  unfold lt in H.
  exact (bits_lt_antirefl x H).
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
  induction x; destruct y.
  - (* I I *)
    destruct (IHx y) as [l|e|g].
    apply LT; auto.
    apply EQ; rewrite e; red; auto.
    apply GT; auto.
  - (* I O *)
    apply GT; simpl; auto.
  - (* I H *)
    apply GT; simpl; auto.
  - (* O I *)
    apply LT; simpl; auto.
  - (* O O *)
    destruct (IHx y) as [l|e|g].
    apply LT; auto.
    apply EQ; rewrite e; red; auto.
    apply GT; auto.
  - (* O H *)
    apply LT; simpl; auto.
  - (* H I *)
    apply LT; simpl; auto.
  - (* H O *)
    apply GT; simpl; auto.
  - (* H H *)
    apply EQ; red; auto.
  Qed.

  Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
  Proof.
  intros. case_eq (x ?= y); intros.
  - left. now apply Pos.compare_eq.
  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
  Qed.

End PositiveOrderedTypeBits.

Module Ascii_as_OT <: UsualOrderedType.
  Definition t := ascii.

  Definition eq := @eq ascii.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition cmp : ascii -> ascii -> comparison := Ascii.compare.

  Lemma cmp_eq (a b : ascii):
    cmp a b = Eq  <->  a = b.
  Proof.
    unfold cmp, Ascii.compare.
    rewrite N.compare_eq_iff.
    split. 2:{ intro. now subst. }
    intro H.
    rewrite<- (ascii_N_embedding a).
    rewrite<- (ascii_N_embedding b).
    now rewrite H.
  Qed.

  Lemma cmp_lt_nat (a b : ascii):
    cmp a b = Lt  <->  (nat_of_ascii a < nat_of_ascii b)%nat.
  Proof.
    unfold cmp. unfold nat_of_ascii, Ascii.compare.
    rewrite N2Nat.inj_compare.
    rewrite Nat.compare_lt_iff.
    reflexivity.
  Qed.

  Lemma cmp_antisym (a b : ascii):
    cmp a b = CompOpp (cmp b a).
  Proof.
    unfold cmp.
    apply N.compare_antisym.
  Qed.

  Definition lt (x y : ascii) := (N_of_ascii x < N_of_ascii y)%N.

  Lemma lt_trans (x y z : ascii):
    lt x y -> lt y z -> lt x z.
  Proof.
    apply N.lt_trans.
  Qed.

  Lemma lt_not_eq (x y : ascii):
     lt x y -> x <> y.
  Proof.
    intros L H. subst.
    exact (N.lt_irrefl _ L).
  Qed.

  Local Lemma compare_helper_eq {a b : ascii} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Local Lemma compare_helper_gt {a b : ascii} (G : cmp a b = Gt):
    lt b a.
  Proof.
    now apply N.compare_gt_iff.
  Qed.

  Definition compare (a b : ascii) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT E
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : ascii): {x = y} + { ~ (x = y)} := ascii_dec x y.
End Ascii_as_OT.

(** [String] is an ordered type with respect to the usual lexical order. *)

Module String_as_OT <: UsualOrderedType.

  Definition t := string.

  Definition eq := @eq string.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Inductive lts : string -> string -> Prop :=
    | lts_empty : forall a s, lts EmptyString (String a s)
    | lts_tail : forall a s1 s2, lts s1 s2 -> lts (String a s1) (String a s2)
    | lts_head : forall (a b : ascii) s1 s2,
        lt (nat_of_ascii a) (nat_of_ascii b) ->
        lts (String a s1) (String b s2).

  Definition lt := lts.

  Lemma nat_of_ascii_inverse a b : nat_of_ascii a = nat_of_ascii b -> a = b.
  Proof.
    intro H.
    rewrite <- (ascii_nat_embedding a).
    rewrite <- (ascii_nat_embedding b).
    apply f_equal; auto.
  Qed.

  Lemma lts_tail_unique a s1 s2 : lt (String a s1) (String a s2) ->
    lt s1 s2.
  Proof.
    intro H; inversion H; subst; auto.
    remember (nat_of_ascii a) as x.
    apply lt_irrefl in H1; inversion H1.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    induction x; intros y z H1 H2.
    - destruct y as [| b y']; inversion H1.
      destruct z as [| c z']; inversion H2; constructor.
    - destruct y as [| b y']; inversion H1; subst;
        destruct z as [| c z']; inversion H2; subst.
      + constructor. eapply IHx; eauto.
      + constructor; assumption.
      + constructor; assumption.
      + constructor. eapply lt_trans; eassumption.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    induction x; intros y LT.
    - inversion LT. intro. inversion H.
    - inversion LT; subst; intros EQ.
      * specialize (IHx s2 H2).
        inversion EQ; subst; auto.
        apply IHx; unfold eq; auto.
      * inversion EQ; subst; auto.
        apply Nat.lt_irrefl in H2; auto.
  Qed.

  Definition cmp : string -> string -> comparison := String.compare.

  Lemma cmp_eq (a b : string):
    cmp a b = Eq  <->  a = b.
  Proof.
    revert b.
    induction a, b; try easy.
    cbn.
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; try discriminate;
      try rewrite Ascii_as_OT.cmp_eq in Heqc; try subst;
      try rewrite IHa; intro H.
    { now subst. }
    { now inversion H. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
  Qed.

  Lemma cmp_antisym (a b : string):
    cmp a b = CompOpp (cmp b a).
  Proof.
    revert b.
    induction a, b; try easy.
    cbn. rewrite IHa. clear IHa.
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; rewrite Ascii_as_OT.cmp_antisym in Heqc;
      destruct Ascii_as_OT.cmp; cbn in *; easy.
  Qed.

  Lemma cmp_lt (a b : string):
    cmp a b = Lt  <->  lt a b.
  Proof.
    revert b.
    induction a as [ | a_head a_tail ], b; try easy; cbn.
    { split; trivial. intro. apply lts_empty. }
    remember (Ascii.compare _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; intro H; try discriminate; trivial.
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      apply String_as_OT.lts_tail.
      apply IHa_tail.
      assumption.
    }
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      inversion H; subst. { rewrite IHa_tail. assumption. }
      exfalso. apply (Nat.lt_irrefl (nat_of_ascii a)). assumption.
    }
    {
      apply String_as_OT.lts_head.
      rewrite<- Ascii_as_OT.cmp_lt_nat.
      assumption.
    }
    {
      exfalso. inversion H; subst.
      {
         assert(X: Ascii.compare a a = Eq). { apply Ascii_as_OT.cmp_eq. trivial. }
         rewrite Heqc in X. discriminate.
      }
      rewrite<- Ascii_as_OT.cmp_lt_nat in *.
      unfold Ascii_as_OT.cmp in *.
      rewrite Heqc in *. discriminate.
    }
  Qed.

  Local Lemma compare_helper_lt {a b : string} (L : cmp a b = Lt):
    lt a b.
  Proof.
    now apply cmp_lt.
  Qed.

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

  Local Lemma compare_helper_eq {a b : string} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Definition compare (a b : string) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT (compare_helper_lt E)
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : string): {x = y} + { ~ (x = y)} := string_dec x y.
End String_as_OT.


Require Import Classical.

Parameter D: Set.
Parameter c d: D.

Parameter P Q: D -> Prop.

(*Beispiel 1*)
Theorem T1: (forall x, P x) /\ (forall x, P x -> Q x) -> (forall x, Q x).
Proof.
  intro.
  destruct H as [H0 H1].
  intro c.
    (*Unterbeweis*)
    apply H1.
    apply H0.
Qed.

(*Beispiel 2*)
Theorem T2: (exists x, P x) /\ (forall x, P x -> Q x) -> (exists x, Q x).
Proof.
  intro.
  destruct H as [H0 H1].
  (*Unterbeweis durch Elimination des Existenzquantors*)
    destruct H0 as [d H0].
    (*Existenzquantor im Ziel fuer d beweisen*)
    exists d.
    apply H1.
  assumption.
Qed.


From Coq Require Import ZArith.
From Coq Require Import Lia.
From Coq Require Import Logic.Eqdep_dec.

From stdpp Require base.

Require Import Program.

Require Import FutharkUtils.

Open Scope bool_scope.
Open Scope Z.

Create HintDb mss.

Ltac mauto :=
  repeat (
      progress autounfold with futhark
      + (progress autounfold with mss)
      + (progress autorewrite with futhark)
      + (progress autorewrite with mss)
      + (progress auto with futhark)
      + (progress auto with mss)).

Definition max (x y : Z) : Z :=
  if x >? y then x else y.

Lemma max_equiv:
  forall x y : Z, max x y = Z.max x y.
Proof.
  intros x y; unfold max; unfold Z.max; unfold Z.gtb;
    destruct (x ?= y) eqn:H; try apply Z.compare_eq_iff in H;
    subst; reflexivity.
Qed.
Hint Rewrite max_equiv : futhark.

Ltac max_equiv_tac := repeat rewrite max_equiv in *.

Lemma max_add_right:
  forall a b c : Z, max a b + c = max (a + c) (b + c).
Proof. intros; max_equiv_tac; lia. Qed.
Hint Rewrite max_add_right : futhark.

Lemma max_add_left:
  forall a b c : Z, a + max b c = max (a + b) (a + c).
Proof. intros; max_equiv_tac; lia. Qed.
Hint Rewrite max_add_left : futhark.

Ltac destruct_ands H :=
  let C1 := fresh "C" in
  let C2 := fresh "C" in
  match type of H with
  | _ /\ _ => destruct H as [C1 C2]; destruct_ands C1; destruct_ands C2
  | _ => idtac
  end.

Ltac destruct_ors H :=
  let D1 := fresh "D" in
  let D2 := fresh "D" in
  match type of H with
  | _ \/ _ => destruct H as [D1 | D2]; try destruct_ors D1; try destruct_ors D2
  | _ => idtac
  end.

Ltac destruct_tuple x :=
  let x1 := fresh "e" in
  let x2 := fresh "e" in
  match type of x with
  | (_ * _)%type  => destruct x as [x1 x2]; destruct_tuple x1; destruct_tuple x2
  | _ => idtac
  end.

Ltac destruct_tuples :=
  repeat match goal with
  | t : (_ * _)%type |- _ => destruct_tuple t
  end.

Ltac destruct_tuple_eqs :=
  repeat match goal with
          | Eq : (_, _) = (_, _) |- _ => inversion Eq; clear Eq
          end.

Ltac split_tuple_eq_goal :=
  repeat match goal with
          | |- (_, _) = (_, _) => f_equal
          end.

Definition X__cond (x : Z * Z * Z * Z) : bool :=
  let '(mss, mis, mcs, ts) := x in
  (mis <=? mss) && (mcs <=? mss) && (0 <=? mis) && (0 <=? mcs) && (ts <=? mis) && (ts <=? mcs).

Definition P__X (x : Z * Z * Z * Z) : Prop := X__cond x = true.

Ltac destruct_bool B :=
  match type of B with
  | true = _    => apply eq_sym in B; destruct_bool B
  | false = _   => apply eq_sym in B; destruct_bool B
  | ?B0 = true  => let B1 := fresh "B" in
                  let B2 := fresh "B" in
                  match B0 with
                  | _ && _ => apply Bool.andb_true_iff in B; destruct B as [B1 B2]
                  | _ || _  => apply Bool.orb_true_iff  in B; destruct B as [B1 | B2]
                  | negb _ => apply Bool.negb_true_iff in B
                  | _ => fail
                  end;
                  try destruct_bool B1;
                  try destruct_bool B2
  | ?B0 = false => let B1 := fresh "B" in
                  let B2 := fresh "B" in
                  match B0 with
                  | _ && _ => apply Bool.andb_false_iff in B; destruct B as [B1 | B2]
                  | _ || _  => apply Bool.orb_false_iff  in B; destruct B as [B1 B2]
                  | negb _ => apply Bool.negb_false_iff in B
                  | _ => fail
                  end;
                  try destruct_bool B1;
                  try destruct_bool B2
  end.

Ltac bool_const_right :=
  repeat match goal with
          | B : true  = _  |- _ => apply eq_sym in B
          | |-   true  = _      => apply eq_sym
          | B : false = _ |- _  => apply eq_sym in B
          | |-   false = _      => apply eq_sym
          end.

Ltac convert_ineqb_to_ineq :=
  bool_const_right;
  repeat match goal with
          | B : (_ =?  _) = true |- _ => apply Z.eqb_eq  in B
          | B : (_ <?  _) = true |- _ => apply Z.ltb_lt  in B
          | B : (_ <=? _) = true |- _ => apply Z.leb_le  in B
          | B : (_ >?  _) = true |- _ => apply Z.gtb_ltb in B
          | B : (_ >=? _) = true |- _ => apply Z.geb_leb in B
          end.

Ltac split_X_cond_goal :=
  repeat (apply Bool.andb_true_iff; split); apply Z.leb_le.

Lemma X_cond_equiv:
  forall x : Z * Z * Z * Z, P__X x <-> let '(mss, mis, mcs, ts) := x in
                  mis <= mss /\ mcs <= mss /\ 0 <= mis /\ 0 <= mcs /\ ts <= mis /\ ts <= mcs.
Proof.
  intros; split; destruct_tuples; unfold P__X; unfold X__cond.
  * intros H; destruct_bool H; convert_ineqb_to_ineq; lia.
  * intros; split_X_cond_goal; lia.
Qed.

Definition X : Type := {x : Z * Z * Z * Z | P__X x }.

Instance X_pi : SigEq P__X := SigEq_dec.

Ltac destruct_X_tuple x v pf :=
  destruct x as [v pf];
  (* in case we have bound the value in a let expression we get rid of the
  corresponding hypothesis *)
  try match goal with
      | var := proj1_sig (exist _ v _) |- _ => simpl in var; subst var
      end;
  destruct_tuple v.

(** tactic for destructing the tuple of an element in X and seperating out the
    inequalities in the condition. *)
Ltac destruct_X x :=
  let v := fresh "v" in
  let pf := fresh "pf" in
  destruct_X_tuple x v pf;
  simpl in *;
  apply X_cond_equiv in pf;
  destruct_ands pf.

(** tactic for destructing the tuple of an element in X and seperating out the
    inequalities in the condition. *)
Ltac destruct_Xs :=
  fold X in *;
  repeat (let x := fresh in
          match goal with
          | [ x : X |- _ ]
            => let v := fresh "v" in
              let pf := fresh "pf" in
              destruct_X_tuple x v pf
          end);
  simpl in *;
  repeat (let pf := fresh "pf" in
          match goal with
          | [pf : P__X _ |- _] => apply X_cond_equiv in pf; destruct_ands pf
          end).

(** operator for calculating the maximal segment sum with the reduce
    operation. The tuple values, (mss, mis, mcs, ts), should be understood as
    follows:
    - mss: Maximal Segment Sum
    - mis: Maximal Initial Sum (maximal sum of a left bounding segment)
    - mcs: Maximal Closing Sum (maximal sum of a right bounding segment)
    - ts:  Total Sum (of the elements of the array)
  *)
Definition redOp_aux (x y : Z * Z * Z * Z) : Z * Z * Z * Z :=
  let '(mssx, misx, mcsx, tsx) := x in
  let '(mssy, misy, mcsy, tsy) := y in
  ( max mssx (max mssy (mcsx + misy))
  , max misx (tsx + misy)
  , max mcsy (mcsx + tsy)
  , tsx + tsy
  ).

Program Definition redOp (x y : X) : X :=
  redOp_aux (proj1_sig x) (proj1_sig y).
Next Obligation.
  destruct_Xs;
    unfold P__X;
    unfold X__cond;
    repeat rewrite max_equiv;
    destruct_tuple_eqs;
    subst;
    split_X_cond_goal;
    lia.
Qed.

Definition X__unit : X := exist _ (0, 0, 0, 0) eq_refl.

#[refine]
Instance X__monoid : IsMonoid X redOp X__unit :=
  {| munit_left  := _;
     munit_right := _;
     massoc      := _
  |}.
(* TODO This is really slow. Is it because I do not help [lia] enough? *)  (* goal 8 slow *)
all:
  intros;
  apply subset_eq;
  destruct_Xs;
  max_equiv_tac;
  split_tuple_eq_goal;
  lia.
Qed.

Program Definition mapOp (x : Z) : X :=
  ( max x 0
  , max x 0
  , max x 0
  , x).
Next Obligation.
  unfold P__X; unfold X__cond;
    intros; split_X_cond_goal;
      repeat rewrite max_equiv;
      convert_ineqb_to_ineq; lia.
Qed.


From NaturalNumbers Require Export Base Tutorial Addition Multiplication Power AdvAddition.

(* Level 0 data *)
(* name `mul_pos` *)
(* tactics symmetry *)
(* Level prologue *)
(*
Welcome to Advanced Multiplication World! It is strongly
recommended that you have finished the worlds before this one,
so that you are familiar with the tactics we introduced there.

Remember that if you have a natural number `n : mynat`, you
can use `destruct n.` to perform case analysis on the cases
where `n = 0` and where `n = S k` for some `k : mynat`. It's
kind of like a weaker form of `induction`.
*)
Lemma mul_pos (a b : mynat) : a <> 0 -> b <> 0 -> a * b <> 0.
Proof.
    intros h k l.
    unfold not in *.
    destruct a.
    - now apply h.  (* convert False to 0 = 0 *)
    - rewrite succ_mul in l.
      specialize (add_left_eq_zero l) as h1.
      exact (k h1).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 1 data *)
(* name `eq_zero_or_eq_zero_of_mul_eq_zero` *)
(* tactics symmetry *)
(* Level prologue *)
(*
A variant on the previous level.
*)
Lemma eq_zero_or_eq_zero_of_mul_eq_zero (a b : mynat) (h : a * b = 0) : a = 0 \/ b = 0.
Proof.
    destruct a.
    - left; easy.
    - right.
      rewrite (succ_mul a b) in h.
      specialize (add_left_eq_zero h) as h1.
      exact h1.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 2 data *)
(* name `mul_eq_zero_iff` *)
(* tactics symmetry *)
(* Level prologue *)
(*
After the previous two levels, this one should be pretty straight forward.
*)
Lemma mul_eq_zero_iff (a b : mynat) : a * b = 0 <-> a = 0 \/ b = 0.
Proof.
    split.
    - exact (eq_zero_or_eq_zero_of_mul_eq_zero _ _).
    - intros h.
      destruct h as [h|h].
      * now rewrite h, zero_mul.
      * now rewrite h, mul_zero.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 3 data *)
(* name `mul_left_cancel` (boss level!) *)
(* tactics revert *)
(* Level prologue *)
(*
This is a pretty tough level. I will admit that I struggled with it a
bit myself as well. It requires a pretty advanced technique. If you just
run at it, and try to use induction on any of the variables, you will get
stuck in the induction step. If you do this, the induction step will
give you an induction hypothesis `a * b = a * c -> b = c`, but
it wants you to prove that `a * b = a * S c -> b = S c`. Here,
your induction hypothesis will be useless!

Instead, we have to use the `revert` tactic. This tactic is kind
of the opposite of the `intro` tactic. It removes one of our hypotheses,
and turns the rest of the hypotheses and the goal into `forall` statments.
I.e., if we have
```plaintext
a, b, c : mynat
ha : a <> 0
============================
a * b = a * c -> b = c
```
and we type `revert b.`, we get
```plaintext
a, c : mynat
ha : a <> 0
============================
forall b : mynat, a * b = a * c -> b = c
```
Now this is a statement we can prove by induction over `c`!

Try to start off your proof with
```
revert b.
induction c as [| ? h].
```
and you should be able to finish the rest, though it might be tough!
*)
Lemma mul_left_cancel (a b c : mynat) (ha : a <> 0) : a * b = a * c -> b = c.
Proof.
    revert b.
    induction c as [| ? h].
    - intro b.
      rewrite mul_zero.
      intro h1.
      rewrite (mul_eq_zero_iff a b) in h1.
      destruct h1 as [|H].
      * contradiction.
      * exact H.
    - intros b h2.
      destruct b.
      * rewrite mul_zero in h2.
        symmetry in h2.
        rewrite mul_eq_zero_iff in h2.
        destruct h2.
        + contradiction.
        + now symmetry.
      * apply succ_eq_succ_of_eq.
        repeat rewrite mul_succ in h2.
        rewrite add_right_cancel_iff in h2.
        exact ((h b) h2).
Qed.
(* Level epilogue *)
(* Level end *)


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Definitions              *
* Arthur Charguéraud, January 2009                                         *
***************************************************************************)

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

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive val : Set :=
  | val_bvar : nat -> val
  | val_fvar : var -> val
  | val_abs  : trm -> val

with trm : Set :=
  | trm_val  : val -> trm
  | trm_app  : val -> trm -> trm.

Notation "'\' v" := (trm_val v) (at level 69).
Coercion trm_val : val >-> trm.
Implicit Types v : val.

(** Opening up abstractions *)

Fixpoint trm_open_rec (k : nat) (u : val) (t : trm) {struct t} : trm :=
  match t with
  | trm_val v1    => trm_val (val_open_rec k u v1)
  | trm_app v1 t2 => trm_app (val_open_rec k u v1) (trm_open_rec k u t2)
  end
with val_open_rec (k : nat) (u : val) (v : val) {struct v} : val :=
  match v with
  | val_bvar i  => If k = i then u else v
  | val_fvar x  => v
  | val_abs t1  => val_abs (trm_open_rec (S k) u t1)
  end.

Definition open t u := trm_open_rec 0 u t.

Notation "{ k ~> u } t" := (trm_open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (val_fvar x)).

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

Inductive term : trm -> Prop :=
  | term_val : forall v,
      value v ->
      term (trm_val v)
  | term_app : forall v1 t2,
      value v1 ->
      term t2 ->
      term (trm_app v1 t2)
with value : val -> Prop :=
  | value_var : forall x,
      value (val_fvar x)
  | value_abs : forall L t1,
      (forall x, x \notin L -> term (t1^x)) ->
      value (val_abs t1).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).
Reserved Notation "E \= v ~: T" (at level 69).

Inductive typing_trm : env -> trm -> typ -> Prop :=
  | typing_trm_val : forall E v T,
      E \= v ~: T ->
      E |= (trm_val v) ~: T
  | typing_trm_app : forall S T E v1 t2,
      E \= v1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app v1 t2) ~: T

where "E |= t ~: T" := (typing_trm E t T)

with typing_val : env -> val -> typ -> Prop :=
  | typing_val_var : forall E x T,
      ok E ->
      binds x T E ->
      E \= (val_fvar x) ~: T
  | typing_val_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E \= (val_abs t1) ~: (typ_arrow U T)

where "E \= t ~: T" := (typing_val E t T).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 v2,
      value (val_abs t1) ->
      value v2 ->
      red (trm_app (val_abs t1) v2) (t1 ^^ v2)
  | red_app_2 : forall v1 t2 t2',
      red t2 t2' ->
      red (trm_app v1 t2) (trm_app v1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     exists v, t = trm_val v
  \/ exists t', t --> t'.


Require Import prosa.classic.util.all
               prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Definition, properties and lemmas about schedules. *)
Module Schedule.

  Export ArrivalSequence.

  (* A processor is defined as a bounded natural number: [0, num_cpus). *)
  Definition processor (num_cpus: nat) := 'I_num_cpus.

  Section ScheduleDef.

    (* Consider any type of job. *)
    Variable Job: eqType.

    (* Given the number of processors... *)
    Variable num_cpus: nat.

    (* ... we define a schedule as a mapping such that each processor
       at each time contains either a job from the sequence or none. *)
    Definition schedule :=
      processor num_cpus -> time -> option Job.

  End ScheduleDef.

  (* Next, we define properties of jobs in a schedule. *)
  Section ScheduledJobs.

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

    (* Given an arrival sequence, ... *)
    Context {arr_seq: arrival_sequence Job}.

    Variable job_cost: Job -> time. (* ... a job cost function, ... *)

    (* ... and the number of processors, ...*)
    Context {num_cpus: nat}.

    (* ... we define the following properties for job j in schedule sched. *)
    Variable sched: schedule Job num_cpus.
    Variable j: Job.

    (* A job j is scheduled on processor cpu at time t iff such a mapping exists. *)
    Definition scheduled_on (cpu: processor num_cpus) (t: time) :=
      sched cpu t == Some j.

    (* A job j is scheduled at time t iff there exists a cpu where it is mapped.*)
    Definition scheduled (t: time) :=
      [exists cpu, scheduled_on cpu t].

    (* A processor cpu is idle at time t if it doesn't contain any jobs. *)
    Definition is_idle (cpu: processor num_cpus) (t: time) :=
      sched cpu t = None.

    (* The instantaneous service of job j at time t is the number of cpus
       where it is scheduled on. Note that we use a sum to account for
       parallelism if required. *)
    Definition service_at (t: time) :=
      \sum_(cpu < num_cpus | scheduled_on cpu t) 1.

    (* The cumulative service received by job j during [0, t'). *)
    Definition service (t': time) := \sum_(0 <= t < t') service_at t.

    (* The cumulative service received by job j during [t1, t2). *)
    Definition service_during (t1 t2: time) := \sum_(t1 <= t < t2) service_at t.

    (* Job j has completed at time t if it received enough service. *)
    Definition completed (t: time) := service t >= job_cost j.

    (* Job j is pending at time t iff it has arrived but has not completed. *)
    Definition pending (t: time) := has_arrived job_arrival j t && ~~completed t.

    (* Job j is backlogged at time t iff it is pending and not scheduled. *)
    Definition backlogged (t: time) := pending t && ~~scheduled t.

    (* Job j is carry-in in interval [t1, t2) iff it arrives before t1 and is
       not complete at time t1 *)
    Definition carried_in (t1: time) := arrived_before job_arrival j t1 && ~~ completed t1.

    (* Job j is carry-out in interval [t1, t2) iff it arrives after t1 and is
       not complete at time t2 *)
    Definition carried_out (t1 t2: time) := arrived_before job_arrival j t2 && ~~ completed t2.

    (* The list of scheduled jobs at time t is the concatenation of the jobs
       scheduled on each processor. *)
    Definition jobs_scheduled_at (t: time) :=
      \cat_(cpu < num_cpus) make_sequence (sched cpu t).

    (* The list of jobs scheduled during the interval [t1, t2) is the
       the duplicate-free concatenation of the jobs scheduled at instant. *)
    Definition jobs_scheduled_between (t1 t2: time) :=
      undup (\cat_(t1 <= t < t2) jobs_scheduled_at t).

  End ScheduledJobs.

  (* In this section, we define properties of valid schedules. *)
  Section ValidSchedules.

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

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

    (* Next, we define whether job are sequential, ... *)
    Definition sequential_jobs :=
      forall j t cpu1 cpu2,
        sched cpu1 t = Some j -> sched cpu2 t = Some j -> cpu1 = cpu2.

    (* ... whether a job can only be scheduled if it has arrived, ... *)
    Definition jobs_must_arrive_to_execute :=
      forall j t,
        scheduled sched j t ->
        has_arrived job_arrival j t.

    (* ... whether a job can be scheduled after it completes. *)
    Definition completed_jobs_dont_execute :=
      forall j t, service sched j t <= job_cost j.

    (* We also define whether jobs come from some arrival sequence. *)
    Definition jobs_come_from_arrival_sequence (arr_seq: arrival_sequence Job) :=
      forall j t, scheduled sched j t -> arrives_in arr_seq j.

  End ValidSchedules.

  (* In this section, we prove some basic lemmas about a job. *)
  Section JobLemmas.

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

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

    (* Next, we prove some lemmas about the service received by a job j. *)
    Variable j: Job.

    Section Basic.

      (* At any time t, job j is not scheduled iff it doesn't get service. *)
      Lemma not_scheduled_no_service :
        forall t,
          ~~ scheduled sched j t = (service_at sched j t == 0).
      Proof.
        unfold scheduled, service_at, scheduled_on; intros t; apply/idP/idP.
        {
          intros NOTSCHED.
          rewrite negb_exists in NOTSCHED.
          move: NOTSCHED => /forallP NOTSCHED.
          rewrite big_seq_cond.
          rewrite -> eq_bigr with (F2 := fun i => 0);
            first by rewrite big_const_seq iter_addn mul0n addn0.
          move => cpu /andP [_ /eqP SCHED].
          by specialize (NOTSCHED cpu); rewrite SCHED eq_refl in NOTSCHED.
        }
        {
          intros NOSERV; rewrite big_mkcond -sum_nat_eq0_nat in NOSERV.
          move: NOSERV => /allP ALL.
          rewrite negb_exists; apply/forallP; intros cpu.
          exploit (ALL cpu); [by apply mem_index_enum | by desf].
        }
      Qed.

      (* If the cumulative service during a time interval is not zero, there
         must be a time t in this interval where the service is not 0, ... *)
      Lemma cumulative_service_implies_service :
        forall t1 t2,
          service_during sched j t1 t2 != 0 ->
          exists t,
            t1 <= t < t2 /\
            service_at sched j t != 0.
      Proof.
        intros t1 t2 NONZERO.
        destruct ([exists t: 'I_t2, (t >= t1) && (service_at sched j t != 0)]) eqn:EX.
        {
          move: EX => /existsP EX; destruct EX as [x EX]. move: EX => /andP [GE SERV].
          exists x; split; last by done.
          by apply/andP; split; [by done | apply ltn_ord].
        }
        {
          apply negbT in EX; rewrite negb_exists in EX; move: EX => /forallP EX.
          unfold service_during in NONZERO; rewrite big_nat_cond in NONZERO.
          rewrite (eq_bigr (fun x => 0)) in NONZERO;
            first by rewrite -big_nat_cond big_const_nat iter_addn mul0n addn0 in NONZERO.
          intros i; rewrite andbT; move => /andP [GT LT].
          specialize (EX (Ordinal LT)); simpl in EX.
          by rewrite GT andTb negbK in EX; apply/eqP.
        }
      Qed.

      (* ... and vice versa. *)
      Lemma service_implies_cumulative_service:
        forall t t1 t2,
          t1 <= t < t2 ->
          service_at sched j t != 0 ->
          service_during sched j t1 t2 != 0.
      Proof.
        intros t t1 t2 LE NONZERO.
        unfold service_during.
        rewrite (bigD1_seq t) /=;
          [| by rewrite mem_index_iota | by apply iota_uniq].
        rewrite -lt0n -addn1 addnC.
        by apply leq_add; first by rewrite lt0n.
      Qed.

    End Basic.

    Section SequentialJobs.

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

      (* ..., the service received by job j at any time t is at most 1, ... *)
      Lemma service_at_most_one :
        forall t, service_at sched j t <= 1.
      Proof.
        unfold service_at, sequential_jobs in *; ins.
        destruct (scheduled sched j t) eqn:SCHED; unfold scheduled in SCHED.
        {
          move: SCHED => /existsP [cpu SCHED]; des.
          rewrite -big_filter (bigD1_seq cpu);
            [simpl | | by rewrite filter_index_enum enum_uniq];
              last by rewrite mem_filter; apply/andP; split.
          rewrite -big_filter -filter_predI big_filter.
          rewrite -> eq_bigr with (F2 := fun cpu => 0);
            first by rewrite /= big_const_seq iter_addn mul0n 2!addn0.
          intro cpu'; move => /andP [/eqP NEQ /eqP SCHED'].
          exfalso; apply NEQ.
          by apply H_sequential_jobs with (j := j) (t := t); last by apply/eqP.
        }
        {
          apply negbT in SCHED; rewrite negb_exists in SCHED.
          move: SCHED => /forallP SCHED.
          rewrite big_pred0; red; ins; apply negbTE, SCHED.
        }
      Qed.

      (* ..., which implies that the service receive during a interval
         of length delta is at most delta. *)
      Lemma cumulative_service_le_delta :
        forall t delta, service_during sched j t (t + delta) <= delta.
      Proof.
        unfold service_at, sequential_jobs in *; ins.
        generalize dependent t.
        induction delta.
        {
          ins; unfold service_during; rewrite addn0.
          by rewrite big_geq.
        }
        {
          unfold service_during; intro t.
          rewrite -addn1 addnA addn1 big_nat_recr; last by apply leq_addr.
          apply leq_add; first by apply IHdelta.
          by apply service_at_most_one.
        }
      Qed.

    End SequentialJobs.

    Section Completion.

      (* Assume that completed jobs do not execute. *)
      Hypothesis H_completed_jobs:
        completed_jobs_dont_execute job_cost sched.

      (* Then, after job j completes, it remains completed. *)
      Lemma completion_monotonic :
        forall t t',
          t <= t' ->
          completed job_cost sched j t ->
          completed job_cost sched j t'.
      Proof.
        unfold completed; move => t t' LE COMPt.
        apply leq_trans with (service sched j t); first by done.
          by rewrite /service /service_during [in X in _ <= X](@big_cat_nat _ _ _ t) //= leq_addr.
      Qed.

      (* A completed job cannot be scheduled. *)
      Lemma completed_implies_not_scheduled :
        forall t,
          completed job_cost sched j t ->
          ~~ scheduled sched j t.
      Proof.
        rename H_completed_jobs into COMP.
        unfold completed_jobs_dont_execute in *.
        intros t COMPLETED.
        apply/negP; red; intro SCHED.
        have BUG := COMP j t.+1.
        rewrite leqNgt in BUG; move: BUG => /negP BUG; apply: BUG.
        unfold service, service_during; rewrite big_nat_recr // /= -addn1.
        apply leq_add; first by done.
          by rewrite lt0n -not_scheduled_no_service negbK.
      Qed.

      (* The service received by job j in any interval is no larger than its cost. *)
      Lemma cumulative_service_le_job_cost :
        forall t t',
          service_during sched j t t' <= job_cost j.
      Proof.
        unfold service_during; rename H_completed_jobs into COMP; red in COMP; ins.
        destruct (t > t') eqn:GT.
          by rewrite big_geq // -ltnS; apply ltn_trans with (n := t); ins.
          apply leq_trans with
              (n := \sum_(0 <= t0 < t') service_at sched j t0);
            last by apply COMP.
          rewrite -> big_cat_nat with (m := 0) (n := t);
            [by apply leq_addl | by ins | by rewrite leqNgt negbT //].
      Qed.

    End Completion.

    Section Arrival.

      (* Assume that jobs must arrive to execute. *)
      Hypothesis H_jobs_must_arrive:
        jobs_must_arrive_to_execute job_arrival sched.

      (* Then, job j does not receive service at any time t prior to its arrival. *)
      Lemma service_before_job_arrival_zero :
        forall t,
          t < job_arrival j ->
          service_at sched j t = 0.
      Proof.
        rename H_jobs_must_arrive into ARR; red in ARR; intros t LT.
        specialize (ARR j t).
        apply contra with (c := scheduled sched j t)
                            (b := has_arrived job_arrival j t) in ARR;
          last by rewrite -ltnNge.
        apply/eqP; rewrite -leqn0; unfold service_at.
        rewrite big_pred0 //; red.
        intros cpu; apply negbTE.
        by move: ARR; rewrite negb_exists; move => /forallP ARR; apply ARR.
      Qed.

      (* The same applies for the cumulative service received by job j. *)
      Lemma cumulative_service_before_job_arrival_zero :
        forall t1 t2,
          t2 <= job_arrival j ->
          \sum_(t1 <= i < t2) service_at sched j i = 0.
      Proof.
        intros t1 t2 LE; apply/eqP; rewrite -leqn0.
        apply leq_trans with (n := \sum_(t1 <= i < t2) 0);
          last by rewrite big_const_nat iter_addn mul0n addn0.
        rewrite big_nat_cond [\sum_(_ <= _ < _) 0]big_nat_cond.
        apply leq_sum; intro i; rewrite andbT; move => /andP LTi; des.
        rewrite service_before_job_arrival_zero; first by ins.
        by apply leq_trans with (n := t2); ins.
      Qed.

      (* Hence, you can ignore the service received by a job before its arrival time. *)
      Lemma service_before_arrival_eq_service_during :
        forall t0 t,
          t0 <= job_arrival j ->
          \sum_(t0 <= t < job_arrival j + t) service_at sched j t =
          \sum_(job_arrival j <= t < job_arrival j + t) service_at sched j t.
      Proof.
        intros t0 t LE; rewrite -> big_cat_nat with (n := job_arrival j);
          [| by ins | by apply leq_addr].
        by rewrite /= cumulative_service_before_job_arrival_zero; [rewrite add0n | apply leqnn].
      Qed.

    End Arrival.

    Section Pending.

      (* Assume that jobs must arrive to execute. *)
      Hypothesis H_jobs_must_arrive:
        jobs_must_arrive_to_execute job_arrival sched.

     (* Assume that completed jobs do not execute. *)
      Hypothesis H_completed_jobs:
        completed_jobs_dont_execute job_cost sched.

      (* Then, if job j is scheduled, it must be pending. *)
      Lemma scheduled_implies_pending:
        forall t,
          scheduled sched j t ->
          pending job_arrival job_cost sched j t.
      Proof.
        rename H_jobs_must_arrive into ARRIVE,
               H_completed_jobs into COMP.
        unfold jobs_must_arrive_to_execute, completed_jobs_dont_execute in *.
        intros t SCHED.
        unfold pending; apply/andP; split; first by apply ARRIVE.
        apply/negP; unfold not; intro COMPLETED.
        have BUG := COMP j t.+1.
        rewrite leqNgt in BUG; move: BUG => /negP BUG; apply BUG.
        unfold service; rewrite -addn1 big_nat_recr // /=.
        apply leq_add; first by done.
        rewrite lt0n; apply/eqP; red; move => /eqP NOSERV.
        rewrite -not_scheduled_no_service in NOSERV.
        by rewrite SCHED in NOSERV.
      Qed.

    End Pending.

  End JobLemmas.

  (* In this section, we prove some lemmas about the list of jobs
     scheduled at time t. *)
  Section ScheduledJobsLemmas.

    Context {Job: eqType}.

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

    Section Membership.

    (* A job is in the list of scheduled jobs iff it is scheduled. *)
      Lemma mem_scheduled_jobs_eq_scheduled :
        forall j t,
          j \in jobs_scheduled_at sched t = scheduled sched j t.
      Proof.
        unfold jobs_scheduled_at, scheduled, scheduled_on.
        intros j t; apply/idP/idP.
        {
          intros IN.
          apply mem_bigcat_ord_exists in IN; des.
          apply/existsP; exists i.
          destruct (sched i t); last by done.
          by rewrite mem_seq1 in IN; move: IN => /eqP IN; subst.
        }
        {
          move => /existsP EX; destruct EX as [i SCHED].
          apply mem_bigcat_ord with (j := i); first by apply ltn_ord.
          by move: SCHED => /eqP SCHED; rewrite SCHED /= mem_seq1 eq_refl.
        }
      Qed.

    End Membership.

    Section Uniqueness.

      (* Suppose that jobs are sequential. *)
      Hypothesis H_sequential_jobs : sequential_jobs sched.

      (* Then, the list of jobs scheduled at any time t has no duplicates. *)
      Lemma scheduled_jobs_uniq :
        forall t,
          uniq (jobs_scheduled_at sched t).
      Proof.
        intros t; rename H_sequential_jobs into SEQUENTIAL.
        unfold sequential_jobs in SEQUENTIAL.
        clear -SEQUENTIAL.
        unfold jobs_scheduled_at.
        induction num_cpus; first by rewrite big_ord0.
        {

          rewrite big_ord_recr cat_uniq; apply/andP; split.
          {
            apply bigcat_ord_uniq;
              first by intro i; unfold make_sequence; desf.
            intros x i1 i2 IN1 IN2; unfold make_sequence in *.
            desf; move: Heq0 Heq => SOME1 SOME2.
            rewrite mem_seq1 in IN1; rewrite mem_seq1 in IN2.
            move: IN1 IN2 => /eqP IN1 /eqP IN2; subst x s0.
            specialize (SEQUENTIAL s t (widen_ord (leqnSn n) i1)
                           (widen_ord (leqnSn n) i2) SOME1 SOME2).
            by inversion SEQUENTIAL; apply ord_inj.
          }
          apply/andP; split; last by unfold make_sequence; destruct (sched ord_max).
          {
            rewrite -all_predC; apply/allP; unfold predC; simpl.
            intros x INx.
            unfold make_sequence in INx.
            destruct (sched ord_max t) eqn:SCHED;
              last by rewrite in_nil in INx.
            apply/negP; unfold not; intro IN'.
            have EX := mem_bigcat_ord_exists _ x n.
            apply EX in IN'; des; clear EX.
            unfold make_sequence in IN'.
            desf; rename Heq into SCHEDi.
            rewrite mem_seq1 in INx; rewrite mem_seq1 in IN'.
            move: INx IN' => /eqP INx /eqP IN'; subst x s0.
            specialize (SEQUENTIAL s t ord_max (widen_ord (leqnSn n) i) SCHED SCHEDi).
            inversion SEQUENTIAL; destruct i as [i EQ]; simpl in *.
            clear SEQUENTIAL SCHEDi.
            by rewrite H0 ltnn in EQ.
          }
        }
      Qed.

    End Uniqueness.

    Section NumberOfJobs.

      (* The number of scheduled jobs is no larger than the number of cpus. *)
      Lemma num_scheduled_jobs_le_num_cpus :
        forall t,
          size (jobs_scheduled_at sched t) <= num_cpus.
      Proof.
        intros t.
        unfold jobs_scheduled_at.
        destruct num_cpus; first by rewrite big_ord0.
        apply leq_trans with (1*n.+1); last by rewrite mul1n.
        apply size_bigcat_ord_max.
        by ins; unfold make_sequence; desf.
      Qed.

    End NumberOfJobs.

  End ScheduledJobsLemmas.

End Schedule.

(* Specific properties of a schedule of sporadic jobs. *)
Module ScheduleOfSporadicTask.

  Import SporadicTask Job.
  Export Schedule.

  Section ScheduledJobs.

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

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

    (* Given a task tsk, ...*)
    Variable tsk: sporadic_task.

    (* ..., we we can state that tsk is scheduled on cpu at time t as follows. *)
    Definition task_scheduled_on (cpu: processor num_cpus) (t: time) :=
      if (sched cpu t) is Some j then
        (job_task j == tsk)
      else false.

    (* Likewise, we can state that tsk is scheduled on some processor. *)
      Definition task_is_scheduled (t: time) :=
        [exists cpu, task_scheduled_on cpu t].

    (* We also define the list of jobs scheduled during [t1, t2). *)
    Definition jobs_of_task_scheduled_between (t1 t2: time) :=
      filter (fun j => job_task j == tsk)
             (jobs_scheduled_between sched t1 t2).

  End ScheduledJobs.

  Section ScheduleProperties.

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

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

    (* Next we define intra-task parallelism. *)
    Definition jobs_of_same_task_dont_execute_in_parallel :=
      forall j j' t,
        job_task j = job_task j' ->
        scheduled sched j t ->
        scheduled sched j' t ->
        j = j'.

  End ScheduleProperties.

  Section BasicLemmas.

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

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

    (* Consider any valid schedule of sporadic tasks ...*)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* ...such that jobs do not execute after completion.*)
    Hypothesis jobs_dont_execute_after_completion :
       completed_jobs_dont_execute job_cost sched.

    (* Let tsk be any tsk...*)
    Variable tsk: sporadic_task.

    (* ...and let j be any valid job of tsk. *)
    Variable j: Job.
    Hypothesis H_job_of_task: job_task j = tsk.
    Hypothesis valid_job:
      valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Remember that for any job of tsk, service <= task_cost tsk *)
    Lemma cumulative_service_le_task_cost :
        forall t t',
          service_during sched j t t' <= task_cost tsk.
    Proof.
      rename valid_job into VALID; unfold valid_sporadic_job in *; ins; des.
      apply leq_trans with (n := job_cost j);
        last by rewrite -H_job_of_task; apply VALID0.
      by apply cumulative_service_le_job_cost.
    Qed.

  End BasicLemmas.

End ScheduleOfSporadicTask.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.dec_fields.
Require Export
  HoTT.Classes.orders.rings.

Generalizable Variables F f R Fle Flt.

Section contents.
Context `{IsDecField F} `{Apart F} `{!TrivialApart F}
  `{!FullPseudoSemiRingOrder Fle Flt} `{DecidablePaths F}.
(* Add Ring F : (stdlib_ring_theory F). *)

Instance pos_dec_recip_compat x : PropHolds (0 < x) -> PropHolds (0 < /x).
Proof.
intros E.
apply (strictly_order_reflecting (x *.)).
rewrite dec_recip_inverse by (apply orders.lt_ne_flip;trivial).
rewrite mult_0_r. solve_propholds.
Qed.

Instance nonneg_dec_recip_compat x : PropHolds (0 ≤ x) -> PropHolds (0 ≤ /x).
Proof.
intros E. red.
destruct (dec (x = 0)) as [E2 | E2].
- rewrite E2, dec_recip_0. rewrite E2 in E;trivial.
- apply lt_le. apply pos_dec_recip_compat.
  apply lt_iff_le_ne. split;trivial.
  apply symmetric_neq;trivial.
Qed.

Lemma neg_dec_recip_compat x : x < 0 -> /x < 0.
Proof.
intros. apply flip_neg_negate.
rewrite dec_recip_negate.
apply pos_dec_recip_compat.
apply flip_neg_negate. trivial.
Qed.

Lemma nonpos_dec_recip_compat x : x ≤ 0 -> /x ≤ 0.
Proof.
intros. apply flip_nonpos_negate.
rewrite dec_recip_negate.
apply nonneg_dec_recip_compat.
apply flip_nonpos_negate;trivial.
Qed.

Lemma flip_le_dec_recip x y : 0 < y -> y ≤ x  -> /x ≤ /y.
Proof.
intros E1 E2.
apply (order_reflecting_pos (.*.) x).
- apply lt_le_trans with y;trivial.
- rewrite dec_recip_inverse.
  + apply (order_reflecting_pos (.*.) y);trivial.
    rewrite (commutativity x), simple_associativity, dec_recip_inverse.
    * rewrite mult_1_l,mult_1_r. trivial.
    * apply lt_ne_flip;trivial.
  + apply lt_ne_flip.
    apply lt_le_trans with y;trivial.
Qed.

Lemma flip_le_dec_recip_l x y : 0 < y -> /y ≤ x  -> /x ≤ y.
Proof.
intros E1 E2.
rewrite <-(dec_recip_involutive y).
apply flip_le_dec_recip;trivial.
apply pos_dec_recip_compat;trivial.
Qed.

Lemma flip_le_dec_recip_r x y : 0 < y -> y ≤ /x  -> x ≤ /y.
Proof.
intros E1 E2.
rewrite <-(dec_recip_involutive x).
apply flip_le_dec_recip;trivial.
Qed.

Lemma flip_lt_dec_recip x y : 0 < y -> y < x  -> /x < /y.
Proof.
intros E1 E2.
assert (0 < x) by (transitivity y;trivial).
apply (strictly_order_reflecting (x *.)).
rewrite dec_recip_inverse.
- apply (strictly_order_reflecting (y *.)).
  rewrite (commutativity x), simple_associativity, dec_recip_inverse.
  + rewrite mult_1_l,mult_1_r. trivial.
  + apply lt_ne_flip. trivial.
- apply lt_ne_flip;trivial.
Qed.

Lemma flip_lt_dec_recip_l x y : 0 < y -> /y < x  -> /x < y.
Proof.
intros E1 E2.
rewrite <-(dec_recip_involutive y).
apply flip_lt_dec_recip; trivial.
apply pos_dec_recip_compat. trivial.
Qed.

Lemma flip_lt_dec_recip_r x y : 0 < y -> y < /x  -> x < /y.
Proof.
intros E1 E2.
rewrite <-(dec_recip_involutive x).
apply flip_lt_dec_recip;trivial.
Qed.
End contents.

(* Due to bug #2528 *)
#[export]
Hint Extern 12 (PropHolds (0 ≤ _)) =>
  eapply @nonneg_dec_recip_compat : typeclass_instances.
#[export]
Hint Extern 12 (PropHolds (0 < _)) =>
  eapply @pos_dec_recip_compat : typeclass_instances.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rle.
Require Export XR_Rtotal_order.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1.
Proof.
  intros x y.
  unfold "~".
  intro h.
  unfold "<=".
  destruct (Rtotal_order x y) as [ hxy | [ heq | hyx ] ].
  {
    exfalso.
    apply h.
    exact hxy.
  }
  {
    subst y.
    right.
    reflexivity.
  }
  {
    left.
    exact hyx.
  }
Qed.


Require Import Arith.
Require Import Omega.
Require Import String.
Require List.

Import List.ListNotations.
Local Open Scope list.

Set Implicit Arguments.

Class Ordering A :=
  { cmp: A -> A -> comparison;
    cmp_eq: forall x y,
        cmp x y = Eq <-> x = y;
    cmp_antisym: forall x y,
        cmp x y = Gt <-> cmp y x = Lt;
    cmp_trans : forall x y z,
        cmp x y = Lt -> cmp y z = Lt ->
        cmp x z = Lt; }.

Lemma cmp_eq1 : forall A (ordA:Ordering A) x y,
    cmp x y = Eq -> x = y.
Proof.
  intros.
  apply cmp_eq; auto.
Qed.

Lemma cmp_refl : forall A (ordA:Ordering A) x,
    cmp x x = Eq.
Proof.
  intros.
  apply cmp_eq; auto.
Qed.

Lemma cmp_antisym1 : forall A (ordA:Ordering A) x y,
    cmp x y = Gt -> cmp y x = Lt.
Proof.
  intros.
  apply cmp_antisym; auto.
Qed.

Lemma cmp_antisym2 : forall A (ordA:Ordering A) x y,
    cmp x y = Lt -> cmp y x = Gt.
Proof.
  intros.
  apply cmp_antisym; auto.
Qed.

Hint Resolve cmp_eq1 cmp_refl cmp_antisym1 cmp_antisym2 cmp_trans : core.

Definition cmp_lt {A} `{Ordering A} :=
  fun x y => cmp x y = Lt.

Definition cmp_dec {A} `{Ordering A} : forall (x y:A), {x=y} + {x<>y}.
Proof.
  intros.
  destruct_with_eqn (cmp x y).
  left; eauto.
  right; intro.
  apply cmp_eq in H0; congruence.
  right; intro.
  apply cmp_eq in H0; congruence.
Defined.

Definition ord_spec {A} `{Ordering A} :
  forall x y, CompareSpec (x=y) (cmp x y = Lt /\ cmp y x = Gt) (cmp y x = Lt /\ cmp x y = Gt) (cmp x y).
Proof.
  intros.
  destruct_with_eqn (cmp x y);
    constructor;
    intuition eauto.
Defined.

Instance nat_Ordering : Ordering nat.
Proof.
  refine {| cmp := fun x y =>
                     if Nat.eq_dec x y then Eq
                     else if lt_dec x y then Lt
                          else Gt; |};
    intros.
  - destruct (Nat.eq_dec x y); split; intros;
      subst; try congruence.
    destruct (lt_dec x y); congruence.
  - destruct (Nat.eq_dec x y), (Nat.eq_dec y x);
      subst;
      try congruence.
    split; congruence.
    destruct (lt_dec x y), (lt_dec y x);
      try omega.
    split; congruence.
    split; auto.
  - destruct (Nat.eq_dec x y), (Nat.eq_dec y z), (Nat.eq_dec x z);
      subst;
      try congruence.
    destruct (lt_dec z y), (lt_dec y z);
      try congruence;
      try omega.
    destruct (lt_dec x y), (lt_dec y z), (lt_dec x z);
      try congruence;
      try omega.
Defined.

Instance prod_Ordering A B {ordA:Ordering A} {ordB: Ordering B} : Ordering (A*B).
Proof.
  refine {| cmp := fun '(x1, x2) '(y1, y2) =>
                     match cmp x1 y1 with
                     | Lt => Lt
                     | Gt => Gt
                     | Eq => cmp x2 y2
                     end |}; intros.
  - destruct x, y.
    destruct (ord_spec a a0); subst; (intuition eauto);
      repeat match goal with
             | [ H: cmp _ _ = Eq |- _ ] =>
               apply cmp_eq in H
             | [ H: (_, _) = (_, _) |- _ ] =>
               inversion H; clear H
             end; subst;
        try congruence; eauto.
  - destruct x, y.
    destruct (ord_spec a a0); subst.
    * rewrite cmp_refl.
      intuition eauto.
    * destruct H.
      rewrite H0.
      split; congruence.
    * intuition.
      rewrite H0; auto.
  - destruct x, y, z.
    destruct (ord_spec a a0), (ord_spec a0 a1);
      intuition subst;
      rewrite ?cmp_refl in *;
      repeat match goal with
             | [ H: cmp _ _ = _ |- _ ] =>
               rewrite H in *
             end;
      try congruence;
      eauto.
    erewrite cmp_trans; eauto.
Defined.

Instance sum_Ordering A B : forall (ordA:Ordering A) (ordB:Ordering B), Ordering (A+B).
Proof.
  intros.
  refine {| cmp := fun x y =>
                     match x, y with
                     | inl x, inl y => cmp x y
                     | inr x, inr y => cmp x y
                     | inl _, inr _ => Lt
                     | inr _, inl _ => Gt
                     end; |}; intros.
  - destruct x, y; (intuition eauto);
      repeat match goal with
             | [ H: inl _ = inl _ |- _ ] =>
               inversion H; subst; clear H
             | [ H: inr _ = inr _ |- _ ] =>
               inversion H; subst; clear H
             | [ H: cmp _ _ = Eq |- _ ] =>
               apply cmp_eq in H; subst
             end;
      try congruence;
      eauto.
  - destruct x, y; intuition eauto.
  - destruct x, y, z; (intuition eauto);
      try congruence.
Defined.

Record injection A B :=
  { inject: A -> B;
    inject_ok : forall x y, inject x = inject y -> x = y; }.

Theorem injection_Ordering A {B} : forall (ordA:Ordering A) (inj:injection B A), Ordering B.
Proof.
  intros.
  refine {| cmp := fun x y =>
                     cmp (inject inj x) (inject inj y) |}; intuition eauto.
  eapply inject_ok; eauto.
  subst; rewrite cmp_refl; auto.
Defined.

Arguments injection_Ordering A {B} ordA inj.

Fixpoint cmp_list A (ord:Ordering A) (l1 l2:list A) : comparison :=
  match l1, l2 with
  | [], [] => Eq
  | [], _::_ => Lt
  | _::_, [] => Gt
  | x::xs, y::ys => match cmp x y with
                   | Eq => cmp_list ord xs ys
                   | Lt => Lt
                   | Gt => Gt
                   end
  end.

(* borrowed from Software Foundations' LibTactics
https://softwarefoundations.cis.upenn.edu/plf-current/LibTactics.html *)
Local Tactic Notation "gen" constr(X1) :=
  generalize dependent X1.
Local Tactic Notation "gen" constr(X1) constr(X2) :=
  gen X2; gen X1.
Local Tactic Notation "gen" constr(X1) constr(X2) constr(X3) :=
  gen X3; gen X1 X2.
Local Tactic Notation "gen" constr(X1) constr(X2) constr(X3) constr(X4) :=
  gen X4; gen X1 X2 X3.
Local Tactic Notation "gen" constr(X1) constr(X2) constr(X3) constr(X4) constr(X5) :=
  gen X5; gen X1 X2 X3 X4.
Local Tactic Notation "gen" constr(X1) constr(X2) constr(X3) constr(X4) constr(X5) constr(X6) :=
  gen X6; gen X1 X2 X3 X4 X5.

Section TwoListInduction.

  Variable A:Type.
  Variable B:Type.
  Variable P: list A -> list B -> Prop.

  Fixpoint zip (l1: list A) (l2:list B) : list (A*B) :=
    match l1 with
    | nil => nil
    | x::xs => match l2 with
              | nil => nil
              | y::ys => (x,y)::zip xs ys
              end
    end.

  Hypothesis Pnil_nil : P [] [].
  Hypothesis Pnil_cons : forall y ys, P [] (y::ys).
  Hypothesis Pcons_nil : forall x xs, P (x::xs) [].

  Theorem empty_zip : forall l1 l2,
      zip l1 l2 = [] ->
      P l1 l2.
  Proof.
    induction l1; simpl; intros.
    destruct l2; eauto.
    destruct l2; simpl in *; try congruence; eauto.
  Qed.

  Hypothesis Pind : forall x y xs ys,
      P xs ys ->
      P (x::xs) (y::ys).

  Theorem two_list_induction : forall l1 l2,
      P l1 l2.
  Proof.
    intros.
    remember (zip l1 l2).
    gen l1 l2.
    induction l; simpl; intros.
    - apply empty_zip; auto.
    - destruct l1, l2; simpl in *; try congruence.
      inversion Heql; subst.
      specialize (IHl l1 l2); intuition.
  Qed.

End TwoListInduction.

Section ThreeListInduction.

  Variable A:Type.
  Variable B:Type.
  Variable C:Type.

  Definition zip3 (l1: list A) (l2:list B) (l3:list C) : list (A*B*C) :=
    zip (zip l1 l2) l3.

  Variable P: list A -> list B -> list C -> Prop.

  Hypothesis Psome_nil : forall xs ys zs,
      xs = [] \/ ys = [] \/ zs = [] -> P xs ys zs.

  Hypothesis Pind : forall x y z xs ys zs,
      P xs ys zs ->
      P (x::xs) (y::ys) (z::zs).

  Theorem three_list_induction : forall l1 l2 l3,
      P l1 l2 l3.
  Proof.
    intros.
    remember (zip l1 l2).
    gen l1 l2.
    eapply two_list_induction with (l1 := l) (l2 := l3);
      intros; eauto.
    destruct l1, l2; eauto.
    simpl in *; congruence.

    gen x y xs ys Heql H.
    clear l.
    clear l3.
    eapply two_list_induction with (l1:=l1) (l2:=l2); simpl; intros; eauto.

    inversion Heql; subst; clear Heql.
    eauto.
  Qed.

End ThreeListInduction.

Local Lemma cmp_list_eq A {ord: Ordering A} x y :
    cmp_list ord x y = Eq <-> x = y.
Proof.
  eapply two_list_induction with (l1 := x) (l2 := y);
    simpl in *;
    try solve [ (intuition eauto); congruence ];
    intros.
  destruct H.
  destruct (ord_spec x0 y0); (intuition subst); eauto; try congruence.
  inversion H2; subst; clear H2; intuition eauto.
Qed.

Lemma cmp_list_antisym A {ord: Ordering A} x y :
  cmp_list ord x y = Gt <-> cmp_list ord y x = Lt.
Proof.
  eapply two_list_induction with (l1 := x) (l2 := y);
    simpl in *;
    try solve [ (intuition eauto); congruence ];
    intros.
  destruct (ord_spec x0 y0); (intuition subst); eauto; try congruence.
  rewrite cmp_refl; eauto.
  rewrite cmp_refl in *; eauto.
  rewrite H2 in *; congruence.
  rewrite H1; eauto.
Qed.

Lemma cmp_list_trans A {ord: Ordering A} x y z :
  cmp_list ord x y = Lt -> cmp_list ord y z = Lt -> cmp_list ord x z = Lt.
Proof.
  eapply three_list_induction with (l1:=x) (l2:=y) (l3:=z); intros; simpl.
  intuition subst.
  destruct ys, zs; simpl in *; try congruence.
  destruct xs, zs; simpl in *; try congruence.
  destruct xs, ys; simpl in *; try congruence.
  simpl in *.
  destruct (ord_spec y0 z0), (ord_spec x0 y0); subst; eauto;
    intuition eauto;
    repeat match goal with
           | [ H: context[cmp ?x ?x] |- _ ] =>
             rewrite cmp_refl in H
           | [ |- context[cmp ?x ?x] ] =>
             rewrite cmp_refl
           | [ H: context[cmp ?x ?y], Heq: cmp ?x ?y = _ |- _ ] =>
             rewrite Heq in H
           | [ Heq: cmp ?x ?y = _ |- context[cmp ?x ?y] ] =>
             rewrite Heq
           | _ =>
             try erewrite cmp_trans by eauto
           end;
    eauto;
    try congruence.
Qed.

Instance list_Ordering A {ord:Ordering A} : Ordering (list A).
Proof.
  refine {| cmp := cmp_list ord |};
    eauto using cmp_list_eq, cmp_list_antisym, cmp_list_trans.
Defined.

Instance bool_Ordering : Ordering bool.
Proof.
  refine {| cmp := fun x y =>
                     match x, y with
                     | false, false => Eq
                     | true, true => Eq
                     | false, true => Lt
                     | true, false => Gt
                     end |}; intros.
  destruct x, y; simpl; (intuition idtac); congruence.
  destruct x, y; simpl; (intuition idtac); congruence.
  destruct x, y, z; simpl; (intuition idtac); congruence.
Defined.

Instance ascii_Ordering : Ordering Ascii.ascii.
Proof.
  apply (injection_Ordering (bool*bool*bool*bool*bool*bool*bool*bool)%type).
  typeclasses eauto.

  unshelve econstructor; intros.
  destruct H.
  exact (b, b0, b1, b2, b3, b4, b5, b6).
  destruct x, y.
  congruence.
Defined.

Fixpoint string_to_list (s:string) : list Ascii.ascii :=
  match s with
  | EmptyString => []
  | String c s => c :: string_to_list s
  end.

Instance string_Ordering : Ordering string.
Proof.
  apply (injection_Ordering (list Ascii.ascii)).
  typeclasses eauto.
  refine {| inject := string_to_list |}; intros.
  remember (string_to_list x).
  remember (string_to_list y).
  gen x y H.
  eapply two_list_induction with (l1 := l) (l2 := l0); intros;
    try congruence.
  destruct x, y; simpl in *; try congruence.
  inversion H0; subst; clear H0; intuition.
  destruct x0, y0; simpl in *; try congruence.
  inversion Heql0; subst; clear Heql0.
  inversion Heql; subst; clear Heql.
  f_equal; eauto.
Defined.