Require Import ssreflect ssrfun.
Require Import HB.structures.
Require Import Arith.

Set Implicit Arguments.

HB.mixin Record IsMonoid M := {
  zero : M;
  add : M -> M -> M;
  addrA : associative add;
  add0r : left_id zero add;
  addr0 : right_id zero add;
}.
HB.structure Definition Monoid := { M of IsMonoid M }.

HB.mixin Record IsRing R of Monoid R := {
  one : R; opp : R -> R; mul : R -> R -> R;
  addrC : @commutative R R add;
  addNr : left_inverse zero opp add;
  addrN : right_inverse zero opp add;
  mulrA : associative mul;
  mul1r : left_id one mul;
  mulr1 : right_id one mul;
  mulrDl : left_distributive mul add;
  mulrDr : right_distributive mul add;
}.
HB.structure Definition Ring := { R of IsRing R & IsMonoid R }.

HB.mixin Record IsComRing R of Ring R := {
  mulrC : @commutative R R mul;
}.
HB.structure Definition ComRing := { R of IsComRing R & IsRing R & IsMonoid R }.

Section rings.
  Declare Scope ring_scope.

  Notation "0" := (@zero _) : ring_scope.
  Notation "1" := (@one _) : ring_scope.
  Notation "-%R" := (@opp _) : ring_scope.
  Notation "- x" := (opp x) : ring_scope.
  Notation "+%R" := (@add _) : fun_scope.
  Local Notation "*%R" := (@mul _) : fun_scope.
  Local Notation "x * y" := (mul x y) : ring_scope.
  Notation "x + y" := (add x y) : ring_scope.
  Notation "x - y" := (x + (@opp y)) : ring_scope.
  Open Scope ring_scope.

  Variable (R : Ring.type).
  Implicit Types a x y : R.
  Hint Rewrite (@addNr R) (@addrN R) (@addNr R) (@add0r R) (@addr0 R) : ring_scope.
  Hint Rewrite (@mul1r R) (@mulr1 R) : ring_scope.

  (* thm_1_1_1_1 *)
  Lemma mul0r a : 0 * a = 0.
  Proof.
    have H x: x + x = x -> x = 0
      by move=> xAddx; rewrite -xAddx -(addrN x) -{3}xAddx -addrA (addrN x) addr0.
    by apply: H; rewrite -mulrDl addr0.
  Qed.

  Hint Rewrite mul0r : ring_scope.

  (* thm_1_1_1_2 *)
  Lemma mulr0 a : a * 0 = 0.
    have H x: x + x = x -> x = 0
      by move=> xAddx; rewrite -xAddx -(addrN x) -{3}xAddx -addrA (addrN x) addr0.
    by apply: H; rewrite -mulrDr addr0.
  Qed.

  Hint Rewrite mulr0 : ring_scope.

  (* thm_1_1_2_1 *)
  Lemma opprK a : opp (opp a) = a.
  Proof.
    have H x y : x + y = 0 -> y = opp x
      by move=> H; rewrite -(add0r (opp x)) -H (addrC x y) -addrA addrN addr0.
    by symmetry; apply: H; rewrite addNr.
  Qed.

  Hint Rewrite opprK : ring_scope.

  Lemma thm_1_1_2_2_1 a b : a * (opp b) = opp (a * b).
  Proof.
    have H x y : x + y = 0 -> y = opp x
      by move=> H; rewrite -(add0r (opp x)) -H (addrC x y) -addrA addrN addr0.
    apply H.
    rewrite -mulrDr.
    by autorewrite with ring_scope.
  Qed.

  Hint Rewrite thm_1_1_2_2_1 : ring_scope.

  Lemma thm_1_1_2_2_2 a b : opp a * b = opp (a * b).
  Proof.
    have H x y : x + y = 0 -> y = opp x
      by move=> H; rewrite -(add0r (opp x)) -H (addrC x y) -addrA addrN addr0.
    by apply: H; rewrite -mulrDl addrN mul0r.
  Qed.

  Hint Rewrite thm_1_1_2_2_2 : ring_scope.

  Lemma thm_1_1_2_3 a b : opp a * opp b = a * b.
  Proof.
    by autorewrite with ring_scope.
  Qed.

  Hint Rewrite thm_1_1_2_3 : ring_scope.

  Fixpoint expt (a : R) (n : nat) : R :=
    match n with
    | 0 => 1
    | S n' => a * expt a n'
    end.

  Notation "x <^> y" := (expt x y) (at level 25, left associativity).

  Lemma thm_1_1_3_1 a n m : expt a n * expt a m = expt a (n + m).
  Proof.
    elim: n m => [| n IHn] /= m.
    - by autorewrite with ring_scope.
    - by rewrite -mulrA IHn.
  Qed.

  Hint Rewrite thm_1_1_3_1 : ring_scope.

  Lemma expt_I n : expt 1 n = 1.
  Proof.
    by elim n => [|?] /=; autorewrite with ring_scope.
  Qed.

  Hint Rewrite expt_I : ring_scope.

  Lemma thm_1_1_3_2 a n : forall m, a <^> n <^> m = a <^> (n * m).
  Proof.
    elim=> [| m IHm] /=.
    - by rewrite -mult_n_O.
    - rewrite IHm. autorewrite with ring_scope.
      by rewrite -mult_n_Sm Nat.add_comm.
  Qed.

  Hint Rewrite thm_1_1_3_2 : ring_scope.

  Lemma expt_reorder a : forall (n m o : nat),
      n = plus m o -> a <^> n = a <^> m * a <^> o.
  Proof. by move=>>; autorewrite with ring_scope; move <-. Qed.

  Lemma thm_1_1_4 : forall (a b : R) n,
      a * b = b * a
      -> (a * b) <^> n = a <^> n * b <^> n.
  Proof.
    intros a b n abComm.
    induction n.
    - by autorewrite with ring_scope.
    - simpl.
      rewrite -(mulrA a (a <^> n)).
      rewrite (mulrA (a <^> n)).
      assert (H: forall n, a <^> n * b = b * a <^> n).
      {
        intros m.
        induction m.
        - by autorewrite with ring_scope.
        - rewrite (expt_reorder a m 1).
          by rewrite Nat.add_1_r.
          simpl (a <^> 1).
          autorewrite with ring_scope.
          rewrite (mulrA b _ a).
          rewrite -IHm.
          rewrite -(mulrA _ b a).
          rewrite -abComm.
          by rewrite mulrA.
      }
      rewrite H.
      rewrite -(mulrA b _ _).
      rewrite (mulrA a b _).
      by rewrite IHn.
  Qed.

  Definition is_nonzero (a : R) := a <> 0.
  Definition is_ring_unit (a : R) := exists b, a * b = 1 /\ b * a = 1.
  Definition divRing := forall (a : R), is_nonzero a -> is_ring_unit a.

  Definition comRing := commutative (@mul R).

  Axiom thm_1_4_c : divRing -> forall (a b : R), a * b = 0 -> a = 0 \/ b = 0.

  (* C' and C'' and C''' are logically equivalent to C *)

  (* Every division ring satisfies C' *)
  Lemma thm_1_4_c' : forall (a b : R),
      divRing -> a <> 0 /\ b <> 0 -> a * b <> 0.
  Proof.
    intros a b divRingR abNK.
    destruct abNK.
    unfold not.
    intros.
    pose proof (thm_1_4_c divRingR a b H1).
    destruct H2; tauto.
  Qed.

  (* Every division ring satisfies C'' *)
  Lemma thm_1_4_c'' : forall (a b : R),
      divRing -> a * b = 0 -> a <> 0 -> b = 0.
  Proof.
    intros a b divRingR abCancel aNz.
    unfold divRing in divRingR.
    destruct (divRingR a aNz) as [x [axI xaI]].
    rewrite -(mul1r b).
    rewrite -xaI.
    rewrite -mulrA.
    rewrite abCancel.
    by autorewrite with ring_scope.
  Qed.

  (* Every division ring satisfies C''' *)
  Lemma thm_1_4_c''' : forall (a b : R),
      divRing -> a * b = 0 -> a <> 0 -> b = 0.
  Proof.
    intros a b divRingR abCancel aNz.
    unfold divRing in divRingR.
    destruct (divRingR a aNz) as [x [axI xaI]].
    rewrite -(mul1r b).
    rewrite -xaI.
    rewrite -mulrA.
    rewrite abCancel.
    by autorewrite with ring_scope.
  Qed.

  Lemma coll_1_3_1 : forall (a b : R),
      divRing -> is_nonzero a -> a * b = 0 -> b = 0.
  Proof.
    intros a b divRingR unitA abZ.
    unfold divRing in divRingR.
    destruct (divRingR a unitA) as [aInv [abI baI]].
    by apply thm_1_4_c'' with (a := a).
  Qed.

  Lemma coll_1_3 : forall (a b c : R),
      divRing -> is_nonzero a -> a * b = a * c -> b = c.
  Proof.
    intros a b c divRingR unitA abEqac.
    unfold divRing in divRingR.
    destruct (divRingR a unitA) as [aInv [abI baI]].
    rewrite -(mul1r b).
    rewrite -(mul1r c).
    rewrite -baI.
    rewrite -!mulrA.
    congruence.
  Qed.

  Definition C := forall (a b : R), a * b = 0 -> a = 0 \/ b = 0.

  Definition domain := comRing /\ C.

  Definition field := comRing /\ (forall (a : R), is_nonzero a -> is_ring_unit a).

  Theorem ring_K : C -> forall (a b c : R), a <> 0 -> a * b = a * c -> b = c.
  Proof.
    intros.
    unfold C in H.
    apply (f_equal (fun x => x + opp (a * c))) in H1.
    autorewrite with ring_scope in H1.
    rewrite -(thm_1_1_2_2_1 a c) in H1.
    rewrite -mulrDr in H1.
    pose proof (H a _ H1).
    destruct H2.
    - tauto.
    - apply (f_equal (fun x => x + c)) in H2.
      rewrite -addrA in H2.
      by autorewrite with ring_scope in H2.
  Qed.

  (* Exercise from homework *)
  Theorem hw5_P2 a : domain -> a * a = 1 -> a = 1 \/ a = opp 1.
  Proof.
    intros domR a2I.
    destruct domR.
    assert ((a + 1) * (a + opp 1) = 0).
    {
      rewrite !mulrDr.
      rewrite !mulrDl.
      autorewrite with ring_scope.
      rewrite -(addrA (a * a) a _).
      rewrite (addrA a (opp a) _).
      autorewrite with ring_scope.
      rewrite a2I.
      by autorewrite with ring_scope.
    }
    pose proof (H0 (a + 1) (a + opp 1) H1).
    destruct H2.
    - right. rewrite -(addrN a) in H2.
      apply (f_equal (fun x => opp a + x)) in H2.
      rewrite !addrA in H2.
      autorewrite with ring_scope in H2.
      rewrite H2.
      by autorewrite with ring_scope.
    - left. rewrite -(addrN a) in H2.
      apply (f_equal (fun x => opp a + x)) in H2.
      rewrite !addrA in H2.
      autorewrite with ring_scope in H2.
      apply (f_equal opp) in H2.
      autorewrite with ring_scope in H2.
      by symmetry.
  Qed.

  Definition divides {R : Ring.type} (a : R) (b : R) := exists c, a * c = b.

  Theorem hw6_2a (Rc : ComRing.type) (a b c : Rc) :
    divides a b -> divides b c -> divides a c.
  Proof.
    by move=> [d adb] [e be]; exists (d * e); rewrite mulrA adb.
  Qed.

  Theorem hw6_2b (a b c : R) :
    comRing -> divides a b -> is_ring_unit c -> divides (a * c) b.
  Proof.
    intros.
    unfold divides in *.
    unfold is_ring_unit in H1.
    destruct H0, H1.
    destruct H1.
    exists (x0 * x).
    subst.
    rewrite -(mulrA a c _).
    rewrite (mulrA c x0 _).
    rewrite H1.
    by autorewrite with ring_scope.
  Qed.

  (* if a|b and b|a for non-zero a, and R is a domain, then there
  exist units u and v in R, such that a = ub and b = va; *)

  Theorem hw6_2c (a b : R) :
    domain -> is_nonzero a -> divides a b -> divides b a
    ->  exists u v, a = u * b /\ b = v * a /\ is_ring_unit u /\ is_ring_unit v.
  Proof.
    intros.
    unfold divides in *.
    destruct H1, H2.
    subst.
    exists x0,  x.
    split.
    - destruct H.
      rewrite -H.
      by symmetry.
    - split.
      + apply (proj1 H).
      + unfold domain in H.
        rewrite -{2}(mulr1 a) in H2.
        rewrite -mulrA in H2.
        destruct H.
        eapply ring_K in H2; try auto.
        unfold is_ring_unit.
        pose proof H2.
        rewrite H in H3.
        split; try ((by exists x) || (by exists x0)).
  Qed.

  Theorem hw6_2d (Rc : ComRing.type) (a b c : Rc) :
    divides a b -> divides (a * c) (b * c).
  Proof.
    by move=> [x axb]; exists x; rewrite /divides -mulrA -(mulrC x c) mulrA axb.
  Qed.

  (* e) if ac|bc , R is a domain, and c ̸= 0, then a|b. *)
  Theorem hw6_2e (a b c : R) :
    divides (a * c) (b * c) -> domain -> is_nonzero c -> divides a b.
  Proof.
    intros divACBC domR nonZC.
    destruct divACBC.
    destruct domR.
    rewrite (H0 a c) in H.
    rewrite (H0 b c) in H.
    rewrite -mulrA in H.
    apply ring_K in H; try auto.
    by exists x.
  Qed.
End rings.


Require Import Classical.
Require Import List.
Require Import Omega.
Require Import Arith.
Require Import Wf.

Require Import ranked_properties.
Require sf_spec.

Section sf_spec_properties.
  Variable candidate:Set.

  Let rankSelection := list candidate.
  Let ballot := list rankSelection.
  Let election := list ballot.

  Lemma next_ranking_elim_unchanged :
    forall (elim elim':candidate -> Prop) b c r,
      (forall x, elim x -> elim' x) ->
      ~elim' c ->
      sf_spec.next_ranking candidate elim b r ->
      In c r ->
      sf_spec.next_ranking candidate elim' b r.
  Proof.
    intros.
    induction H1.
    * apply sf_spec.next_ranking_eliminated; auto.
      rewrite Forall_forall in *; firstorder.
    * apply sf_spec.next_ranking_valid with c; auto.
  Qed.

  Lemma selected_candidate_elim_unchanged :
    forall (elim elim':candidate -> Prop) b c,
      sf_spec.selected_candidate candidate elim b c ->
      (forall x, elim x -> elim' x) ->
      ~elim' c ->
      sf_spec.selected_candidate candidate elim' b c.
  Proof.
    intros.
    destruct H.
    destruct H2 as [r [Hr Hc]].
    split.
    * intro. apply H.
      destruct H2.
      elim H2.
      exists r. eapply next_ranking_elim_unchanged; eauto.
      destruct H2 as [r' [??]].
      assert (r = r').
      { cut (sf_spec.next_ranking candidate elim' b r'); [ apply sf_spec.next_ranking_unique; auto | auto ].
        eapply next_ranking_elim_unchanged; eauto.
      }
      subst r'.
      right; exists r; split; auto.
    * exists r; split; auto.
      eapply next_ranking_elim_unchanged; eauto.
  Qed.

  (** As we eliminate candidates, the first-choice counts of the remaining
      candidates increases monotonically.
    *)
  Lemma first_choices_monotone :
    forall elim elim' e c m n,
      ~elim' c ->
      sf_spec.first_choices candidate elim c e m ->
      sf_spec.first_choices candidate elim' c e n ->
      (forall x, elim x -> elim' x) ->
      m <= n.
  Proof.
    intros.
    revert n H1.
    induction H0; intros.
    * auto with arith.
    * inversion H3; subst; clear H3.
      - cut (n' <= n'0). auto with arith.
        apply IHfirst_choices; auto.
      - elim H6.
        eapply selected_candidate_elim_unchanged; eauto.
    * inversion H3; subst; clear H3.
      transitivity n'; auto with arith.
      apply IHfirst_choices; eauto.
  Qed.

  Let sf_may_win_election c e :=
    sf_spec.winner candidate e (fun _ => False) c.

  Definition all_candidates : election -> list candidate :=
    fold_right (fun a b => b ++ fold_right (@app _) nil a) nil.

  Lemma all_candidates_participates : forall c e,
     In c (all_candidates e) <-> sf_spec.participates _ c e.
  Proof.
    intros c e. induction e; simpl; intuition.
    destruct H as [? [??]]. elim H.
    apply in_app_or in H1. destruct H1.
    apply H in H1.
    destruct H1 as [? [??]].
    exists x. split; simpl; auto.
    exists a. split; simpl; auto.
    induction a; simpl in *.
    elim H1.
    apply in_app_or in H1.
    destruct H1.
    exists a. split; auto.
    apply IHa in H1.
    destruct H1 as [r [??]].
    eauto.
    apply in_or_app.
    destruct H1 as [b [??]].
    simpl in H1.
    destruct H1.
    subst a.
    right.
    induction b.
    destruct H2 as [r [??]].
    elim H1.
    simpl.
    apply in_or_app.
    destruct H2 as [r [??]].
    simpl in H1. destruct H1.
    subst a.
    auto.
    right. eauto.
    left. apply H0.
    red; eauto.
  Qed.

  Lemma list_remove_prop_weak : forall A (l:list A) (P:A -> Prop),
       exists l',
           length l' <= length l /\
           (forall a, In a l -> In a l' \/ P a) /\
           (forall a, In a l' -> In a l /\ ~P a).
  Proof.
    intro A. induction l; simpl; intuition.
    * exists nil; simpl; intuition.
    * destruct (IHl P) as [l' [?[??]]].
      destruct (classic (P a)).
      + exists l'. simpl; intuition.
        subst; auto.
        apply H1 in H3. intuition.
        apply H1 in H3; intuition.
      + exists (a::l'). simpl; intuition.
        destruct (H0 a0); intuition.
        subst a0. auto.
        destruct (H1 a0); auto.
        destruct (H1 a0); auto.
  Qed.

  Lemma list_remove_prop : forall A (l:list A) (P:A -> Prop) x,
        P x -> In x l ->
        exists l',
           length l' < length l /\
           (forall a, In a l -> In a l' \/ P a) /\
           (forall a, In a l' -> In a l /\ ~P a).
  Proof.
    intro A. induction l; simpl; intuition.
    * subst a.
      destruct (list_remove_prop_weak A l P) as [l' [?[??]]].
      exists l'. simpl; intuition; subst; auto.
      apply H2 in H3. intuition.
      apply H2 in H3. intuition.
    * destruct (IHl P x) as [l' [?[??]]]; auto.
      destruct (classic (P a)).
      + exists l'; intuition.
        subst; auto.
        apply H3 in H5. intuition.
        apply H3 in H5. intuition.
      + exists (a::l'); simpl; intuition.
        destruct (H2 a0); intuition; subst; auto.
        subst; auto.
        apply H3 in H6. intuition.
        apply H3 in H6. intuition.
  Qed.

  Lemma majority_satisfies_ballot_exists P e :
    majority_satisfies candidate P e ->
    exists b, P b /\ In b e.
  Proof.
    intros [n [t [?[??]]]].
    revert t H0 H1.
    induction H; intros.
    exists b; intuition.
    red in H1.
    inversion H1; subst; clear H1.
    destruct (IHcount_votes n0) as [b' [??]]; auto.
    omega.
    exists b'. split; simpl; auto.
    destruct (IHcount_votes t) as [b' [??]]; auto.
    exists b'. split; simpl; auto.
    omega.
  Qed.

  Lemma continuing_ballot_selects (b:ballot) (eliminated:candidate -> Prop) :
    sf_spec.continuing_ballot _ eliminated b <->
    exists c, sf_spec.selected_candidate _ eliminated b c.
  Proof.
    split; intros.
    destruct (classic (exists c, sf_spec.selected_candidate _ eliminated b c )); auto.
    elim H. clear H.
    rewrite sf_spec.exhausted_ballot_next_ranking_iff.
    intros.
    destruct (sf_spec.next_ranking_spec candidate eliminated b r); auto.
    destruct H1 as [c[?[??]]].
    elim H0. exists c.
    split; eauto.
    intro. destruct H4.
    elim H4. eauto.
    destruct H4 as [r' [??]].
    assert (r = r'). { eapply sf_spec.next_ranking_unique; eauto. }
    subst r'.
    destruct H5 as [r1 [r2 [?[??]]]].
    rewrite Forall_forall in H1.
    apply H7. transitivity c; firstorder.

    destruct H as [c ?].
    intros [?|?].
    destruct H as [? [r [??]]].
    elim H0; eauto.
    destruct H0 as [r [??]].
    destruct H.
    apply H.
    right. exists r. split; auto.
  Qed.

  Lemma sf_forced_majority (e:election) (eliminated:candidate -> Prop) :
    forall c n,
    n > 0 ->
    sf_spec.first_choices _ eliminated c e n ->
    (forall c', sf_spec.participates _ c' e -> ~eliminated c' -> c' = c) ->
    sf_spec.majority _ eliminated e c.
  Proof.
    induction e; simpl; intros.
    red; simpl; intros.
    inversion H3; subst; clear H3.
    inversion H2; subst; clear H2.
    inversion H0. subst n. omega.
    red; intros.
    assert ( winner_votes = n ) by
        (eapply sf_spec.sf_first_choices_unique; eauto).
    subst n. clear H0.
    inversion H2; clear H2; subst.
    inversion H3; clear H3; subst.
    *
    destruct n'.
    simpl.
    assert( n = 0 ).
    { cut (forall c', sf_spec.participates _ c' e -> ~eliminated c' -> c' = c).
      clear -H7 H8.
      revert n H7; induction e; intros.
      + inversion H7; subst; auto.
      + inversion H8; subst; clear H8; subst; auto.
        inversion H7; subst; clear H7; subst; auto.
        apply continuing_ballot_selects in H3.
        destruct H3 as [c' ?].
        elim H2.
        replace c with c'; auto.
        apply H; auto.
        exists a. split; simpl; auto.
        destruct H0 as [?[?[??]]].
        exists x; split; auto.
        eapply sf_spec.next_ranking_in_ballot; eauto.
        eapply sf_spec.selected_candidate_not_eliminated; eauto.
        apply IHe; eauto.
        intros. apply H; auto.
        destruct H0 as [b [??]].
        exists b; intuition.
      + intros. apply H1; auto.
        destruct H0 as [b [??]].
        exists b; intuition.
    }
    subst n. omega.
    cut (S n' * 2 > n). omega.
    eapply (IHe c (S n')); auto.
    omega.
    intros. apply H1; auto.
    destruct H0 as [b [??]].
    exists b; intuition.
  * apply continuing_ballot_selects in H5.
    destruct H5 as [c' ?].
    elim H4.
    replace c with c'; auto.
    apply H1; auto.
    destruct H0.
    destruct H2 as [r [??]].
    exists a. split; simpl; auto.
    exists r; split; simpl; auto.
    eapply sf_spec.next_ranking_in_ballot; eauto.
    assert (sf_spec.continuing_ballot _ eliminated a).
    apply continuing_ballot_selects.
    eauto.
    eapply sf_spec.selected_candidate_not_eliminated; eauto.
  * inversion H3; clear H3; subst.
    destruct H4. elim H0. auto.
    apply (IHe c winner_votes); auto.
    intros. apply H1; auto.
    destruct H0 as [b [??]].
    exists b; intuition.
  Qed.

    Lemma nonzero_first_choices_selected :
      forall (eliminated:candidate -> Prop) c e n,
        sf_spec.first_choices _ eliminated c e n ->
        n > 0 ->
        exists b, In b e /\ sf_spec.selected_candidate _ eliminated b c.
    Proof.
      intros. induction H.
      * omega.
      * simpl; eauto.
      * destruct IHfirst_choices as [b [??]]; simpl; eauto.
    Qed.

  Section sf_spec_existential_induction.
    Variable e : election.
    Variable P : (candidate -> Prop) -> Prop.
    Variable Q : (candidate -> Prop) -> candidate -> Prop.
    Variable Hbase : forall eliminated c,
       P eliminated ->
       sf_spec.majority _ eliminated e c ->
       Q eliminated c.
    Variable Hind : forall eliminated,
       P eliminated ->
       (exists c0 n, n > 0 /\ sf_spec.first_choices _ eliminated c0 e n) ->
       sf_spec.no_majority _ eliminated e ->
       exists loser,
         sf_spec.is_loser _ eliminated e loser /\
         let eliminated' := sf_spec.update_eliminated _ eliminated loser in
         P eliminated' /\
         (forall c, Q eliminated' c -> Q eliminated c).

    Lemma sf_spec_existential_induction_aux : forall
      (n:nat)
      (viable:list candidate)
      (eliminated:candidate -> Prop),
       (forall c, In c viable -> sf_spec.participates _ c e) ->
      (exists c, In c viable /\ exists n, n > 0 /\ sf_spec.first_choices _ eliminated c e n) ->
      (forall c, eliminated c <-> sf_spec.participates _ c e /\ ~In c viable) ->
      1 <= length viable <= n ->
      P eliminated ->
      exists c, Q eliminated c.
    Proof.
      induction n; [ simpl; intros; omega | ].
      intros viable eliminated Hviable ????.
      destruct (classic (exists c, sf_spec.majority _ eliminated e c)).
      * destruct H3 as [c ?].
        exists c. apply Hbase; auto.
      * destruct (Hind eliminated) as [loser [?[??]]]; auto.
        + destruct H as [c [??]]; eauto.
        + destruct (list_remove_prop candidate viable (eq loser) loser)
            as [viable' [?[??]]]; auto.
          destruct (classic (In loser viable)); auto.
          destruct H4 as [[??]?].
          elim H4. apply H0. split; auto.
          set ( eliminated' := sf_spec.update_eliminated _ eliminated loser).
          assert (Hviable' : exists c', In c' viable').
          { destruct viable'; simpl; auto.
            destruct H as [c [? [nc [??]]]].
            exists c.
            apply H8 in H. destruct H. elim H. subst c.
            elim H3. exists loser.
            apply sf_forced_majority with nc; auto.
            intros.
            destruct (H8 c'); auto.
            destruct (classic (In c' viable)); auto.
            elim H12.
            apply H0. split; auto.
            elim H13.
            eauto.
          }
          destruct (IHn viable' eliminated') as [c ?]; auto.
          - intros. apply H9 in H10. intuition.
          - destruct H as [c [? [cn [??]]]].
            destruct (classic (c = loser)).
            subst c.
            destruct Hviable' as [c' ?].
            exists c'. split; auto.
            destruct (sf_spec.sf_first_choices_total candidate eliminated' e c') as [n' ?].
            destruct (sf_spec.sf_first_choices_total candidate eliminated e c') as [n'' ?].
            exists n'; split; auto.
            cut (n'' <= n'). intro Hn''.
            cut (cn <= n'').  omega.
            { destruct H4.
              apply (H15 c'); auto.
              split.
              intro. apply H0 in H16. intuition.
              apply H19.
              apply H9 in H12; intuition.
              apply Hviable.
              apply H9 in H12. intuition.
            }
            { apply first_choices_monotone with eliminated eliminated' e c'; auto.
              intro. hnf in H15. apply H9 in H12.
              destruct H15.
              apply H0 in H15.
              intuition.
              intuition.
              intros. hnf. auto.
            }

            exists c; intuition.
            apply H8 in H. intuition.
            elim H12; auto.
            destruct (sf_spec.sf_first_choices_total candidate eliminated' e c) as [cn' ?].
            exists cn'; split; auto.
            cut (cn <= cn'). omega.
            apply first_choices_monotone with eliminated eliminated' e c; auto.
            intro. hnf in H15.
            destruct H15.
            apply H0 in H15.
            intuition.
            elim H12; auto.
            intros. hnf. auto.

          - unfold eliminated'.
            unfold sf_spec.update_eliminated.
            intuition.
            apply H0 in H12; intuition.
            apply H0 in H12; intuition.
            apply H14. apply H9. auto.
            subst c.
            destruct H4 as [[??]?]; auto.
            subst c; auto.
            apply H9 in H1.
            intuition.
            destruct (classic (c = loser)).
            subst c. auto.
            left.
            apply H0.
            split; auto.
            intros. apply H13.
            apply H8 in H14.
            intuition.
            subst. intuition.
          - split; auto.
            destruct viable'; simpl; auto.
            destruct Hviable' as [?[]].
            omega.
            omega.
          - exists c.
            apply H6. auto.
    Qed.

    Lemma sf_spec_existential_induction : forall (eliminated:candidate -> Prop),
      (forall c0, eliminated c0 -> sf_spec.participates _ c0 e) ->
      (exists c0 n, n > 0 /\ sf_spec.first_choices _ eliminated c0 e n) ->
      P eliminated -> exists c, Q eliminated c.
    Proof.
      intros.
      destruct (list_remove_prop_weak _ (all_candidates e) eliminated)
               as [viable [?[??]]].
      apply (sf_spec_existential_induction_aux (length viable) viable); auto.
      * intros. apply H4 in H5. destruct H5.
        apply (all_candidates_participates c e); auto.
      * destruct H0 as [c [n[??]]].
        exists c; split; eauto.
        destruct (nonzero_first_choices_selected eliminated c e n) as [b [??]]; auto.
        generalize (sf_spec.selected_candidate_not_eliminated _ _ b c H7); intro.
        assert ( sf_spec.participates candidate c e ).
        destruct H7.
        red; exists b. split; auto.
        destruct H9 as [r [??]].
        exists r; split; auto.
        eapply sf_spec.next_ranking_in_ballot; eauto.
        generalize (all_candidates_participates c e); intros [??].
        apply H11 in H9.
        apply H3 in H9.
        intuition.
      * intuition.
        apply H4 in H6. intuition.
        generalize (all_candidates_participates c e); intros [??].
        apply H8 in H6.
        apply H3 in H6.
        intuition.
      * intuition.
        destruct H0 as [c [n [??]]].
        destruct (nonzero_first_choices_selected eliminated c e n) as [b [??]]; auto.
        generalize (sf_spec.selected_candidate_not_eliminated _ _ b c H7); intro.
        assert ( sf_spec.participates candidate c e ).
        destruct H7.
        red; exists b. split; auto.
        destruct H9 as [r [??]].
        exists r; split; auto.
        eapply sf_spec.next_ranking_in_ballot; eauto.
        generalize (all_candidates_participates c e); intros [??].
        apply H11 in H9.
        apply H3 in H9.
        destruct H9.
        - destruct viable. elim H9.
          simpl. omega.
        - contradiction.
    Qed.

  End sf_spec_existential_induction.

  Section sf_loser_exists.
    Variable (e:election).
    Variable (eliminated:candidate -> Prop).

    Lemma sf_loser_exists_aux :
      forall (n:nat) c,
        ~eliminated c ->
        sf_spec.participates _ c e ->
        sf_spec.first_choices _ eliminated c e n ->
        exists c', sf_spec.is_loser _ eliminated e c'.
    Proof.
      induction n using (well_founded_induction lt_wf).
      intros.
      destruct (classic (exists c', ~eliminated c' /\
                           sf_spec.participates _ c' e /\
                           exists n', n' < n /\
                               sf_spec.first_choices _ eliminated c' e n')).
      * destruct H3 as [c' [?[?[n' [??]]]]].
        apply (H n') with c'; auto.
      * exists c. split; auto. split; auto.
        intros.
        destruct (classic (n0 <= m)); auto.
        destruct H4.
        elim H3. exists c'. split; auto. split; auto.
        assert( n = n0 ).
        eapply sf_spec.sf_first_choices_unique; eauto.
        subst n0.
        exists m. split; auto. omega.
    Qed.

    Lemma sf_loser_exists :
      (exists c, ~eliminated c /\ sf_spec.participates _ c e) ->
      exists c, sf_spec.is_loser _ eliminated e c.
    Proof.
      intros.
      destruct H as [c [??]].
      destruct (sf_spec.sf_first_choices_total _ eliminated e c) as [n ?].
      apply sf_loser_exists_aux with n c; auto.
    Qed.
  End sf_loser_exists.

  Theorem sf_spec_total e (eliminated:candidate -> Prop) :
    (forall c0, eliminated c0 -> sf_spec.participates _ c0 e) ->
    (exists c n, n > 0 /\ sf_spec.first_choices _ eliminated c e n) ->
    exists c, sf_spec.winner _ e eliminated c.
  Proof.
    intros.
    apply sf_spec_existential_induction with e (fun _ => True); intuition.
    * apply sf_spec.winner_now; auto.
    * destruct (sf_loser_exists e eliminated0) as [loser ?]; auto.
      + destruct H2 as [c [n [??]]].
        destruct (nonzero_first_choices_selected eliminated0 c e n) as [b [??]]; auto.
        exists c.
        generalize (sf_spec.selected_candidate_not_eliminated _ _ b c H6); intro.
        split; auto.
        destruct H6.
        red; exists b. split; auto.
        destruct H8 as [r [??]].
        exists r; split; auto.
        eapply sf_spec.next_ranking_in_ballot; eauto.
      + exists loser; intuition.
        apply sf_spec.winner_elimination with loser; auto.
  Qed.

  Definition mutual_majority_invariant (e:election) (group:list candidate) (eliminated:candidate -> Prop) :=
    exists c, In c group /\ ~eliminated c.

  Lemma majority_satisfies_monotone (P Q:ballot -> Prop) :
    forall e,
      (forall b, P b -> Q b) ->
      majority_satisfies _ P e ->
      majority_satisfies _ Q e.
  Proof.
    intros e HPQ [nmaj [ntotal [?[??]]]].
    destruct (count_monotone _ P Q e HPQ nmaj H) as [nmaj' [??]].
    exists nmaj'. exists ntotal. intuition.
  Qed.

  Lemma selected_candidate_tail (eliminated : candidate -> Prop) :
    forall a h c,
      sf_spec.does_not_select _ eliminated a ->
      sf_spec.selected_candidate _ eliminated h c ->
      sf_spec.selected_candidate _ eliminated (a :: h) c.
  Proof.
    intros. destruct H0. split.
    intro. apply H0.
    destruct H2.
    left.
    intros [q ?].
    apply H2. exists q.
    apply sf_spec.next_ranking_eliminated; auto.
    rewrite Forall_forall.
    intros.
    destruct H. subst a. elim H4.
    destruct H as [c' [?[??]]].
    rewrite Forall_forall in H.
    replace x with c'; auto.
    intros [?[?[?[??]]]].
    destruct H. subst a. elim H4.
    apply H6.
    destruct H as [c' [?[??]]].
    rewrite Forall_forall in H.
    transitivity c'; auto. symmetry; auto.
    right.
    destruct H2 as [q [??]].
    exists q; split; auto.
    inversion H2; clear H2; subst; auto.
    elimtype False.
    destruct H.
    subst q. elim H6.
    destruct H as [c' [?[??]]].
    rewrite Forall_forall in H.
    destruct H8.
    destruct H5 as [?[?[?[??]]]].
    apply H8.
    transitivity c'; auto. symmetry; auto.
    apply H5.
    replace c0 with c'; auto.

    destruct H1 as [r [??]].
    exists r; split; auto.
    apply sf_spec.next_ranking_eliminated; auto.
    rewrite Forall_forall. intros.
    destruct H. subst a. elim H3.
    destruct H as [c' [?[??]]].
    rewrite Forall_forall in H.
    replace x with c'; auto.
    intros [?[?[?[??]]]].
    apply H5.
    destruct H. subst. elim H3.
    destruct H as [c' [?[??]]].
    rewrite Forall_forall in H.
    transitivity c'; auto. symmetry; auto.
  Qed.

  Lemma sf_total_le_total (eliminated : candidate -> Prop) :
    forall e n n',
      sf_spec.total_selected _ eliminated e n ->
      total_votes _ e n' ->
      n <= n'.
  Proof.
    induction e; intros.
    inversion H. inversion H0. auto.
    inversion H; subst; clear H;
    inversion H0; subst; clear H0; auto.
    cut (n0 <= n). omega.
    apply IHe; auto.
    elim H2.
    rewrite (continuing_ballot_selects a eliminated) in H3.
    destruct H3 as [c ?].
    clear -H.
    destruct H. destruct H0 as [r [??]].
    induction H0.
    rewrite Forall_forall in H0.
    destruct r'.
    destruct IHnext_ranking as [c' ?]; auto.
    { intro. elim H.
      destruct H4.
      left. intros [q ?].
      apply H4. exists q.
      inversion H5; clear H5; subst; auto.
      elim H8.
      destruct H4 as [q [??]].
      right. exists q; split; auto.
      apply sf_spec.next_ranking_eliminated; auto.
    }
    exists c'.
    apply first_skip. auto.
    exists c0. apply first_top.
    split; simpl; auto.
    intros.
    destruct (classic (c0 = c')); auto.
    elim H2.
    exists c0, c'. simpl; intuition.
    exists c.
    apply first_top.
    split; auto.
    intros.
    destruct (classic (c = c')); auto.
    elim H.
    right.
    exists r.
    split.
    apply sf_spec.next_ranking_valid with c0; auto.
    exists c. exists c'; intuition.
  Qed.

  Theorem sf_mutual_majority :
    mutual_majority_criterion candidate sf_may_win_election.
  Proof.
    red; intros. red.
    cut (forall (eliminated:candidate -> Prop) c,
           mutual_majority_invariant e group eliminated ->
           sf_spec.winner _ e eliminated c ->
           In c group).
    { intuition.
      destruct (sf_spec_total e (fun _ => False)).
      intuition.
      destruct (majority_satisfies_ballot_exists _ _ H0) as [b [??]].
      red in H2.
      destruct H as [[cin ?] [cout ?]].
      generalize (H2 cin cout H H4); intros.
      clear -H2 H3 H5.
      { induction e; intros.
      * elim H3.
      * simpl in H3. destruct H3.
        + clear IHe. subst b.
          clear H2.
          induction H5.
          - destruct (sf_spec.sf_first_choices_total _ (fun _ => False) ((r::b) :: e) cin) as [n ?].
            exists cin. exists n. split; auto.
            inversion H0; subst; clear H0.
            omega.
            elim H3; clear H3. split.
            intro. destruct H0.
            apply H0.
            exists r.
            apply sf_spec.next_ranking_valid with cin; auto.
            destruct H. auto.
            destruct H0 as [r' [??]].
            assert (r = r').
            eapply sf_spec.next_ranking_unique; eauto.
            apply sf_spec.next_ranking_valid with cin.
            destruct H; auto.
            right; auto.
            subst r'.
            destruct H.
            destruct H1 as [c1 [c2 [?[??]]]].
            elim H4.
            transitivity cin; firstorder.
            exists r. split; auto.
            apply sf_spec.next_ranking_valid with cin.
            destruct H; auto.
            right; auto.
            destruct H; auto.
          - destruct IHprefers as [c [n [??]]].
            exists c. exists n. split; auto.
            inversion H0; subst; clear H0.
            apply sf_spec.first_choices_selected.
            destruct H3. split.
            intro. apply H0.
            destruct H2.
            left. intro.
            apply H2.
            destruct H3 as [r ?].
            exists r. apply sf_spec.next_ranking_eliminated.
            rewrite Forall_forall. simpl; auto.
            intros [?[?[??]]]. elim H4.
            auto.
            right.
            destruct H2 as [r [??]].
            exists r; split; auto.
            inversion H2; subst; clear H2.
            auto.
            destruct H3 as [?[?[??]]]. elim H2.
            destruct H1 as [r [??]].
            exists r; split; auto.
            apply sf_spec.next_ranking_eliminated.
            rewrite Forall_forall. simpl; auto.
            intros [?[?[??]]]. elim H3.
            auto.
            auto.
            apply sf_spec.first_choices_not_selected; auto.
            intro. apply H3.
            destruct H0. split.
            intro. apply H0.
            destruct H2. left.
            intro. apply H2.
            destruct H4 as [r ?].
            exists r.
            inversion H4; subst; clear H4.
            auto.
            elim H9.
            right.
            destruct H2 as [r [??]].
            exists r; split; auto.
            apply sf_spec.next_ranking_eliminated.
            rewrite Forall_forall; auto.
            intros [?[?[??]]]. elim H7.
            auto.
            destruct H1 as [r [??]].
            exists r. split; auto.
            inversion H1; subst; clear H1.
            auto.
            elim H2.
          - destruct IHprefers as [c [n [??]]].
            destruct (sf_spec.sf_first_choices_total _ (fun _ => False) ((r::b)::e) c').
            exists c'. exists x. split; auto.
            inversion H4; subst; clear H4.
            omega.
            elim H8.
            split.
            intro. destruct H4.
            apply H4.
            exists r.
            apply sf_spec.next_ranking_valid with c'.
            destruct H1. auto.
            auto.
            destruct H4 as [r' [??]].
            inversion H4; subst; clear H4.
            destruct H1.
            rewrite Forall_forall in H11.
            apply H11 in H1. auto.
            destruct H6 as [?[?[?[??]]]].
            destruct H1.
            elim H7.
            transitivity c'; auto.
            symmetry; auto.
            exists r; split; auto.
            2: destruct H1; auto.
            apply sf_spec.next_ranking_valid with c'.
            destruct H1; auto.
            auto.

        + destruct IHe as [c [n [??]]]; auto.
          destruct (classic (sf_spec.selected_candidate _ (fun _ => False) a c)).
          exists c. exists (S n).
          split. omega.
          apply sf_spec.first_choices_selected; auto.
          exists c. exists n.
          split; auto.
          apply sf_spec.first_choices_not_selected; auto.
      }

      exists x; split; auto.
      apply (H1 (fun _ => False)); auto.
      red.
      destruct H.
      destruct H as [c ?]. eauto.
      apply (H1 (fun _ => False)); auto.
      red; simpl; auto.
      destruct H.
      destruct H as [c' ?]. eauto.
    }

    intros.
    induction H2.

    (* a winning candidate is always selected from the group *)
    * red in H0.
      red in H2.
      destruct H0 as [n [t [?[??]]]].

      destruct (sf_spec.sf_first_choices_total _ eliminated election0 winning_candidate) as [nwin ?].
      destruct (sf_spec.total_selected_total _ eliminated election0) as [ntotal ?].
      assert (nwin * 2 > ntotal) by (apply H2; auto). clear H2.
      destruct (classic (In winning_candidate group)); auto.
      elimtype False.
      destruct H1 as [cg [??]].
      assert( ntotal <= t ).
      { eapply sf_total_le_total; eauto. }
      assert( ntotal < n + nwin ) by omega.
      assert( n + nwin <= ntotal ).
      { revert cg H1 H8 H0 H2 H5 H6. clear. revert n nwin ntotal.
        induction election0; simpl; intros.
        * inversion H0; subst; clear H0.
          inversion H5; subst; clear H5.
          simpl. omega.
        * inversion H6; clear H6; subst.
          inversion H0; clear H0; subst;
          inversion H5; clear H5; subst.
          { elimtype False.
            hnf in H6.
            generalize (H6 cg winning_candidate H1 H2); intro.
            clear IHelection0 H9 H10 H11.
            assert (Hnelim : ~eliminated winning_candidate) by
                (eapply sf_spec.selected_candidate_not_eliminated; eauto).
            clear H6.
            induction H.
          - inversion H3; clear H3; subst.
            destruct H5 as [r' [??]].
            destruct H.
            inversion H3; clear H3; subst.
            rewrite Forall_forall in H10.
            elim H8. apply H10. auto.
            elim H2.
            replace winning_candidate with cg; auto.
          - apply IHprefers; auto.
            intro. apply H4.
            destruct H0.
            left. intros [q ?]. apply H0. exists q.
            inversion H5; clear H5; subst. auto.
            elim H9.
            right.
            destruct H0 as [q [??]].
            exists q. split; auto.
            constructor.
            rewrite Forall_forall. simpl. intuition.
            intro. destruct H6 as [?[?[??]]]. elim H6.
            auto.
            destruct H3. split; auto.
            intro. apply H0.
            clear -H5.
            destruct H5.
            left.
            intros [r ?].
            apply H. exists r. inversion H0; subst; auto.
            elim H3.
            right.
            destruct H as [r [??]].
            exists r; split; auto.
            constructor; auto.
            intros [?[?[??]]]. elim H1.
            destruct H3 as [r [??]].
            exists r; split; auto.
            inversion H3; clear H3; subst; auto.
            elim H9.
          - destruct H3.
            destruct H7 as [q [??]].
            inversion H7; clear H7; subst.
            assert (sf_spec.continuing_ballot candidate eliminated b).
            { intro. destruct H7.
              apply H7; eauto.
              destruct H7 as [q' [??]].
              apply H3.
              right.
              exists q'. split; auto.
              apply sf_spec.next_ranking_eliminated; auto.
            }
            apply IHprefers; auto.
            split; auto.
            exists q; split; auto.
            destruct H5.
            apply H0.
            apply H7. auto.
          }

          - cut (n1 + nwin <= n0). omega.
            eapply IHelection0; eauto.
          - cut (n + n' <= n0). omega.
            eapply IHelection0; eauto.
          - cut (n + nwin <= n0). omega.
            eapply IHelection0; eauto.
          - inversion H5; clear H5; subst; auto.
            elimtype False.
            destruct H6.
            apply H; auto.
            inversion H0; clear H0; subst; auto.
            hnf in H5.
            elimtype False.
            generalize (H5 cg winning_candidate H1 H2).
            clear H11 H5 n0 H10 H6 H9.
            intro.
            induction H.
            destruct H4.
            elim H0. exists r.
            apply sf_spec.next_ranking_valid with cg.
            destruct H; auto.
            right; auto.
            destruct H0 as [q [??]].
            inversion H0; clear H0; subst.
            rewrite Forall_forall in H6.
            apply H8. apply H6.
            destruct H; auto.
            destruct H3 as [?[?[?[??]]]].
            destruct H.
            apply H4.
            transitivity cg; auto.
            symmetry; auto.
            apply IHprefers.
            destruct H4.
            left; intro.
            apply H0.
            destruct H3 as [q ?].
            exists q.
            apply sf_spec.next_ranking_eliminated.
            rewrite Forall_forall. simpl. intuition.
            intros [?[?[?[??]]]]. elim H4.
            auto.
            right.
            destruct H0 as [q [??]].
            exists q. split; auto.
            inversion H0; clear H0; subst.
            auto.
            elim H6.
            destruct (classic (eliminated c')).
            apply IHprefers.
            destruct H4.
            left.
            intros [q ?].
            apply H4.
            exists q.
            apply sf_spec.next_ranking_eliminated.
            rewrite Forall_forall.
            intros.
            destruct H3.
            replace x with c'; auto.
            intros [?[?[?[??]]]].
            apply H11; auto.
            destruct H3.
            transitivity c'; auto. symmetry; auto.
            auto.
            destruct H4 as [q [??]].
            right.
            exists q.
            split; auto.
            inversion H4; clear H4; subst; auto.
            destruct H13.
            destruct H4 as [?[?[?[??]]]].
            elim H10.
            destruct H3.
            transitivity c'; auto. symmetry; auto.
            elim H4.
            replace c with c'; auto.
            destruct H3; auto.
            destruct H4.
            apply H4.
            exists r.
            apply sf_spec.next_ranking_valid with c'; auto.
            destruct H3; auto.
            destruct H4 as [q [??]].
            inversion H4; clear H4; subst; auto.
            rewrite Forall_forall in H11.
            apply H6. apply H11. destruct H3; auto.
            destruct H7 as [?[?[?[??]]]].
            apply H9.
            destruct H3.
            transitivity c'; auto. symmetry; auto.
            eapply IHelection0; eauto.
      }
      omega.

    (* After every elimination, some member from the group remains in the running, because otherwise the last
       remaining member of the group must have had a majority. *)
    * apply IHwinner; auto. clear IHwinner. hnf.
      destruct (classic (exists c, In c group /\ ~eliminated' c)); auto.
      assert (forall c, In c group -> eliminated' c).
      intros.
      destruct (classic (eliminated' c)); auto.
      elim H5; eauto.
      elimtype False. clear H5.
      unfold eliminated' in H6.
      unfold sf_spec.update_eliminated in H6.
      elim H2.
      destruct H1 as [winner [??]].
      exists winner.
      hnf; intros.
      destruct H0 as [n [t [?[??]]]].
      assert (n <= winner_votes).
      {
        assert (winner = loser).
        {
          destruct (H6 _ H1); auto.
          elim H5; auto.
        }
        clear -H H0 H1 H5 H6 H8 H11.
        subst loser.
        revert n H0. induction H8; intros.
        * inversion H0; clear H0; subst; auto.
        * inversion H2; clear H2; subst; auto.
          cut (n0 <= n'). omega.
          apply IHfirst_choices; auto.
        * inversion H2; clear H2; subst; auto.
          elim H0.
          clear t n n1 IHfirst_choices H0 H8 H10.
          destruct H as [_ [cOther ?]].
          specialize (H7 winner).
          induction h.
          - generalize (H7 cOther H1 H).
            intros. inversion H0.
          - destruct (sf_spec.ranking_cases _ eliminated a) as [?|[?|?]].
            + generalize (H7 cOther H1 H); intros.
              inversion H2; clear H2; subst.
              destruct H0 as [?[?[?[??]]]].
              elim H3. destruct H4.
              transitivity winner; auto. symmetry; auto.
              destruct H0 as [?[?[?[??]]]]. elim H0.
              destruct H0 as [?[?[?[??]]]].
              destruct H10.
              elim H3.
              transitivity c'; auto. symmetry; auto.
            + destruct H0 as [c [?[??]]].
              assert (c = winner).
              { destruct (classic (In c group)).
                apply H6 in H4. intuition.
                generalize (H7 c H1 H4). intros.
                inversion H8; clear H8; subst.
                destruct H10.
                symmetry; auto.
                inversion H2.
                elim H12.
                destruct H13. auto.
              }
              subst c.
              split.
              intros [?|?].
              elim H4.
              exists a. apply sf_spec.next_ranking_valid with winner; auto.
              destruct H4 as [q [??]].
              inversion H4; clear H4; subst.
              rewrite Forall_forall in H11.
              elim H5. apply H11. auto.
              rewrite Forall_forall in H0.
              destruct H8 as [?[?[?[??]]]].
              elim H9.
              transitivity winner; auto. symmetry; auto.

              exists a; split; auto.
              apply sf_spec.next_ranking_valid with winner; auto.
            +
              apply selected_candidate_tail; auto.
              apply IHh.
              intros.
              generalize (H7 cout H2 H3).
              intros.
              inversion H4; clear H4; subst; auto.
              destruct H0.
              subst a. destruct H9. elim H0.
              destruct H0 as [c' [?[??]]].
              rewrite Forall_forall in H0.
              destruct H9.
              assert (c' = winner) by auto.
              subst c'.
              elim H5; auto.
      }
      assert (total_votes <= t).
      { eapply sf_total_le_total; eauto. }
      omega.
  Qed.
End sf_spec_properties.

Check sf_mutual_majority.
Print Assumptions sf_mutual_majority.

Check sf_spec_total.
Print Assumptions sf_spec_total.


(**************************************************************
 Composition

 We show that the pullback functor has a left biadjoint using
 universal arrows. The left biadjoint is given on objects by
 composition.

 Contents
 1. Action on objects
 2. The unit
 3. Fullness
 4. Faithfulness
 5. Essentially surjective
 6. Universal arrow
 **************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Import Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.PullbackFunctor.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Import PullbackFunctions.Notations.

Local Open Scope cat.

Section Composition.
  Context {B : bicat_with_pb}
          (HB : is_univalent_2_1 B)
          {b₁ b₂ : B}
          (f : b₁ --> b₂).

  (**
   1. Action on objects
   *)
  Definition comp_ob
    : slice_bicat b₁ → slice_bicat b₂
    := λ h, make_ob_slice (pr2 h · f).

  (**
   2. The unit
   *)
  Definition comp_unit_mor
             {x : B}
             (h : x --> b₁)
    : x --> f /≃ (h · f)
    := h ⊗[ linvunitor_invertible_2cell (h · f) ] (id₁ x).

  Definition comp_unit_inv2cell
             {x : B}
             (h : x --> b₁)
    : invertible_2cell
        h
        (comp_unit_mor h · pr2 (pb_psfunctor B f (comp_ob (make_ob_slice h))))
    := inv_of_invertible_2cell
         (mor_to_pb_obj_pr1
            h (id₁ x)
            (linvunitor_invertible_2cell (h · f))).

  Definition comp_unit
             (h : slice_bicat b₁)
    : h --> pb_psfunctor B f (comp_ob h).
  Proof.
    use make_1cell_slice.
    - exact (comp_unit_mor (pr2 h)).
    - exact (comp_unit_inv2cell (pr2 h)).
  Defined.

  (**
   3. Fullness
   *)
  Definition comp_full_cell
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α β : comp_ob h₁ --> h₂)
             (p : comp_unit h₁ · # (pb_psfunctor B f) α
                  ==>
                  comp_unit h₁ · # (pb_psfunctor B f) β)
    : pr1 α ==> pr1 β
    := linvunitor _
       • ((mor_to_pb_obj_pr2 _ _ _)^-1 ▹ _)
       • rassociator _ _ _
       • (_ ◃ (pb_on_1cell_pr2 f (pr2 α))^-1)
       • lassociator _ _ _
       • (pr1 p ▹ π₂)
       • rassociator _ _ _
       • (_ ◃ pb_on_1cell_pr2 _ _)
       • lassociator _ _ _
       • (mor_to_pb_obj_pr2 _ _ _ ▹ _)
       • lunitor _.

  Definition comp_full_homot
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α β : comp_ob h₁ --> h₂)
             (p : comp_unit h₁ · # (pb_psfunctor B f) α
                  ==>
                  comp_unit h₁ · # (pb_psfunctor B f) β)
    : cell_slice_homot α β (comp_full_cell α β p).
  Proof.
    unfold cell_slice_homot.
    unfold comp_full_cell.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocr.
    do 5 (use vcomp_move_R_Mp ; [ is_iso ; apply property_from_invertible_2cell | ]).
    cbn.
    use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ].
    rewrite !vassocl.
    rewrite rwhisker_rwhisker_alt.
    use (vcomp_rcancel (_ ◃ (pb_cell _ _)^-1)) ; [ is_iso | ].
    rewrite !vassocl.
    rewrite vcomp_whisker.
    use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ].
    rewrite !vassocl.
    rewrite <- rwhisker_rwhisker.
    assert (pr1 p ▹ π₁
            =
            rassociator _ _ _
            • (_ ◃ pb_on_1cell_pr1 f (pr2 α))
            • (_ ◃ (pb_on_1cell_pr1 f (pr2 β))^-1)
            • lassociator _ _ _)
      as H.
    {
      pose (pr2 p) as d.
      cbn in d.
      rewrite !vassocl.
      use vcomp_move_L_pM ; [ is_iso | ].
      use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ].
      cbn.
      use (vcomp_lcancel ((mor_to_pb_obj_pr1 _ _ _) ^-1)) ; [ is_iso | ].
      rewrite !vassocl in d.
      exact d.
    }
    etrans.
    {
      do 10 apply maponpaths.
      exact H.
    }
    clear H.
    refine (!_).
    etrans.
    {
      do 5 apply maponpaths.
      rewrite !vassocr.
      etrans.
      {
        do 2 apply maponpaths_2.
        rewrite rwhisker_hcomp.
        rewrite inverse_pentagon_2.
        apply idpath.
      }
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocl.
      rewrite <- lassociator_lassociator.
      apply idpath.
    }
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    do 3 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 15 apply maponpaths.
      exact (pb_on_1cell_cell f (pr2 β)).
    }
    rewrite !vassocr.
    use vcomp_move_R_Mp.
    {
      is_iso ; apply property_from_invertible_2cell.
    }
    cbn.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite <- rwhisker_lwhisker_rassociator.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite <- rwhisker_lwhisker_rassociator.
    etrans.
    {
      do 8 apply maponpaths.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_hcomp.
      rewrite !vassocl.
      rewrite <- inverse_pentagon_4.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    etrans.
    {
      do 5 apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      do 3 apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- rassociator_rassociator.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 4 apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      do 3 apply maponpaths.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      rewrite rassociator_rassociator.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    use vcomp_move_R_Mp ; [ is_iso | ].
    cbn.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 10 apply maponpaths.
      apply mor_to_pb_obj_cell.
    }
    rewrite !vassocl.
    rewrite lwhisker_lwhisker_rassociator.
    rewrite !vassocr.
    apply maponpaths_2.
    do 7 (use vcomp_move_R_Mp ; [ is_iso ; apply property_from_invertible_2cell | ]).
    cbn.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 12 apply maponpaths.
      apply pb_on_1cell_cell.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite <- rwhisker_lwhisker_rassociator.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    etrans.
    {
      do 9 apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite vassocl.
      apply idpath.
    }
    rewrite <- lunitor_triangle.
    etrans.
    {
      do 4 apply maponpaths.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      apply idpath.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    use vcomp_move_R_Mp ; [ is_iso | ].
    cbn.
    refine (!_).
    etrans.
    {
      rewrite !vassocl.
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite rassociator_rassociator.
      apply idpath.
    }
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      apply idpath.
    }
    use (vcomp_lcancel (lunitor _)) ; [ is_iso | ].
    rewrite !vassocr.
    rewrite <- !vcomp_lunitor.
    rewrite <- !lunitor_triangle.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lunitor_linvunitor.
      rewrite id2_rwhisker.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      rewrite <- lwhisker_lwhisker_rassociator.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lunitor_linvunitor.
      rewrite id2_rwhisker.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite <- vcomp_whisker.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite lwhisker_vcomp.
    rewrite vcomp_rinv.
    rewrite lwhisker_id2.
    rewrite id2_left.
    rewrite !vassocl.
    etrans.
    {
      do 5 apply maponpaths.
      apply mor_to_pb_obj_cell.
    }
    rewrite !vassocl.
    etrans.
    {
      do 4 apply maponpaths.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      rewrite id2_left.
      cbn.
      apply idpath.
    }
    rewrite linvunitor_assoc.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lunitor_linvunitor.
      rewrite id2_rwhisker.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_rinv.
      rewrite id2_rwhisker.
      apply id2_left.
    }
    rewrite !vassocr.
    rewrite lassociator_rassociator.
    apply id2_left.
  Qed.

  Definition comp_full
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α β : comp_ob h₁ --> h₂)
             (p : comp_unit h₁ · # (pb_psfunctor B f) α
                  ==>
                  comp_unit h₁ · # (pb_psfunctor B f) β)
    : α ==> β.
  Proof.
    use make_2cell_slice.
    - exact (comp_full_cell α β p).
    - exact (comp_full_homot α β p).
  Defined.

  Definition comp_full_eq
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α β : comp_ob h₁ --> h₂)
             (p : comp_unit h₁ · # (pb_psfunctor B f) α
                  ==>
                  comp_unit h₁ · # (pb_psfunctor B f) β)
    : comp_unit h₁ ◃ ## (pb_psfunctor B f) (comp_full α β p) = p.
  Proof.
    use eq_2cell_slice.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot ; cbn.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        rewrite lassociator_rassociator.
        apply id2_right.
      }
      rewrite <- vcomp_whisker.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    - cbn.
      use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite <- rwhisker_lwhisker.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        apply pb_on_2cell_pr1.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ].
      cbn.
      use (vcomp_lcancel
             (mor_to_pb_obj_pr1
                (pr2 h₁) (id₁ _)
                (linvunitor_invertible_2cell _)^-1)).
      {
        is_iso.
      }
      rewrite !vassocr.
      refine (!_).
      pose (pr2 p) as p'.
      cbn in p'.
      rewrite !vassocr in p'.
      exact p'.
    - cbn.
      use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite <- rwhisker_lwhisker.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        apply pb_on_2cell_pr2.
      }
      rewrite <- !lwhisker_vcomp.
      use vcomp_move_R_Mp ; [ is_iso | ].
      use vcomp_move_R_Mp ; [ is_iso | ].
      use vcomp_move_R_pM ; [ is_iso ; apply property_from_invertible_2cell | ].
      cbn.
      rewrite !vassocl.
      use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ].
      use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ].
      use (vcomp_lcancel ((mor_to_pb_obj_pr2 _ _ _)^-1 ▹ _)) ; [ is_iso | ].
      use (vcomp_rcancel (mor_to_pb_obj_pr2 _ _ _ ▹ _)).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      use (vcomp_lcancel (linvunitor _)) ; [ is_iso | ].
      use (vcomp_rcancel (lunitor _)) ; [ is_iso | ].
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      rewrite vcomp_lunitor.
      etrans.
      {
        rewrite !vassocr.
        rewrite linvunitor_lunitor.
        apply id2_left.
      }
      rewrite !vassocr.
      apply idpath.
  Qed.

  (**
   4. Faithfulness
   *)
  Definition comp_faithful
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             {α β : comp_ob h₁ --> h₂}
             (p : comp_unit h₁ · # (pb_psfunctor B f) α
                  ==>
                  comp_unit h₁ · # (pb_psfunctor B f) β)
             (q₁ q₂ : α ==> β)
             (r₁ : comp_unit h₁ ◃ ## (pb_psfunctor B f) q₁ = p)
             (r₂ : comp_unit h₁ ◃ ## (pb_psfunctor B f) q₂ = p)
    : q₁ = q₂.
  Proof.
    use eq_2cell_slice.
    assert (comp_unit_mor (pr2 h₁) ◃ (π₂ ◃ pr1 q₁)
            =
            comp_unit_mor (pr2 h₁) ◃ (π₂ ◃ pr1 q₂))
      as H₁.
    {
      pose (H := maponpaths
                    (λ z, lassociator _ _ _ • (z ▹ π₂))
                    (maponpaths pr1 r₁ @ !(maponpaths pr1 r₂))).
      cbn in H.
      rewrite <- !rwhisker_lwhisker in H.
      rewrite !pb_on_2cell_pr2 in H.
      rewrite <- !lwhisker_vcomp in H.
      rewrite !vassocl in H.
      use (vcomp_lcancel (comp_unit_mor (pr2 h₁) ◃ pb_on_1cell_pr2 f (pr2 α))).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      use (vcomp_rcancel (comp_unit_mor (pr2 h₁) ◃ (pb_on_1cell_pr2 f (pr2 β)) ^-1)).
      {
        is_iso.
      }
      use (vcomp_rcancel (lassociator _ _ _)).
      {
        is_iso.
      }
      rewrite !vassocl.
      exact H.
    }
    pose (maponpaths (λ z, rassociator _ _ _ • z • lassociator _ _ _) H₁) as H₂.
    cbn in H₂.
    rewrite !vassocl in H₂.
    rewrite !lwhisker_lwhisker in H₂.
    rewrite !vassocr in H₂.
    rewrite !rassociator_lassociator in H₂.
    rewrite !id2_left in H₂.
    unfold comp_unit_mor in H₂.
    pose (maponpaths (λ z, z • (mor_to_pb_obj_pr2 _ _ _ ▹ _)) H₂) as H₃.
    cbn in H₃.
    rewrite <- !vcomp_whisker in H₃.
    use (vcomp_lcancel (lunitor _)) ; [ is_iso | ].
    rewrite <- !vcomp_lunitor.
    apply maponpaths_2.
    use (vcomp_lcancel
           (mor_to_pb_obj_pr2 _ _ (linvunitor_invertible_2cell (pr2 h₁ · f)) ▹ _)).
    {
      is_iso.
      apply property_from_invertible_2cell.
    }
    exact H₃.
  Qed.

  (**
   5. Essentially surjective
   *)
  Definition comp_essentially_surj_mor
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : pr1 h₁ --> pr1 h₂
    := pr1 α · π₂.

  Definition comp_essentially_surj_mor_inv2cell
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : invertible_2cell
        (pr2 h₁ · f)
        (comp_essentially_surj_mor α · pr2 h₂)
    := comp_of_invertible_2cell
         (rwhisker_of_invertible_2cell _ (pr2 α))
         (comp_of_invertible_2cell
            (rassociator_invertible_2cell _ _ _)
            (comp_of_invertible_2cell
               (lwhisker_of_invertible_2cell
                  _
                  (pb_cell _ _))
               (lassociator_invertible_2cell _ _ _))).

  Definition comp_essentially_surj
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : comp_ob h₁ --> h₂.
  Proof.
    use make_1cell_slice.
    - exact (comp_essentially_surj_mor α).
    - exact (comp_essentially_surj_mor_inv2cell α).
  Defined.

  Section EssentiallySurjective.
    Context {h₁ : slice_bicat b₁}
            {h₂ : slice_bicat b₂}
            (α : h₁ --> pb_psfunctor B f h₂).

    Local Arguments lassociator {_ _ _ _ _ _ _ _}.
    Local Arguments rassociator {_ _ _ _ _ _ _ _}.

    Definition comp_essentially_surj_cell_pr1
      : comp_unit_mor (pr2 h₁) · (f /≃₁ comp_essentially_surj_mor_inv2cell α) · π₁
        ==>
        pr1 α · π₁
      := rassociator
         • (_ ◃ pb_on_1cell_pr1 _ _)
         • mor_to_pb_obj_pr1 _ _ _
         • pr12 α.

    Definition comp_essentially_surj_cell_pr2
      : comp_unit_mor (pr2 h₁) · (f /≃₁ comp_essentially_surj_mor_inv2cell α) · π₂
        ==>
        pr1 α · π₂
      := rassociator
         • (_ ◃ pb_on_1cell_pr2 _ _)
         • lassociator
         • (mor_to_pb_obj_pr2 _ _ _ ▹ _)
         • lunitor _.

    Definition comp_essentially_surj_cell_eq
      : (_ ◃ pb_cone_cell _)
        • lassociator
        • (comp_essentially_surj_cell_pr2 ▹ _)
        • rassociator
        =
        lassociator
        • (comp_essentially_surj_cell_pr1 ▹ _)
        • rassociator
        • (pr1 α ◃ pb_cone_cell _).
    Proof.
      use (vcomp_lcancel lassociator) ; [ is_iso | ].
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths_2.
        apply maponpaths.
        apply pb_on_1cell_cell.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        apply maponpaths_2.
        unfold comp_unit_mor.
        apply mor_to_pb_obj_cell.
      }
      cbn.
      rewrite !vassocr.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        do 9 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- lassociator_lassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rassociator_lassociator.
        rewrite lwhisker_id2.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 11 apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          unfold comp_essentially_surj_cell_pr2 .
          rewrite !vassocr.
          rewrite lassociator_rassociator.
          rewrite id2_left.
          apply idpath.
        }
        rewrite <- !rwhisker_vcomp.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        rewrite lwhisker_id2.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        do 10 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_lassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        do 4 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          rewrite !vassocl.
          rewrite !lwhisker_vcomp.
          rewrite lwhisker_lwhisker_rassociator.
          apply idpath.
        }
        rewrite !vassocl.
        rewrite rassociator_lassociator.
        apply id2_right.
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocl.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_triangle.
        apply idpath.
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_lunitor.
        apply idpath.
      }
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite linvunitor_lunitor.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      rewrite lassociator_rassociator.
      rewrite id2_right.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !rwhisker_vcomp.
      apply maponpaths.
      rewrite !vassocl.
      unfold comp_essentially_surj_cell_pr1.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    Qed.

    Definition comp_essentially_surj_cell
      : comp_unit_mor (pr2 h₁) · (f /≃₁ comp_essentially_surj_mor_inv2cell α)
        ==>
        pr1 α.
    Proof.
      use pb_ump_cell.
      - apply (pr2 B b₁ (pr1 h₂) b₂ f (pr2 h₂)).
      - exact comp_essentially_surj_cell_pr1.
      - exact comp_essentially_surj_cell_pr2.
      - exact comp_essentially_surj_cell_eq.
    Defined.
  End EssentiallySurjective.

  Definition comp_essentially_surj_cell_homot
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : cell_slice_homot
        (comp_unit h₁ · # (pb_psfunctor B f) (comp_essentially_surj α))
        α
        (comp_essentially_surj_cell α).
  Proof.
    unfold cell_slice_homot.
    cbn.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      apply pb_ump_cell_pr1.
    }
    unfold comp_essentially_surj_cell_pr1.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite vcomp_linv.
    apply id2_left.
  Qed.

  Definition comp_essentially_surj_cell_slice
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : comp_unit h₁ · # (pb_psfunctor B f) (comp_essentially_surj α)
      ==>
      α.
  Proof.
    use make_2cell_slice.
    - exact (comp_essentially_surj_cell α).
    - exact (comp_essentially_surj_cell_homot α).
  Defined.

  Definition comp_essentially_surj_is_inv2cell
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : is_invertible_2cell (comp_essentially_surj_cell_slice α).
  Proof.
    use is_invertible_2cell_in_slice_bicat.
    cbn.
    use is_invertible_2cell_pb_ump_cell.
    - unfold comp_essentially_surj_cell_pr1.
      is_iso.
      + apply property_from_invertible_2cell.
      + apply property_from_invertible_2cell.
      + apply property_from_invertible_2cell.
    - unfold comp_essentially_surj_cell_pr2.
      is_iso.
      + apply property_from_invertible_2cell.
      + apply property_from_invertible_2cell.
  Defined.

  Definition comp_essentially_surj_inv2cell
             {h₁ : slice_bicat b₁}
             {h₂ : slice_bicat b₂}
             (α : h₁ --> pb_psfunctor B f h₂)
    : invertible_2cell
        (comp_unit h₁ · # (pb_psfunctor B f) (comp_essentially_surj α))
        α.
  Proof.
    use make_invertible_2cell.
    - exact (comp_essentially_surj_cell_slice α).
    - exact (comp_essentially_surj_is_inv2cell α).
  Defined.

  (**
   6. Universal arrow
   *)
  Definition pb_left_universal_arrow
    : left_universal_arrow (pb_psfunctor B f).
  Proof.
    use make_left_universal_arrow'.
    - use is_univalent_2_1_slice_bicat.
      exact HB.
    - exact comp_ob.
    - exact comp_unit.
    - exact (λ h₁ h₂ α β p,
             comp_full _ _ p ,, comp_full_eq _ _ p).
    - exact @comp_faithful.
    - exact (λ h₁ h₂ α, comp_essentially_surj α ,, comp_essentially_surj_inv2cell α).
  Defined.
End Composition.


Require Import rt.util.all.
Require Import rt.model.suspension.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence.
Require Import rt.model.schedule.uni.schedule.
Require Import rt.model.schedule.uni.susp.last_execution.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module SuspensionIntervals.

  Export Job UniprocessorSchedule Suspension LastExecution.

  (* In this section we define job suspension intervals in a schedule. *)
  Section DefiningSuspensionIntervals.

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

    (* Consider any job suspension times... *)
    Variable next_suspension: job_suspension Job.

    (* ...and any uniprocessor schedule. *)
    (*Context {arr_seq: arrival_sequence Job}.*)
    Variable sched: schedule Job.

    (* For simplicity, let's define some local names. *)
    Let job_scheduled_at := scheduled_at sched.
    Let job_completed_by := completed_by job_cost sched.

    (* Based on the time after the last execution of a job, we define next
       whether a job is suspended. *)
    Section JobSuspension.

      (* Let j be any job. *)
      Variable j: Job.

      Section DefiningSuspension.

        (* We are going to define whether job j is suspended at time t. *)
        Variable t: time.

        (* First, we define the beginning of the latest self suspension as the
           time following the last execution of job j in the interval [0, t).
           (Note that suspension_start can return time t itself.) *)
        Let suspension_start := time_after_last_execution job_arrival sched j t.

        (* Next, using the service received by j in the interval [0, suspension_start), ... *)
        Let current_service := service sched j suspension_start.

        (* ... we recall the duration of the suspension expected for job j after having
           received that amount of service. *)
        Definition suspension_duration := next_suspension j current_service.

        (* Then, we say that job j is suspended at time t iff j has not completed
           by time t and t lies in the latest suspension interval.
           (Also note that the suspension interval can have duration 0, in which
            case suspended_at will be trivially false.)                         *)
        Definition suspended_at :=
          ~~ completed_by job_cost sched j t &&
          (suspension_start <= t < suspension_start + suspension_duration).

      End DefiningSuspension.

      (* Based on the notion of suspension, we also define the cumulative
         suspension time of job j in any interval [t1, t2)... *)
      Definition cumulative_suspension_during (t1 t2: time) :=
        \sum_(t1 <= t < t2) (suspended_at t).

      (* ...and the cumulative suspension time in any interval [0, t). *)
      Definition cumulative_suspension (t: time) := cumulative_suspension_during 0 t.

    End JobSuspension.

    (* Next, we define whether the schedule respects self-suspensions. *)
    Section SuspensionAwareSchedule.

      (* We say that the schedule respects self-suspensions iff suspended
         jobs are never scheduled. *)
      Definition respects_self_suspensions :=
        forall j t,
          job_scheduled_at j t -> ~ suspended_at j t.

    End SuspensionAwareSchedule.

    (* In this section, we prove several results related to job suspensions. *)
    Section Lemmas.

      (* First, we prove that at any time within any suspension interval,
         a job is always suspended. *)
      Section InsideSuspensionInterval.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job. *)
        Variable j: Job.

        (* Consider any time t after the arrival of j... *)
        Variable t: time.
        Hypothesis H_has_arrived: has_arrived job_arrival j t.

        (* ...and recall the latest suspension interval of job j relative to time t. *)
        Let suspension_start := time_after_last_execution job_arrival sched j t.
        Let duration := suspension_duration j t.

        (* First, we analyze the service received during a suspension interval. *)
        Section SameService.

          (* Let t_in be any time in the suspension interval relative to time t. *)
          Variable t_in: time.
          Hypothesis H_within_suspension_interval:
            suspension_start <= t_in <= suspension_start + duration.

          (* Then, we show that the service received before time t_in
             equals the service received before the beginning of the
             latest suspension interval (if exists). *)
          Lemma same_service_in_suspension_interval:
            service sched j t_in = service sched j suspension_start.
          Proof.
            rename H_within_suspension_interval into BETWEEN,
                   H_respects_self_suspensions into SUSP, t_in into i.
            generalize dependent i.
            suff SAME:
              forall delta,
                delta <= duration ->
                service sched j (suspension_start + delta) =
                service sched j suspension_start.
            {
              move => i /andP [GE LT].
              feed (SAME (i-suspension_start)); first by rewrite leq_subLR.
              by rewrite addnBA // addKn in SAME.
            }
            induction delta; first by rewrite addn0.
            intros LT.
            feed IHdelta; first by apply ltnW.
            rewrite addnS -[service _ _ suspension_start]addn0.
            rewrite /service /service_during big_nat_recr //=.
            f_equal; first by done.
            apply/eqP; rewrite eqb0; apply/negP; intro SCHED.
            move: (SCHED) => SCHED'.
            apply SUSP in SCHED; apply SCHED; clear SCHED.
            rewrite /suspended_at /suspension_duration.
            case: (boolP (completed_by _ _ _ _)) => [COMP | NOTCOMP];
              first by apply completed_implies_not_scheduled in COMP;
                first by rewrite SCHED' in COMP.
            rewrite andTb (same_service_implies_same_last_execution _ _ _ _ suspension_start) //.
            rewrite /suspension_start last_execution_idempotent //.
            apply/andP; split; first by apply leq_addr.
            by rewrite ltn_add2l.
          Qed.

        End SameService.

        (* Next, we infer that the job is suspended at all times during
           the suspension interval. *)
        Section JobSuspendedAtAllTimes.

          (* Let t_in be any time before the completion of job j. *)
          Variable t_in: time.
          Hypothesis H_not_completed: ~~ job_completed_by j t_in.

          (* If t_in lies in the suspension interval relative to time t, ...*)
          Hypothesis H_within_suspension_interval:
            suspension_start <= t_in < suspension_start + duration.

          (* ...then job j is suspended at time t_in. More precisely, the suspension
             interval relative to time t_in is included in the suspension interval
             relative to time t. *)
          Lemma suspended_in_suspension_interval:
            suspended_at j t_in.
          Proof.
            rename H_within_suspension_interval into BETWEEN.
            move: BETWEEN => /andP [GE LT].
            have ARR: has_arrived job_arrival j t_in.
            {
              apply leq_trans with (n := suspension_start); last by done.
              rewrite -/(has_arrived job_arrival j suspension_start).
              by apply last_execution_after_arrival.
            }
            apply/andP; split; first by done.
            apply/andP; split;
              first by apply last_execution_bounded_by_identity.
            apply (leq_trans LT).
            have SAME: time_after_last_execution job_arrival sched j t =
                       time_after_last_execution job_arrival sched j t_in.
            {
              set b := _ _ t.
              rewrite [_ _ t_in](same_service_implies_same_last_execution _ _ _ _ b);
                first by rewrite last_execution_idempotent.
              apply same_service_in_suspension_interval.
              by apply/andP; split; last by apply ltnW.
            }
            rewrite /suspension_start SAME leq_add2l.
            by rewrite /duration /suspension_duration SAME.
          Qed.

        End JobSuspendedAtAllTimes.

      End InsideSuspensionInterval.

      (* Next, we prove lemmas about the state of a suspended job. *)
      Section StateOfSuspendedJob.

        (* Assume that jobs do not execute before they arrived. *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* Let j be any job. *)
        Variable j: Job.

        (* Assume that j is suspended at time t. *)
        Variable t: time.
        Hypothesis H_j_is_suspended: suspended_at j t.

        (* First, we show that j must have arrived by time t. *)
        Lemma suspended_implies_arrived: has_arrived job_arrival j t.
        Proof.
          rename H_j_is_suspended into SUSP.
          move: SUSP => /andP [_ SUSP].
          rewrite -[_ && _]negbK in SUSP; move: SUSP => /negP SUSP.
          rewrite /has_arrived leqNgt; apply/negP; intro LT.
          apply SUSP; clear SUSP.
          rewrite negb_and; apply/orP; left.
          rewrite -ltnNge.
          apply: (leq_trans LT); clear LT.
          rewrite /time_after_last_execution.
          case EX: [exists _, _]; last by apply leqnn.
          set t' := \max_(_ < _ | _)_.
          move: EX => /existsP [t0 EX].
          apply bigmax_pred in EX; rewrite -/t' /job_scheduled_at in EX.
          apply leq_trans with (n := t'); last by apply leq_addr.
          rewrite leqNgt; apply/negP; intro LT.
          have NOTSCHED: ~~ scheduled_at sched j t'.
          {
            rewrite -eqb0; apply/eqP.
            by eapply service_before_job_arrival_zero; first by eauto.
          }
          by rewrite EX in NOTSCHED.
        Qed.

        (* By the definition of suspension, it also follows that j cannot
           have completed by time t. *)
        Corollary suspended_implies_not_completed:
          ~~ completed_by job_cost sched j t.
        Proof.
          by move: H_j_is_suspended => /andP [NOTCOMP _].
        Qed.

      End StateOfSuspendedJob.

      (* Next, we establish a bound on the cumulative suspension time of any job. *)
      Section BoundOnCumulativeSuspension.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job. *)
        Variable j: Job.

        (* Recall the total suspension of job j as given by the dynamic suspension model. *)
        Let cumulative_suspension_of_j :=
          cumulative_suspension_during j.
        Let total_suspension_of_j :=
          total_suspension job_cost next_suspension j.

        (* We prove that the cumulative suspension time of job j in any
           interval is upper-bounded by the total suspension time. *)
        Lemma cumulative_suspension_le_total_suspension:
          forall t1 t2,
            cumulative_suspension_of_j t1 t2 <= total_suspension_of_j.
        Proof.
          unfold cumulative_suspension_of_j, cumulative_suspension_during,
                 total_suspension_of_j, total_suspension.
          intros t1 t2.
          apply leq_trans with (n := \sum_(0 <= s < job_cost j)
                                      \sum_(t1 <= t < t2 | service sched j t == s) suspended_at j t).
          {
            rewrite (exchange_big_dep_nat (fun x => true)) //=.
            apply leq_sum; intros s _.
            destruct (boolP (suspended_at j s)) as [SUSP | NOTSUSP]; last by done.
            rewrite (big_rem (service sched j s)); first by rewrite eq_refl.
            rewrite mem_index_iota; apply/andP; split; first by done.
            rewrite ltn_neqAle; apply/andP; split; last by apply cumulative_service_le_job_cost.
            by apply suspended_implies_not_completed in SUSP.
          }
          {
            apply leq_sum_nat; move => s /andP [_ LT] _.
            destruct (boolP [exists t: 'I_t2, (t >= t1) && (service sched j t == s)]) as [EX | ALL];
              last first.
            {
              rewrite negb_exists in ALL; move: ALL => /forallP ALL.
              rewrite big_nat_cond big1 //.
              move => i /andP [/andP [GEi LTi] SERV].
              by specialize (ALL (Ordinal LTi)); rewrite /= SERV GEi andbT in ALL.
            }
            move: EX => /existsP [t' /andP [GE' /eqP SERV]].
            unfold suspended_at, suspension_duration.
            set b := time_after_last_execution job_arrival sched j.
            set n := next_suspension j s.
            apply leq_trans with (n := \sum_(t1 <= t < t2 | b t' <= t < b t' + n) 1).
            {
              rewrite big_mkcond [\sum_(_ <= _ < _ | b t' <= _ < _) _]big_mkcond /=.
              apply leq_sum_nat; intros t LEt _.
              case: (boolP (completed_by _ _ _ _)) => [COMP | NOTCOMP];
                [by case (_ == _) | simpl].
              case EQ: (service _ _ _ == _); last by done.
              move: EQ => /eqP EQ. rewrite /n -EQ.
              case INT: (_ <= _ < _); last by done.
              apply eq_leq; symmetry; apply/eqP; rewrite eqb1.
              move: INT => /andP [GEt LTt].
              rewrite (same_service_in_suspension_interval _ _ _ _ t') //.
              {
                rewrite -/b [b t'](same_service_implies_same_last_execution _ _ _ _ t);
                  last by rewrite SERV EQ.
                by apply/andP; split.
              }
              {
                rewrite /suspension_duration -/b.
                rewrite [b t'](same_service_implies_same_last_execution _ _ _ _ t);
                  last by rewrite SERV EQ.
                by apply/andP; split; last by apply ltnW.
              }
            }
            apply leq_trans with (n := \sum_(b t' <= t < b t' + n) 1);
              last by simpl_sum_const; rewrite addKn.
            by apply leq_sum1_smaller_range; move => i [LE LE']; split.
          }
        Qed.

      End BoundOnCumulativeSuspension.

      (* Next, we show that when a job completes, it must have suspended
         as long as the total suspension time. *)
      Section SuspendsForTotalSuspension.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job. *)
        Variable j: Job.

        (* Assume that j has completed by time t. *)
        Variable t: time.
        Hypothesis H_j_has_completed: completed_by job_cost sched j t.

        (* Then, we prove that the cumulative suspension time must be
           exactly equal to the total suspension time of the job. *)
        Lemma cumulative_suspension_eq_total_suspension:
          cumulative_suspension j t = total_suspension job_cost next_suspension j.
        Proof.
          rename H_j_has_completed into COMP, H_jobs_must_arrive_to_execute into ARR.
          have EARLIER := exists_last_execution_with_smaller_service job_arrival
                                                                     job_cost sched ARR j t COMP.
          apply/eqP; rewrite eqn_leq; apply/andP; split;
            first by apply cumulative_suspension_le_total_suspension.
          rewrite /total_suspension /cumulative_suspension /cumulative_suspension_during.
          move: COMP => /eqP COMP.
          apply leq_trans with (n := \sum_(0 <= s < job_cost j)
                                      \sum_(0 <= t0 < t | service sched j t0 == s) suspended_at j t0);
            last first.
          {
            rewrite (exchange_big_dep_nat (fun x => true)) //=.
            apply leq_sum_nat; move => t0 /andP [_ LT] _.
            case (boolP [exists s: 'I_(job_cost j), service sched j t0 == s]) => [EX | ALL].
            {
              move: EX => /existsP [s /eqP EQs].
              rewrite big_mkcond /=.
              rewrite (bigD1_seq (nat_of_ord s)); [simpl | | by apply iota_uniq];
                last by rewrite mem_index_iota; apply/andP;split; last by apply ltn_ord.
              rewrite EQs eq_refl big1; first by rewrite addn0.
              by move => i /negbTE NEQ; rewrite eq_sym NEQ.
            }
            {
              rewrite big_nat_cond big1; first by done.
              move => i /andP [/andP [_ LTi] /eqP SERV].
              rewrite negb_exists in ALL; move: ALL => /forallP ALL.
              by specialize (ALL (Ordinal LTi)); rewrite /= SERV eq_refl in ALL.
            }
          }
          {
            apply leq_sum_nat; move => s /andP [_ LTs] _.
            rewrite /suspended_at /suspension_duration.
            set b := time_after_last_execution job_arrival sched j.
            set n := next_suspension j.

            move: (EARLIER s LTs) => [t' EQ'].
            apply leq_trans with (n := \sum_(0 <= t0 < t | (service sched j t0 == s) &&
                                (b t' <= t0 < b t' + n (service sched j (b t')))) 1); last first.
            {
              rewrite big_mkcond [\sum_(_ <= _ < _ | _ == s)_]big_mkcond.
              apply leq_sum_nat; move => i /andP [_ LTi] _.
              case EQi: (service sched j i == s); [rewrite andTb | by rewrite andFb].
              case LE: (_ <= _ <= _); last by done.
              rewrite lt0n eqb0 negbK.
              apply suspended_in_suspension_interval with (t := t'); try (by done).
              rewrite neq_ltn; apply/orP; left.
              by apply: (leq_ltn_trans _ LTs); apply eq_leq; apply/eqP.
            }
            {
              apply leq_trans with (n := \sum_(b t' <= t0 < b t' + n (service sched j (b t')) |
                                               (0 <= t0 < t) && (service sched j t0 == s)) 1).
              {
                apply leq_trans with (n := \sum_(b t' <= t0 < b t' + n (service sched j (b t'))) 1);
                  first by simpl_sum_const; rewrite addKn -EQ'.
                rewrite [in X in _ <= X]big_mkcond /=.
                apply leq_sum_nat; move => i /andP [LEi GTi] _.
                apply eq_leq; symmetry; apply/eqP; rewrite eqb1.
                apply/andP; split.
                {
                  have SUSPi: suspended_at j i.
                  {
                    apply: (suspended_in_suspension_interval _ _ _ _ t');
                      try (by done); last by apply/andP; split.
                    rewrite neq_ltn; apply/orP; left.
                    rewrite (same_service_in_suspension_interval _ _ _ _ t') //;
                      first by rewrite EQ'.
                    by apply/andP; split; last by apply ltnW.
                  }
                  apply contraT; rewrite -leqNgt; intro LE.
                  apply suspended_implies_not_completed in SUSPi.
                  exfalso; move: SUSPi => /negP COMPi; apply COMPi.
                  apply completion_monotonic with (t0 := t); try (by done).
                  by apply/eqP.
                }
                {
                  rewrite -EQ'; apply/eqP.
                  apply same_service_in_suspension_interval; try (by done).
                  by apply/andP; split; last by apply ltnW.
                }
              }
              {
                apply leq_sum1_smaller_range.
                by move => i [LEb /andP [LE EQs]]; split;
                  last by apply/andP; split.
              }
            }
          }
        Qed.

      End SuspendsForTotalSuspension.

    End Lemmas.

  End DefiningSuspensionIntervals.

End SuspensionIntervals.


Require Import List.
Import ListNotations.
From Coq Require Import Relations.
Require Import Coq.Logic.Classical_Prop.
Require Import NonEmptyList.
Require Import LambekSyntax.
Require Import Semantics.

Inductive singleton: Set := Sing.
Definition totalOnSingleton (_ _:singleton) := True.

Lemma transitiveOnSingleton : transitive singleton totalOnSingleton.
Proof.
  unfold transitive.
  intros x y z T1 T2.
  unfold totalOnSingleton.
  exact I.
Qed.

Definition singletonFrame: frame := exist _ (existT _ _ totalOnSingleton) transitiveOnSingleton.
Definition singletonW := @Wpoint singletonFrame.

Definition allSingleton (_:singletonW) := True.
Definition valOnSingleton := fun (_:elem_cat) => allSingleton.

Definition singletonModel : model := existT _ singletonFrame valOnSingleton.

Definition WpointOnSingleton := exist (fun (_: singleton * singleton) => True) (Sing, Sing) I.

Lemma allEqualOnSingleton: forall (x y: singletonW), x = y.
Proof.
  intros.
  destruct x as [[[] []] []]. destruct y as [[[] []] []]. reflexivity.
Qed.

Lemma allTrueOnSingleton: forall (A: formula)  (p: @Wpoint singletonFrame),
    formValuation singletonModel A p.
  intros. induction A as [v| A IHA B IHB | A IHA B IHB | A IHA B IHB].
  - apply I.
  - simpl. intros.
    assert (p = z) as PZ by apply allEqualOnSingleton.
    rewrite <- PZ. assumption.
  - simpl. intros.
    assert (p = z) as PZ by apply allEqualOnSingleton.
    rewrite <- PZ. assumption.
  - simpl.
    exists WpointOnSingleton. split.
    + assert (p = WpointOnSingleton) as PP by apply allEqualOnSingleton.
      rewrite <- PP. assumption.
    + exists WpointOnSingleton. split.
      * assert (p = WpointOnSingleton) as PP by apply allEqualOnSingleton.
        rewrite <- PP. assumption.
      * unfold C. simpl. destruct p. simpl. destruct x as [[] []]. simpl. auto.
Qed.


Require Import synth.
Require Export Bauer.
Require Import List.

Import ListNotations.
Open Scope bool_scope.

Definition instance := Graph.
Definition solution := vertex_list.

Definition metric := nat.
Definition eval (S : solution) := length S.
Definition better (m1 m2 : metric) := m1 <=? m2.

Definition verifier (I : instance) (S : solution) :=
let v_list := S.elements (V I) in
path I S /\
forall v, (In v v_list -> In v S).

Fixpoint checker (I : instance) (S : solution) :=
let v_set := S.elements (V I) in
pathb I S &&
forallb (fun v => existsb (fun v' => v' =? v) S) v_set.

Definition gen_space := fun I => all_perm (S.elements (V I)).
Definition Tsp_brute_force := synthesize instance solution metric checker eval better gen_space.

Compute (Tsp_brute_force (K 10)).


Require Import Omega.

Definition twice x := x+x.
Definition fice x := twice(twice x).
Definition ice x := twice(fice x).

Definition vbig x y :=
  x > ice(y+1).

Definition big x y :=
  x > fice(y+1).

Definition vclose x y :=
  ~ big x y /\
  ~ big y x.

Definition close x y :=
  ~ vbig x y /\
  ~ vbig y x.

(*
  ice (x+1) >= y /\
  ice (y+1) >= x.
*)
Ltac basic :=
  unfold not in *;
  intros;
  unfold close in *;
  unfold vclose in *;
  unfold big in *;
  unfold vbig in *;
  unfold ice in *;
  unfold fice in *;
  unfold twice in *;
  try omega.

Locate "{ _ } + { _ }".
Print sumbool.
Print or.
Check (fun a b => a = b \/ a < b).

Theorem t1 a b: a = b \/ a < b -> {a = b} + {a < b}.
Proof.
  intros.
  Print or.
  elim H.
  destruct H.

Lemma singleLeft :
  exists A, exists B, exists C,
    close A B /\
    close (A+B+1) C /\
    vbig (twice A) B /\
    close (twice A - 1) B /\
    ~vclose (twice A) (B+C+1).
Proof.
  basic.
  Locate {
  intros.
Qed.

Lemma singleLeft :
  ~forall A B C,
    close A B ->
    close (A+B+1) C ->
    vbig (twice A) B ->
    close (twice A - 1) B ->
    vclose (twice A) (B+C+1).
Proof.
  basic.
  intros.
Qed.

Print singleLeft.