Require Import Classical.
Require Import List.
Require Import Arith.

Require Import Ranked_properties.
Require Import SF_spec.
Require Import SF_tactic.
Require Import SF_properties.

(**  The formal specification given in SF_spec always chooses exactly one loser at each
     round; the choice is nondeterministic in the case of ties.  However, the statute
     text and actual election practice is to implement the following optimization:

         In a given round, choose the largest set of losers such that the combined sum
         of continuing votes for all losing candidates is less than the continuing votes
         for all other candidates.  Simultaneously eliminate all losing candidates in this set.

     Here we prove that this procedure is indeed just an optimization of the simple procedure
     that chooses exactly one loser at each round.  Actually, we prove something slightly more
     general, which is that one may chose _any_ set satisfying the condition above and the
     result is unchanged (i.e., prefering the largest such set makes no difference in the end).
  *)

Lemma first_choice_loser_set :
  forall (candidate:Set) e c cs elim x y,
    In c cs ->
    count_votes candidate (fun b => exists c, selected_candidate _ elim b c /\ In c cs) e x ->
    first_choices _ elim c e y ->
    y <= x.
Proof.
  intros candidate e. induction e; simpl; intros.
  * inv H0. inv H1. auto.
  * inv H0; inv H1; auto.
    cut (n' <= n). omega.
    eapply IHe; eauto.
    cut (y <= n). omega.
    eapply IHe; eauto.
    elim H4.
    exists c. split; auto.
    eapply IHe; eauto.
Qed.

Lemma count_votes_total candidates P e :
  exists c, count_votes candidates P e c.
Proof.
  induction e.
  * exists 0. constructor.
  * destruct IHe as [n ?].
    destruct (classic (P a)).
    exists (S n).
    apply count_satisfies; auto.
    exists n.
    apply count_not_satisfies; auto.
Qed.

Lemma count_votes_monotone candidates (P P':ballot candidates -> Prop) e x y :
  (forall b, P b -> P' b) ->
  count_votes candidates P e x ->
  count_votes candidates P' e y ->
  x <= y.
Proof.
  intros. revert x y H0 H1. induction e; intros.
  * inv H0. inv H1. auto.
  * inv H0; inv H1; auto.
    cut ( n <= n0 ). omega.
    apply IHe; auto.
    elim H3. apply H. auto.
Qed.

Lemma majority_unique :
  forall candidate r e x x',
    SF_spec.majority candidate r e x ->
    SF_spec.majority candidate r e x' ->
    x = x'.
Proof.
  intros.
  destruct (classic (x = x')); auto. elimtype False.
  destruct (SF_spec.total_selected_total candidate r e) as [t ?].
  destruct (SF_spec.sf_first_choices_total candidate r e x) as [n ?].
  destruct (SF_spec.sf_first_choices_total candidate r e x') as [n' ?].
  generalize (H t n H2 H3); intro.
  generalize (H0 t n' H2 H4); intro.
  assert ( n + n' <= t ).
  { clear H H0 H5 H6.
    revert t n n' H2 H3 H4.
    induction e; simpl; intros.
    inv H2. inv H3. inv H4. auto.
    inv H2. inv H3. inv H4.
    elim H1.
    eapply selected_candidate_unique; eauto.
    cut (n'0 + n' <= n0). omega.
    apply IHe; eauto.
    inv H4.
    cut (n + n'0 <= n0). omega.
    apply IHe; eauto.
    cut (n + n' <= n0). omega.
    apply IHe; eauto.
    inv H3.
    rewrite exhausted_ballot_next_ranking_iff in H5.
    destruct H2.
    destruct H0 as [q [??]].
    elim H.
    right. exists q. split; auto.
    inv H4.
    rewrite exhausted_ballot_next_ranking_iff in H5.
    destruct H3.
    destruct H0 as [q [??]].
    elim H.
    right. exists q. split; auto.
    apply IHe; auto.
  }
  omega.
Qed.

Lemma exhausted_ballot_monotone :
  forall (candidate:Set) (elim elim':candidate -> Prop) b,
    (forall x, (exists r, In r b /\ In x r) -> elim x -> elim' x) ->
    SF_spec.exhausted_ballot candidate elim b ->
    SF_spec.exhausted_ballot candidate elim' b.
Proof.
  unfold exhausted_ballot. intuition.
  left. intros [r ?].
  induction H0.
  destruct (classic (Forall elim r')).
  apply IHnext_ranking.
  intros.
  apply (H x); auto.
  { destruct H5 as [r0 [??]]. exists r0. split; simpl; auto. }
  intro.
  apply H1.
  destruct H5 as [r0 ?].
  exists r0.
  apply SF_spec.next_ranking_eliminated; auto.
  elim H1.
  exists r'.
  destruct r'.
  elim H4.
  rewrite Forall_forall.
  simpl; intuition.
  apply SF_spec.next_ranking_valid with c; simpl; auto.
  right.
  intro.
  apply H4.
  rewrite Forall_forall; intros.
  destruct (classic (x = c)).
  subst x; auto.
  elim H2.
  exists x. exists c.
  simpl; intuition.
  apply H1. exists r.
  apply SF_spec.next_ranking_valid with c; auto.
  intuition.
  right. intro.
  apply H3; auto.
  apply H; auto.
  exists r; split; simpl; auto.
  destruct H1 as [r [??]].
  right. exists r. split; auto.
  induction H0.
  apply SF_spec.next_ranking_eliminated; auto.
  rewrite Forall_forall. intros.
  apply H.
  exists r'; split; simpl; auto.
  rewrite Forall_forall in H0; auto.
  apply IHnext_ranking.
  intros. apply H; auto.
  destruct H4 as [r0 [??]].
  exists r0; split; simpl; auto.
  auto.
  apply SF_spec.next_ranking_valid with c; auto.
Qed.

Lemma total_selected_elim_eq :
  forall candidate elim elim' e n,
    (forall x, participates _ x e -> (elim x <-> elim' x)) ->
    SF_spec.total_selected candidate elim e n ->
    SF_spec.total_selected candidate elim' e n.
Proof.
  intros.
  induction H0.
  * apply total_nil.
  * apply total_continuing; auto.
    intro. apply H0.
    eapply exhausted_ballot_monotone. 2: eauto.
    intros. rewrite H; auto.
    hnf; simpl; eauto.
    apply IHtotal_selected.
    intros. apply H.
    destruct H2 as [q [??]].
    exists q; split; simpl; auto.
  * apply total_exhausted; auto.
    eapply exhausted_ballot_monotone. 2: eauto.
    intros. rewrite <- H; auto.
    hnf; simpl; eauto.
    apply IHtotal_selected.
    intros. apply H.
    destruct H2 as [q [??]].
    hnf; simpl; eauto.
Qed.

Lemma next_ranking_elim_eq :
  forall candidate elim elim' b r,
    (forall x, (exists r, In r b /\ In x r) -> (elim x <-> elim' x)) ->
    SF_spec.next_ranking candidate elim b r ->
    SF_spec.next_ranking candidate elim' b r.
Proof.
  intros. induction H0.
  * apply next_ranking_eliminated; auto.
    rewrite Forall_forall; intros.
    rewrite <- H.
    rewrite Forall_forall in H0. auto.
    simpl; eauto.
    apply IHnext_ranking; auto.
    intros.
    apply H.
    destruct H3 as [r0 [??]].
    simpl; eauto.
  * apply next_ranking_valid with c; intuition.
    right.
    rewrite <- H. auto.
    simpl; eauto.
Qed.

Lemma selected_candidate_elim_eq :
  forall candidate elim elim' b c,
    (forall x, (exists r, In r b /\ In x r) -> (elim x <-> elim' x)) ->
    SF_spec.selected_candidate candidate elim b c ->
    SF_spec.selected_candidate candidate elim' b c.
Proof.
  intros.
  destruct H0; split.
  intro. apply H0.
  eapply exhausted_ballot_monotone. 2: eauto.
  intuition. rewrite H; auto.
  destruct H1 as [r [??]].
  exists r; split; auto.
  eapply next_ranking_elim_eq. 2: eauto.
  auto.
Qed.

Lemma first_choices_elim_eq :
  forall candidate elim elim' e c n,
    (forall x, SF_spec.participates _ x e -> (elim x <-> elim' x)) ->
    SF_spec.first_choices candidate elim c e n ->
    SF_spec.first_choices candidate elim' c e n.
Proof.
  intros.
  induction H0.
  * apply first_choices_nil.
  * apply first_choices_selected; auto.
    eapply selected_candidate_elim_eq. 2: eauto.
    intros; apply H.
    hnf; simpl; eauto.
    apply IHfirst_choices.
    intros. apply H.
    destruct H2 as [q [??]].
    exists q; simpl; eauto.
  * eapply first_choices_not_selected; auto.
    intro. apply H0.
    eapply selected_candidate_elim_eq. 2: eauto.
    intros. rewrite H; intuition.
    hnf; simpl; eauto.
    apply IHfirst_choices.
    intros; apply H.
    destruct H2 as [q [??]].
    exists q; simpl; eauto.
Qed.

Lemma majority_elim_eq :
  forall candidate elim elim' e c,
    (forall x, SF_spec.participates _ x e -> (elim x <-> elim' x)) ->
    SF_spec.majority candidate elim e c ->
    SF_spec.majority candidate elim' e c.
Proof.
  intros; hnf; intros.
  apply H0; auto.
  eapply total_selected_elim_eq; eauto.
  intros. rewrite H; auto.
  intuition.
  eapply first_choices_elim_eq; eauto.
  intros. rewrite H; auto.
  intuition.
Qed.

Lemma is_loser_elim_eq :
  forall candidate elim elim' e c,
    (forall x, SF_spec.participates _ x e -> (elim x <-> elim' x)) ->
    SF_spec.is_loser candidate elim e c ->
    SF_spec.is_loser candidate elim' e c.
Proof.
  repeat intro.
  destruct H0. split.
  destruct H0. split; auto.
  rewrite <- H; auto.
  intros.
  eapply H1.
  2: eapply first_choices_elim_eq. 3: eauto.
  3: eapply first_choices_elim_eq. 4: eauto.
  destruct H2; split; auto.
  rewrite H; auto.
  intro. symmetry. auto.
  intro. symmetry. auto.
Qed.

Lemma winner_elim_eq :
  forall candidate elim elim' e c,
    (forall x, SF_spec.participates _ x e -> (elim x <-> elim' x)) ->
    SF_spec.winner candidate e elim c ->
    SF_spec.winner candidate e elim' c.
Proof.
  intros.
  revert elim' H.
  induction H0; intros.
  * apply winner_now.
    eapply majority_elim_eq; eauto.
  * apply winner_elimination with loser; auto.
    red; intros [c ?].
    apply H. exists c.
    eapply majority_elim_eq; eauto.
    intro. intro.
    rewrite H2; intuition.
    eapply is_loser_elim_eq; eauto.
    apply IHwinner.
    unfold eliminated'.
    unfold update_eliminated.
    intuition.
    rewrite H2 in H5; auto.
    rewrite H2; auto.
Qed.

Lemma disjoint_first_choices :
  forall (candidate:Set) (eliminated:candidate -> Prop) e c1 c2 n1 n2 t,
    c1 <> c2 ->
    first_choices _ eliminated c1 e n1 ->
    first_choices _ eliminated c2 e n2 ->
    total_selected _ eliminated e t ->
    n1 + n2 <= t.
Proof.
  intros until e. induction e; intros.
  * inv H0. inv H1. inv H2. omega.
  * inv H2. inv H0; inv H1.
    + elim H. eapply selected_candidate_unique; eauto.
    + cut (n' + n2 <= n). omega.
      eapply IHe; eauto.
    + cut (n1 + n' <= n). omega.
      eapply IHe; eauto.
    + cut (n1 + n2 <= n). omega.
      eapply IHe; eauto.
    + eapply IHe; eauto.
      inv H0; auto.
      destruct H4. elim H0; auto.
      inv H1; auto.
      destruct H4. elim H1; auto.
Qed.

Section sf_spec_opt.
  Variable candidate : Set.
  Variable e : election candidate.
  Variable losers : list candidate.
  Variable loserCount : nat.

  Variables eliminated eliminated':candidate -> Prop.

  Hypothesis Hdups : NoDup losers.

  Hypothesis Hcount : count_votes _ (fun b => exists c, SF_spec.selected_candidate _ eliminated b c /\ In c losers) e loserCount.
  Hypothesis Hviable : forall l, In l losers -> viable_candidate _ eliminated e l.
  Hypothesis Hnonloser : exists c, ~In c losers /\ SF_spec.viable_candidate _ eliminated e c.
  Hypothesis Hdominated :
      forall c count,
         ~In c losers ->
         SF_spec.viable_candidate _ eliminated e c ->
         SF_spec.first_choices _ eliminated c e count ->
         loserCount < count.
  Hypothesis Helim_eq :
      forall x, eliminated' x <-> eliminated x \/ In x losers.

  Lemma sf_opt_loser_in_set :
    forall
      (loser : candidate),
      length losers > 0 ->
      is_loser candidate eliminated e loser ->
      In loser losers.
  Proof.
    intros.
    destruct (classic (In loser losers)); auto. elimtype False.
    destruct (SF_spec.sf_first_choices_total _ eliminated e loser) as [lCount HlCount].
    assert (loserCount < lCount).
    apply Hdominated with loser; auto.
    destruct H0; auto.
    destruct losers.
    simpl in H. omega.
    destruct H0.
    destruct (SF_spec.sf_first_choices_total _ eliminated e c) as [cn Hcn].
    assert( lCount <= loserCount ).
    transitivity cn.
    apply H3 with c; auto.
    apply Hviable. simpl; auto.
    eapply first_choice_loser_set; eauto. simpl; auto.
    simpl in H2.
    omega.
  Qed.

  Lemma sf_opt_inductive_step :
    forall
      (loser : candidate)
      (losers' : list candidate),

      is_loser candidate eliminated e loser ->
      (forall x0 : candidate, In x0 losers <-> x0 = loser \/ In x0 losers') ->

      forall (c : candidate) (count : nat),
        ~ In c losers' ->
        viable_candidate candidate (update_eliminated candidate eliminated loser) e c ->
        first_choices candidate (update_eliminated candidate eliminated loser) c e count ->
        loserCount < count.
   Proof.
     intros.
     destruct (SF_spec.sf_first_choices_total _ eliminated e c) as [count0 ?].
     destruct (SF_spec.sf_first_choices_total _ eliminated e loser) as [lCount HlCount].
     assert ( count0 > 0 \/ (lCount = 0 /\ count0 = 0) ).
     { destruct count0. auto.
       cut ( lCount <= 0 ). omega.
       destruct H.
       apply H5 with c; auto.
       destruct H2; split; auto.
       intro. apply H2; hnf; auto.
       left. omega.
     }
     destruct H5.
     apply lt_le_trans with count0; auto.
     apply (Hdominated c count0); auto.
     intro.
     rewrite H0 in H6.
     destruct H6; auto.
     { subst c. destruct H2. elim H2; hnf; auto. }
     { destruct H2; split; auto.
       intro. apply H2; hnf; auto. }
     apply first_choices_monotone with candidate eliminated (SF_spec.update_eliminated _ eliminated loser) e c; auto.
     unfold update_eliminated; simpl; auto.
     { intros [?|?].
       destruct H2.
       elim H2; hnf; simpl; auto.
       subst c.
       destruct H2. elim H2; hnf; auto.
     }
     unfold update_eliminated; simpl; auto.
     destruct H5. subst.
     destruct (classic (In c losers)).
     rewrite H0 in H5.
     destruct H5. 2: elim H1; auto.
     subst c.
     destruct H2.
     elim H2; hnf; simpl; auto.
     assert (loserCount < 0).
     apply Hdominated with c; auto.
     destruct H2; split; auto.
     intro; apply H2; hnf; auto.
     elimtype False; omega.
   Qed.

   Lemma sf_opt_majority_forward :
     forall w,
       majority _ eliminated e w ->
       majority _ eliminated' e w.
   Proof.
     repeat intro.
     destruct (SF_spec.sf_first_choices_total _ eliminated e w) as [wc ?].
     destruct (SF_spec.total_selected_total _ eliminated e) as [t ?].
     generalize (H t wc H3 H2). intros.
     red. red in H4.
     assert ( wc <= winner_votes ).
     { eapply first_choices_monotone.
       2: apply H2.
       2: apply H1.
       rewrite Helim_eq. intros [?|?].
       destruct (nonzero_first_choices_selected _ eliminated w e wc) as [b [??]]; auto.
       omega.
       eapply selected_candidate_not_eliminated; eauto.
       { destruct Hnonloser as [c [??]].
         destruct (sf_first_choices_total _ eliminated e c) as [cn ?].
         assert (loserCount < cn).
         eapply Hdominated; eauto.
         assert ( cn + wc <= t ).
         { eapply disjoint_first_choices.
           2: eauto. 2: eauto. 2: eauto.
           intro. subst c. contradiction.
         }
         assert ( wc <= loserCount ).
         {
           clear -Hcount H5 H2.
           revert wc loserCount Hcount H2.
           induction e; intros.
           * inv H2. omega.
           * inv H2; inv Hcount.
             + cut (n' <= n). omega.
               apply IHe0; auto.
             + elim H2; eauto.
             + cut (wc <= n). omega.
               apply IHe0; eauto.
             + apply IHe0; eauto.
         }
         omega.
       }
       intros. rewrite Helim_eq. auto.
     }
     assert ( total_votes <= t ).
     { clear -H0 H3 Helim_eq.
       revert total_votes t H0 H3.
       induction e; intros.
       inv H3. inv H0. auto.
       inv H3. inv H0.
       cut (n0 <= n). omega.
       apply IHe0; auto.
       transitivity n.
       apply IHe0; auto.
       omega.
       inv H0.
       elim H3.
       eapply exhausted_ballot_monotone.
       2: eauto.
       intros. rewrite Helim_eq. auto.
       apply IHe0; auto.
     }
     omega.
  Qed.

End sf_spec_opt.

Lemma next_ranking_back :
  forall (candidate:Set) (elim elim':candidate -> Prop) b r c,
    (forall x, elim x -> elim' x) ->
    In c r ->
    next_ranking _ elim' b r ->
    next_ranking _ elim b r \/
    (exists c' r',
       ~overvote _ r' /\
       next_ranking _ elim b r' /\
       In c' r' /\ elim' c' /\ ~elim c').
Proof.
  intros. induction H1.
  * destruct (classic (Forall elim r')).
    destruct IHnext_ranking; auto.
    left. apply SF_spec.next_ranking_eliminated; auto.
    destruct H5 as [c' [q [?[?[?[??]]]]]].
    right.
    exists c'. exists q. intuition.
    apply SF_spec.next_ranking_eliminated; auto.
    destruct (classic (exists x, In x r' /\ ~elim x)).
    destruct H5 as [x [??]].
    right. exists x. exists r'.
    repeat split; auto.
    apply SF_spec.next_ranking_valid with x; auto.
    rewrite Forall_forall in H1.
    apply H1; auto.
    elim H4.
    rewrite Forall_forall; intros.
    destruct (classic (elim x)); auto.
    elim H5.
    eauto.
  * left. apply SF_spec.next_ranking_valid with c0; auto.
    intuition.
Qed.

Lemma continuing_ballot_back :
  forall (candidate:Set) (elim elim':candidate -> Prop) b,
  (forall x, elim x -> elim' x) ->
  continuing_ballot _ elim' b ->
  continuing_ballot _ elim b.
Proof.
  repeat intro.
  apply H0.
  destruct H1.
  left. intros [r ?]. elim H1.
  clear H0 H1.
  induction H2.
  destruct (classic (exists x, In x r' /\ ~elim x)).
  destruct H3 as [x [??]].
  exists r'.
  apply SF_spec.next_ranking_valid with x; auto.
  destruct IHnext_ranking as [q ?].
  exists q.
  apply SF_spec.next_ranking_eliminated; auto.
  rewrite Forall_forall; intros.
  destruct (classic (elim x)); auto.
  elim H3; eauto.
  exists r.
  apply SF_spec.next_ranking_valid with c; auto.
  intuition.
  destruct H1 as [r [??]].
  clear H0.
  hnf.
  right.
  exists r. split; auto.
  induction H1.
  apply SF_spec.next_ranking_eliminated; auto.
  rewrite Forall_forall; intros.
  apply H.
  rewrite Forall_forall in H0.
  apply H0; auto.
  apply SF_spec.next_ranking_valid with c; auto.
Qed.

Lemma selected_candidate_back :
  forall (candidate:Set) (elim elim':candidate -> Prop) b c,
    (forall x, elim x -> elim' x) ->
    selected_candidate _ elim' b c ->
    selected_candidate _ elim b c \/
    (exists x, selected_candidate _ elim b x /\ elim' x /\ ~elim x).
Proof.
  intros.
  destruct H0.
  destruct H1 as [r [??]].
  destruct (next_ranking_back candidate elim elim' b r c); auto.
  left. split; auto.
  eapply continuing_ballot_back; eauto.
  eauto.
  destruct H3 as [c' [r' [?[?[?[??]]]]]].
  right. exists c'.
  repeat split; auto.
  eapply continuing_ballot_back; eauto.
  exists r'; split; auto.
Qed.

Lemma count_votes_unique :
  forall (candidate:Set) (P:ballot candidate -> Prop) e n1 n2,
    count_votes _ P e n1 ->
    count_votes _ P e n2 ->
    n1 = n2.
Proof.
  intros until e. induction e; intros.
  * inv H. inv H0. auto.
  * inv H; inv H0; auto.
    elim H2; auto.
    elim H3; auto.
Qed.

Lemma count_votes_add :
  forall (candidate:Set) (P1 P2 P:ballot candidate -> Prop) e n1 n2,
    (forall b, P b <-> P1 b \/ P2 b) ->
    (forall b, P1 b -> P2 b -> False) ->
    count_votes _ P1 e n1 ->
    count_votes _ P2 e n2 ->
    count_votes _ P e (n1+n2).
Proof.
  intros. revert n1 n2 H1 H2.
  induction e; intros.
  * inv H1. inv H2. simpl. constructor.
  * inv H1; inv H2.
    elim (H0 a); auto.
    simpl.
    apply count_satisfies.
    apply H. auto.
    apply IHe; auto.
    replace (n1 + S n) with (S (n1 + n)) by omega.
    apply count_satisfies.
    apply H; auto.
    apply IHe; auto.
    apply count_not_satisfies.
    intro.
    rewrite H in H1.
    intuition.
    apply IHe; auto.
Qed.

Lemma elim_loser_list :
  forall
    (candidate:Set)
    (eliminated:candidate -> Prop)
    (losers : list candidate)
    (losers' : list candidate)
    (loser  : candidate)
    b,

    (In loser losers) ->
    (forall x, In x losers <-> x = loser \/ In x losers') ->
    (exists c, SF_spec.selected_candidate _ (update_eliminated _ eliminated loser) b c /\ In c losers') ->
    (exists c, SF_spec.selected_candidate _ eliminated b c /\ In c losers).
Proof.
  intros.
  destruct H1 as [c [??]].
  destruct (selected_candidate_back _ eliminated (update_eliminated _ eliminated loser) b c); auto.
  { unfold update_eliminated; auto. }
  exists c; split; auto.
  rewrite H0; auto.
  destruct H3 as [x [?[??]]].
  hnf in H4.
  destruct H4. contradiction.
  subst x.
  exists loser; auto.
Qed.

Lemma decompose_losers' :
 forall
    (candidate:Set)
    (eliminated:candidate -> Prop)
    (e:election candidate)
    (losers : list candidate)
    (loser  : candidate),
   NoDup losers ->
   In loser losers ->
   (forall l, In l losers -> viable_candidate _ eliminated e l) ->

   exists losers',
     NoDup losers' /\
     (forall l, In l losers' -> viable_candidate _ (update_eliminated _ eliminated loser) e l) /\
     length losers = S (length losers') /\
     (~In loser losers') /\
     (forall x, In x losers <-> x = loser \/ In x losers').
Proof.
  intros until losers. induction losers; intros. elim H0.
  inv H.
  simpl in H0. destruct H0.
  * subst a.
    exists losers.
    intuition.
    destruct (H1 loser); simpl; auto.
    split; auto.
    unfold update_eliminated.
    intuition.
    destruct (H1 l); simpl; auto.
    subst l; auto.
    destruct (H1 l); simpl; auto.
    simpl in H. intuition.
    simpl; auto.
  * destruct (IHlosers loser) as [losers' [?[?[?[??]]]]]; auto.
    intros; apply H1; simpl; auto.
    exists (a::losers'); intuition.
    constructor; auto.
    intro.
    apply H4.
    rewrite H7. auto.
    simpl in H8. destruct H8.
    subst l.
    destruct (H1 a); simpl; auto.
    split; auto.
    unfold update_eliminated; auto.
    intuition.
    subst a. contradiction.
    destruct (H1 l); simpl; auto.
    rewrite H7; auto.
    simpl. omega.
    simpl in H8.
    destruct H8.
    subst a.
    contradiction.
    contradiction.
    simpl in H8.
    rewrite H7 in H8.
    simpl. intuition.
    simpl; auto.
    subst x; auto.
    simpl in H9; simpl.
    rewrite H7.
    intuition.
Qed.

Lemma decompose_losers :
 forall
    (candidate:Set)
    (eliminated:candidate -> Prop)
    (e:election candidate)
    (losers : list candidate)
    (loser  : candidate)
    (loserCount : nat),
   NoDup losers ->
   In loser losers ->
   count_votes _ (fun b => exists c, SF_spec.selected_candidate _ eliminated b c /\ In c losers) e loserCount ->
   (forall l, In l losers -> viable_candidate _ eliminated e l) ->

   exists losers' loserCount',
     NoDup losers' /\
     count_votes _ (fun b => exists c, SF_spec.selected_candidate _ (update_eliminated _ eliminated loser) b c /\ In c losers') e loserCount' /\
     (forall l, In l losers' -> viable_candidate _ (update_eliminated _ eliminated loser) e l) /\
     loserCount' <= loserCount /\
     length losers = S (length losers') /\
     (~In loser losers') /\
     (forall x, In x losers <-> x = loser \/ In x losers').
Proof.
  intros.
  destruct (decompose_losers' candidate eliminated e losers loser)
           as [losers' [?[?[?[??]]]]]; auto.
  destruct (count_votes_total _
        (fun b : list (list candidate) =>
        exists c : candidate,
          selected_candidate candidate
            (update_eliminated candidate eliminated loser) b c /\
          In c losers') e) as [loserCount' ?].
  exists losers', loserCount'.
  intuition.
  eapply count_votes_monotone.
  2: eauto. 2: eauto.
  simpl.
  intro b.
  apply elim_loser_list; auto.
Qed.

Lemma sf_spec_optimization_backward :
  forall (candidate:Set)
         (len : nat)
         (eliminated eliminated':candidate -> Prop)
         (e:election candidate)
         (losers:list candidate)
         (loserCount:nat),

      len = length losers ->
      NoDup losers ->
      (forall l, In l losers -> viable_candidate _ eliminated e l) ->
      count_votes _ (fun b =>
                       exists c, SF_spec.selected_candidate _ eliminated b c /\ In c losers)
                  e loserCount ->
      (forall c count,
         ~In c losers ->
         SF_spec.viable_candidate _ eliminated e c ->
         SF_spec.first_choices _ eliminated c e count ->
         loserCount < count) ->
      (exists c, ~In c losers /\ SF_spec.viable_candidate _ eliminated e c) ->
      (forall x, eliminated' x <-> eliminated x \/ In x losers) ->
      (forall x,
         SF_spec.winner candidate e eliminated' x ->
         SF_spec.winner candidate e eliminated x).
Proof.
  intros candidate n.
  induction n.
  * intros.
    eapply winner_elim_eq. 2: eauto.
    intros.
    rewrite H5.
    intuition.
    destruct losers. elim H9.
    inv H.
  * intros.
    destruct (classic (exists winner, majority _ eliminated e winner)).
    + destruct H7 as [winner ?].
      apply SF_spec.winner_now.
      replace x with winner; auto.
      inv H6.
      symmetry.
      eapply majority_unique.
      apply H8.
      eapply sf_opt_majority_forward; eauto.
      elim H8.
      exists winner.
      eapply sf_opt_majority_forward; eauto.
    + assert (exists loser, In loser losers /\ is_loser _ eliminated e loser).
      { destruct (sf_loser_exists _ e eliminated) as [loser ?].
        destruct losers. inversion H.
        exists c; auto.
        destruct (H1 c); simpl; auto.
        exists loser; split; auto.
        eapply sf_opt_loser_in_set; eauto.
        rewrite <- H. omega.
      }
      destruct H8 as [loser [??]].
      apply SF_spec.winner_elimination with loser; auto.
      destruct (decompose_losers _ eliminated e losers loser loserCount) as [losers' [loserCount' [?[?[?[?[?[??]]]]]]]]; auto.
      apply (IHn _ eliminated' e losers' loserCount'); auto.
      omega.
      eapply sf_opt_inductive_step; eauto.
      intros.
      apply le_lt_trans with loserCount; eauto.
      destruct H4 as [c [??]].
      exists c. split; auto.
      intro. apply H4.
      rewrite H16. auto.
      destruct H17; split; auto.
      unfold update_eliminated.
      intuition.
      subst c.
      contradiction.

      unfold update_eliminated.
      intro.
      rewrite H5.
      rewrite H16.
      intuition.
Qed.

Lemma sf_spec_optimization_forward :
  forall (candidate:Set)
         (len : nat)
         (eliminated eliminated':candidate -> Prop)
         (e:election candidate)
         (losers:list candidate)
         (loserCount:nat),

      len = length losers ->
      NoDup losers ->
      (forall l, In l losers -> viable_candidate _ eliminated e l) ->
      count_votes _ (fun b =>
                       exists c, SF_spec.selected_candidate _ eliminated b c /\ In c losers)
                  e loserCount ->
      (exists c, ~In c losers /\ SF_spec.viable_candidate _ eliminated e c) ->
      (forall c count,
         ~In c losers ->
         SF_spec.viable_candidate _ eliminated e c ->
         SF_spec.first_choices _ eliminated c e count ->
         loserCount < count) ->
      (forall x, eliminated' x <-> eliminated x \/ In x losers) ->
      (forall x,
         SF_spec.winner candidate e eliminated x ->
         SF_spec.winner candidate e eliminated' x).
Proof.
  intros candidate n.
  induction n.
  * intros.
    eapply winner_elim_eq. 2: eauto.
    intros.
    rewrite H5.
    intuition.
    destruct losers. elim H9.
    inv H.
  * intros.
    inv H6.
      - apply SF_spec.winner_now.
        eapply sf_opt_majority_forward; eauto.
      - assert (In loser losers).
        { eapply sf_opt_loser_in_set; eauto.
          rewrite <- H. omega.
        }
        destruct (decompose_losers _ eliminated e losers loser loserCount) as [losers' [loserCounts' [?[?[?[?[?[??]]]]]]]]; auto.
        apply (IHn (SF_spec.update_eliminated _ eliminated loser) eliminated' e losers' loserCounts'); auto.
        rewrite H14 in H.
        injection H; auto.

        destruct H3 as [c [??]].
        exists c. split; auto.
        intro. apply H3.
        rewrite H16. auto.
        destruct H17; split; auto.
        unfold update_eliminated.
        intuition.
        subst c.
        contradiction.

        eapply sf_opt_inductive_step; eauto.
        intros.
        apply le_lt_trans with loserCount; eauto.
        unfold update_eliminated.
        intro.
        rewrite H5.
        rewrite H16.
        intuition.
Qed.

Theorem sf_spec_optimization :
  forall (candidate:Set)
         (eliminated eliminated':candidate -> Prop)
         (e:election candidate)
         (losers:list candidate)
         (loserCount:nat),

      count_votes _ (fun b =>
                       exists c, SF_spec.selected_candidate _ eliminated b c /\ In c losers)
                  e loserCount ->

      (exists c, ~In c losers /\ SF_spec.viable_candidate _ eliminated e c) ->

      (forall c count,
         ~In c losers ->
         SF_spec.viable_candidate _ eliminated e c ->
         SF_spec.first_choices _ eliminated c e count ->
         loserCount < count) ->
      (forall x, eliminated' x <-> eliminated x \/ In x losers) ->
      (forall x,
         SF_spec.winner candidate e eliminated x <-> SF_spec.winner candidate e eliminated' x).
Proof.
  intros.
  assert (exists losers',
            NoDup losers' /\
            (forall l, In l losers' <-> viable_candidate _ eliminated e l /\ In l losers)).
  { clear. induction losers.
    * exists nil. simpl; intuition. constructor.
    * destruct IHlosers as [losers' [??]].
      destruct (classic (In a losers')).
      + exists losers'. intuition.
        rewrite H0 in H2; intuition.
        rewrite H0 in H2; simpl; intuition.
        rewrite H0. split; simpl in *; intuition.
        subst l. auto.
        rewrite H0 in H1.
        intuition.
      + destruct (classic (viable_candidate _ eliminated e a)).
        - exists (a::losers').
          split. constructor; auto.
          simpl; intuition subst; auto.
          rewrite H0 in H4; intuition.
          rewrite H0 in H4; intuition.
          rewrite H0; intuition.
        - exists losers'.
          simpl; intuition subst; auto.
          rewrite H0 in H3; intuition.
          rewrite H0 in H3; intuition.
          rewrite H0; intuition.
          rewrite H0; intuition.
  }
  destruct H3 as [losers' [??]].
  set (eliminated'' c := eliminated c \/ In c losers').

  cut (winner _ e eliminated x <-> winner _  e eliminated'' x).
  { intros. rewrite H5.
    cut (forall c, SF_spec.participates _ c e -> (eliminated'' c <-> eliminated' c)).
    intros. split; apply winner_elim_eq; auto.
    intros. symmetry; apply H6; auto.
    intros. unfold eliminated''.
    rewrite H2.
    intuition.
    right.
    rewrite H4 in H9. intuition.
    destruct (classic (eliminated c)); auto.
    right.
    rewrite H4. split; auto.
    split; auto.
  }

  assert (Hviable :
   forall l : candidate,
   In l losers' -> viable_candidate candidate eliminated e l).
  { intros. rewrite H4 in H5. intuition. }

  assert (Hcount :    count_votes candidate
     (fun b : list (list candidate) =>
      exists c : candidate,
        selected_candidate candidate eliminated b c /\ In c losers') e
     loserCount).
  { revert H. apply count_eq.
    intuition.
    destruct H5 as [c [??]]. exists c; split; auto.
    rewrite H4; auto. split; auto.
    split.
    eapply selected_candidate_not_eliminated; eauto.
    destruct H5.
    destruct H7 as [r [??]].
    hnf; eauto.
    exists b; split; auto.
    exists r; split; auto.
    eapply next_ranking_in_ballot; eauto.
    destruct H5 as [c [??]].
    exists c; split; auto.
    rewrite H4 in H6. intuition.
  }
  assert (Hnonloser :    exists c : candidate,
     ~ In c losers' /\ viable_candidate candidate eliminated e c).
  { destruct H0 as [c [??]].
    exists c; split; auto.
    intro.
    apply H0.
    rewrite H4 in H6. intuition.
  }
  assert (Hdominated : forall (c : candidate) (count : nat),
   ~ In c losers' ->
   viable_candidate candidate eliminated e c ->
   first_choices candidate eliminated c e count -> loserCount < count).
  { intros.
    eapply H1; eauto.
    intro. apply H5.
    apply H4. split; auto.
  }
  assert (Helim :
     forall x0 : candidate, eliminated'' x0 <-> eliminated x0 \/ In x0 losers').
  { unfold eliminated''. intuition. }

  split.
  apply sf_spec_optimization_forward with (length losers') losers' loserCount; auto.
  apply sf_spec_optimization_backward with (length losers') losers' loserCount; auto.
Qed.


Set Implicit Arguments.
Require Import List.

(** * The Functor Type Class *)

Local Notation "f ∘ g" := (fun x => f (g x)) (at level 40, left associativity).

Class Functor (f : Type -> Type) : Type :=
{ fmap         : forall {A B}, (A -> B) -> f A -> f B }.
Class Functor_Correct (f : Type -> Type) `{F : Functor f} :=
{ fmap_id      : forall A, fmap (fun (x:A)=> x) = (fun x => x);
  fmap_compose : forall A B C (g : A -> B) (f : B -> C),
                 fmap (f ∘ g) = fmap f ∘ fmap g
}.
Class Applicative (f : Type -> Type) `{F : Functor f} : Type :=
{ pure : forall {A}, A -> f A;
  liftA : forall {A B}, f (A -> B) -> f A -> f B
}.
Notation "f <*> a" := (liftA f a) (left associativity, at level 25).

Class Applicative_Correct (f : Type -> Type) `{Applicative f} :=
{ applicative_id : forall A, liftA (pure (fun  (x:A) => x)) = (fun  x => x);
  applicative_composition : forall {A B C} (u : f (B -> C)) (v : f (A -> B)) (w : f A),
    pure (fun  x => fun  y => x ∘ y) <*> u <*> v <*> w = u <*> (v <*> w);
  applicative_homomorphism : forall {A B} (f : A -> B) (x : A),
    pure f <*> pure x = pure (f x);
  applicative_interchange : forall {A B} (u : f (A -> B)) (y : A),
    u <*> pure y = pure (fun x => x y) <*> u
}.

Class Monad (m: Type -> Type) `{M : Applicative m} : Type :=
{ bind: forall {A}, m A -> forall {B}, (A -> m B) -> m B
}.
Definition return_ {m : Type -> Type} `{M : Monad m} {A : Type} : A -> m A := pure.
Notation "a >>= f" := (bind a f) (at level 50, left associativity).

Hint Unfold bind return_ : monad_db.

Class Monad_Correct (m : Type -> Type) `{M : Monad m} := {
  bind_right_unit: forall A (a: m A), a = a >>= return_;
  bind_left_unit: forall A (a: A) B (f: A -> m B),
             f a = return_ a >>= f;
  bind_associativity: forall A (ma: m A) B f C (g: B -> m C),
                 bind ma (fun  x=> f x >>= g) = (ma >>= f) >>= g
}.

Arguments Functor f : assert.
Arguments Functor_Correct f {F}.
Arguments Applicative f {F}.
Arguments Applicative_Correct f {F} {A} : rename.
Arguments Monad m {F} {M}.
Arguments Monad_Correct m {F} {A} {M} : rename.

Section monadic_functions.
 Variable m : Type -> Type.
 Variable F : Functor m.
 Variable A : Applicative m.
 Variable M : Monad m.

 Definition wbind {A: Type} (ma: m A) {B: Type} (mb: m B) :=
 ma >>= fun  _=>mb.

 Definition liftM {A B: Type} (f: A->B) (ma: m A): m B :=
 ma >>= (fun  a => return_ (f a)).

 Definition join {A: Type} (mma: m (m A)): m A :=
 mma >>= (fun  ma => ma).

End monadic_functions.

Notation "a >> f" := (wbind _ a f) (at level 50, left associativity).
Notation "'do' a ← e ; c" := (e >>= (fun  a => c)) (at level 60, right associativity).

Fixpoint foldM {A B m} `{Monad m}
               (f : B -> A -> m B) (b : B) (ls : list A) : m B :=
  match ls with
  | nil      => return_ b
  | x :: ls' => do y ← f b x;
                foldM f y ls'
  end.
Hint Unfold foldM : monad_db.

About fmap_compose.
Lemma fmap_compose' {f} (F : Functor f) `{Functor_Correct f} :
    forall {A B C} (g : A -> B) (h : B -> C) (a : f A),
    fmap h (fmap g a) = fmap (h ∘ g) a.
Proof.
  intros.
  rewrite (fmap_compose g h).
  reflexivity.
Qed.

Require Import Program.
Lemma bind_eq : forall {A B m} `{Monad m} (a a' : m A) (f f' : A -> m B),
      a = a' ->
      (forall x, f x = f' x) ->
      bind a f = bind a' f'.
Proof.
  intros. subst.
  f_equal.
  apply functional_extensionality.
  auto.
Qed.

Ltac simplify_monad_LHS :=
  repeat match goal with
  | [ |- bind (return_ _) _ = _ ] => rewrite <- bind_left_unit
  | [ |- bind (bind _ _) _ = _ ]  => rewrite <- bind_associativity
  | [ |- _ = _ ]                  => reflexivity
  | [ |- bind ?a ?f = _ ]         => erewrite bind_eq; intros;
                                     [ | simplify_monad_LHS | simplify_monad_LHS ]
  end.

Ltac simplify_monad :=
  simplify_monad_LHS;
  apply eq_sym;
  simplify_monad_LHS;
  apply eq_sym.

Ltac simpl_m :=
  repeat (try match goal with
  [ |- bind ?a _ = bind ?a _ ] => apply bind_eq; [ reflexivity | intros ]
  end; simplify_monad).

Proposition test : forall {m} `{Monad m} `{Monad_Correct m} (a b c : m unit),
        do x ← a; do y ← b;  c
      = do y ← (do x ← a; b); c.
Proof. intros.
simplify_monad.
Abort.

(** * Some classic Monads *)

(** ** The list monad *)

Open Scope list_scope.
(*
Definition list_fmap {A B} (f : A -> B) :=
  fix map (l : list A) : list B :=
  match l with
  | nil => nil
  | a :: t => f a :: map t
  end.
*)
Definition list_fmap := map.
Hint Unfold list_fmap : monad_db.
(*
Fixpoint list_fmap {A B} (f : A -> B) (ls : list A) : list B :=
  match ls with
  | nil => nil
  | a :: ls' => f a :: list_fmap f ls'
  end.  *)

(*
Fixpoint concat {A} (xs : list (list A)) : list A :=
  match xs with
  | nil => nil
  | ys :: xs' => ys ++ concat xs'
  end.
*)

Definition list_liftA {A B} (fs : list (A -> B)) (xs : list A) : list B :=
  let g := fun a => list_fmap (fun f => f a) fs
  in
  concat (list_fmap g xs).
Hint Unfold list_liftA : monad_db.

Fixpoint list_bind {A} (xs : list A) {B} (f : A -> list B) : list B :=
  match xs with
  | nil => nil
  | a :: xs' => f a ++ list_bind xs' f
  end.
Hint Unfold list_bind : monad_db.

Instance listF : Functor list := { fmap := @list_fmap }.
Instance listA : Applicative list := { pure := fun _ x => x :: nil
                                     ; liftA := @list_liftA }.
Instance listM : Monad list :=
  { bind := @list_bind }.

Instance listF_correct : Functor_Correct list.
Proof.
  constructor.
  * intros. simpl. apply functional_extensionality; intros x.
    induction x; simpl; auto.
    rewrite IHx; auto.
  * intros. simpl. apply functional_extensionality; intros x.
    induction x; simpl; auto.
    rewrite IHx.
    auto.
Qed.

Instance listA_correct : Applicative_Correct list.
Proof.
  constructor.
  * intros. simpl. apply functional_extensionality; intros l.
    induction l; simpl; auto.
    unfold list_liftA in *. simpl in *.
    rewrite IHl; easy.
Abort.

Instance listM_correct : Monad_Correct list.
Abort.

Lemma fmap_app : forall {A B} (f : A -> B) ls1 ls2,
      fmap f (ls1 ++ ls2) = fmap f ls1 ++ fmap f ls2.
Proof.
  induction ls1; intros; simpl; auto.
  rewrite IHls1. auto.
Qed.

(** ** The Maybe monad (using option type) *)

Definition option_fmap {A B} (f : A -> B) (x : option A) : option B :=
  match x with
  | None => None
  | Some a => Some (f a)
  end.
Definition option_liftA {A B} (f : option (A -> B)) (x : option A) : option B :=
  match f, x with
  | Some f', Some a => Some (f' a)
  | _, _ => None
  end.
Instance optionF : Functor option := { fmap := @option_fmap}.
Instance optionA : Applicative option := { pure := @Some;
                                           liftA := @option_liftA}.
Instance optionM : Monad option :=
  { bind := fun  A m B f => match m with None => None | Some a => f a end
  }.
Instance optionM_Laws : Monad_Correct option.
Proof. split.
  - destruct a; auto.
  - intros; auto.
  - destruct ma; intros; auto.
Defined.

(* Monad Transformer *)
Class MonadTrans (t : (Type -> Type) -> (Type -> Type)) :=
  { liftT : forall {m} `{Monad m} {A}, m A -> t m A }.

(** Option monad transformer *)
Definition optionT m (A : Type) : Type := m (option A).

Definition optionT_liftT {m} `{Monad m} {A} (x : m A) : optionT m A.
Proof.
  unfold optionT.
  refine (do a ← x; return_ (Some a)).
Defined.
Instance optionT_T : MonadTrans optionT := {liftT := @optionT_liftT}.

Definition optionT_fmap {f} `{Functor f}
                        {A B} (g : A -> B) (x : optionT f A) : optionT f B :=
  @fmap f _ _ _ (fmap g) x.
Definition optionT_liftA {f} `{Applicative f}
                         {A B} (g : optionT f (A -> B)) (x : optionT f A)
                       : optionT f B.
(*  @liftA f _ _ _ _ (fmap liftA g) x.*)
Proof.
  unfold optionT in *.
  exact (fmap liftA g <*> x).
Defined.
Definition optionT_pure {f} `{Applicative f}
                        {A} (a : A) : optionT f A := @pure f _ _ _ (pure a).
Definition optionT_bind {m} `{Monad m}
                        {A} (ma : optionT m A) {B} (f : A -> optionT m B)
                        : optionT m B.
  unfold optionT in *.
  exact (do oa ← ma;
         match oa with
         | None => pure None
         | Some a => f a
         end
  ).
Defined.

Instance optionT_F {f} `{Functor f} : Functor (optionT f) :=
    {fmap := @optionT_fmap f _}.
Instance optionT_A {f} `{Applicative f} : Applicative (optionT f) :=
  { pure := @optionT_pure f _ _;
    liftA := @optionT_liftA f _ _ }.
Instance optionT_M {m} `{Monad m} : Monad (optionT m) :=
  { bind := @optionT_bind m _ _ _ }.

(** The Reader monad *)
Axiom Eta: forall A (B: A -> Type) (f: forall a, B a), f = fun  a=>f a.

Definition Reader (E : Type) := fun  X => E -> X.
Definition reader_fmap E A B (f : A -> B) (r : Reader E A) : Reader E B :=
  fun x => f (r x).
Definition reader_liftA E A B (f : Reader E (A -> B)) (r : Reader E A) :=
  fun x => (f x) (r x).
Definition reader_bind E A (r : Reader E A) B (f : A -> Reader E B) : Reader E B :=
  fun x => f (r x) x.

Instance readerF E : Functor (Reader E) :=
 { fmap := @reader_fmap E }.
Instance readerA E : Applicative (Reader E) :=
 { pure := fun  A (a:A) e=> a;
   liftA := @reader_liftA E }.
Instance readerM (E : Type): Monad (Reader E) :=
 { bind := @reader_bind E }.
(*
(* Checking the 3 laws *)
 - (* unit_left *)
   intros; apply Eta.
 - (* unit_right *)
   intros; apply Eta.
 - (* associativity *)
   reflexivity.
Defined.
*)
(** ** The State monad *)

Require Import Program.
Section State.
(*Axiom Ext: forall A (B: A->Type) (f g: forall a, B a), (forall a, f a = g a) -> f = g.*)

  Variable S : Type.

  Definition State (A : Type) := S -> A * S.
  Definition state_fmap A B (f : A -> B) (st : State A) : State B :=
    fun  s => let (a,s) := st s in (f a,s).
  Definition state_liftA A B (st_f : State (A -> B)) (st_a : State A) :=
    fun  s => let (f,s) := st_f s in
              let (a,s) := st_a s in
              (f a,s).
  Definition state_bind A (st_a : State A) B  (f : A -> State B) :=
    fun  s => let (a,s) := st_a s in
              f a s.

  Definition put (x : S) : State () :=
    fun _ => (tt,x).
  Definition get : State S :=
    fun x => (x,x).
  Definition runState  {A} (op : State A) : S -> A * S := op.
  Definition evalState {A} (op : State A) : S -> A := fst ∘ op.
  Definition execState {A} (op : State A) : S -> S := snd ∘ op.

End State.
Hint Unfold put get runState evalState execState state_fmap state_liftA state_bind : monad_db.
Ltac fold_evalState :=
  match goal with
  | [ |- context[fst (?c ?v)] ] => replace (fst (c v)) with (evalState c v)
                                                       by reflexivity
  end.

Arguments get {S}.
Arguments put {S}.

Instance stateF {A} : Functor (State A) :=
    { fmap := @state_fmap A }.
Instance stateA {A} : Applicative (State A) :=
    { pure := fun  A a s=> (a,s);
      liftA := @state_liftA A }.
Instance stateM {A} : Monad (State A) :=
    { bind := @state_bind A }.

Instance stateF_correct {A} : Functor_Correct (State A).
  Proof.
    split; intros;
      apply functional_extensionality; intros op;
      apply functional_extensionality; intros x;
      simpl; unfold state_fmap.
    - destruct (op x); reflexivity.
    - destruct (op x); reflexivity.
  Qed.

Instance stateA_correct {A} : Applicative_Correct (State A).
  Proof.
    split; intros;
      apply functional_extensionality; intros op;
      simpl; unfold state_liftA.
    - apply functional_extensionality; intros x.
      destruct (op x); reflexivity.
    - destruct (u op).
      destruct (v a).
      destruct (w a0).
      reflexivity.
    - reflexivity.
    - destruct (u op).
      reflexivity.
  Qed.

Instance stateM_correct {A} : Monad_Correct (State A).
  Proof.
    split; intros; simpl; unfold state_bind.
    - apply functional_extensionality; intros x.
      destruct (a x); reflexivity.
    - reflexivity.
    - apply functional_extensionality; intros x.
      destruct (ma x).
      reflexivity.
  Qed.

Hint Unfold Basics.compose : monad_db.
Hint Unfold stateM : monad_db.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.

(* Hack so that Why3 does not override the notation below.

(* Why3 assumption *)
Definition divides (d:Z) (n:Z): Prop := exists q:Z, (n = (q * d)%Z).

*)

Require Import Znumtheory.
Notation divides := Zdivide (only parsing).

(* Why3 goal *)
Lemma divides_refl :
forall (n:Z), (divides n n).
Proof.
exact Zdivide_refl.
Qed.

(* Why3 goal *)
Lemma divides_1_n :
forall (n:Z), (divides 1%Z n).
Proof.
exact Zone_divide.
Qed.

(* Why3 goal *)
Lemma divides_0 :
forall (n:Z), (divides n 0%Z).
Proof.
exact Zdivide_0.
Qed.

(* Why3 goal *)
Lemma divides_left :
forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides (c * a)%Z (c * b)%Z).
Proof.
exact Zmult_divide_compat_l.
Qed.

(* Why3 goal *)
Lemma divides_right :
forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides (a * c)%Z (b * c)%Z).
Proof.
exact Zmult_divide_compat_r.
Qed.

(* Why3 goal *)
Lemma divides_oppr :
forall (a:Z) (b:Z), (divides a b) -> (divides a (-b)%Z).
Proof.
exact Zdivide_opp_r.
Qed.

(* Why3 goal *)
Lemma divides_oppl :
forall (a:Z) (b:Z), (divides a b) -> (divides (-a)%Z b).
Proof.
exact Zdivide_opp_l.
Qed.

(* Why3 goal *)
Lemma divides_oppr_rev :
forall (a:Z) (b:Z), (divides (-a)%Z b) -> (divides a b).
Proof.
exact Zdivide_opp_l_rev.
Qed.

(* Why3 goal *)
Lemma divides_oppl_rev :
forall (a:Z) (b:Z), (divides a (-b)%Z) -> (divides a b).
Proof.
exact Zdivide_opp_r_rev.
Qed.

(* Why3 goal *)
Lemma divides_plusr :
forall (a:Z) (b:Z) (c:Z),
 (divides a b) -> ((divides a c) -> (divides a (b + c)%Z)).
Proof.
exact Zdivide_plus_r.
Qed.

(* Why3 goal *)
Lemma divides_minusr :
forall (a:Z) (b:Z) (c:Z),
 (divides a b) -> ((divides a c) -> (divides a (b - c)%Z)).
Proof.
exact Zdivide_minus_l.
Qed.

(* Why3 goal *)
Lemma divides_multl :
forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a (c * b)%Z).
Proof.
intros a b c.
apply Zdivide_mult_r.
Qed.

(* Why3 goal *)
Lemma divides_multr :
forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a (b * c)%Z).
Proof.
exact Zdivide_mult_l.
Qed.

(* Why3 goal *)
Lemma divides_factorl :
forall (a:Z) (b:Z), (divides a (b * a)%Z).
Proof.
exact Zdivide_factor_l.
Qed.

(* Why3 goal *)
Lemma divides_factorr :
forall (a:Z) (b:Z), (divides a (a * b)%Z).
Proof.
exact Zdivide_factor_r.
Qed.

(* Why3 goal *)
Lemma divides_n_1 :
forall (n:Z), (divides n 1%Z) -> ((n = 1%Z) \/ (n = (-1%Z)%Z)).
Proof.
exact Zdivide_1.
Qed.

(* Why3 goal *)
Lemma divides_antisym :
forall (a:Z) (b:Z),
 (divides a b) -> ((divides b a) -> ((a = b) \/ (a = (-b)%Z))).
Proof.
exact Zdivide_antisym.
Qed.

(* Why3 goal *)
Lemma divides_trans :
forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides b c) -> (divides a c)).
Proof.
exact Zdivide_trans.
Qed.

(* Why3 goal *)
Lemma divides_bounds :
forall (a:Z) (b:Z),
 (divides a b) ->
 ((~ (b = 0%Z)) -> ((ZArith.BinInt.Z.abs a) <= (ZArith.BinInt.Z.abs b))%Z).
Proof.
exact Zdivide_bounds.
Qed.

Import EuclideanDivision.

(* Why3 goal *)
Lemma mod_divides_euclidean :
forall (a:Z) (b:Z),
 (~ (b = 0%Z)) -> (((int.EuclideanDivision.mod1 a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (div a b).
rewrite (Div_mod a b Zb) at 1.
rewrite H.
ring.
Qed.

(* Why3 goal *)
Lemma divides_mod_euclidean :
forall (a:Z) (b:Z),
 (~ (b = 0%Z)) -> ((divides b a) -> ((int.EuclideanDivision.mod1 a b) = 0%Z)).
Proof.
intros a b Zb H.
assert (Zmod a b = Z0).
now apply Zdivide_mod.
unfold mod1, div.
rewrite H0.
case Z_le_dec ; intros H1.
rewrite (Z_div_exact_full_2 a b Zb H0) at 1.
apply Zminus_diag.
now elim H1.
Qed.

(* Why3 goal *)
Lemma mod_divides_computer :
forall (a:Z) (b:Z),
 (~ (b = 0%Z)) -> (((ZArith.BinInt.Z.rem a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (Z.quot a b).
rewrite Zmult_comm.
now apply Zquot.Z_quot_exact_full.
Qed.

(* Why3 goal *)
Lemma divides_mod_computer :
forall (a:Z) (b:Z),
 (~ (b = 0%Z)) -> ((divides b a) -> ((ZArith.BinInt.Z.rem a b) = 0%Z)).
Proof.
intros a b Zb (q,H).
rewrite H.
apply Zquot.Z_rem_mult.
Qed.

(* Why3 goal *)
Lemma even_divides :
forall (a:Z), (number.Parity.even a) <-> (divides 2%Z a).
Proof.
split ;
  intros (q,H) ; exists q ; now rewrite Zmult_comm.
Qed.

(* Why3 goal *)
Lemma odd_divides :
forall (a:Z), (number.Parity.odd a) <-> ~ (divides 2%Z a).
Proof.
split.
intros H.
contradict H.
apply Parity.even_not_odd.
now apply <- even_divides.
intros H.
destruct (Parity.even_or_odd a).
elim H.
now apply -> even_divides.
exact H0.
Qed.


Definition NonEmpty_foldr1 {a} (f : a -> a -> a) (x: GHC.Base.NonEmpty a) : a :=
  match x with
    | GHC.Base.NEcons a as_ => List.fold_right f a as_
  end.

Definition NonEmpty_maximum {a} `{GHC.Base.Ord a} (x:GHC.Base.NonEmpty a) : a :=
  NonEmpty_foldr1 GHC.Base.max x.

Definition NonEmpty_minimum {a} `{GHC.Base.Ord a} (x:GHC.Base.NonEmpty a) : a :=
  NonEmpty_foldr1 GHC.Base.min x.

Definition toList {a} : GHC.Base.NonEmpty a -> list a :=
  fun arg_0__ => match arg_0__ with | GHC.Base.NEcons a as_ => cons a as_ end.

Definition List_size {a} : list a -> nat :=
List.fold_right (fun x y => S y) O .
Definition NonEmpty_size {a} : GHC.Base.NonEmpty a -> nat :=
  fun arg_0__ =>
    match arg_0__ with
      | GHC.Base.NEcons _ xs => 1 + List_size xs
    end.

Program Fixpoint insertBy {a} (cmp: a -> a -> comparison) (x : a)
        (xs : GHC.Base.NonEmpty a) {measure (NonEmpty_size xs)} : GHC.Base.NonEmpty a :=
  match xs with
  | GHC.Base.NEcons x nil => GHC.Base.NEcons x nil
  | (GHC.Base.NEcons y ((cons y1 ys') as ys)) =>
    match cmp x y with
    | Gt  => GHC.Base.NEcons y (toList (insertBy cmp x (GHC.Base.NEcons y1 ys')))
    | _   => GHC.Base.NEcons x ys
    end
  end.

Program Fixpoint insertBy' {a} (cmp: a -> a -> comparison) (x : a)
        (xs : list a) {measure (List_size xs)} : GHC.Base.NonEmpty a :=
  match xs with
  | nil => GHC.Base.NEcons x nil
  | cons x nil => GHC.Base.NEcons x nil
  | (cons y ((cons y1 ys') as ys)) =>
    match cmp x y with
    | Gt  => GHC.Base.NEcons y (toList (insertBy' cmp x (cons y1 ys')))
    | _   => GHC.Base.NEcons x ys
    end
  end.

Definition insert {a} `{GHC.Base.Ord a} : a ->  GHC.Base.NonEmpty a -> GHC.Base.NonEmpty a :=
  insertBy GHC.Base.compare.

Definition sortBy {a} : (a -> a -> comparison) -> GHC.Base.NonEmpty a -> GHC.Base.NonEmpty a :=
  fun f ne => match ne with
           | GHC.Base.NEcons x xs => insertBy' f x (Data.OldList.sortBy f xs)
           end.

Definition sort {a} `{GHC.Base.Ord a} : GHC.Base.NonEmpty a -> GHC.Base.NonEmpty a :=
             sortBy GHC.Base.compare.


From Coq Require Import Relations.Relations.
From Coq Require Import Classes.RelationClasses.
From VSA Require Import Basics.
From VSA Require Import Lattice.
From VSA Require Import LatticeProperties.
From VSA Require Import Functions.

Import SetNotations.

Definition PreFixpoints {A: Type} (f: A -> A) `{Increasing A A f}: ℘ A :=
  fun x => x ⊑ f x.

Definition PostFixpoints {A: Type} (f: A -> A) `{Increasing A A f}: ℘ A :=
  fun x => f x ⊑ x.

Definition Fixpoints {A: Type} (f: A -> A) `{Increasing A A f}: ℘ A :=
  fun x => f x = x.

Definition lfp {A: Type} (f: A -> A) `{Increasing A A f} (u: A) :=
  LowerBound (Fixpoints f) u /\ u ∈ (Fixpoints f).

Definition glp {A: Type} (f: A -> A) `{Increasing A A f} (u: A) :=
  UpperBound (Fixpoints f) u /\ u ∈ (Fixpoints f).

Section Tarski.

  Context {A: Type} `{CompleteLattice A} (f: A -> A) {I: Increasing f}.

  Definition lfp_tarski: A := inf (PostFixpoints f).

  Lemma lfp_tarski_fixpoint:
    f (lfp_tarski) = lfp_tarski.
  Proof.
    assert (f lfp_tarski ⊑ lfp_tarski).
    {
      apply inf_glb. intros x H__x.
      transitivity (f x); auto.
      apply increasing.
      apply inf_lb.
      assumption.
    }
    apply antisymmetry; auto.
    apply inf_lb. apply increasing. assumption.
  Qed.

  Lemma lfp_tarski_leastfixpoint:
    LowerBound (Fixpoints f) lfp_tarski.
  Proof.
    intros u H__u.
    apply inf_lb. unfold PostFixpoints. rewrite H__u. reflexivity.
  Qed.

  Theorem lfp_tarski_iff:
    lfp f lfp_tarski.
  Proof.
    split.
    - apply lfp_tarski_leastfixpoint.
    - apply lfp_tarski_fixpoint.
  Qed.

End Tarski.


Require Import Coq.ZArith.ZArith Coq.ZArith.Zcomplements. Open Scope Z_scope.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.Logic.Classical.
Require Import Coq.micromega.Lia.

Set Implicit Arguments.

Definition Znth{T: Type}(l: list T)(i: Z)(default: T): T := nth (Z.to_nat i) l default.

Parameter Error: Prop.

(* number of variables and list of clauses *)
Definition Input: Type := Z * list (list Z).

Example test1 := (5, [
  [1; -5; 4];
  [-1; 5; 3; 4];
  [-3; -4]
]).

Definition interp_lit(env: list Prop)(l: Z): Prop :=
  let x := Znth env (Z.abs l) Error in
  match l with
  | Z0 => Error
  | Zpos _ => x
  | Zneg _ => ~ x
  end.

Fixpoint interp_clause(env: list Prop)(c: list Z): Prop :=
  match c with
  | nil => False
  | [x] => interp_lit env x
  | x :: rest => interp_lit env x \/ interp_clause env rest
  end.

Fixpoint interp_formula(env: list Prop)(f: list (list Z)): Prop :=
  match f with
  | nil => True
  | [c] => interp_clause env c
  | c :: rest => interp_clause env c /\ interp_formula env rest
  end.

Eval cbv -[not] in (forall (x1 x2 x3 x4 x5: Prop),
                       interp_formula [Error; x1; x2; x3; x4; x5] (snd test1)).

Fixpoint foralls(n: nat)(acc: list Prop)(body: list Prop -> Prop): Prop :=
  match n with
  | O => body (rev acc)
  | S n' => forall (x: Prop), foralls n' (x :: acc) body
  end.

Definition claim_unsat(inp: Input): Prop :=
  let '(nvars, clauses) := inp in
  forall (x x0: Prop), (* dummy vars to make Coq's auto naming scheme match *)
    foralls (Z.to_nat nvars) [x0]
            (fun env =>
               forall e, e = env -> (* dummy equation to easily get env later *)
               True -> (* dummy hypothesis to get auto naming of hypotheses match *)
               interp_formula env clauses -> False).

Eval cbv -[not] in (claim_unsat test1).

Lemma resolution: forall x1 A B,
    x1 \/ A ->
    ~ x1 \/ B ->
    A \/ B.
Proof. tauto. Qed.

Lemma resolution1: forall C1 A1 D,
    C1 \/ A1 ->
    ~A1 \/ D ->
    C1 \/ D.
Proof. tauto. Qed.

Lemma resolution2: forall C1 A1 C2 A2 D,
    C1 \/ A1 ->
    C2 \/ A2 ->
    ~A1 \/ ~A2 \/ D ->
    C1 \/ C2 \/ D.
Proof. tauto. Qed.

Lemma resolution3: forall C1 A1 C2 A2 C3 A3 D,
    C1 \/ A1 ->
    C2 \/ A2 ->
    C3 \/ A3 ->
    ~A1 \/ ~A2 \/ ~A3 \/ D ->
    C1 \/ C2 \/ C3 \/ D.
Proof. tauto. Qed.

Lemma resolution4: forall C1 A1 C2 A2 C3 A3 C4 A4 D,
    C1 \/ A1 ->
    C2 \/ A2 ->
    C3 \/ A3 ->
    C4 \/ A4 ->
    ~A1 \/ ~A2 \/ ~A3 \/ ~A4 \/ D ->
    C1 \/ C2 \/ C3 \/ C4 \/ D.
Proof. tauto. Qed.

Lemma resolution5: forall C1 A1 C2 A2 C3 A3 C4 A4 C5 A5 D,
    C1 \/ A1 ->
    C2 \/ A2 ->
    C3 \/ A3 ->
    C4 \/ A4 ->
    C5 \/ A5 ->
    ~A1 \/ ~A2 \/ ~A3 \/ ~A4 \/ ~A5 \/ D ->
    C1 \/ C2 \/ C3 \/ C4 \/ C5 \/ D.
Proof. tauto. Qed.

Ltac indexOf firstIndex default e l :=
  match l with
  | nil => default
  | e :: _ => firstIndex
  | _ :: ?rest => indexOf (firstIndex + 1) default e rest
  end.

Ltac reify_lit env l :=
  lazymatch l with
  | ~ ?x => let r := indexOf 0 0 x env in constr:(-r)
  | ?x => indexOf 0 0 x env
  end.

Ltac reify_clause env c :=
  lazymatch c with
  | ?c1 \/ ?c2 =>
    let r1 := reify_clause env c1 in
    let r2 := reify_clause env c2 in
    constr:(r1 ++ r2)
  | ?l =>
    let r := reify_lit env l in
    constr:([r])
  end.

Fixpoint insert(lit: Z)(c: list Z): list Z :=
  match c with
  | nil => [lit]
  | h :: t => match Z.compare (Z.abs lit) (Z.abs h) with
              | Eq => if h =? lit then c (* x \/ x \/ rest *) else lit :: h :: nil (* x \/ ~x *)
              | Gt => h :: (insert lit t)
              | Lt => lit :: h :: t
              end
  end.

Lemma interp_lit_neg: forall env l,
    interp_lit env (- l) <-> ~ interp_lit env l.
Proof.
  unfold interp_lit.
  split; intros; destruct l; simpl in *; auto.
  - admit.
  - admit.
  - apply NNPP. assumption.
Admitted.

Lemma insert_sound: forall env l c,
    interp_clause env (insert l c) ->
    interp_lit env l \/ interp_clause env c.
Proof.
  induction c; intros; simpl in *; auto.
  destruct (Z.abs l ?= Z.abs a) eqn: E.
  - apply Z.compare_eq in E.
    destruct (a =? l) eqn: F.
    + apply Z.eqb_eq in F. subst a. simpl in *.
      right. exact H.
    + apply Z.eqb_neq in F. assert (a = -l) by lia. subst a.
      destruct c; rewrite interp_lit_neg;
      destruct (classic (interp_lit env l)); auto.
  - simpl in *.  exact H.
  - simpl in *.
    destruct (insert l c) eqn: F.
    + destruct c eqn: G; auto.
    + destruct c eqn: G.
      * intuition idtac. simpl in *. contradiction.
      * intuition idtac.
Qed.

Lemma insert_complete: forall env l c,
    interp_lit env l \/ interp_clause env c ->
    interp_clause env (insert l c).
Proof.
  induction c; intros; simpl in *; try solve [intuition idtac].
  destruct (Z.abs l ?= Z.abs a) eqn: E.
  - apply Z.compare_eq in E.
    destruct (a =? l) eqn: F.
    + apply Z.eqb_eq in F. subst a. simpl in *.
      destruct c; tauto.
    + apply Z.eqb_neq in F. assert (a = -l) by lia. subst a.
      destruct c.  simpl in *. (*[simpl in *; contradiction|].
      rewrite interp_lit_neg.
      destruct (classic (interp_lit env l)); auto.
  - simpl in *.  exact H.
  - simpl in *.
    destruct (insert l c) eqn: F.
    + destruct c eqn: G; auto.
    + destruct c eqn: G.
      * intuition idtac. simpl in *. contradiction.
      * intuition idtac.
Qed.
*)
Abort.

Goal claim_unsat test1.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.
  destruct (classic (x1 = True)).
  - subst.
    destruct (classic (x5 = True)).
    + subst.
      destruct (classic (x4 = False)).
      * subst.
        (* SAT *)
Abort.

(* TODO claim_sat *)

Goal claim_unsat test1.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.
  pose proof (resolution H1 H2). (* contains x5 and ~x5, so it's useless *) clear H4.
  assert (H1': x4 \/ x1 \/ ~ x5) by tauto. clear H1.
  assert (H3': ~x4 \/ ~x3) by tauto. clear H3.
  pose proof (resolution H1' H3') as H4.

  match goal with
  | H: _ = ?l |- _ => let res := indexOf 0 0 x4 l in let res' := eval cbv in res in idtac res'
  end.

  match goal with
  | H: _ = ?env |- _ => let res := reify_lit env (~x3) in let res' := eval cbv in res in idtac res'
  end.

  match goal with
  | H: _ = ?env |- _ =>
    let T := type of H4 in
    let res := reify_clause env T in let r := eval cbv in res in idtac r
  end.
Abort.

Example test2 := (4, [
  [ 1;  2; -3];
  [-1; -2;  3];
  [ 2;  3; -4];
  [-2; -3;  4];
  [ 1;  3;  4];
  [-1; -3; -4];
  [-1;  2;  4];
  [ 1; -2; -4]
]).

(* from https://www.satcompetition.org/2013/certunsat.shtml *)

(* resolution proof *)
Goal claim_unsat test2.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.

  (* 9  1  2  0 1 3 5 0 *)
  assert (H9: x1 \/ x2) by (clear -H1 H3 H5; tauto).
  (* 10  1  0  9 4 5 8 0 *)
  assert (H10: x1) by (clear -H9 H4 H5 H8; tauto).
  (* 11  2  0  9 3 6 7 0 *)
  assert (H11: x2) by (clear -H9 H3 H6 H7; tauto).
  (* 12  0 10 11 2 4 6 0 *)
  assert (H12: False) by (clear -H10 H11 H2 H4 H6; tauto).

  exact H12.
Qed.

(* RUP proof: would have to delete the "clear" clauses but then tauto is too slow *)
Goal claim_unsat test2.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.
  (* 1 2 0 *)
  assert (H9: x1 \/ x2) by (clear -H1 H3 H5; tauto).
  (* 1 0 *)
  assert (H10: x1) by (clear -H9 H4 H5 H8; tauto).
  (* 2 0 *)
  assert (H11: x2) by (clear -H9 H3 H6 H7; tauto).
  (* 0 *)
  assert (H12: False) by (clear -H10 H11 H2 H4 H6; tauto).

  exact H12.
Qed.

(* DRUP proof: deletion & reverse unit progagation (should not need the "clear -..." but tauto is too slow otherwise) *)
Goal claim_unsat test2.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.
  (*    1  2  0 *)
  assert (H9: x1 \/ x2) by (clear -H1 H3 H5; tauto).
  (* d  1  2 -3 0 *)
  clear H1.
  (*    1  0 *)
  assert (H10: x1) by (clear -H9 H4 H5 H8; tauto).
  (* d  1  2  0 *)
  (* clear H9. not sure if we can really clear that one?? *)
  (* d  1  3  4 0 *)
  clear H5.
  (* d  1 -2 -4 0 *)
  clear H8.
  (*    2  0 *)
  assert (H11: x2) by (clear -H9 H3 H6 H7; tauto).
  (*    0 *)
  assert (H12: False) by (clear -H10 H11 H2 H4 H6; tauto).

  exact H12.
Qed.

(* details of how resolution works *)
Goal claim_unsat test2.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.

  (* 9  1  2  0 1 3 5 0 *)
  assert (H9: x1 \/ x2). {
    clear -H1 H3 H5.

    assert (H1': ~x3 \/ x1 \/ x2) by (clear -H1; tauto).
    assert (H3': x3 \/ x2 \/ ~ x4) by (clear -H3; tauto).
    pose proof (resolution H3' H1') as H_1_3'. clear H1' H3'.
    assert (H_1_3: x1 \/ x2 \/ ~x4) by (clear -H_1_3'; tauto). clear H_1_3'.

    assert (H1': ~x3 \/ x1 \/ x2) by (clear -H1; tauto).
    assert (H5': x3 \/ x1 \/ x4) by (clear -H5; tauto).
    pose proof (resolution H5' H1') as H_1_5'. clear H1' H5'.
    assert (H_1_5: x1 \/ x2 \/ x4) by (clear -H_1_5'; tauto). clear H_1_5'.

    assert (H_1_3': ~x4 \/ x1 \/ x2) by (clear -H_1_3; tauto).
    assert (H_1_5': x4 \/ x1 \/ x2) by (clear -H_1_5; tauto).
    pose proof (resolution H_1_5' H_1_3') as H_1_3_5.
    clear -H_1_3_5.
    tauto.
  }

  (* 10  1  0  9 4 5 8 0 *)
  assert (H10: x1). {
    clear -H9 H4 H5 H8.
    tauto.
  }

  (* 11  2  0  9 3 6 7 0 *)
  assert (H11: x2) by (clear -H9 H3 H6 H7; tauto).
  (* 12  0 10 11 2 4 6 0 *)
  assert (H12: False) by (clear -H10 H11 H2 H4 H6; tauto).

  exact H12.
Qed.

(*
Ltac resolvent allvars on acc cl1 cl2 :=
  match allvars with
  | nil => acc
  | on :: ?rest => resolvent rest on acc cl1 cl2
  | ?v :: ?rest =>
    lazymatch cl1 with
    | context [~v] => resolvent rest on (~v \/ acc) cl1 cl2
    | context [ v] => resolvent rest on ( v \/ acc) cl1 cl2
    | _ => lazymatch cl2 with
           | context [~v] => resolvent rest on (~v \/ acc) cl1 cl2
           | context [ v] => resolvent rest on ( v \/ acc) cl1 cl2
           | _ => resolvent rest on acc cl1 cl2
           end
    end
  end.
*)
Ltac resolvent allvars on cl1 cl2 :=
  match allvars with
  | nil => constr:(False)
  | on :: ?rest => resolvent rest on cl1 cl2
  | ?v :: ?rest =>
    let r := resolvent rest on cl1 cl2 in
    lazymatch cl1 with
    | context [~v] => constr:(~v \/ r)
    | context [ v] => constr:( v \/ r)
    | _ => lazymatch cl2 with
           | context [~v] => constr:(~v \/ r)
           | context [ v] => constr:( v \/ r)
           | _ => constr:(r)
           end
    end
  end.

Ltac do_one_resolution :=
  match goal with
      | A: context[?X1], B: context[~?X1] |- _ =>
        is_var X1;
        (*idtac "----" A B "on" X1;*)
        tryif (match type of A with
               | context[?X2] =>
                 is_var X2;
                 tryif (unify X1 X2) then fail else
                 (match type of B with
                  | context[~ X2] => idtac (* "no because" X2 *)
                  end)
               end)
        then fail
        else
          (tryif (match type of B with
                  | context[?X2] =>
                    is_var X2;
                    tryif (unify X1 X2) then fail else
                      (match type of A with
                       | context[~ X2] => idtac (* "no because" X2 *)
                       end)
                  end)
            then fail
            else (idtac "yes" A B;
                  lazymatch goal with
                  | H: _ = ?env |- _ =>
                    let P1 := type of A in
                    let P2 := type of B in
                    let res := resolvent env X1 P1 P2 in idtac res;
                    lazymatch goal with
                    | _: res |- _ => fail
                    | |- _ => assert res by (clear -A B; tauto)
                    end
                  end))
      end.

Goal claim_unsat test2.
  cbv -[not].
  intros.
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end.
  repeat do_one_resolution.
  assumption.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive tree :=
  | Leaf : tree
  | Node : tree -> tree -> tree.
Axiom tree_WhyType : WhyType tree.
Existing Instance tree_WhyType.

(* Why3 assumption *)
Fixpoint depths (d:Z) (t:tree) {struct t}: (list Z) :=
  match t with
  | Leaf => (cons d nil)
  | (Node l r) => (List.app (depths (d + 1%Z)%Z l) (depths (d + 1%Z)%Z r))
  end.

Axiom depths_head : forall (t:tree) (d:Z), match (depths d
  t) with
  | (cons x _) => (d <= x)%Z
  | nil => False
  end.

Axiom depths_unique : forall (t1:tree) (t2:tree) (d:Z) (s1:(list Z))
  (s2:(list Z)), ((List.app (depths d t1) s1) = (List.app (depths d
  t2) s2)) -> ((t1 = t2) /\ (s1 = s2)).

Axiom depths_prefix : forall (t:tree) (d1:Z) (d2:Z) (s1:(list Z))
  (s2:(list Z)), ((List.app (depths d1 t) s1) = (List.app (depths d2
  t) s2)) -> (d1 = d2).

Axiom depths_prefix_simple : forall (t:tree) (d1:Z) (d2:Z), ((depths d1
  t) = (depths d2 t)) -> (d1 = d2).

Axiom depths_subtree : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z)
  (s1:(list Z)), ((List.app (depths d1 t1) s1) = (depths d2 t2)) ->
  (d2 <= d1)%Z.

Axiom depths_unique2 : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z), ((depths d1
  t1) = (depths d2 t2)) -> ((d1 = d2) /\ (t1 = t2)).

(* Why3 assumption *)
Definition lex (x1:((list Z)* Z)%type) (x2:((list Z)* Z)%type): Prop :=
  match x1 with
  | (s1, d1) =>
      match x2 with
      | (s2, d2) => ((list.Length.length s1) < (list.Length.length s2))%Z \/
          (((list.Length.length s1) = (list.Length.length s2)) /\ match (s1,
          s2) with
          | ((cons h1 _), (cons h2 _)) => ((d2 < d1)%Z /\ (d1 <= h1)%Z) /\
              (h1 = h2)
          | _ => False
          end)
      end
  end.

(* Why3 goal *)
Theorem WP_parameter_build : forall (s:(list Z)), (forall (t:tree)
  (s':(list Z)), ~ ((List.app (depths 0%Z t) s') = s)) -> forall (t:tree),
  ~ ((depths 0%Z t) = s).
(* Why3 intros s h1 t. *)
intuition.
replace (depths 0 t) with (app (depths 0 t) nil) in H0.
apply (H _ _ H0).
apply Append.Append_l_nil.
Qed.


(** Catalan number via generating functions *)
(******************************************************************************)
(*       Copyright (C) 2019 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import fintype div bigop ssralg binomial rat ssrnum.

Require tfps.
Require Import auxresults fps.

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

Section Catalan.

Variable (C : nat -> nat).

Hypothesis C0 : C 0 = 1%N.
Hypothesis CS : forall n : nat, C n.+1 = \sum_(i < n.+1) C i * C (n - i).

Local Definition Csimpl := (C0, CS, big_ord0, big_ord_recl).
Example C1 : C 1 = 1.  Proof. by rewrite !Csimpl. Qed.
Example C2 : C 2 = 2.  Proof. by rewrite !Csimpl. Qed.
Example C3 : C 3 = 5.  Proof. by rewrite !Csimpl. Qed.
Example C4 : C 4 = 14. Proof. by rewrite !Csimpl. Qed.
Example C5 : C 5 = 42. Proof. by rewrite !Csimpl. Qed.

Import GRing.Theory.

Local Definition Rat := [fieldType of rat].
Local Definition char_Rat := Num.Theory.char_num [numDomainType of Rat].
Local Definition nat_unit := tfps.TFPSField.nat_unit_field char_Rat.
Local Definition fact_unit := tfps.TFPSField.fact_unit char_Rat.
Hint Resolve char_Rat nat_unit : core.

Section GenSeries.

Local Open Scope ring_scope.
Local Open Scope fps_scope.

Definition FC : {fps Rat} := \fps (C i)%:R .X^i.

Lemma FC_in_coef0_eq1 : FC \in coefs0_eq1.
Proof. by rewrite coefs0_eq1E coefs_FPSeries C0. Qed.

Proposition FC_algebraic_eq : FC = 1 + ''X * FC ^+ 2.
Proof.
rewrite /FC; apply/fpsP => i.
rewrite !(coefs_FPSeries, coefs_simpl, coef_fpsXM).
case: i => [|i]; first by rewrite C0 addr0.
rewrite add0r CS /= expr2 coefsM natr_sum.
apply eq_bigr => [[j /= _]] _.
by rewrite !coefs_FPSeries natrM.
Qed.

End GenSeries.

(** Extraction of the coefficient using square root and Newton's formula *)
Section AlgebraicSolution.

Local Open Scope ring_scope.
Local Open Scope fps_scope.

Lemma mulr_nat i (f : {fps Rat}) : i%:R *: f = i%:R * f.
Proof. by rewrite scaler_nat -[f *+ i]mulr_natr mulrC. Qed.

Theorem FC_algebraic_solution :
  ''X * FC = 2%:R^-1 *: (1 - \sqrt (1 - 4%:R *: ''X)).
Proof.
have co1 : 1 - 4%:R *: ''X \in @coefs0_eq1 Rat.
  by rewrite mulr_nat coefs0_eq1E !coefs_simpl mulrC coef_fpsXM subr0.
have: (2%:R *: ''X * FC - 1) ^+ 2 = 1 - 4%:R *: ''X.
  apply/eqP; rewrite !mulr_nat sqrrB1 !exprMn 2!expr2 -natrM.
  rewrite mulrA -subr_eq0 opprB [_ - 1]addrC addrA addrK addrC addrA.
  rewrite -{1}(mulr1 (4%:R * _)) -[X in _ + X + _]mulrA -mulrDr.
  rewrite -FC_algebraic_eq.
  by rewrite -[_ *+ 2]mulr_natl !mulrA -natrM subrr.
move/(sqrtE nat_unit) => /(_ co1) [HeqP | HeqN].
  exfalso; move: HeqP => /(congr1 (fun x => x``_0)).
  rewrite mulr_nat coefsB -mulrA mulrC -mulrA coef_fpsXM coefs1.
  rewrite (eqP (coefs0_eq1_expr _ _)) /= => /eqP.
  rewrite -subr_eq0 add0r -oppr_eq0 opprD opprK -mulr2n => /eqP Habs.
  by have:= char_Rat 2; rewrite !inE Habs /= eq_refl.
have neq20 : 2%:R != 0 :> Rat by rewrite Num.Theory.pnatr_eq0.
apply (scalerI neq20); rewrite scalerA divff // scale1r -HeqN.
by rewrite addrC subrK scalerAl.
Qed.

Theorem coefFC i : FC``_i = i.*2`!%:R / i`!%:R /i.+1`!%:R.
Proof.
have:= congr1 (fun x => x``_i.+1) FC_algebraic_solution.
rewrite coef_fpsXM ![X in (X = _)]/= => ->.
rewrite coefsZ coefsB coefs1 sub0r -scaleNr coef_expr1cX ?{}Hi //.
rewrite mulrN mulrA -mulNr; congr (_ / (i.+1)`!%:R).
rewrite -[4]/(2 * 2)%N mulrnA -mulNrn -[(1 *- 2 *+ 2)]mulr_natl.
rewrite exprMn -mulrA.
have -> : (1 *- 2)^+ i.+1 = \prod_(i0 < i.+1) (1 *- 2) :> rat.
  by rewrite prodr_const /= card_ord.
rewrite -big_split /= big_ord_recl /=.
rewrite subr0 mulNr divrr // mulN1r 2!mulrN [LHS]opprK.
rewrite exprS !mulrA [2%:R^-1 * 2%:R]mulVf // mul1r.
rewrite (eq_bigr (fun j : 'I_i => (2 * j + 1)%:R)) /=; last first.
  move=> j _; rewrite /bump /=.
  rewrite mulNr -mulrN opprD addrC opprK addnC natrD 2!mulrDr.
  rewrite mulrN divff // mulr1 -{2}addn1 {2}natrD addrA addrK.
  by rewrite natrD natrM.
elim: i => [|i IHi]; first by rewrite expr0 big_ord0 double0 fact0 mulr1.
rewrite big_ord_recr /= exprS -mulrA mulrC mulrA {}IHi.
rewrite doubleS !factS 3!natrM.
set F := (i.*2)`!%:R; rewrite [_ * F]mulrC mulrA [_ * F]mulrC -!mulrA.
congr (_ * _); rewrite {F} mulrC invfM // !mulrA; congr (_ * _).
rewrite mul2n -{2}[i.*2.+1]addn1 [X in X / _]mulrC -mulrA; congr (_ * _).
rewrite -[i.*2.+2]addn1 addSnnS -mul2n -[X in (_ + X)%N]muln1.
rewrite -mulnDr addn1 natrM mulfK //.
by have /charf0P -> := char_Rat.
Qed.

Theorem Cat_rat i : (C i)%:R = i.*2`!%:R / i`!%:R /i.+1`!%:R :> Rat.
Proof. by rewrite -coefFC coefs_FPSeries. Qed.

Local Close Scope ring_scope.

Theorem CatM i : C i * i`! * i.+1`! = i.*2`!.
Proof.
have:= Cat_rat i.
move/(congr1 (fun x => x * (i.+1)`!%:R * i`!%:R)%R).
rewrite (divrK (fact_unit i.+1)) (divrK (fact_unit i)) // -!natrM => /eqP.
rewrite Num.Theory.eqr_nat => /eqP <-.
by rewrite -[RHS]mulnA [_`! * i`!]mulnC mulnA.
Qed.

Theorem CatV i : C i = i.*2`! %/ (i`! * i.+1`!).
Proof.
have:= CatM i; rewrite -mulnA => /(congr1 (fun j => j %/ (i`! * (i.+1)`!))).
by rewrite mulnK // muln_gt0 !fact_gt0.
Qed.

Theorem Cat i : C i = 'C(i.*2, i) %/ i.+1.
Proof.
case: (ltnP 0 i)=> [Hi|]; last first.
  by rewrite leqn0 => /eqP ->; rewrite C0 bin0 divn1.
rewrite (CatV i) factS [i.+1 * _]mulnC mulnA.
by rewrite -{3}(addnK i i) addnn divnMA bin_factd // double_gt0.
Qed.

End AlgebraicSolution.

(** Extraction of the coefficient using Lagrange inversion formula *)
Section LagrangeSolution.

Local Open Scope ring_scope.
Local Open Scope tfps_scope.

Lemma one_plusX_2_unit : ((1 + ''X) ^+ 2 : {fps Rat}) \is a GRing.unit.
Proof.
rewrite unit_fpsE coefs0M coefsD coefs1.
by rewrite coef_fpsX addr0 mulr1.
Qed.

Proposition FC_fixpoint_eq : FC - 1 = lagrfix ((1 + ''X) ^+ 2).
Proof.
apply: (lagrfix_uniq one_plusX_2_unit).
rewrite {1}FC_algebraic_eq -addrA addrC subrK.
rewrite rmorphX rmorphD /= comp_fps1 comp_fpsX //; first last.
  rewrite coefs0_eq0E coefsB coefs1.
  by rewrite coefs_FPSeries /= C0 subrr.
by rewrite addrC subrK.
Qed.

Theorem CatM_Lagrange i : (i.+1 * (C i))%N = 'C(i.*2, i).
Proof.
case: i => [|i]; first by rewrite C0 mul1n bin0.
apply/eqP; rewrite -(Num.Theory.eqr_nat [numDomainType of Rat]); rewrite natrM.
have:= (congr1 (fun s => s``_i.+1) FC_fixpoint_eq).
rewrite coefsD coefs_FPSeries.
rewrite coefsN coefs1 subr0 /= => ->.
rewrite (coefs_lagrfix nat_unit) ?one_plusX_2_unit //.
rewrite -exprM mul2n addrC exprD1n coefs_sum.
have Hord : (i < (i.+1).*2.+1)%N.
  by rewrite ltnS doubleS -addnn -!addnS leq_addr.
rewrite (bigD1 (Ordinal Hord)) //= -!/(_`_i.+1).
rewrite coefsMn coef_fpsXn // eqxx /=.
rewrite big1 ?addr0 => [|[j /= Hj]]; first last.
  rewrite -val_eqE /= => {Hj} /negbTE Hj.
  by rewrite coefsMn coef_fpsXn eq_sym Hj mul0rn.
rewrite ltnS in Hord.
rewrite -bin_sub // -{2}addnn -addSnnS addnK.
by rewrite mulrA -natrM mul_bin_left -addnn addnK natrM mulrC mulKr.
Qed.

Local Close Scope ring_scope.

Theorem Cat_Lagrange i : C i = 'C(i.*2, i) %/ i.+1.
Proof.
by have:= congr1 (fun m => m %/ i.+1) (CatM_Lagrange i); rewrite mulnC mulnK.
Qed.

End LagrangeSolution.

(** Extraction of the coefficient using Holonomic differential equation *)
Section HolonomicSolution.

Local Open Scope ring_scope.
Local Open Scope fps_scope.

Proposition FC_differential_eq :
  (1 - ''X *+ 2) * FC + (1 - ''X *+ 4) * ''X * FC^`()%fps = 1.
Proof.
have X2Fu : (1 - ''X *+ 2 * FC) \is a GRing.unit.
  rewrite unit_fpsE coefsB coefs1.
  by rewrite mulrnAl coefsMn coef_fpsXM.
rewrite -mulrA.
have FalgN : ''X * FC ^+ 2 = FC - 1.
  by apply/eqP; rewrite eq_sym subr_eq addrC -FC_algebraic_eq.
have -> : ''X * FC^`()%fps = (FC - 1)/(1 - ''X *+ 2 * FC).
  rewrite -[LHS]divr1; apply/eqP.
  rewrite (eq_divr (''X * _)) ?unitr1 // ?X2Fu // mulr1.
  have /= := congr1 ((fun s => ''X * s) \o (@deriv_fps _)) FC_algebraic_eq.
  rewrite derivD_fps deriv_fps1 add0r.
  rewrite derivM_fps /= deriv_fpsX mul1r derivX_fps /= expr1.
  rewrite mulrDr FalgN => /eqP; rewrite -(subr_eq _ _ (''X * _)) => /eqP <-.
  rewrite mulrBr mulr1 -!mulrA; apply/eqP; congr (_ - ''X * _).
  by rewrite !(mulrnAr, mulrnAl) mulrC mulrA.
rewrite mulrA -[X in X + _](mulrK X2Fu) -mulrDl -[RHS]divr1.
apply/eqP; rewrite eq_divr ?unitr1 // mulr1 mul1r.
rewrite -mulrA [FC * _]mulrC [(1 - _ * FC) * FC]mulrBl -mulrA -expr2.
rewrite mul1r mulrnAl FalgN.
rewrite !mulrnBl opprB addrA (mulr2n FC) (opprD FC) addrA.
rewrite [_ - FC]addrC 2!addrA [-FC + _]addrC subrr add0r.
rewrite !mulrBr mulr1 addrA addrC !addrA.
rewrite opprB mulrBl mul1r mulr_natr -mulrnA -[(2 * 2)%N]/4.
rewrite [''X *+ 4 - 1 + _]addrC addrA subrK addrK.
rewrite -addrA -mulNr -mulrDl.
rewrite opprD [-1 + _]addrC addrA subrK -opprD mulNr.
rewrite -[4]/(2 + 2)%N mulrnDr addrA.
by rewrite [_ *- _ + _]addrC subrK.
Qed.

Local Close Scope ring_scope.
Local Close Scope tfps_scope.

Proposition Catalan_rec n : n.+2 * C (n.+1) = (4 * n + 2) * C n.
Proof.
have := congr1 (fun x => (x``_n.+1)%R) FC_differential_eq.
rewrite coefs1 coefsD !mulrDl !mul1r !coefsD.
rewrite -!mulNrn !(mulrnAl, coefsMn, mulNr, coefsN).
rewrite -mulrA !coef_fpsXM /= !coef_deriv_fps !coefs_FPSeries.
case: n => [|n] /=; first by rewrite !Csimpl.
move: {n} n.+1 => n; move: (C n.+1) (C n) => Cn1 Cn.
rewrite !mulNrn addrA [X in (X - _)%R]addrC addrA -mulrSr -!mulrnA.
move/eqP; rewrite subr_eq add0r subr_eq -natrD Num.Theory.eqr_nat => /eqP.
rewrite mulnC -mulnDr => ->.
by rewrite mulnC [n * 4]mulnC.
Qed.

Theorem CatM_from_rec n : n.+1 * C n = 'C(n.*2, n).
Proof.
elim: n => [| n IHn] /=; first by rewrite C0 bin0.
rewrite Catalan_rec doubleS !binS.
have leq_n2 : n <= n.*2 by rewrite -addnn leq_addr.
rewrite -[X in _ + _ + X]bin_sub; last exact: (leq_trans leq_n2 (leqnSn _)).
rewrite subSn // -{4}addnn addnK binS addnn.
rewrite addn2 -[4]/(2 * 2) -mulnA !mul2n -doubleS -doubleMl; congr _.*2.
rewrite -IHn -{1}addnn -addnS mulnDl; congr (_ + _).
have:= mul_bin_down n.*2 n.
rewrite mul_bin_diag -{2}addnn addnK -{}IHn mulnA [n * n.+1]mulnC.
rewrite -mulnA ![n.+1 * _]mulnC => /(congr1 (fun m => m %/ n.+1)).
by rewrite !mulnK.
Qed.

Theorem Cat_from_rec i : C i = 'C(i.*2, i) %/ i.+1.
Proof.
by have:= congr1 (fun m => m %/ i.+1) (CatM_from_rec i); rewrite mulnC mulnK.
Qed.

End HolonomicSolution.

End Catalan.