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

Require Import Arith List Omega.

Require Import tacs.

Require Import rel_utils.
Require Import list_utils.
Require Import sublist.

Set Implicit Arguments.

Section Ge_Good.

  Variables (A : Type) (R : A -> A -> Prop).

  Infix "<<" := R (at level 70).

  Definition Ge_ex a w := exists x, In x w /\ x << a.
  Definition Ge_fa a w := forall x, In x w -> x << a.
  Definition Ge_ex_fa a lw := exists w, In w lw /\ Ge_fa a w.
  Definition Ge_fa_fa a lw := forall w, In w lw -> Ge_fa a w.

  Fixpoint Incr w :=
    match w with
      | nil   => True
      | a::w  => Ge_fa a w /\ Incr w
    end.

  Fact Incr_spec w : Incr w <-> forall l a r, w = l++a::r -> Ge_fa a r.
  Proof.
    split.

    induction w as [ | b w IH ]; intros H [ | x l ] a r E; try discriminate E; simpl in E;
    injection E; clear E; intros; subst; simpl in H; auto.
    apply H.
    destruct H as [ _ H ]; apply (IH H) with (1 := eq_refl).

    intros H.
    induction w as [ | x w IH ]; simpl in H |- *; auto; split.
    apply H with (l := nil); auto.
    apply IH.
    intros l a r ?; apply (H (x::l)); simpl; f_equal; auto.
  Qed.

  Fact Ge_ex_sg a b : Ge_ex a (b::nil) <-> b << a.
  Proof.
    split.
    intros (? & [ | [] ] & ?); subst; auto.
    exists b; split; auto; left; auto.
  Qed.

  Fact Ge_fa_sg a b : Ge_fa a (b::nil) <-> b << a.
  Proof.
    split.
    intros H; apply H; left; auto.
    intros ? ? [ ? | [] ]; subst; auto.
  Qed.

  Fact Ge_ex_fa_sg a w : Ge_ex_fa a (w::nil) <-> Ge_fa a w.
  Proof.
    split.
    intros (? & [ | [] ] & ?); subst; auto.
    exists w; split; auto; left; auto.
  Qed.

  Fact Ge_ex_fa_app a ll mm : Ge_ex_fa a (ll++mm) <-> (Ge_ex_fa a ll \/ Ge_ex_fa a mm).
  Proof.
    split.
    intros (x & H1 & H2).
    apply in_app_or in H1.
    destruct H1; [ left | right ]; exists x; auto.
    intros [ (x & ? & ?) | (x & ? & ?) ]; exists x; split; auto;
      apply in_or_app; [ left | right ]; auto.
  Qed.

  Inductive good : list A -> Prop :=
    | in_good_0 : forall ll a b, In b ll -> b << a -> good (a::ll)
    | in_good_1 : forall ll a, good ll -> good (a::ll).

  Inductive bad : list A -> Prop :=
    | in_bad_0 : bad nil
    | in_bad_1 : forall ll a, (forall b, In b ll -> ~ b << a) -> bad ll -> bad (a::ll).

  Fact good_mono a ll : good ll -> good (a::ll).
  Proof.
    constructor 2; auto.
  Qed.

  Fact good_nil_inv : ~ good nil.
  Proof. intros H; inversion H. Qed.

  Fact good_cons_inv a ll : good (a::ll) -> Ge_ex a ll \/ good ll.
  Proof.
    intros H; inversion_clear H.
    left; exists b; auto.
    right; auto.
  Qed.

  Fact good_sg_inv a : ~ good (a::nil).
  Proof.
    intros H; apply good_cons_inv in H.
    destruct H as [ (? & [] & _ ) | H ].
    revert H; apply good_nil_inv.
  Qed.

  Fact good_cons_not_inv a ll : good (a::ll) -> ~ good ll -> Ge_ex a ll.
  Proof.
    intros H ?; apply good_cons_inv in H; tauto.
  Qed.

  Fact good_two_inv a b : good (a::b::nil) -> b << a.
  Proof.
    intros H.
    apply good_cons_inv in H.
    destruct H as [ H | H ].
    apply Ge_ex_sg in H; auto.
    apply good_sg_inv in H; destruct H.
  Qed.

  Fact good_bad_False ll : good ll -> bad ll -> False.
  Proof.
    induction 1 as [ ll a b H1 H2 | ll a Hll IH ].
    inversion_clear 1.
    apply H0 with (1 := H1); auto.
    inversion_clear 1; auto.
  Qed.

  Fact not_good_eq_bad ll : ~ good ll <-> bad ll.
  Proof.
    split.

    induction ll; intros H.
    constructor.
    constructor.
    intros; contradict H.
    constructor 1 with (1 := H0); auto.
    apply IHll; contradict H.
    constructor 2; auto.

    intros ? ?; apply good_bad_False with ll; auto.
  Qed.

  Fact good_or_bad_implies_dec : (forall ll, { good ll } + { bad ll }) -> (forall x y, { x << y } + { ~ x << y }).
  Proof.
    intros H x y.
    destruct (H (y::x::nil)).
    left.
    inversion_clear g.
    destruct H0 as [ | [] ]; subst; tauto.
    inversion_clear H0.
    destruct H1.
    inversion_clear H1.
    right.
    inversion_clear b.
    apply H0; left; auto.
  Qed.

  Fact good_sublist ll mm : ll <sl mm -> good ll -> good mm.
  Proof.
    induction 1 as [ mm | a ll mm H IH | a ll mm H IH ].
    intros H; inversion H.
    intros H'; apply good_cons_inv in H'.
    destruct H' as [ (b & H1 & H2) | H' ].
    constructor 1 with b; auto.
    apply sl_In with (1 := H); auto.
    constructor 2; auto.
    constructor 2; auto.
  Qed.

  Fact good_app_left ll mm : good mm -> good (ll++mm).
  Proof.
    apply good_sublist, sl_app_left.
  Qed.

  Fact good_app_right ll mm : good ll -> good (ll++mm).
  Proof.
    apply good_sublist, sl_app_right.
  Qed.

  Fact good_pfx_rev f a b : a <= b -> good (pfx_rev f a) -> good (pfx_rev f b).
  Proof.
    intros H.
    rewrite (le_plus_minus _ _ H), plus_comm, pfx_rev_plus.
    apply good_app_left.
  Qed.

  Fact good_inv ll : good ll <-> exists l a m b r, ll = l++a::m++b::r /\ b << a.
  Proof.
    split.

    induction 1 as [ ll a b Hll H1 | ll x Hll IH ].
    apply in_split in Hll; destruct Hll as ( m & r & H2 ).
    exists nil, a, m, b, r; subst; auto.
    destruct IH as (l & a & m & b & r & H1 & H2).
    exists (x::l), a, m, b, r; subst; auto.

    intros (l & a & m & b & r & H1 & H2); subst.
    apply good_app_left.
    constructor 1 with b; auto.
    apply in_or_app; right; left; auto.
  Qed.

  Fact good_pfx_rev_eq n f : good (pfx_rev f n) <-> exists i j, i < j < n /\ R (f i) (f j).
  Proof.
    rewrite good_inv; split.

    intros (l & a & m & b & r & H1 & H2).
    exists (length r), (length (m++b::r)); split.
    apply f_equal with (f := @length _) in H1.
    rewrite pfx_rev_length in H1.
    rewrite H1.
    do 3 (rewrite app_length; simpl); split; omega.
    rewrite pfx_rev_eq with (1 := H1).
    cutrewrite (l++a::m++b::r = (l++a::m)++b::r) in H1.
    rewrite pfx_rev_eq with (1 := H1); auto.
    rewrite app_ass; simpl; auto.

    intros (i & j & (H1 & H2) & H3).
    exists (pfx_rev (fun x => f (S j + x)) (n - S j)),
           (f j),
           (pfx_rev (fun x => f (S i + x)) (j - S i)),
           (f i),
           (pfx_rev f i).
    split; auto.
    assert (n = (n - S i) + S i) as H; try omega.
    rewrite H at 1.
    rewrite pfx_rev_plus; simpl.
    assert (n - S i = (n - S j) + S (j - S i)) as H'; try omega.
    rewrite H' at 1.
    rewrite pfx_rev_plus; simpl.
    rewrite app_ass; simpl.
    f_equal.
    apply pfx_rev_ext; intros; f_equal; omega.
    f_equal.
    f_equal; omega.
  Qed.

  Fact good_pfx_eq n f : good (pfx f n) <-> exists i j, i < j < n /\ R (f j) (f i).
  Proof.
    rewrite <- (rev_involutive (pfx f n)).
    rewrite <- pfx_pfx_rev_eq.
    rewrite pfx_rev_minus.
    rewrite <- pfx_pfx_rev_eq.
    rewrite good_pfx_rev_eq.
    split; intros (i & j & H1 & H2).
    exists (n - S j), (n - S i); split; auto; omega.
    exists (n - S j), (n - S i); split.
    omega.
    replace_with H2; f_equal; omega.
  Qed.

  Fact exists_good_app ll mm : (exists a b, In a ll /\ In b mm /\ R b a) -> good (ll++mm).
  Proof.
    intros (a & b & H1 & H2 & H3).
    revert a H1 b H2 H3.
    induction ll as [ | x ll IHll ].
    intros ? [].
    intros a [ ? | Ha ] b Hb ?; subst; simpl.
    constructor 1 with b; auto; apply in_or_app; tauto.
    constructor 2; apply IHll with (1 := Ha) (2 := Hb); auto.
  Qed.

  Fact good_app_inv ll mm : good (ll++mm) -> good ll
                                          \/ good mm
                                          \/ exists a b, In a ll /\ In b mm /\ b << a.
  Proof.
    induction ll as [ | x ll IH ]; simpl.
    tauto.
    intros H.
    apply good_cons_inv in H.
    destruct H as [ (a & H1 & H2) | H ].
    apply in_app_or in H1; destruct H1 as [ H1 | H1 ].
    left; constructor 1 with a; auto.
    right; right; exists x, a; tauto.
    apply IH in H.
    destruct H as [ H | [ H | (a & b & H1 & H2 & H3) ] ].
    left; constructor 2; auto.
    tauto.
    right; right; exists a, b; tauto.
  Qed.

  Fact good_eq_exists ll : good ll <-> exists l a m b r, ll = l++a::m++b::r /\ b << a.
  Proof.
    apply good_inv.
  Qed.

  Fact sublist_good_eq ll : good ll <-> exists a b, R b a /\ a::b::nil <sl ll.
  Proof.
    split.

    induction 1 as [ l a b H1 H2 | l b H (u & v & H1 & H2)].
    exists a, b; split; auto; constructor 2; apply In_sl; auto.
    exists u, v; split; auto; constructor 3; auto.

    intros (a & b & H1 & H2).
    apply good_sublist with (1 := H2).
    constructor 1 with b; auto; left; auto.
  Qed.

  Section decision_procedures.

    Variable Rdec : forall x y, { x << y } + { ~ x << y }.

    Definition Ge_ex_dec a w : { Ge_ex a w } + { ~ Ge_ex a w }.
    Proof.
      destruct list_dec_rec with (P := fun x => x << a) (ll := w)
        as [ (x & H1 & H2) | H ]; simpl; auto.
      left; exists x; auto.
      right; intros (x & H1 & H2); apply H with (1 := H1); auto.
    Qed.

    Definition Ge_fa_dec a w : { Ge_fa a w } + { ~ Ge_fa a w }.
    Proof.
      destruct list_dec_rec with (P := fun x => ~ x << a) (ll := w)
        as [ (x & H1 & H2) | H ]; simpl; auto.
      intros x; destruct (Rdec x a); tauto.
      left; intros z Hz.
      destruct (Rdec z a) as [ | C ]; try tauto.
      apply H in C; tauto.
    Qed.

    Definition Ge_ex_fa_dec a lw : { Ge_ex_fa a lw } + { ~ Ge_ex_fa a lw }.
    Proof.
      destruct list_dec_rec with (P := fun w => Ge_fa a w) (ll := lw)
        as [ (w & H1 & H2) | H ]; auto.
      intros; apply Ge_fa_dec.
      left; exists w; auto.
      right; intros (x & H1 & H2).
      revert H2; apply H; auto.
    Qed.

    Fact Ge_ex_fa_app_dec a ll mm : Ge_ex_fa a (ll++mm) -> { Ge_ex_fa a ll } + { Ge_ex_fa a mm }.
    Proof.
      intros H.
      rewrite Ge_ex_fa_app in H.
      destruct (Ge_ex_fa_dec a ll);
      destruct (Ge_ex_fa_dec a mm); tauto.
    Qed.

    Definition good_bad_dec ll : { good ll } + { bad ll }.
    Proof.
      induction ll as [ | x ll [ IH | IH ] ].
      right; constructor 1.
      left; constructor 2; auto.
      destruct (list_dec_rec (fun y => y << x) ll) as [ (y & H1 & H2) | H ].
      intros; apply Rdec.
      left; constructor 1 with (1 := H1); auto.
      right; constructor; auto.
    Qed.

    Definition good_dec ll : { good ll } + { ~ good ll }.
    Proof.
      destruct (good_bad_dec ll); [ left | right ]; auto.
      rewrite not_good_eq_bad; auto.
    Qed.

  End decision_procedures.

  Fact sublist_good ll mm : ll <sl mm -> good ll -> good mm.
  Proof.
    induction 1 as [ mm | x ll mm H IH | x ll mm H IH ]; intros H1.
    apply good_nil_inv in H1; tauto.
    apply good_cons_inv in H1; destruct H1 as [ (y & H1 & H2) | H1 ].
    constructor 1 with y; auto.
    apply sl_In with (1 := H); auto.
    constructor 2; auto.
    constructor 2; auto.
  Qed.

  (* From Fridlender Thesis *)

  Definition ctxt ll a1 a2 := good ll \/ Ge_ex a1 ll \/ a1 << a2.

  Fact ctxt_nil a1 a2 : ctxt nil a1 a2 <-> a1 << a2.
  Proof.
    split.
    intros [ H | [ H | H ] ]; auto.
    apply good_nil_inv in H; tauto.
    destruct H as (? & [] & _).
    right; right; auto.
  Qed.

  Fact ctxt_cons a ll a1 a2 : ctxt (a::ll) a1 a2 <-> ctxt ll a1 a2 \/ ctxt ll a a1.
  Proof.
    split.

    intros [ H | [ H | H ] ]; auto.
    apply good_cons_inv in H.
    destruct H as [ H | H ].
    right; right; left; auto.
    right; left; auto.
    destruct H as (x & [ H | H ] & H1); subst.
    right; right; right; auto.
    left; right; left; exists x; auto.
    left; right; right; auto.

    intros [ H | H ]; revert H; intros  [ H | [ H | H ] ].

    left; constructor 2; auto.
    destruct H as ( x & H1 & H2 ).
    right; left; exists x; split; auto; right; auto.
    right; right; auto.

    left; constructor 2; auto.
    destruct H as ( x & H1 & H2 ).
    left; constructor 1 with x; auto.
    right; left; exists a; split; auto; left; auto.

  Qed.

  (* this looks very much like Coquand lift_rel *)

  Fact lift_rel_list_ctxt ll : R lrlift ll ~eq2 ctxt ll.
  Proof.
    induction ll as [ | a ll IH ]; simpl; split; intros u v;
    (rewrite ctxt_nil || rewrite ctxt_cons); auto; unfold lift_rel;
    intros [ | ]; [ left | right | left | right ]; apply IH; auto.
  Qed.

End Ge_Good.

Fact good_inc X (R S : X -> X -> Prop) : R inc2 S -> good R inc1 good S.
Proof.
  intros H ll.
  induction 1 as [ ll a b Hll Hab | ].
  constructor 1 with (1 := Hll); auto.
  constructor 2; auto.
Qed.

Section good_map.

  Variable (X Y : Type) (f : X -> Y) (R : X -> X -> Prop) (S : Y -> Y -> Prop)
           (HRS2 : forall x y, S (f x) (f y) -> R x y)
           (HRS1 : forall x y, R x y -> S (f x) (f y)).

  Fact good_map_inv ll : good S (map f ll) -> good R ll.
  Proof.
    set (ll' := map f ll).
    generalize (eq_refl ll').
    unfold ll' at 2.
    intros H1 H2.
    generalize ll' H2 ll H1.
    clear ll ll' H1 H2.
    induction 1 as [ ll' a b Hll Hab | ll' a H1 IH ]; intros [ | x ll ] Hll'; try discriminate Hll';
      simpl in Hll'; injection Hll'; clear Hll'; intros; subst.
    apply in_map_iff in Hll.
    destruct Hll as (y & H1 & H2); subst.
    constructor 1 with y; auto.
    specialize (IH _ eq_refl).
    constructor 2; auto.
  Qed.

  Fact good_map ll : good R ll -> good S (map f ll).
  Proof.
    induction 1 as [ ll a b Hll Hab | ll a H1 IH ]; simpl.
    constructor 1 with (f b); auto.
    apply in_map_iff; exists b; auto.
    constructor 2; auto.
  Qed.

End good_map.

Fact good_lift_rel X R ll a : good (R rlift a) ll -> @good X R (ll++a::nil).
Proof.
  induction 1 as [ ll u v H1 [ H2 | H2 ] | ll u H IH ]; simpl.
  apply in_good_0 with v; auto.
  apply in_or_app; left; auto.
  apply in_good_1.
  induction ll as [ | x ll IH]; simpl; destruct H1; subst.
  simpl; apply in_good_0 with a; auto.
  apply in_or_app; right; left; auto.
  apply in_good_1; auto.
  apply in_good_1; auto.
Qed.

Fact good_lift_rel_list X R mm ll : good (R lrlift mm) ll -> @good X R (ll++mm).
Proof.
  revert ll.
  induction mm as [ | a mm IH ]; simpl; intros ll.
  rewrite <- app_nil_end; auto.
  intros H.
  apply good_lift_rel, IH in H.
  revert H.
  rewrite app_ass; simpl; auto.
Qed.

Fact good_snoc X R ll a : @good X R (ll++a::nil) -> good (R rlift a) ll \/ exists x, R a x /\ In x ll.
Proof.
  intros H2.
  apply good_app_inv in H2.
  destruct H2 as [ H2 | [ H2 | H2 ] ].
  left; revert H2; apply good_inc; red; auto.
  apply good_sg_inv in H2; destruct H2.
  destruct H2 as (x & b & H2 & [ | [] ] & H3); subst b.
  right; exists x; auto.
Qed.

Fact Forall_map_proj1_sig X (P : X -> Prop) (ll : list (sig P)) : Forall P (map (@proj1_sig _ _) ll).
Proof.
  induction ll as [ | (x & Hx) ll IH ]; simpl; constructor; auto.
Qed.

Fact good_Restr X (R : X -> X -> Prop) P ll : good (R <# P #>) ll <-> good R (map (@proj1_sig _ _) ll) /\ Forall P (map (@proj1_sig _ _) ll).
Proof.
  split.

  induction 1 as [ ll (a & Ha) (b & Hb) H1 H2 | ll (a & Ha) H1 (H2 & H3) ]; split.

  simpl.
  constructor 1 with b.
  rewrite in_map_iff.
  exists (exist _ b Hb); auto.
  simpl in H2; auto.
  simpl; constructor; auto.
  apply Forall_map_proj1_sig.

  simpl; constructor 2; auto.
  simpl; constructor; auto.

  intros (H1 & H2).
  induction ll as [ | (a & Ha) ll IH ].
  apply good_nil_inv in H1; destruct H1.
  simpl in H1; apply good_cons_inv in H1.
  simpl in H2; apply Forall_cons_inv in H2.
  destruct H2 as [ H2 H3 ].
  destruct H1 as [ (b & Hb & H1) | H1 ].
  2: constructor 2; auto.
  rewrite in_map_iff in Hb.
  destruct Hb as ((b' & Hb) & H4 & H5); simpl in H4; subst b'.
  constructor 1 with (exist _ b Hb); auto.
Qed.

Section interleave.

  Variable X : Type.

  Inductive interleave : list X -> list X -> list X -> Prop :=
    | in_intl_0 : forall m, interleave nil m m
    | in_intl_1 : forall l, interleave l nil l
    | in_intl_2 : forall a l m k, interleave l m k -> interleave (a::l) m (a::k)
    | in_intl_3 : forall l b m k, interleave l m k -> interleave l (b::m) (b::k).

  Variable (R : X -> X -> Prop).

  Fact In_inlt_left x l m k : interleave l m k -> In x l -> In x k.
  Proof.
     induction 1 as [ m | l | a l m k H IH | l b m k H IH ]; auto.
     intros [].
     intros [ [] | ]; [ left | right ]; auto.
     right; auto.
  Qed.

  Fact In_inlt_right x l m k : interleave l m k -> In x m -> In x k.
  Proof.
     induction 1 as [ m | l | a l m k H IH | l b m k H IH ]; auto.
     intros [].
     right; auto.
     intros [ [] | ]; [ left | right ]; auto.
  Qed.

  Fact good_intl_left l m k : interleave l m k -> good R l -> good R k.
  Proof.
    induction 1 as [ m | l | a l m k H IH | l b m k H IH ]; auto.
    intros H; apply good_nil_inv in H; destruct H.
    intros H1; apply good_cons_inv in H1.
    destruct H1 as [ (x & H1 & H2) | H1 ].
    constructor 1 with x; auto.
    revert H1; apply In_inlt_left with (1 := H).
    constructor 2; auto.
    constructor 2; auto.
  Qed.

  Fact good_intl_right l m k : interleave l m k -> good R m -> good R k.
  Proof.
    induction 1 as [ m | l | a l m k H IH | l b m k H IH ]; auto.
    intros H; apply good_nil_inv in H; destruct H.
    constructor 2; auto.
    intros H1; apply good_cons_inv in H1.
    destruct H1 as [ (x & H1 & H2) | H1 ].
    constructor 1 with x; auto.
    revert H1; apply In_inlt_right with (1 := H).
    constructor 2; auto.
  Qed.

End interleave.


(* 1 *)

Inductive month : Set :=
    January   | Febuary | March    | April
  | May       | June    | July     | August
  | September | October | November | December.

Inductive season : Set :=
    Winter
  | Spring
  | Summer
  | Autumn.

Definition which_season : month -> season :=
  month_rec (fun month => season)
            Winter Winter Spring
            Spring Spring Summer
            Summer Summer Autumn
            Autumn Autumn Winter.

(* 3 *)

Theorem bool_equal :
  forall b : bool, b = true \/ b = false.
Proof.
  intro b;
    elim b;
    [apply or_introl | apply or_intror];
    apply refl_equal.
Qed.

Reset bool_equal.

Theorem bool_equal :
  forall b : bool, b = true \/ b = false.
Proof.
  intro b; pattern b; apply bool_ind; [left | right]; reflexivity.
Qed.

(* 4 *)

Reset which_season.

Definition which_season (m : month) : season :=
  match m with
     December | January | Febuary => Winter
   | March    | April   | May     => Spring
   | June     | July    | August  => Summer
   | _ => Autumn
  end.

(* 5 *)

Definition even_days (leap : bool) (m : month) : bool :=
  match m with
    April | June | September | November => true
  | Febuary => if leap then false else true
  | _ => false
  end.

(* 6 *)

Definition bool_eq (a b : bool) : bool :=
  match a,b with
    true,true | false,false => true
  | _,_ => false
  end.

Definition bool_not (a : bool) : bool := if a then false else true.

Definition bool_xor (a b : bool) : bool := bool_not (bool_eq a b).

Definition bool_and (a b : bool) : bool :=
  match a,b with
    true,true => true
  | _,_ => false
  end.

Definition bool_or (a b : bool) : bool :=
  match a,b with
    true,_ | _,true => true
  | _,_ => false
  end.

Theorem xor_not_eq : forall b1 b2 : bool,
    bool_xor b1 b2 = bool_not (bool_eq b1 b2).
Proof. trivial. Qed.

Theorem not_and_or_not_not : forall b1 b2 : bool,
    bool_not (bool_and b1 b2) =
    bool_or (bool_not b1) (bool_not b2).
Proof.
  intros b1 b2;
    induction b1; induction b2;
                  simpl; trivial.
Qed.

Theorem not_not_eq_b : forall b : bool,
    bool_not (bool_not b) = b.
Proof.
  intros b; unfold bool_not; induction b; trivial.
Qed.

Theorem bool_tex : forall b : bool,
                   (bool_or b (bool_not b)) = true.
Proof.
  intros b; induction b; simpl; trivial.
Qed.

Theorem bool_eq_reflect : forall b1 b2 : bool,
    (bool_eq b1 b2) = true -> b1 = b2.
Proof.
  intros b1 b2; induction b1; induction b2; simpl; trivial.
  intros H; rewrite H; elim H; trivial.
Qed.

Theorem bool_eq_reflect2 : forall b1 b2 : bool,
                           b1 = b2 -> (bool_eq b1 b2) = true.
Proof.
  intros b1 b2. induction b1; induction b2; simpl; trivial.
  intros H; rewrite H; elim H; trivial.
Qed.

Theorem bool_not_or : forall b1 b2 : bool,
    (bool_not (bool_or b1 b2)) =
    (bool_and (bool_not b1) (bool_not b2)).
Proof.
  intros b1 b2; induction b1; induction b2; simpl; trivial.
Qed.

Theorem bool_or_and_distr: forall b1 b2 b3 : bool,
        (bool_or (bool_and b1 b3) (bool_and b2 b3))
        = (bool_and (bool_or b1 b2) b3).
Proof.
  intros b1 b2 b3. induction b1; induction b2; induction b3; simpl; trivial.
Qed.

(* 8 *)

Require Import ZArith.

Open Scope Z_scope.

Record plane : Set := point {abscissa : Z; ordinate : Z}.

Definition manhattan (a b : plane) : Z :=
  (Z.abs (abscissa a - abscissa b)) + (Z.abs (ordinate a - ordinate b)).

(* 9 *)

Inductive vehicle : Set :=
  bicycle : nat -> vehicle | motorized : nat -> nat -> vehicle.

Definition nb_seats : vehicle -> nat :=
  vehicle_rec (fun _ => nat)
              (fun n => n)
              (fun n _ => n).

(* 10 *)

Definition next_month : month -> month :=
  month_rec (fun m => month)
            Febuary March April May
            June July August September
            October November December January.

Definition is_jan : month -> Prop :=
  month_rect (fun month => Prop)
             True False False False
             False False False False
             False False False False.

(* 11 *)

Definition bool_to_prop (b : bool) : Prop :=
  match b with
    true => True | _ => False
  end.

Theorem true_not_false : true <> false.
Proof.
  unfold not; intros H.
  change (bool_to_prop false).
  rewrite <- H.
  simpl.
  trivial.
Qed.

(* 12 *)

Definition vehicle_to_prop (v : vehicle) : Prop :=
  match v with
    bicycle _ => True
  |  _ => False
  end.

Theorem bi_not_motor : forall n m l: nat,
    bicycle n <> motorized m l.
Proof.
  intros n m l H.
  change (vehicle_to_prop (motorized m l)).
  rewrite <- H.
  simpl.
  trivial.
Qed.

(* 13 *)

Require Import Arith.

Open Scope nat_scope.

Record RatPlus : Set :=
  mkRat {top : nat; bottom:nat; bottom_condition: bottom <> 0}.

Axiom eq_ratplus :
  forall r r',
    top r * bottom r' = top r' * bottom r ->
    r = r'.

Definition r : RatPlus.
  apply (mkRat 2 4); auto with arith.
Defined.

Definition r' : RatPlus.
  apply (mkRat 3 6); auto with arith.
Defined.

Theorem r_r'_eq : r = r'.
Proof.
  apply eq_ratplus; auto.
Qed.

Theorem r_not_r' : r <> r'.
  unfold not. intros H. discriminate H.
Qed.

Theorem rat_contradiction : False.
  absurd (r = r').
  apply r_not_r'.
  apply r_r'_eq.
Qed.

Reset eq_RatPlus.

(* 15 *)

Definition true_under_three (n : nat) : bool :=
  match n with
    0 => true
  | 1 => true
  | 2 => true
  | _ => false
  end.

Eval compute in true_under_three 2.

(* 16 *)

Fixpoint rev_plus (n m : nat) {struct m} : nat :=
  match m with 0 => n | S p => S (rev_plus n p) end.

Eval compute in rev_plus 3 5.

(* 17 *)

Fixpoint sum_f (n : nat) (f : nat -> Z) : Z :=
  match n with
    0 => 0
  | S k => f k + sum_f k f
  end.

(* 18 *)

Fixpoint two_power (n : nat) : nat :=
  match n with
    0 => 1
  | S k => 2 * two_power k
  end.

(* 20 *)

Definition pos_even_bool (p : positive) : bool :=
  match p with xO _ => true | _ => false end.

(* 21 *)

Definition pos_div4 (p : positive) : Z :=
  match p with
    xO (xO n) | xO (xI n) => Zpos n
  | xI (xI n) | xI (xO n) => Zpos n
  | _ => 0
  end.

(* 22 *)

Variable pos_mult : positive -> positive -> positive.

Definition mul (n m : Z) : Z :=
  match n,m with
    Zpos x, Zpos y | Zneg x, Zneg y => Zpos (pos_mult x y)
  | Zpos x, Zneg y | Zneg x, Zpos y => Zneg (pos_mult x y)
  | _,_ => Z0
  end.

(* 23 *)

Inductive l : Set :=
    l_and : l -> l -> l
  | l_or : l -> l -> l
  | not_l : l -> l
  | l_imp : l -> l -> l
  | l_t : l
  | l_f : l.

Fixpoint l_eval (form : l) : l :=
  match form with
  | l_and la lb => match (l_eval la),(l_eval lb) with
                     l_t, l_t => l_t
                   | _,_ => l_f
                   end
  | l_or la lb => match (l_eval la),(l_eval lb) with
                    l_t,_ | _,l_t => l_t
                  | _,_ => l_f
                  end
  | not_l la => match l_eval la with
                  l_t => l_f
                | _ => l_t
                end
  | l_imp la lb => match (l_eval la),(l_eval lb) with
                     _,l_t | l_f, l_f => l_t
                   | _,_ => l_f
                   end
  | l_t => l_t
  | l_f => l_f
  end.

(* 24 *)

Inductive rat : Set :=
  one : rat | N : rat -> rat | D : rat -> rat.

(* 25 *)

Inductive Z_btree : Set :=
  Z_leaf : Z_btree | Z_node : Z -> Z_btree -> Z_btree -> Z_btree.

Fixpoint value_present (z : Z) (t : Z_btree) : bool :=
  match t with
    Z_leaf => false
  | Z_node x l r =>
    if Zeq_bool z x then true
    else match value_present z l with
           true => true
         | _ => value_present z r
         end
  end.

(* 26 *)

Fixpoint power (z : Z) (n : nat) : Z :=
  match n with
    0%nat => 1 | S p => z * (power z p)
  end.

Fixpoint discrete_log (p : positive) : nat :=
  match p with
    xH => 0%nat
  | xO n | xI n => S (discrete_log n)
  end.

(* 27 *)

Inductive Z_fbtree : Set :=
  Z_fleaf : Z_fbtree
| Z_fnode : Z -> (bool -> Z_fbtree) -> Z_fbtree.

Fixpoint fzero_present (t : Z_fbtree) : bool :=
  match t with
    Z_fleaf => false
  | Z_fnode z f =>
    if Zeq_bool z 0%Z then true
    else match fzero_present (f true) with
           true => true
         | _ => fzero_present (f false)
         end
  end.

(* 28 *)

Inductive Z_inf_tree : Set :=
  Z_inf_leaf : Z_inf_tree
| Z_inf_branch : Z -> (nat -> Z_inf_tree) -> Z_inf_tree.

Fixpoint sum_or (n : nat) (f : nat -> bool) : bool :=
  match n with
    0 => false
  | S k => if f (S k) then true else sum_or k f
  end.

Fixpoint zero_in_inf (n : nat) (t : Z_inf_tree) : bool :=
  match n,t with
  | S k, Z_inf_branch z f => if Zeq_bool z 0 then true else sum_or k (fun x : nat => zero_in_inf k (f x))
  | Z, Z_inf_branch z _ => Zeq_bool z 0
  | _, Z_inf_leaf => false
  end.

(* 29 *)

Ltac refl := reflexivity.

Theorem plus_n_0 : forall n : nat, n = n + 0.
Proof.
  intro n. elim n. refl.
  intros n' H. simpl. elim H. refl.
Qed.

(* 30 *)

Fixpoint zb_to_zfb  (t : Z_btree) : Z_fbtree :=
  match t with
    Z_leaf => Z_fleaf
  | Z_node x l r =>
      Z_fnode x (fun b : bool => if b
                                 then zb_to_zfb l
                                 else zb_to_zfb r)
  end.

Fixpoint zfb_to_zb  (t : Z_fbtree) : Z_btree :=
  match t with
    Z_fleaf => Z_leaf
  | Z_fnode x f => Z_node x
                          (zfb_to_zb (f true))
                          (zfb_to_zb (f false))
  end.

Theorem zb_to_zfb_and_back :
  forall t : Z_btree, zfb_to_zb (zb_to_zfb t) = t.
Proof.
  induction t.
  simpl; refl.
  simpl; rewrite IHt1; rewrite IHt2; refl.
Qed.

(*
Theorem zfb_to_zb_and_back :
  forall t : Z_fbtree, zb_to_zfb (zfb_to_zb t) = t.
*)

(* 31 *)

Fixpoint mult2 (n : nat) : nat :=
  match n with
    0 => 0
  | S k => S (S (mult2 k))
  end.

Theorem plus_n_eq_x_2 :
  forall n : nat, mult2 n = n + n.
Proof.
  induction n.
  trivial.
  simpl.
  rewrite IHn.
  rewrite plus_n_Sm.
  trivial.
Qed.

(* 32 *)

Fixpoint sum_n (n : nat) : nat :=
  match n with
    0 => 0
  | S p => S p + sum_n p
  end.

(* misprint?  *)

(* 33 *)

Require Import Arith.

Theorem n_lt_sum_n :
  forall n : nat, n <= sum_n n.
Proof.
  induction n.
  refl.
  simpl.
  rewrite le_n_S.
  2: apply IHn.
  rewrite plus_n_Sm.
  apply le_plus_r.
Qed.

(* 34 *)

Require Import List.

Definition fst_2 (A : Set) (l : list A) : list A :=
  match l with
    x :: y :: _ => x :: y :: nil
  | _ => nil
  end.

(* 35 *)

Fixpoint fst_n (A : Set) (n : nat) (l : list A) {struct n} : list A :=
  match n,l with
    S k, x :: xs => x :: fst_n _ k xs
  | _,_ => nil
  end.

(* 36 *)

Fixpoint sum_list (l : list Z) : Z :=
  match l with
    x :: xs => x + sum_list xs
  | _ => 0
  end.

(* 37 *)

Fixpoint n_ones (n : nat) : list Z :=
  match n with
    S k => 1%Z :: n_ones k
  | O => nil
  end.

(* 38 *)

Fixpoint one_to_n (n : nat) : list Z :=
  match n with
    O => nil
  | S k => one_to_n k ++ Z.of_nat (S k) :: nil
  end.

(* 39 *)

Fixpoint nth_option (A:Set)(n:nat)(l:list A) {struct l}
  : option A :=
  match n, l with
  | O, cons a tl =>  Some a
  | S p, cons a tl => nth_option _ p tl
  | n, nil => None
  end.

Fixpoint nth_option' (A : Set) (n : nat) (l : list A) {struct n}
  : option A :=
  match n,l with
    O, a :: t => Some a
  | S k, a :: t => nth_option _ k t
  | n, nil => None
  end.

Theorem nth_eq_prime :
  forall (A : Set) (n : nat) (l : list A),
    nth_option A n l = nth_option' A n l.
Proof.
  intros A n l. induction n; induction l; simpl; trivial.
Qed.

(* 40 *)

Theorem none_means_shorter :
  forall (A : Set) (n : nat) (l : list A),
    nth_option A n l = None -> length l <= n.
Proof.
  simple induction n.
  destruct l0. simpl. trivial.
  simpl. intros H. absurd (Some a = None). discriminate H.
  assumption.
  intros n0 H l H'.
  destruct l. simpl. auto with arith.
  simpl. auto with arith.
Qed.

(* 41 *)

Fixpoint la_to_fa (A : Set) (f : A -> bool) (l : list A) {struct l} : option A :=
  match l with
    x :: xs => if f x then Some x else la_to_fa _ f xs
  | _ => None
  end.

(* 42 *)

Fixpoint split_pairs (A B : Set) (l : list (A*B)) {struct l} : (list A) * (list B) :=
  match l with
    (a,b) :: ps => ((a :: fst (split_pairs _ _ ps)) , (b :: snd (split_pairs _ _ ps)))
  | _ => (nil,nil)
  end.

Fixpoint combine (A B : Set) (la : list A) (lb : list B) {struct la} : list (A*B) :=
  match la,lb with
    x::xs,y::ys => (x,y) :: combine _ _ xs ys
  | _,_ => nil
  end.

Theorem cmb_split_eq_og :
  forall (A B : Set) (l : list (A*B)), combine A B (fst (split_pairs A B l)) (snd (split_pairs A B l)) = l.
Proof.
  induction l0. simpl. trivial.
  case a. intros a0 b. simpl. rewrite IHl0. trivial.
Qed.

(* 43 *)

Inductive btree (A : Set) : Set :=
  leaf : btree A
| node : A -> btree A -> btree A -> btree A.

Fixpoint Z_to_btree (t : Z_btree) : btree Z :=
  match t with
    Z_leaf => leaf _
  | Z_node x l r => node _ x (Z_to_btree l) (Z_to_btree r)
  end.

Fixpoint btree_to_ztree (t : btree Z) : Z_btree :=
  match t with
    leaf _ => Z_leaf
  | node _ x l r => Z_node x (btree_to_ztree l) (btree_to_ztree r)
  end.

Theorem iso_btree_z_zbtree :
  forall t : Z_btree, btree_to_ztree (Z_to_btree t) = t.
Proof.
  intros t. induction t.
  simpl; trivial.

  simpl; rewrite IHt1; rewrite IHt2; trivial.
Qed.

(* 44 *)

(*
Inductive rat : Set :=
  one : rat | N : rat -> rat | D : rat -> rat.
 *)

Fixpoint frac (r : rat) : nat * nat :=
  match r with
    one => (1,1)
  | N r => let (n,d) := frac r in (n + d, d)
  | D r => let (n,d) := frac r in (d, n + d)
  end.

(* 45 / 46 skipping till later *)

Inductive htree (A : Set) : nat -> Set :=
  hleaf : A -> htree A 0
| hnode : forall n : nat, A -> htree A n -> htree A n -> htree A (S n).

(* 47 *)

Fixpoint n_to_tree (n : nat) : htree Z n :=
  match n with
    S k => hnode _ _ (Z.of_nat (S k)) (n_to_tree k) (n_to_tree k)
  | O => hleaf Z 0%Z
  end.

(* 48 *)

Inductive binary_word : nat -> Set :=
  empty_bin : binary_word 0
| cons_bin : forall m : nat, bool -> binary_word m -> binary_word (S m).

Fixpoint binary_word_concat (n m : nat) (w : binary_word n) (w' : binary_word m) {struct w}
  : binary_word (n + m) :=
  match w in binary_word p return binary_word (p + m) with
    empty_bin => w'
  | cons_bin q b w'' => cons_bin (q + m) b (binary_word_concat q m w'' w')
  end.

(* 49  and 50 skipping for now*)

(* 51 *)

Lemma l1 : forall x y : Empty_set, x = y.
Proof.
  intros x y.
  induction x.
Qed.

Lemma l2 : forall x y : Empty_set, ~ x=y.
Proof.
  intros x y.
  induction x.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \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)         *)
(************************************************************************)

Set Implicit Arguments.

(** Streams *)

Section Streams.

Variable A : Type.

CoInductive Stream : Type :=
    Cons : A -> Stream -> Stream.

Definition hd (x:Stream) := match x with
                            | Cons a _ => a
                            end.

Definition tl (x:Stream) := match x with
                            | Cons _ s => s
                            end.

Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream :=
  match n with
  | O => s
  | S m => Str_nth_tl m (tl s)
  end.

Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s).

Lemma unfold_Stream :
 forall x:Stream, x = match x with
                      | Cons a s => Cons a s
                      end.
Proof.
  intro x.
  case x.
  trivial.
Qed.

Lemma tl_nth_tl :
 forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s).
Proof.
  simple induction n; simpl; auto.
Qed.
Hint Resolve tl_nth_tl: datatypes.

Lemma Str_nth_tl_plus :
 forall (n m:nat) (s:Stream),
   Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s.
simple induction n; simpl; intros; auto with datatypes.
rewrite <- H.
rewrite tl_nth_tl; trivial with datatypes.
Qed.

Lemma Str_nth_plus :
 forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s.
intros; unfold Str_nth; rewrite Str_nth_tl_plus;
 trivial with datatypes.
Qed.

(** Extensional Equality between two streams  *)

CoInductive EqSt (s1 s2: Stream) : Prop :=
    eqst :
        hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2.

(** A coinduction principle *)

Ltac coinduction proof :=
  cofix proof; intros; constructor;
   [ clear proof | try (apply proof; clear proof) ].

(** Extensional equality is an equivalence relation *)

Theorem EqSt_reflex : forall s:Stream, EqSt s s.
coinduction EqSt_reflex.
reflexivity.
Qed.

Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1.
coinduction Eq_sym.
case H; intros; symmetry ; assumption.
case H; intros; assumption.
Qed.

Theorem trans_EqSt :
 forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3.
coinduction Eq_trans.
transitivity (hd s2).
case H; intros; assumption.
case H0; intros; assumption.
apply (Eq_trans (tl s1) (tl s2) (tl s3)).
case H; trivial with datatypes.
case H0; trivial with datatypes.
Qed.

(** The definition given is equivalent to require the elements at each
    position to be equal *)

Theorem eqst_ntheq :
 forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2.
unfold Str_nth; simple induction n.
intros s1 s2 H; case H; trivial with datatypes.
intros m hypind.
simpl.
intros s1 s2 H.
apply hypind.
case H; trivial with datatypes.
Qed.

Theorem ntheq_eqst :
 forall s1 s2:Stream,
   (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2.
coinduction Equiv2.
apply (H 0).
intros n; apply (H (S n)).
Qed.

Section Stream_Properties.

Variable P : Stream -> Prop.

(*i
Inductive Exists : Stream -> Prop :=
  | Here    : forall x:Stream, P x -> Exists x
  | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x.
i*)

Inductive Exists ( x: Stream ) : Prop :=
  | Here : P x -> Exists x
  | Further : Exists (tl x) -> Exists x.

CoInductive ForAll (x: Stream) : Prop :=
    HereAndFurther : P x -> ForAll (tl x) -> ForAll x.

Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x).
Proof.
induction m.
 tauto.
intros x [_ H].
simpl.
apply IHm.
assumption.
Qed.

Section Co_Induction_ForAll.
Variable Inv : Stream -> Prop.
Hypothesis InvThenP : forall x:Stream, Inv x -> P x.
Hypothesis InvIsStable : forall x:Stream, Inv x -> Inv (tl x).

Theorem ForAll_coind : forall x:Stream, Inv x -> ForAll x.
coinduction ForAll_coind; auto.
Qed.
End Co_Induction_ForAll.

End Stream_Properties.

End Streams.

Section Map.
Variables A B : Type.
Variable f : A -> B.
CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)).

Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s).
Proof.
induction n.
reflexivity.
simpl.
intros s.
apply IHn.
Qed.

Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s).
Proof.
intros n s.
unfold Str_nth.
rewrite Str_nth_tl_map.
reflexivity.
Qed.

Lemma ForAll_map : forall (P:Stream B -> Prop) (S:Stream A), ForAll (fun s => P
(map s)) S <-> ForAll P (map S).
Proof.
intros P S.
split; generalize S; clear S; cofix ForAll_map; intros S; constructor;
destruct H as [H0 H]; firstorder.
Qed.

Lemma Exists_map : forall (P:Stream B -> Prop) (S:Stream A), Exists (fun s => P
(map s)) S -> Exists P (map S).
Proof.
intros P S H.
(induction H;[left|right]); firstorder.
Defined.

End Map.

Section Constant_Stream.
Variable A : Type.
Variable a : A.
CoFixpoint const  : Stream A := Cons a const.
End Constant_Stream.

Section Zip.

Variable A B C : Type.
Variable f: A -> B -> C.

CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C :=
Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)).

Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B),
 Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b).
Proof.
induction n.
reflexivity.
intros [x xs] [y ys].
unfold Str_nth in *.
simpl in *.
apply IHn.
Qed.

Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a
 b)= f (Str_nth n a) (Str_nth n b).
Proof.
intros.
unfold Str_nth.
rewrite Str_nth_tl_zipWith.
reflexivity.
Qed.

End Zip.

Unset Implicit Arguments.


Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => true
  | true => (negb b2)
end.

Example test_nandb1: (nandb true false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nandb2: (nandb false false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nandb3: (nandb false true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nandb4: (nandb true true) = false.
Proof.
  simpl.
  reflexivity.
Qed.


(* begin hide *)
From mathcomp Require Import ssreflect ssrfun ssrbool.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import Coq.Logic.Description.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Unicode.Utf8.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* end hide *)
(** Quotients are crucial in mathematical practice, and it is a shame that they
are not available in Coq's standard library.  There was a recent discussion on
the #Coq GitHub page# on
this issue and the consequences of implementing quotients like #Lean# does, where the eliminator for
function types has a reduction rule that breaks pleasant metatheoretic
properties such as subject reduction.

In this post, we are going to define quotients in Coq with three standard
axioms:

- Functional extensionality

- Propositional extensionality

- Constructive definite description (also known as the axiom of unique choice) *)

Check @functional_extensionality_dep :
  ∀ A B (f g : ∀ x : A, B x),
    (∀ x : A, f x = g x) → f = g.

Check @propositional_extensionality :
  ∀ P Q, (P ↔ Q) → P = Q.

Check @constructive_definite_description :
  ∀ A P, (exists! x : A, P x) → {x : A | P x}.

(** As far as axioms go, these three are relatively harmless.  In particular,
they are valid in any #elementary
topos#, which are generally regarded as a good universe for doing
constructive, higher-order reasoning.  (Naturally, adding axioms in type theory
does not come for free: since they have no useful reduction behavior, our
quotients won't compute.) *)

Section Quotient.

(** We define the quotient of [T] by an equivalence relation [R] as usual: it is
the type of equivalence classes of [R]. *)

Context (T : Type) (R : relation T) (RP : Equivalence R).

(* begin hide *)
Unset Elimination Schemes.
(* end hide *)
Record quot := Quot_ {
  quot_class  : T → Prop;
  quot_classP : ∃ x, quot_class = R x;
}.
(* begin hide *)
Set Elimination Schemes.
(* end hide *)

(** The projection into the quotient is given by the [Quot] constructor below,
which maps [x] to its equivalence class [R x].  This definition satisfies the
usual properties: [Quot x = Quot y] if and only if [R x y].  The "if" direction
requires the principle of proof irrelevance, which is a consequence of
propositional extensionality. *)

Definition Quot (x : T) : quot :=
  @Quot_ (R x) (ex_intro _ x erefl).

Lemma Quot_inj x y : Quot x = Quot y → R x y.
Proof.
move=> e; rewrite -[R x y]/(quot_class (Quot x) y) e //=; reflexivity.
Qed.

Lemma eq_Quot x y : R x y → Quot x = Quot y.
Proof.
move=> e; rewrite /Quot; move: (ex_intro _ y _).
suff ->: R y = R x.
  move=> ?; congr Quot_; exact: proof_irrelevance.
apply: functional_extensionality=> z.
apply: propositional_extensionality.
by rewrite /= e.
Qed.

(** We can also show that [Quot] is surjective by extracting the witness in the
existential. *)
Lemma Quot_inv q : ∃ x, q = Quot x.
Proof.
case: q=> [P [x xP]]; exists x; move: (ex_intro _ _ _).
rewrite xP=> e; congr Quot_; exact: proof_irrelevance.
Qed.

(** Unique choice comes into play when defining the elimination principles for
the quotient.  In its usual non-dependent form, the principle says that we can
lift a function [f : T → S] to another function [quot → S] provided that [f] is
constant on equivalence classes.  We define a more general dependently typed
version, which allows in particular to prove a property [S q] by proving that [S
(Quot x)] holds for any [x].  The statement of the compatibility condition for
[f] is a bit complicated because it needs to equate terms of different types [S
(Quot x)] and [S (Quot y)], which requires us to transport the left-hand side
along the equivalence [R x y]. *)

Section Elim.

Definition cast A B (e : A = B) : A → B :=
  match e with erefl => id end.

Context (S : quot → Type) (f : ∀ x, S (Quot x)).
Context (fP : ∀ x y (exy : R x y), cast (congr1 S (eq_Quot exy)) (f x) = f y).

(** We begin with an auxiliary result that uniquely characterizes the result of
applying the eliminator to an element [q : quot].  Thanks to unique choice, this
allows us to define the eliminator as a function [quot_rect]. *)

Lemma quot_rect_subproof (q : quot) :
  exists! a : S q, ∃ x (exq : Quot x = q), a = cast (congr1 S exq) (f x).
Proof.
case: (Quot_inv q)=> x -> {q}.
exists (f x); split=> [|a]; first by exists x, erefl.
case=> y [eyx -> {a}].
by rewrite (proof_irrelevance _ eyx (eq_Quot (Quot_inj eyx))) fP.
Qed.

Definition quot_rect q : S q :=
  sval (constructive_definite_description _ (quot_rect_subproof q)).

Lemma quot_rectE x : quot_rect (Quot x) = f x.
Proof.
rewrite /quot_rect.
case: constructive_definite_description=> _ [y [eyx /= ->]].
by rewrite (proof_irrelevance _ eyx (eq_Quot (Quot_inj eyx))) fP.
Qed.

End Elim.

(** In the non-dependent case, the compatibility condition acquires its usual
form. *)

Section Rec.

Context S (f : T → S) (fP : ∀ x y, R x y → f x = f y).

Definition congr1CE (A B : Type) (b : B) x y (e : x = y) :
  congr1 (λ _ : A, b) e = erefl :=
  match e with erefl => erefl end.

Definition quot_rec : quot -> S :=
  @quot_rect (λ _, S) f
    (λ x y exy, etrans
      (congr1 (λ p, cast p (f x)) (congr1CE S (eq_Quot exy)))
      (fP exy)).

Lemma quot_recE x : quot_rec (Quot x) = f x.
Proof. by rewrite /quot_rec quot_rectE. Qed.

End Rec.

End Quotient.


(*
  Smolka-Brown Chapter 9

Spyridon Antonatos
*)

Require Import List.
Require Import Basics.

Definition var := nat.

Inductive ter : Type :=
  | V : var -> ter
  | T : ter -> ter -> ter.

(* An equation is a tuple of two terms (term, term) *)
Definition eqn := prod ter ter.

(* Implicit types for ease of use*)
Implicit Types x y z : var.
Implicit Types s t u v : ter.
Implicit Type e : eqn.
Implicit Types A B C : list eqn.
Implicit Types sigma tau : ter -> ter.
Implicit Types m n k : nat.

(* Substitution method *)
Definition subst sigma : Prop :=
  forall s t, sigma (T s t) = T (sigma s) (sigma t).

Definition unif sigma A : Prop :=
  subst sigma /\ forall s t, In (s,t) A -> sigma s = sigma t.

Definition unifiable A : Prop :=
  exists sigma, unif sigma A.

Definition principal_unifier sigma A : Prop :=
  unif sigma A /\ forall tau, unif tau A -> forall s, tau (sigma s) = tau s.

(* Exercise 9.1.1 *)
Lemma subst_term_var_agreement :
  forall sigma tau, (subst sigma) -> (subst tau) ->
    (forall x, sigma (V x) = tau (V x)) ->
        forall s, (sigma s) = (tau s).
Proof.
  intros sigma tau sub1 sub2 var_agree s. induction s.
  - apply var_agree.
  - unfold subst in sub1. unfold subst in sub2. rewrite sub1.
  rewrite sub2. rewrite IHs1. rewrite IHs2. reflexivity.
Qed.

(* Exercise 9.1.2 *)
Lemma principle_unif_idempotent :
forall sigma A, principal_unifier sigma A -> (forall t, (sigma (sigma t)) = (sigma t)).
Proof.
intros. unfold principal_unifier in H. destruct H. apply H0. apply H.
Qed.

(* Exercise 9.1.3 *)
Lemma unif_fact_a :
forall A t s sigma, unif sigma ((s, t) :: A) <-> (sigma s) = (sigma t) /\ unif sigma A.
Proof.
intros. split.
- intros. split.
{ unfold unif in H. destruct H. apply H0. simpl. left. reflexivity. }
{ unfold unif in *. destruct H. split.
 { apply H. }
 { intros. apply H0. simpl. right. apply H1. }
}
- intros. destruct H. unfold unif in *. destruct H0. split.
{ apply H0. }
{ intros. unfold In in H2. destruct H2.
  { inversion H2. rewrite H4 in H. rewrite H5 in H. apply H. }
  { apply H1 in H2. apply H2. }}
Qed.

Lemma unif_fact_b :
forall A B sigma, unif sigma (A ++ B) <-> (unif sigma A) /\ (unif sigma B).
Proof.
intros. split.
- intros. split.
+ induction B.
* rewrite app_nil_r in H. apply H.
* apply IHB. unfold unif in H. destruct H. unfold unif. split. apply H. intros. apply H0. apply in_app_or in H1. apply in_app_iff with (l':= a :: B).
destruct H1.
{ left. apply H1. }
{ right. apply in_cons. apply H1. }
+ induction A.
* simpl in H. apply H.
* apply IHA. unfold unif in H. destruct H. unfold unif. split. apply H. intros. apply H0. apply in_app_or in H1. apply in_app_iff with (l := a :: A).
destruct H1.
{ left. apply in_cons. apply H1. }
{ right. apply H1. }

- intros. unfold unif in *. destruct H. destruct H. destruct H0. split. apply H. intros.
apply in_app_or in H3. destruct H3.
{ apply H1. apply H3. }
{ apply H2. apply H3. }
Qed.

Lemma sub_list_unif :
forall A B C, unifiable (A ++ B ++ C) -> unifiable B.
Admitted.

(* Proof.
intros.
inversion H.
inversion H0.
unfold In in H2.
inversion H2.
Abort. *)

Lemma sub_list_not_unif_sublist :
forall A B,
(incl A B) ->  unifiable B ->  unifiable A.
Proof.
intros.
unfold incl in H.
unfold unifiable in *.
unfold unif in *.
destruct H0.
destruct H0.
exists x.
split.
- apply H0.
- intros. apply H in H2. apply H1 in H2. apply H2.
Qed.

(* 9.1.2 *)
Fixpoint V_t (x : ter) : list ter :=
   match x with
   | V v1 => (cons x nil)
   | T t1 t2 => (V_t t1) ++ (V_t t2)
  end.

Fixpoint V_l (l : list eqn) : list ter :=
   match l with
   | nil => nil
   | ((s , t) :: l') => (V_t s) ++ (V_t t) ++ (V_l l')
  end.

Fixpoint Domain (A : list eqn) : list ter :=
  match A with
  | nil => nil
  | ((t1 , t2) :: A') =>
    match t1 with
    | V v1 => t1 :: (Domain A')
    | T ta tb => nil
    end
  end.

Inductive disjoint {T} : list T -> list T -> Prop :=
  | disjoint_nil : disjoint nil nil
  | disjoint_cons_l : forall l1 l2 q, ~ In q l2 ->
                        disjoint l1 l2 -> disjoint (q :: l1) l2
  | disjoint_cons_r : forall l1 l2 q, ~ In q l1 ->
                        disjoint l1 l2 -> disjoint l1 (q :: l2).

Inductive solved : list eqn -> Prop :=
  | solved_n : solved nil
  | solved_f : forall x s A, ((~ (In (V x)(V_t s))) /\ (~ (In (V x) (Domain A)))
                                              /\ (disjoint (V_t s) (Domain A))
                                              /\ (solved A) )-> solved ((V x , s) :: A).

(* Definition disjoint {X} (A B : list X) : Prop :=
  ~ (exists x:X, In x A /\ In x B ).
*)

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Definition eq_var (x1 : var) (x2 : var) : bool :=
  beq_nat x1 x2.

Fixpoint var_repl_t (s : ter) (x : var) (t : ter) : ter :=
  match s with
  | V v1 =>
    if eq_var v1 x then t else s
  | T ta tb => T (var_repl_t ta x t) (var_repl_t tb x t)
  end.

Fixpoint var_repl_l (A : list eqn) (x : var) (t : ter) : list eqn :=
  match A with
  | nil => nil
  | ((t1 , t2) :: A') => ( var_repl_t t1 x t, var_repl_t t2 x t) :: (var_repl_l A' x t)
  end.

Fixpoint fi (A : list eqn) (s : ter) : ter :=
  match A with
  | nil => s
  | ((t1 , t2) :: A') =>
    match t1 with
    | V v1 => (var_repl_t (fi A' s) v1 t2)
    | T _ _ => s
    end
  end.

(* Lemma A_solv_pric_unif :
forall A s, solved A -> principle_unifier (fi A s) A
*)

Fixpoint beq_terms (t1 : ter) (t2 : ter) : bool :=
  match t1 with
  | V v1 =>
    match t2 with
    | V v2 => eq_var v1 v2
    | T _ _ => false
    end
  | T t1a t2a =>
    match t2 with
    | V v2 => false
    | T t1b t2b => (beq_terms t1a t1b) &&
                   (beq_terms t2a t2b)
    end
  end.

Definition bad_eqn e : Prop :=
  match e with
  | (t1 , t2)=>
    match t1 with
    | V v1 => (beq_terms t1 t2) = false /\ (In t1 (V_t t2))
    | T _ _ => False
    end
  end.

Lemma De_morgan_1 : forall p1 p2 : Prop,
    ~ (p1 \/ p2 ) -> ~p1 /\ ~p2.
Proof.
unfold not.
intros p1 p2 H.
split.
- intros p1a. apply H. left. apply p1a.
- intros p2a. apply H. right. apply p2a.
Qed.

Lemma exercise_923_a :
forall x s t, ~ (In (V x) (V_t s)) -> var_repl_t s x t = s.
Proof.

intros.
induction s.
- simpl in H. apply De_morgan_1 in H. simpl in H. inversion H.
unfold var_repl_t. destruct H0. inversion H.  destruct (eq_var v x) .
Abort.

Lemma exercise_923_b :
forall x A t, ~ (In (V x) (V_l A)) -> var_repl_l A x t = A.
Proof.
Abort.

Lemma exercise_923_c :
forall x A t, ~ (In (V x) (Domain A)) -> Domain (var_repl_l A x t) = Domain A.
Proof.
Abort.


From mathcomp Require Import ssreflect.

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

Require Import logic_theories.
Require Import logic_pred_theories.
Require Import class_set.
Require Import class_set_theories.

Section Direct_Product_Theories.

  Variable U:Type.

  Theorem ordered_pair_in_direct_product_iff_and:
    forall (A B:Ensemble U) (a b:U), (|a,b|) ∈ A × B <-> a ∈ A /\ b ∈ B.
  Proof.
    move => A B a b.
    rewrite /iff.
    split.
    move => H.
    inversion H.
    inversion H0.
    inversion H2 as [y].
    inversion H3.
    inversion H5.
    fold (OrderedPair x y) in H7.
    move: H7.
    rewrite (ordered_pair_iff a b x y).
    case => H7 H8.
    rewrite H7.
    rewrite H8.
    split.
    apply H4.
    apply H6.
    case => [H0 H1].
    split.
    exists a.
    exists b.
    split.
    apply H0.
    split.
    apply H1.
    fold (OrderedPair a b).
    reflexivity.
  Qed.

  Theorem direct_product_empty_r: forall (X:Ensemble U), X × {||} = {||}.
  Proof.
    move => X.
    apply /Extensionality_Ensembles.
    split => Y.
    -case.
     move => Z.
     case => [x [y [H1 [H2 H3]]]].
     rewrite H3.
     apply NNPP.
     rewrite /not => H4.
     move: H2.
     apply Noone_in_empty.
    -move => H0.
     apply NNPP.
     rewrite /not => H1.
     move: H0.
     apply Noone_in_empty.
  Qed.

  Theorem direct_product_empty_l: forall (X:Ensemble U), {||} × X = {||}.
  Proof.
    move => X.
    apply /Extensionality_Ensembles.
    split => Y.
    move => H0.
    apply NNPP.
    rewrite /not => H1.
    move: H0.
    case => Z.
    case => [x [y]].
    case => [H2 [H3 H4]].
    move : H2.
    apply Noone_in_empty.
    move => H0.
    apply NNPP.
    rewrite /not => H1.
    move: H0.
    apply Noone_in_empty.
  Qed.

  Theorem direct_product_empty_comm: forall (X:Ensemble U), {||} × X =  X × {||}.
  Proof.
    move => X.
    rewrite direct_product_empty_r.
    rewrite direct_product_empty_l.
    reflexivity.
  Qed.

  Theorem direct_product_empty_iff:
    forall (X Y:Ensemble U), X × Y = {||} <-> X = {||} \/ Y = {||}.
  Proof.
    move => X Y.
    rewrite /iff.
    split.
    +apply contrapositive.
     apply classic.
     move => H.
     ++suff: ~(forall (x y:U), ~((|x,y|) ∈ X × Y)).
       move => H0 H1.
       apply H0.
       rewrite H1.
       move => x y.
       apply Noone_in_empty.
     ++suff: exists x y:U, (|x,y|) ∈ X × Y.
       case => [x [y]].
       move => H0.
       unfold not.
       move => H1.
       move: H0.
       apply H1.
     ++suff: exists x y:U, x ∈ X /\ y ∈ Y.
       case => [x [y [HX HY]]].
       exists x.
       exists y.
       rewrite ordered_pair_in_direct_product_iff_and.
       split.
       apply HX.
       apply HY.
     ++suff: (exists x:U, x ∈ X) /\ (exists y:U, y ∈ Y).
       case.
       case => [x HX [y HY]].
       exists x.
       exists y.
       split.
       apply HX.
       apply HY.
     ++split; apply not_all_not_ex; unfold not; rewrite -Axiom_of_EmptySet; move => H1; apply H.
       left.
       apply H1.
       right.
       apply H1.
    +case => H; rewrite H.
     rewrite direct_product_empty_l.
     reflexivity.
     rewrite direct_product_empty_r.
     reflexivity.
  Qed.

  Theorem direct_product_included_iff:
    forall (X Y W Z:Ensemble U), W × Z ⊂ X × Y <-> W × Z = {||} \/ (W ⊂ X /\ Z ⊂ Y).
  Proof.
    +move => X Y W Z.
     rewrite /iff.
     split.
     move => H.
     (* W × Z ⊂ X × Y -> forall (t s:U), (|t,s|) ∈ W × Z -> (|t,s|) ∈ X × Y *)
     ++have L0: forall (t s:U), (|t,s|) ∈ W × Z -> (|t,s|) ∈ X × Y.
       move => t s.
       unfold Included in H.
       apply H.
     (* (forall (t s:U), (|t,s|) ∈ W × Z -> (|t,s|) ∈ X × Y) -> (forall (t s:U), ((t ∈ W /\ s ∈ Z) -> (t ∈ X /\ s ∈ Y))) *)
     ++have L1: forall (t s:U), ((t ∈ W /\ s ∈ Z) -> (t ∈ X /\ s ∈ Y)).
       move => t s.
       rewrite -!ordered_pair_in_direct_product_iff_and.
       apply L0.
     (* (forall (t s:U), ((t ∈ W /\ s ∈ Z) -> (t ∈ X /\ s ∈ Y))) -> (forall (t s:U), ((t ∈ W /\ s ∈ Z) -> t ∈ X) /\ ((t ∈ W /\ s ∈ Z) -> s ∈ Y)) *)
     ++have L2: forall (t s:U), ((t ∈ W /\ s ∈ Z) -> t ∈ X) /\ ((t ∈ W /\ s ∈ Z) -> s ∈ Y).
       move => t s.
       split; apply L1.
     (*  forall (t s:U), ((t ∈ W /\ s ∈ Z) -> t ∈ X) /\ ((t ∈ W /\ s ∈ Z) -> s ∈ Y) -> forall (t s:U), ((t ∈ W -> False) \/ (s ∈ Z -> False) \/ t ∈ X) /\ ((t ∈ W -> False) \/ (s ∈ Z -> False) \/ s ∈ Y) *)
     ++have L3: forall (t s:U), ((t ∈ W -> False) \/ (s ∈ Z -> False) \/ t ∈ X) /\ ((t ∈ W -> False) \/ (s ∈ Z -> False) \/ s ∈ Y).
       move => t0 s0.
       +++have L31: ((t0 ∈ W /\ s0 ∈ Z) -> False) <-> (t0 ∈ W -> False) \/ (s0 ∈ Z -> False).
          rewrite /iff.
          split; move => HF.
          apply not_and_or.
          unfold not.
          apply HF.
          apply or_not_and.
          unfold not.
          apply HF.
       +++have L32: forall (P:Prop), (((t0 ∈ W -> False) \/ (s0 ∈ Z -> False)) \/ P) <-> ((t0 ∈ W -> False) \/ (s0 ∈ Z -> False) \/ P).
          move => P.
          rewrite /iff.
          split.
          case.
          move => HL1.
          inversion HL1.
          left.
          apply H0.
          right.
          left.
          apply H0.
          move => HL1.
          right.
          right.
          apply HL1.
          move => HL1.
          inversion HL1.
          left.
          left.
          apply H0.
          inversion H0.
          left.
          right.
          apply H1.
          right.
          apply H1.
     ++rewrite -!L32.
       rewrite -L31.
       rewrite !or_not_l_iff_2.
       apply L2.
       apply classic.
       apply classic.
     (* forall (t s:U), ((t ∈ W -> False) \/ (s ∈ Z -> False) \/ t ∈ X) /\ ((t ∈ W -> False) \/ (s ∈ Z -> False) \/ s ∈ Y) ->
        forall (t s:U), ((t ∈ W -> t ∈ X) \/ (s ∈ Z -> False)) /\ ((s ∈ Z -> s ∈ Y) \/ (t ∈ W -> False)) *)
     ++have L4: forall (t s:U), ((t ∈ W -> t ∈ X) \/ (s ∈ Z -> False)) /\ ((s ∈ Z -> s ∈ Y) \/ (t ∈ W -> False)).
       move => t s.
       rewrite -(or_not_l_iff_1 (t ∈ W) (t ∈ X)).
       rewrite or_assoc.
       rewrite (or_comm (t ∈ X) (s ∈ Z -> False)).
       rewrite -(or_not_l_iff_1 (s ∈ Z) (s ∈ Y)).
       rewrite or_assoc.
       rewrite (or_comm (s ∈ Y) (t ∈ W -> False)).
       rewrite -(or_assoc (s ∈ Z -> False) (t ∈ W -> False) (s ∈ Y)).
       rewrite (or_comm (s ∈ Z -> False) (t ∈ W -> False)).
       rewrite or_assoc.
       apply L3.
       apply classic.
       apply classic.
    (* (forall (t s:U), ((t ∈ W -> t ∈ X) \/ (s ∈ Z -> False)) /\ ((s ∈ Z -> s ∈ Y) \/ (t ∈ W -> False))) ->
       forall (t s:U), ((t ∈ W -> t ∈ X) \/ (s ∈ Z -> False))) /\ (forall (t s:U),((s ∈ Z -> s ∈ Y) \/ (t ∈ W -> False)) *)
    +have L5: (forall (t s:U), ((t ∈ W -> t ∈ X) \/ (s ∈ Z -> False))) /\ (forall (t s:U),((s ∈ Z -> s ∈ Y) \/ (t ∈ W -> False))).
     split; apply L4.
    (*
       (forall (t s:U), ((t ∈ W -> t ∈ X) \/ (s ∈ Z -> False))) /\ (forall (t s:U),((s ∈ Z -> s ∈ Y) \/ (t ∈ W -> False))))
       ->
       ((forall (t:U), (t ∈ W -> t ∈ X)) \/ forall (s:U), (s ∈ Z -> False)) /\ ((forall (s:U), (s ∈ Z -> s ∈ Y)) \/ (forall (t:U), (t ∈ W -> False)))
     *)
    +have L6: ((forall (t:U), (t ∈ W -> t ∈ X)) \/ (forall (s:U), (s ∈ Z -> False))) /\
              ((forall (s:U), (s ∈ Z -> s ∈ Y)) \/ (forall (t:U), (t ∈ W -> False))).
     move: L5.
     case.
     move => L61 L62.
     split; apply forall_bound_or_dist_2.
     apply L61.
     move => t s.
     apply L62.
    +fold (Included U W X) in L6.
     fold (Included U Z Y) in L6.
     move : L6.
     rewrite -(Axiom_of_EmptySet Z).
     rewrite -(Axiom_of_EmptySet W).
     move => L6.
     rewrite direct_product_empty_iff.
     apply or_dist_and.
     ++suff: (Z={||} \/ W ⊂ X) /\ (W={||} \/ Z ⊂ Y).
       case.
       move => H0 H1.
       split.
       inversion H0.
       left.
       right.
       apply H2.
       right.
       apply H2.
       inversion H1.
       left.
       left.
       apply H2.
       right.
       apply H2.
     rewrite (or_comm (Z={||}) (W ⊂ X)).
     rewrite (or_comm (W={||}) (Z ⊂ Y)).
     apply L6.
    +case.
     move => H.
     rewrite H.
     apply Included_Empty.
     case => H0 H1.
     unfold Included.
     move => S.
     case => [T [x [y [HxW [HyZ HT]]]]].
     rewrite HT.
     apply ordered_pair_in_direct_product_iff_and.
     split.
     move: HxW.
     apply H0.
     move: HyZ.
     apply H1.
  Qed.

  Theorem direct_product_eq_to_or:
    forall (A B C D:Ensemble U), A × B = C × D -> A × B = {||} \/ C × D = {||} \/ (A = C /\ B = D).
  Proof.
    +move => A B C D H.
     ++have L0: (A × B ⊂ C × D) /\ (C × D ⊂ A × B).
       apply Extension.
       apply H.
    +inversion L0 as [LH0 LH1].
     apply imp_not_l.
     apply classic.
     move => H0.
     apply imp_not_l.
     apply classic.
     move => H1.
     ++suff: (A ⊂ C /\ B ⊂ D) /\ (C ⊂ A /\ D ⊂ B).
       case => [[H2 H3] [H4 H5]].
       split.
       apply /Extensionality_Ensembles.
       unfold Same_set.
       split.
       apply H2.
       apply H4.
       apply /Extensionality_Ensembles.
       unfold Same_set.
       split.
       apply H3.
       apply H5.
    +split.
     move: H0.
     apply imp_not_l.
     apply classic.
     apply direct_product_included_iff.
     apply LH0.
     move: H1.
     apply imp_not_l.
     apply classic.
     apply direct_product_included_iff.
     apply LH1.
  Qed.

  Theorem direct_product_or_eq:
    forall (A B C D:Ensemble U), (A × B = {||} /\ C × D = {||}) \/ (A = C /\ B = D) -> A × B = C × D.
  Proof.
    move => A B C D.
    case => H; inversion H; rewrite H0; rewrite H1; reflexivity.
  Qed.

  Theorem direct_product_included_right:
    forall (X Y Z:Ensemble U), ~(X={||}) /\ X × Z ⊂ X × Y -> Z ⊂ Y.
  Proof.
    move => X Y Z.
    case => HFX.
    rewrite direct_product_included_iff.
    rewrite direct_product_empty_iff.
    case.
    case.
    apply contrapositive.
    apply classic.
    move => H.
    apply HFX.
    move => H.
    rewrite H.
    apply Included_Empty.
    case => H.
    apply.
  Qed.

  Theorem direct_product_included_partial:
    forall (X Y Z:Ensemble U), Z ⊂ Y -> X × Z ⊂ X × Y.
  Proof.
    move => X Y Z H.
    apply direct_product_included_iff.
    right.
    split => x.
    apply.
    apply H.
  Qed.

  Theorem direct_product_union_dist_r:
    forall (X Y Z:Ensemble U), X × (Y ∪ Z) = X × Y ∪ X × Z.
  Proof.
    move => X Y Z.
    apply /Extensionality_Ensembles.
    +split => S.
     case => T.
     case => [x [y [H1 [H2 H3]]]].
     inversion H2.
     ++left.
       rewrite H3.
       apply ordered_pair_in_direct_product_iff_and.
       split.
       apply H1.
       apply H.
     ++right.
       rewrite H3.
       apply ordered_pair_in_direct_product_iff_and.
       split.
       apply H1.
       apply H.
    +case; move => T; case => V; case => [x [y [H1 [H2 H3]]]]; rewrite H3; apply ordered_pair_in_direct_product_iff_and; split.
     apply H1.
     left.
     apply H2.
    +apply H1.
     right.
     apply H2.
  Qed.

  Theorem direct_product_intersection_dist_r:
    forall (X Y Z:Ensemble U), X × (Y ∩ Z) = X × Y ∩ X × Z.
  Proof.
    move => X Y Z.
    apply /Extensionality_Ensembles.
    split => S.
    +case => T.
     case => [x [y [H1 [H2 H3]]]].
     inversion H2 as [y0 H4 H5 H6].
     split; split; exists x; exists y.
     split.
     apply H1.
     split.
     apply H4.
     apply H3.
     split.
     apply H1.
     split.
     apply H5.
     apply H3.
    +case => T.
     case => V.
     case => [x [y [H1 [H2 H3]]]].
     rewrite H3.
     rewrite ordered_pair_in_direct_product_iff_and.
     case => [H4 H5].
     rewrite ordered_pair_in_direct_product_iff_and.
     split.
     apply H1.
     split.
     apply H2.
     apply H5.
  Qed.

  Goal forall (y:U) (X Y:Ensemble U), y ∈ Y -> Pr1 (X × Y) = X.
  Proof.
    move => y X Y HY.
    apply /Extensionality_Ensembles.
    split => x H.
    inversion H.
    inversion H0 as [y0].
    apply ordered_pair_in_direct_product_iff_and in H2.
    inversion H2.
    apply H3.
    split.
    exists y.
    apply ordered_pair_in_direct_product_iff_and.
    split.
    apply H.
    apply HY.
  Qed.

  Goal forall (x:U) (X Y:Ensemble U), x ∈ X -> Pr2 (X × Y) = Y.
  Proof.
    move => x X Y HX.
    apply /Extensionality_Ensembles.
    split => y H.
    inversion H.
    inversion H0 as [x0].
    apply ordered_pair_in_direct_product_iff_and in H2.
    inversion H2.
    apply H4.
    split.
    exists x.
    apply ordered_pair_in_direct_product_iff_and.
    split.
    apply HX.
    apply H.
  Qed.

  Lemma ordered_pair_swap:
    forall (x y z w:U), (|x,y|) = (|z,w|) <-> (|y,x|) = (|w,z|).
  Proof.
    move => x y z w.
    rewrite /iff.
    split => H; apply ordered_pair_iff in H; inversion H; rewrite H0;  rewrite H1; reflexivity.
  Qed.

End Direct_Product_Theories.

Export class_set_theories.


Add LoadPath "." as OPAT.
Require Export OPAT.aula3 OPAT.aula4 OPAT.aula5 OPAT.aula6.

Inductive natlist : Type :=
  | nil  : natlist
  | cons : nat -> natlist -> natlist.

(** For example, here is a three-element list: *)

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => l2
  | h :: t => h :: (app t l2)
  end.

(** Actually, [app] will be used a lot in some parts of what
    follows, so it is convenient to have an infix operator for it. *)

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1:             [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4;5] = [4;5].
Proof. reflexivity.  Qed.
Example test_app3:             [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity.  Qed.

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd1:             hd 0 [1;2;3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tl:              tl [1;2;3] = [2;3].
Proof. reflexivity.  Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job
               prosa.classic.model.arrival.basic.task_arrival
               prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.uni.service
               prosa.classic.model.schedule.uni.schedule.
Require Import prosa.classic.model.schedule.uni.limited.platform.definitions
               prosa.classic.model.schedule.uni.limited.busy_interval.

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

(** * Priority inversion is bounded *)
(** In this module we prove that any priority inversion that occurs in the model with bounded
    nonpreemptive segments defined in module prosa.classic.model.schedule.uni.limited.platform.definitions
    is bounded. *)
Module PriorityInversionIsBounded.

  Import Job Priority UniprocessorSchedule LimitedPreemptionPlatform BusyIntervalJLFP.

  Section PriorityInversionIsBounded.

    Context {Task: eqType}.
    Variable task_max_nps task_cost: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_max_nps job_cost: Job -> time.
    Variable job_task: Job -> 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.

    (* Next, consider any uniprocessor schedule of this arrival sequence...*)
    Variable sched: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence: jobs_come_from_arrival_sequence sched arr_seq.

    (* ... where jobs do not execute before their arrival 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 a JLFP policy that indicates a higher-or-equal priority relation,
       and assume that the relation is reflexive and transitive. *)
    Variable higher_eq_priority: JLFP_policy Job.
    Hypothesis H_priority_is_reflexive: JLFP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: JLFP_is_transitive higher_eq_priority.

    (* We consider an arbitrary function can_be_preempted which defines
       a preemption model with bounded nonpreemptive segments. *)
    Variable can_be_preempted: Job -> time -> bool.
    Let preemption_time := preemption_time sched can_be_preempted.
    Hypothesis H_correct_preemption_model:
      correct_preemption_model arr_seq sched can_be_preempted.
    Hypothesis H_model_with_bounded_nonpreemptive_segments:
      model_with_bounded_nonpreemptive_segments
        job_cost job_task arr_seq can_be_preempted job_max_nps task_max_nps.

    (* Next, we assume that the schedule is a work-conserving schedule... *)
    Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.

    (* ... and the schedule respects the policy defined by the
       can_be_preempted function (i.e., bounded nonpreemptive segments). *)
    Hypothesis H_respects_policy:
      respects_JLFP_policy_at_preemption_point
        job_arrival job_cost arr_seq sched can_be_preempted higher_eq_priority.

    (* Let's define some local names for clarity. *)
    Let job_scheduled_at := scheduled_at sched.
    Let job_completed_by := completed_by job_cost sched.

    (* Finally, we introduce the notion of the maximal length of (potential) priority
       inversion at a time instant t, which is defined as the maximum length of
       nonpreemptive segments among all jobs that arrived so far. Note that
       the value [job_max_nps j_lp] is at least ε for any job j_lp, so the maximal
       length of priority inversion cannot be negative. *)
    Definition max_length_of_priority_inversion (j: Job) (t: time) :=
      \max_(j_lp <- jobs_arrived_before arr_seq t | ~~ higher_eq_priority j_lp j)
       (job_max_nps j_lp - ε).

    (** Next we prove that a priority inversion of a job is bounded by
        function max_length_of_priority_inversion. *)

    (** Note that any bound on function max_length_of_priority_inversion will also be
        a bound on the maximal priority inversion. This bound may be different
        for different scheduler and/or task models. Thus, we don't define such a bound
        in this module. *)

    (* Consider any job j of tsk with positive job cost. *)
    Variable j: Job.
    Hypothesis H_j_arrives: arrives_in arr_seq j.
    Hypothesis H_job_cost_positive: job_cost_positive job_cost j.

    (* Consider any busy interval prefix [t1, t2) of job j. *)
    Variable t1 t2: time.
    Hypothesis H_busy_interval_prefix:
      busy_interval_prefix job_arrival job_cost arr_seq sched higher_eq_priority j t1 t2.

    (* In this section, we prove that at any time instant after any preemption point
       (inside the busy interval), the processor is always busy scheduling a
       job with higher or equal priority. *)
    Section PreemptionTimeAndPriorityInversion.

      (* First, we show that the processor at any preemptive point is always
         busy scheduling a job with higher or equal priority. *)
      Lemma not_quiet_implies_exists_scheduled_hp_job_at_preemption_point:
        forall t,
          t1 <= t < t2 ->
          preemption_time t ->
          exists j_hp,
            arrived_between job_arrival j_hp t1 t2 /\
            higher_eq_priority j_hp j /\
            job_scheduled_at j_hp t.
      Proof.
        move: (H_busy_interval_prefix) => [SL [QUIET [NOTQUIET INBI]]].
        rename H_work_conserving into WORK, H_respects_policy into PRIO,
        H_jobs_come_from_arrival_sequence into CONS.
        move => t /andP [GEt LEt] PREEMPTP.
        have NOTIDLE := not_quiet_implies_not_idle
                          job_arrival job_cost arr_seq _
                          sched higher_eq_priority j _ _ _ _ _ t1 t2 _ t.
        feed_n 8 NOTIDLE; eauto 2.
        unfold is_idle, FP_is_transitive, transitive in *.
        destruct (sched t) as [j_hp|] eqn:SCHED; [clear NOTIDLE | by exfalso; apply NOTIDLE].
        move: SCHED => /eqP SCHED.
        exists j_hp.
        have HP: higher_eq_priority j_hp j.
        { apply contraT; move => /negP NOTHP; exfalso.
          have TEMP: t <= t2.-1; first by rewrite -subn1 subh3 // addn1.
          rewrite leq_eqVlt in TEMP; move: TEMP => /orP [/eqP EQUALt2m1 | LTt2m1];
                                                    first rewrite leq_eqVlt in GEt; first move: GEt => /orP [/eqP EQUALt1 | LARGERt1].
          { subst t; clear LEt.
            rewrite -EQUALt1 in SCHED; move: EQUALt1 => /eqP EQUALt1.
            destruct (job_scheduled_at j t1) eqn:SCHEDj.
            { simpl. have EQ:= only_one_job_scheduled sched j j_hp t1 SCHEDj SCHED.
                by subst j; apply NOTHP.
            }
            { apply NOTHP.
              apply PRIO with t1; try done.
              - by move: EQUALt1 => /eqP EQUALt1; rewrite EQUALt1.
              - apply/andP; split; last first.
                + by move: SCHEDj; rewrite /job_scheduled_at; move => /negP /negP SCHEDj.
                + have EQ: t1 = job_arrival j.
                  { rewrite -eqSS in EQUALt1.
                    have EQ: t2 = t1.+1.
                    { rewrite prednK in EQUALt1; first by apply/eqP; rewrite eq_sym.
                      apply negbNE; rewrite -eqn0Ngt; apply/neqP; intros EQ0.
                      move: INBI; rewrite EQ0; move => /andP [_ CONTR].
                        by rewrite ltn0 in CONTR.
                    } clear EQUALt1.
                      by move: INBI; rewrite EQ ltnS -eqn_leq; move => /eqP INBI.
                  }
                    by rewrite EQ; eapply job_pending_at_arrival; eauto 2.
            }
          }
          { feed (NOTQUIET t); first by apply/andP; split.
            apply NOTQUIET; intros j_hp' IN HP ARR.
            apply contraT; move => /negP NOTCOMP'; exfalso.
            have BACK: backlogged job_arrival job_cost sched j_hp' t.
            { apply/andP; split.
              - apply/andP; split. unfold arrived_before, has_arrived in *. by rewrite ltnW.
                apply/negP; intro COMP; apply NOTCOMP'.
                  by apply completion_monotonic with (t0 := t).
              - apply/negP; intro SCHED'.
                apply only_one_job_scheduled with (j1 := j_hp) in SCHED'; last by done.
                  by apply NOTHP; subst.
            }
            feed (PRIO j_hp' j_hp t PREEMPTP IN BACK); first by done.
              by apply NOTHP; apply H_priority_is_transitive with j_hp'.
          }
          {
            unfold quiet_time in *.
            feed (NOTQUIET t.+1). apply/andP; split.
            - by apply leq_ltn_trans with t1.
            - rewrite -subn1 ltn_subRL addnC in LTt2m1.
                by rewrite -[t.+1]addn1.
                apply NOTQUIET.
                unfold quiet_time in *; intros j_hp' IN HP ARR.
                apply contraT; move => /negP NOTCOMP'; exfalso.
                have BACK: backlogged job_arrival job_cost sched j_hp' t.
                { apply/andP; split; last first.
                  { apply/negP; intro SCHED'.
                    apply only_one_job_scheduled with (j1 := j_hp) in SCHED'; last by done.
                    apply NOTHP.
                      by subst.
                  }
                  apply/andP; split. unfold arrived_before, has_arrived in *. by done.
                  apply/negP; intro COMP; apply NOTCOMP'.
                    by apply completion_monotonic with (t0 := t).
                }
                feed (PRIO j_hp' j_hp t PREEMPTP IN BACK); first by done.
                  by apply NOTHP; apply H_priority_is_transitive with j_hp'.
          }
        }
        repeat split; [| by done | by done].
        move: (SCHED) => PENDING.
        eapply scheduled_implies_pending with (job_cost0 := job_cost) in PENDING; [| by eauto | by done].
        apply/andP; split; last by apply leq_ltn_trans with (n := t); first by move: PENDING => /andP [ARR _].
        apply contraT; rewrite -ltnNge; intro LT; exfalso.
        feed (QUIET j_hp); first by eapply CONS, SCHED.
        specialize (QUIET HP LT).
        have COMP: job_completed_by j_hp t by apply completion_monotonic with (t0 := t1).
        apply completed_implies_not_scheduled in COMP; last by done.
          by move: COMP => /negP COMP; apply COMP.
      Qed.

      (* In addition, we prove that every nonpreemptive segment
         always begins with a preemption time. *)
      Lemma scheduling_of_any_segment_starts_with_preemption_time:
        forall j t,
          job_scheduled_at j t ->
          exists pt,
            job_arrival j <= pt <= t /\
            preemption_time pt /\
            (forall t', pt <= t' <= t -> job_scheduled_at j t').
      Proof.
        intros s t SCHEDst.
        have EX: exists t',
            (t' <= t)
              && (job_scheduled_at s t')
              && (all (fun t'' => job_scheduled_at s t'') (iota t' (t - t').+1 )).
        { exists t.
          apply/andP; split; [ by apply/andP; split | ].
          apply/allP; intros t'.
          rewrite mem_iota.
          rewrite subnn addn1 ltnS -eqn_leq.
            by move => /eqP EQ; subst t'. }
        have MIN := ex_minnP EX.
        move: MIN => [mpt /andP [/andP [LT1 SCHEDsmpt] /allP ALL] MIN]; clear EX.
        destruct mpt.
        { exists 0; repeat split.
          - apply/andP; split; last by done.
              by apply H_jobs_must_arrive_to_execute in SCHEDsmpt.
          - by eapply zero_is_pt; eauto 2.
          - by intros; apply ALL; rewrite mem_iota subn0 add0n ltnS. }
        { have NSCHED: ~~ job_scheduled_at s mpt.
          { apply/negP; intros SCHED.
            feed (MIN mpt).
            apply/andP; split; [by apply/andP; split; [ apply ltnW | ] | ].
            apply/allP; intros t'.
            rewrite mem_iota addnS ltnS.
            move => /andP [GE LE].
            move: GE; rewrite leq_eqVlt; move => /orP [/eqP EQ| LT].
            subst t'. by done.
            apply ALL.
            rewrite mem_iota addnS ltnS.
            apply/andP; split; first by done.
            apply leq_trans with (mpt + (t - mpt)); first by done.
            rewrite !subnKC; last rewrite ltnW; by done.
              by rewrite ltnn in MIN. }
          have PP: preemption_time mpt.+1.
          { apply first_moment_is_pt with (arr_seq0 := arr_seq) (j0 := s); eauto 2. }
          exists mpt.+1; repeat split; try done.
          - apply/andP; split; last by done.
              by apply H_jobs_must_arrive_to_execute in SCHEDsmpt.
          - move => t' /andP [GE LE].
            apply ALL; rewrite mem_iota.
            rewrite addnS ltnS subnKC; last by done.
              by apply/andP; split.
        }
      Qed.

      (* Next we prove that at any time instant after a preemption point the
         processor is always busy with a job with higher or equal priority. *)
      Lemma not_quiet_implies_exists_scheduled_hp_job_after_preemption_point:
        forall tp t,
          preemption_time tp ->
          t1 <= tp < t2 ->
          tp <= t < t2 ->
          exists j_hp,
            arrived_between job_arrival j_hp t1 t.+1 /\
            higher_eq_priority j_hp j /\
            job_scheduled_at j_hp t.
      Proof.
        move: (H_jobs_come_from_arrival_sequence) (H_work_conserving) => CONS WORK.
        move: (H_respects_policy) => PRIO.
        move => tp t PRPOINT /andP [GEtp LTtp] /andP [LEtp LTt].
        have NOTIDLE := not_quiet_implies_not_idle
                          job_arrival job_cost arr_seq _ sched higher_eq_priority
                          j _ _ _ _ _ t1 t2 _ t.
        feed_n 8 NOTIDLE; eauto 2.
        apply/andP; split; [by apply leq_trans with tp | by done].
        destruct (sched t) as [j_hp|] eqn:SCHED;
          last by exfalso; apply NOTIDLE; rewrite /is_idle SCHED.
        move: SCHED => /eqP SCHED.
        exists j_hp.
        have HP: higher_eq_priority j_hp j.
        { intros.
          have SOAS := scheduling_of_any_segment_starts_with_preemption_time _ _ SCHED.
          move: SOAS => [prt [/andP [_ LE] [PR SCH]]].
          case E:(t1 <= prt).
          - move: E => /eqP /eqP E; rewrite subn_eq0 in E.
            have EXISTS := not_quiet_implies_exists_scheduled_hp_job_at_preemption_point prt.
            feed_n 2 EXISTS; try done.
            { by apply /andP; split; last by apply leq_ltn_trans with t. }
            move: EXISTS => [j_lp [_ [HEP SCHEDjhp]]].
            have EQ: j_hp = j_lp.
            { by apply (only_one_job_scheduled sched _ _ prt); first (apply SCH; apply/andP; split). }
              by subst j_hp.
          - move: E => /eqP /neqP E; rewrite -lt0n subn_gt0 in E.
            apply negbNE; apply/negP; intros LP.
            rename j_hp into j_lp.
            have EXISTS := not_quiet_implies_exists_scheduled_hp_job_at_preemption_point tp.
            feed_n 2 EXISTS; try done.
            { by apply /andP; split. }
            move: EXISTS => [j_hp [_ [HEP SCHEDjhp]]].
            have EQ: j_hp = j_lp.
            { apply (only_one_job_scheduled sched _ _ tp).
                by done.
                apply SCH; apply/andP; split.
                apply leq_trans with t1. rewrite ltnW //. by done.
                  by done.
            }
              by subst j_hp; move: LP => /negP LP; apply: LP.
        }
        repeat split; [| by done | by done].
        move: (H_busy_interval_prefix) => [SL [QUIET [NOTQUIET EXj]]].
        move: (SCHED) => PENDING.
        eapply scheduled_implies_pending with (job_cost0 := job_cost) in PENDING;
          [| by eauto | by done].
        apply/andP; split;
          last by apply leq_ltn_trans with (n := t); first by move: PENDING => /andP [ARR _].
        apply contraT; rewrite -ltnNge; intro LT; exfalso.
        feed (QUIET j_hp); first by eapply CONS, SCHED.
        specialize (QUIET HP LT).
        have COMP: job_completed_by j_hp t.
        { by apply completion_monotonic with (t0 := t1); [ apply leq_trans with tp | ]. }
        apply completed_implies_not_scheduled in COMP; last by done.
          by move: COMP => /negP COMP; apply COMP.
      Qed.

      (* Now, suppose there exists some constant K that bounds the distance to
         a preemption time from the beginning of the busy interval. *)
      Variable K: time.
      Hypothesis H_preemption_time_exists:
        exists pr_t, preemption_time pr_t /\ t1 <= pr_t <= t1 + K.

      (* Then we prove that the processor is always busy with a job with
         higher-or-equal priority after time instant [t1 + K]. *)
      Lemma not_quiet_implies_exists_scheduled_hp_job:
        forall t,
          t1 + K <= t < t2 ->
          exists j_hp,
            arrived_between job_arrival j_hp t1 t.+1 /\
            higher_eq_priority j_hp j /\
            job_scheduled_at j_hp t.
      Proof.
        move => t /andP [GE LT].
        move: H_preemption_time_exists => [prt [PR /andP [GEprt LEprt]]].
        apply not_quiet_implies_exists_scheduled_hp_job_after_preemption_point with (tp := prt); eauto 2.
        -  apply/andP; split; first by done.
           apply leq_ltn_trans with (t1 + K); first by done.
             by apply leq_ltn_trans with t.
        - apply/andP; split; last by done.
            by apply leq_trans with (t1 + K).
      Qed.

    End PreemptionTimeAndPriorityInversion.

    (* In this section we prove that the function max_length_of_priority_inversion
       indeed upper bounds the priority inversion length. *)
    Section PreemprionTimeExists.

      (* First we prove that if a job with higher-or-equal priority is scheduled at
         a quiet time t+1 then this is the first time when this job is scheduled. *)
      Lemma hp_job_not_scheduled_before_quiet_time:
        forall jhp t,
          quiet_time job_arrival job_cost arr_seq sched higher_eq_priority j t.+1 ->
          job_scheduled_at jhp t.+1 ->
          higher_eq_priority jhp j ->
          ~~ job_scheduled_at jhp t.
      Proof.
        intros jhp t QT SCHED1 HP.
        apply/negP; intros SCHED2.
        specialize (QT jhp).
        feed_n 3 QT; try done.
        eapply H_jobs_come_from_arrival_sequence; eauto 1.
        rewrite /arrived_before ltnS.
        apply H_jobs_must_arrive_to_execute. by done.
        apply completed_implies_not_scheduled in QT; last by done.
          by move: QT => /negP NSCHED; apply: NSCHED.
      Qed.

      (* Also, we show that lower-priority jobs that are scheduled inside the
         busy-interval prefix [t1,t2) must have arrived before that interval. *)
      Lemma low_priority_job_arrives_before_busy_interval_prefix:
        forall jlp t,
          t1 <= t < t2 ->
          job_scheduled_at jlp t ->
          ~~ higher_eq_priority jlp j ->
          job_arrival jlp < t1.
      Proof.
        move => jlp t /andP [GE LT] SCHED LP.
        move: (H_busy_interval_prefix) => [NEM [QT [NQT HPJ]]].
        apply negbNE; apply/negP; intros ARR; rewrite -leqNgt in ARR.
        have SCH:= scheduling_of_any_segment_starts_with_preemption_time _ _ SCHED.
        move: SCH => [pt [/andP [NEQ1 NEQ2] [PT FA]]].
        have NEQ: t1 <= pt < t2.
        { apply/andP; split.
          apply leq_trans with (job_arrival jlp); by done.
          apply leq_ltn_trans with t; by done. }
        have LL:= not_quiet_implies_exists_scheduled_hp_job_at_preemption_point pt.
        feed_n 2 LL; try done.
        move: LL => [jhp [ARRjhp [HP SCHEDhp]]].
        feed (FA pt). apply/andP; split; by done.
        have OOJ:= only_one_job_scheduled _ _ _ _ FA SCHEDhp; subst jhp.
          by move: LP => /negP LP; apply: LP.
      Qed.

      (* Moreover, we show that lower-priority jobs that are scheduled inside the
         busy-interval prefix [t1,t2) must be scheduled before that interval. *)
      Lemma low_priority_job_scheduled_before_busy_interval_prefix:
        forall jlp t,
          t1 <= t < t2 ->
          job_scheduled_at jlp t ->
          ~~ higher_eq_priority jlp j ->
          exists t', t' < t1 /\ job_scheduled_at jlp t'.
      Proof.
        move => jlp t NEQ SCHED LP.
        have ARR := low_priority_job_arrives_before_busy_interval_prefix _ _ NEQ SCHED LP.
        move: NEQ => /andP [GE LT].
        exists t1.-1.
        split.
        { rewrite prednK; first by done.
            by apply leq_ltn_trans with (job_arrival jlp).
        }
        { move: (H_busy_interval_prefix) => [NEM [QT [NQT HPJ]]].
          have SCHEDST := scheduling_of_any_segment_starts_with_preemption_time _ _ SCHED.
          move: SCHEDST => [pt [NEQpt [PT SCHEDc]]].
          have NEQ: pt < t1.
          { rewrite ltnNge; apply/negP; intros CONTR.
            have NQSCHED := not_quiet_implies_exists_scheduled_hp_job_at_preemption_point pt.
            feed_n 2 NQSCHED; try done.
            { apply/andP; split; first by done.
                by apply leq_ltn_trans with t; move: NEQpt => /andP [_ T].
            }
            move: NQSCHED => [jhp [ARRhp [HPhp SCHEDhp]]].
            specialize (SCHEDc pt).
            feed SCHEDc.
            { by apply/andP; split; last move: NEQpt => /andP [_ T]. }
            have EQ:= only_one_job_scheduled sched jhp jlp pt.
            feed_n 2 EQ; try done.
            subst jhp.
              by move: LP => /negP LP; apply: LP.
          }
          apply SCHEDc; apply/andP; split.
          - rewrite -addn1 in NEQ.
            apply subh3 in NEQ.
              by rewrite subn1 in NEQ.
          - apply leq_trans with t1. by apply leq_pred. by done.
        }
        Qed.

      (* Thus, there must be a preemption time in the interval [t1, t1 + max_priority_inversion t1].
         That is, if a job with higher-or-equal priority is scheduled at time instant t1, then t1 is
         a preemprion time. Otherwise, if a job with lower priority is scheduled at time t1,
         then this jobs also should be scheduled before the beginning of the busy interval. So, the
         next preemption time will be no more than [max_priority_inversion t1] time units later. *)
      Lemma preemption_time_exists:
        exists pr_t,
          preemption_time pr_t /\
          t1 <= pr_t <= t1 + max_length_of_priority_inversion j t1.
      Proof.
        set (service := service sched).
        move: (H_correct_preemption_model) => CORR.
        move: (H_busy_interval_prefix) => [NEM [QT1 [NQT HPJ]]].
        case SCHED: (sched t1) => [s | ]; move: SCHED => /eqP SCHED; last first.
        { exists t1; split; last first.
          apply/andP; split; [by done | by rewrite leq_addr].
          move: SCHED => /eqP SCHED.
          rewrite /preemption_time /LimitedPreemptionPlatform.preemption_time.
            by rewrite SCHED.
        }
        { case PRIO: (higher_eq_priority s j).
          { exists t1; split; last first.
            apply/andP; split; [by done | by rewrite leq_addr].
            destruct t1.
            { eapply zero_is_pt; [eauto 2 | apply H_jobs_come_from_arrival_sequence]. }
            eapply hp_job_not_scheduled_before_quiet_time in QT1; eauto 2.
            eapply first_moment_is_pt with (j0 := s); eauto 2.
          }
          { move: (SCHED) => ARRs; apply H_jobs_come_from_arrival_sequence in ARRs.
            move: (H_model_with_bounded_nonpreemptive_segments s ARRs) => [_ [_ [_ EXPP]]].
            move: (EXPP (service s t1)) => PP; clear EXPP.
            feed PP. by apply/andP; split; [done | apply H_completed_jobs_dont_execute].
            have EX: exists pt,
                ((service s t1) <= pt <= (service s t1) + (job_max_nps s - 1))
                  && can_be_preempted s pt.
            { move: PP => [pt [NEQ PP]].
              exists pt; apply/andP; split; by done.
            } clear PP.
            have MIN := ex_minnP EX.
            move: MIN => [sm_pt /andP [NEQ PP] MIN]; clear EX.
            have Fact: exists Δ, sm_pt = service s t1 + Δ.
            { exists (sm_pt - service s t1).
              apply/eqP; rewrite eq_sym; apply/eqP; rewrite subnKC //.
                by move: NEQ => /andP [T _]. }
            move: Fact => [Δ EQ]; subst sm_pt; rename Δ into sm_pt.
            exists (t1 + sm_pt); split.
            { have Fact1:
                forall prog, service s t1 <= prog < service s t1 + sm_pt ->
                        ~~ can_be_preempted s prog.
              { move => prog /andP [GE LT].
                apply/negP; intros PPJ.
                feed (MIN prog); first (apply/andP; split); try done.
                - apply/andP; split; first by done.
                  apply leq_trans with (service s t1 + sm_pt).
                  + by apply ltnW.
                  + by move: NEQ => /andP [_ K].
                - by move: MIN; rewrite leqNgt; move => /negP NLT; apply: NLT.
              }
              have Fact2: forall t', t1 <= t' < t1 + sm_pt -> job_scheduled_at s t'.
              {
                move => t' /andP [GE LT].
                have Fact: exists Δ, t' = t1 + Δ.
                { by exists (t' - t1); apply/eqP; rewrite eq_sym; apply/eqP; rewrite subnKC.  }
                move: Fact => [Δ EQ]; subst t'.
                move: (Fact1 (service s (t1 + Δ)))(CORR s) => NPPJ T.
                feed T; first by done. move: T => [T _ ].
                apply: T; apply: NPPJ.
                apply/andP; split.
                { by apply Service.service_monotonic; rewrite leq_addr. }
                rewrite /service /UniprocessorSchedule.service (@Service.service_during_cat _ _ _ t1).
                { rewrite ltn_add2l; rewrite ltn_add2l in LT.
                  apply leq_ltn_trans with Δ; last by done.
                  rewrite -{2}(sum_of_ones t1 Δ).
                  rewrite leq_sum //; clear; intros t _.
                    by rewrite /service_at; destruct (scheduled_at sched s t). }
                { by apply/andP; split; [done | rewrite leq_addr]. }
              }
              rewrite /preemption_time /LimitedPreemptionPlatform.preemption_time.
              case SCHEDspt: (sched (t1 + sm_pt)) => [s0 | ]; last by done.
              move: SCHEDspt => /eqP SCHEDspt.
              destruct (s == s0) eqn: EQ.
              { move: EQ => /eqP EQ; subst s0.
                rewrite /UniprocessorSchedule.service.
                rewrite (@Service.service_during_cat _ _ _ t1); last first.
                { by apply/andP; split; [ done | rewrite leq_addr]. }
                have ALSCHED: service_during sched s t1 (t1 + sm_pt) = sm_pt.
                { rewrite -{2}(sum_of_ones t1 sm_pt) /service_during.
                  apply/eqP; rewrite eqn_leq //; apply/andP; split.
                  { rewrite leq_sum //; clear; intros t _.
                      by unfold service_at; destruct (scheduled_at sched s t). }
                  { rewrite big_nat_cond [in X in _ <= X]big_nat_cond.
                    rewrite leq_sum //.
                    move => x /andP [HYP _].
                    rewrite lt0b.
                      by apply Fact2.
                  }
                }
                  by rewrite ALSCHED.
              }
              destruct sm_pt.
              { exfalso; move: EQ => /negP EQ; apply: EQ.
                move: SCHED SCHEDspt => /eqP SCHED /eqP SCHEDspt.
                rewrite addn0 in SCHEDspt; rewrite SCHEDspt in SCHED.
                  by inversion SCHED. }
              { rewrite addnS.
                move: (H_correct_preemption_model s0) => T.
                feed T; first by eauto 2. move: T => [_ T]; apply: T.
                apply /negP; intros CONTR.
                move: EQ => /negP EQ; apply: EQ.
                move: (Fact2 (t1 + sm_pt)) => SCHEDs0.
                feed SCHEDs0; first by apply/andP; split; [rewrite leq_addr | rewrite addnS].
                apply/eqP; eapply only_one_job_scheduled; eauto 2.
                  by rewrite -addnS.
              }
            }
            move: NEQ => /andP [GE LE].
            apply/andP; split; first by rewrite leq_addr.
            rewrite leq_add2l.
            unfold max_length_of_priority_inversion.
            rewrite (big_rem s) //=.
            { rewrite PRIO; simpl.
              apply leq_trans with (job_max_nps s - ε); last by rewrite leq_maxl.
                by rewrite leq_add2l in LE. }
            eapply arrived_between_implies_in_arrivals; eauto 2.
            apply/andP; split; first by done.
            eapply low_priority_job_arrives_before_busy_interval_prefix with t1; eauto 2.
              by rewrite PRIO.
          }
        }
      Qed.

    End PreemprionTimeExists.

  End PriorityInversionIsBounded.

End PriorityInversionIsBounded.