Require Import List.
Require Import Classical.

Section election_spec.
  (** For this section, we hold the set of candidates abstract,
      and define ballots and some properties of ballots irrespective
      of how candidates are defined.
   *)
  Variable candidate:Set.

  (** Voters cast votes, which consist of a sequence of rank positions.
      For each rank position, a voter selects 0 or more candidates.
      A properly cast vote will have (1) no more than one candidate selected
      at each rank, (2) each candidate selected at most once, and (3) no
      candidate selected at a rank position later than a rank position with
      zero candidates.  However, voters do not always follow the rules;
      voters may select more than one candidate at a given rank, may select
      the same candidate more than once, or may skip rankings.

      The vote tabulation system must handle these cases.
   *)
  Definition rankSelection := list candidate.
  Definition ballot := list rankSelection.
  Definition election := list ballot.
  Definition contestants := list candidate.

  Section ballot_properties.
    (**  At any given round of a tabulation, some collection of candidates
         have been eliminated.  The following definitions are all defined
         with respect to the candidates that have been eliminated thus far.
         The abstract 'eliminated' predicate indicates which candidates are
         already eliminated.
      *)

    Variable eliminated : candidate -> Prop.

    (**  One condition for a ballot to be exhausted is that it
         all the candidates it selects have already been eliminated.
         This vacuously covers the case of an empty ballot.
     *)
    Definition no_viable_candidates (b:ballot) :=
      forall rank, In rank b ->
        forall candidate, In candidate rank ->
          eliminated candidate.

    (**  From a given ballot, find the first rank selection
         (if it exists) which contains at least one
         continuing candidate.
      *)
    Definition overvote (r : rankSelection) :=
       exists c1 c2, In c1 r /\ In c2 r /\ c1 <> c2.

    Inductive next_ranking : ballot -> rankSelection -> Prop :=
    | next_ranking_eliminated : forall b r r',
        Forall eliminated r' ->
        ~overvote r' ->
        next_ranking b r ->
        next_ranking (r' :: b) r
    | next_ranking_valid : forall b r c,
        In c r  ->
        (overvote r \/ ~eliminated c) ->
        next_ranking (r :: b) r.

    Definition properly_selects r c :=
      Forall (eq c) r /\ In c r /\ ~eliminated c.

    Definition does_not_select r :=
      r = nil \/ (exists c, Forall (eq c) r /\ In c r /\ eliminated c).

    Lemma not_overvote_cons :
      forall h t,
        ~overvote (h :: t) ->
        Forall (eq h) t /\ ~overvote t.
    Proof.
      induction t; intros.
      - split.
        + constructor.
        + intro. unfold overvote in H0.
          destruct H0. destruct H0.
          intuition.
      -split.
        + constructor.
          destruct (classic (h = a)).
          * auto.
          * exfalso.
            apply H.
            unfold overvote.
            exists h. exists a. intuition.
          * unfold overvote in H.
            apply IHt.
            intro.
            apply H.
            clear H.
            destruct H0.
            destruct H.
            exists x. exists x0.
            simpl in *. intuition.
        + intuition.
          apply H; clear H.
          unfold overvote in H0.
          destruct H0.
          destruct H.
          destruct H.
          destruct H0.
          unfold overvote.
          exists x. exists x0.
          intuition.
    Qed.

    Lemma not_overvote_all_same :
      forall r c,
        ~overvote r ->
        In c r ->
        Forall (eq c) r.
    Proof.
      induction r; intros.
      - inversion H0.
      - apply not_overvote_cons in H.
        intuition. destruct H0. subst.
        rewrite Forall_forall. intros. simpl in *.
        intuition. assert (In x r) by auto.
        eapply IHr in H0; eauto.
        rewrite Forall_forall in *.
        specialize (H0 x).
        specialize (H1 x). intuition.
        constructor; intuition.
        rewrite Forall_forall in H1. specialize (H1 c).
        intuition.
    Qed.

    Lemma ranking_cases : forall r,
    overvote r \/ (exists c, properly_selects r c) \/ does_not_select r.
    intros.
    destruct r.
    - right. right. left. auto.
    - destruct (classic (overvote (c :: r))).
      + auto.
      + right. destruct (classic (eliminated c)).
        * right. right. exists c. simpl. intuition.
          apply not_overvote_all_same; simpl; auto.
        * left. exists c. repeat split; auto.
          apply not_overvote_all_same; simpl; auto.
          simpl; auto.
    Qed.

    Lemma next_ranking_not_not_selects : forall b r,
        next_ranking b r ->
        ~does_not_select r.
    Proof.
      intros.
      induction H.
      - auto.
      - intro.
        unfold does_not_select in *.
        destruct H1. subst. elim H.
        destruct H1.
        destruct H1.
        rewrite Forall_forall in H1.
        apply H1 in H. subst. intuition.
        unfold overvote in *.
        destruct H2. destruct H0. intuition. apply H5. transitivity c; eauto.
        symmetry. eauto.
    Qed.

    Lemma next_ranking_spec : forall b r,
        next_ranking b r ->
        overvote r \/ (exists c, properly_selects r c).
    Proof.
      intros.
      destruct (ranking_cases r); intuition.
      apply next_ranking_not_not_selects in H.
      intuition.
    Qed.

    (**  TODO: Do we need a notion of overvote for a ballot any more?
         A ballot is an overvote if its next ranking contains
         two distinct candidates.
      *)
   (* Definition overvote (b:ballot) : Prop :=
      exists r, next_ranking b r /\
         exists c1 c2, In c1 r /\ In c2 r /\ c1 <> c2.*)

    (**  A ballot is exhausted if it selects no vaiable candidates
         or is an overvote
      *)

    Definition exhausted_ballot (b:ballot) :=
      (~ exists r, next_ranking b r ) \/
      (exists r, next_ranking b r /\ overvote r).

    Ltac inv H := inversion H; subst; clear H.
    Lemma next_ranking_unique : forall b r1 r2,
        next_ranking b r1 ->
        next_ranking b r2 ->
        r1= r2.
    Proof.
      intros.
      induction b.
      inversion H.
      inv H; inv H0; try rewrite Forall_forall in *; firstorder.
    Qed.

    Lemma exhausted_ballot_next_ranking_iff : forall (b : ballot),
          exhausted_ballot b <-> forall r, next_ranking b r -> overvote r.
    Proof.
      intros.
      split; intros.
      - unfold exhausted_ballot in H.
        intuition. exfalso.
        apply H1. exists r. auto.
        destruct H1. destruct H. eapply next_ranking_unique in H0; eauto.
        subst; auto.
      - unfold exhausted_ballot.
        destruct (classic (exists r, next_ranking b r)).
        destruct H0. right.
        exists x. auto.
        left. auto.
    Qed.

    Definition continuing_ballot (b:ballot) :=
      ~exhausted_ballot b.

    (**  A ballot selects a particular candidate iff it is a
         continuing ballot and its next ranking contains that
         candidate.
      *)
    Definition selected_candidate (b:ballot) (c:candidate) :=
      continuing_ballot b /\
      exists r, next_ranking b r /\ In c r.

    (** If a candidate receives a majority of the first choices, that
candidate shall be declared elected.*)

    Inductive first_choices (c : candidate) : election ->  nat -> Prop :=
    | first_choices_nil : first_choices c nil 0
    | first_choices_selected : forall h t n', selected_candidate h c ->
                                              first_choices c t n' ->
                                              first_choices c (h::t) (S n')
    | first_choices_not_selected : forall h t n, ~selected_candidate h c ->
                                                 first_choices c t n ->
                                                 first_choices c (h::t) n.

    Lemma sf_first_choices_unique : forall e c n1 n2,
        first_choices c e n1 ->
        first_choices c e n2 ->
        n1 = n2.
    Proof.
      induction e.
      * intros. inversion H. inversion H0. auto.
      * intros.
        inversion H; clear H; subst;
        inversion H0; clear H0; subst; try contradiction.
        f_equal; eauto.
        eauto.
    Qed.

    Lemma sf_first_choices_total : forall e c, exists n,
        first_choices c e n.
    Proof.
      induction e.
      * intros. exists 0. apply first_choices_nil.
      * intros.
        destruct (IHe c) as [n ?].
        destruct (classic (selected_candidate a c)).
        exists (S n). apply first_choices_selected; auto.
        exists n. apply first_choices_not_selected; auto.
    Qed.

    Inductive total_selected : election -> nat -> Prop :=
    | total_nil : total_selected nil 0
    | total_continuing : forall b e' n, continuing_ballot b ->
                                        total_selected e' n ->
                                        total_selected (b :: e') (S n)
    | total_exhausted : forall b e' n, exhausted_ballot b ->
                                       total_selected e' n ->
                                       total_selected (b :: e') (n).

    Lemma total_selected_total : forall e,
        exists n, total_selected e n.
    Proof.
      induction e; intros.
      - exists 0; constructor.
      - destruct IHe.
        destruct (classic (exhausted_ballot a)).
        + exists x; constructor; auto.
        + exists (S x). apply total_continuing; auto.
    Qed.

    Definition majority (e : election) (winner : candidate) :=
      forall total_votes winner_votes,
        total_selected e total_votes ->
        first_choices winner e winner_votes ->
        (winner_votes * 2) > total_votes.

    (** If no candidate receives a
majority, the candidate who received the fewest first choices shall be
eliminated and each vote cast for that candidate shall be transferred to
the next ranked candidate on that voter's ballot. *)

    Definition participates (c:candidate) (e:election) :=
      exists b, In b e /\ exists r, In r b /\ In c r.

    Definition viable_candidate (e:election) (c:candidate) :=
      ~eliminated c /\ participates c e.

    Definition is_loser (e:election) (loser:candidate) :=
      viable_candidate e loser /\
      forall c' n m,
        viable_candidate e c' ->
        first_choices loser e n ->
        first_choices c' e m ->
        n <= m.

    Definition no_majority (e : election) :=
      ~(exists c, majority e c).

    (**  Every ballot selects at most one candidate.
     *)
    Lemma selected_candidate_unique (b:ballot) (c1 c2:candidate) :
      selected_candidate b c1 ->
      selected_candidate b c2 ->
      c1 = c2.
    Proof.
      unfold selected_candidate.
      intros [Hb [r1 [??]]].
      intros [_ [r2 [??]]].
      assert (r1 = r2) by (apply (next_ranking_unique b); auto).
      subst r2.
      destruct (classic (c1=c2)); auto.
      elim Hb. red. right. firstorder.
    Qed.

    (**
What to do if a ballot has multiple choices for a rank, but all
have already been eliminated?  Shall the ballot be deemed exhausted,
or will we continue to consider later choices?

E.g.,

     A
     B, C
     D

Suppose both B and C were eliminated in earlier rounds, but
A is not eliminated.  We should count this ballot as a vote
for A.  Suppose, in a subsequent round, A is also eliminated.
Now, should this ballot be considered an overvote and removed;
or should it count as a vote for D?  The statue language is
unclear.

However, actual practice seems to be that a ballot is decared an overvote
as soon as the first ranking with more than one selection becomse relevant;
i.e., when all properly-selected candidates above it have been eliminated.
In other words, the ballot is considered to be truncated at the position
of the first ranking with more than one selection.

The formal specification above follows suit, and counts this situation
as an overvote as soon as A is eliminated.
*)

    (**  Whenever a ballot selects a candidate, that candidate is not eliminated.
      *)
    Lemma selected_candidate_not_eliminated (b:ballot) :
      forall c, selected_candidate b c -> ~eliminated c.
    Proof.
      induction b.
      unfold selected_candidate. intros c [Hc [r [??]]]. inv H.
      unfold selected_candidate. intros c [Hc [r [??]]]. inv H.
      * apply IHb. split; eauto.
        red; intro.
        apply Hc.
        destruct H.
        elim H; eauto.
        destruct H as [r' [??]].
        right. exists r'. split; auto.
        apply next_ranking_eliminated; auto.
      * intro Helim.
        elim Hc. red.
        right. exists r. split; auto.
        eapply next_ranking_valid; eauto.
        destruct H5; auto.
        red. exists c. exists c0. intuition.
        subst c0. contradiction.
    Qed.

    (* The next ranking for a ballot is in the ballot. *)
    Lemma next_ranking_in_ballot (b:ballot) :
      forall r, next_ranking b r -> In r b.
    Proof.
      intros r H. induction H; intuition; eauto.
    Qed.

  End ballot_properties.

  Definition update_eliminated (eliminated : candidate -> Prop) (c : candidate) :=
    fun cs => eliminated cs \/ c = cs.

  Inductive winner :
    election -> (candidate -> Prop) -> candidate -> Prop :=
  | winner_now : forall election winning_candidate eliminated,
      majority eliminated election winning_candidate ->
      winner election eliminated winning_candidate
  | winner_elimination : forall election winning_candidate eliminated loser,
      no_majority eliminated election ->
      is_loser eliminated election loser ->
      let eliminated' := update_eliminated eliminated loser in
      winner election eliminated' winning_candidate ->
      winner election eliminated winning_candidate.

End election_spec.

(**
SAN FRANCISCO CHARTER

[Obtained from-- http://www.amlegal.com/library/ca/sfrancisco.shtml on
June 13, 2015.]

ARTICLE XIII: ELECTIONS

SEC. 13.102. INSTANT RUNOFF ELECTIONS.

(a) For the purposes of this section: (1) a candidate shall be deemed
"continuing" if the candidate has not been eliminated; (2) a ballot
shall be deemed "continuing" if it is not exhausted; and (3) a ballot
shall be deemed "exhausted," and not counted in further stages of the
tabulation, if all of the choices have been eliminated or there are no
more choices indicated on the ballot. If a ranked-choice ballot gives
equal rank to two or more candidates, the ballot shall be declared
exhausted when such multiple rankings are reached. If a voter casts a
ranked-choice ballot but skips a rank, the voter's vote shall be
transferred to that voter's next ranked choice.

(b) The Mayor, Sheriff, District Attorney, City Attorney, Treasurer,
Assessor-Recorder, Public Defender, and members of the Board of
Supervisors shall be elected using a ranked-choice, or "instant runoff,"
ballot. The ballot shall allow voters to rank a number of choices in
order of preference equal to the total number of candidates for each
office; provided, however, if the voting system, vote tabulation system
or similar or related equipment used by the City and County cannot
feasibly accommodate choices equal to the total number of candidates
running for each office, then the Director of Elections may limit the
number of choices a voter may rank to no fewer than three. The ballot
shall in no way interfere with a voter's ability to cast a vote for a
write-in candidate.

(c) If a candidate receives a majority of the first choices, that
candidate shall be declared elected. If no candidate receives a
majority, the candidate who received the fewest first choices shall be
eliminated and each vote cast for that candidate shall be transferred to
the next ranked candidate on that voter's ballot. If, after this
transfer of votes, any candidate has a majority of the votes from the
continuing ballots, that candidate shall be declared elected.

(d) If no candidate receives a majority of votes from the continuing
ballots after a candidate has been eliminated and his or her votes have
been transferred to the next-ranked candidate, the continuing candidate
with the fewest votes from the continuing ballots shall be eliminated.
All votes cast for that candidate shall be transferred to the next-
ranked continuing candidate on each voter's ballot. This process of
eliminating candidates and transferring their votes to the next-ranked
continuing candidates shall be repeated until a candidate receives a
majority of the votes from the continuing ballots.

(e) If the total number of votes of the two or more candidates credited
with the lowest number of votes is less than the number of votes
credited to the candidate with the next highest number of votes, those
candidates with the lowest number of votes shall be eliminated
simultaneously and their votes transferred to the next-ranked continuing
candidate on each ballot in a single counting operation.

(f) A tie between two or more candidates shall be resolved in accordance
with State law.

(g) The Department of Elections shall conduct a voter education campaign
to familiarize voters with the ranked-choice or, "instant runoff,"
method of voting.

(h) Any voting system, vote tabulation system, or similar or related
equipment acquired by the City and County shall have the capability to
accommodate this system of ranked-choice, or "instant runoff,"
balloting.

(i) Ranked choice, or "instant runoff," balloting shall be used for the
general municipal election in November 2002 and all subsequent
elections. If the Director of Elections certifies to the Board of
Supervisors and the Mayor no later than July 1, 2002 that the Department
will not be ready to implement ranked-choice balloting in November 2002,
then the City shall begin using ranked-choice, or "instant runoff,"
balloting at the November 2003 general municipal election.

If ranked-choice, or "instant runoff," balloting is not used in November
of 2002, and no candidate for any elective office of the City and
County, except the Board of Education and the Governing Board of the
Community College District, receives a majority of the votes cast at an
election for such office, the two candidates receiving the most votes
shall qualify to have their names placed on the ballot for a runoff
election held on the second Tuesday in December of 2002.
 *)


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.

Set Universe Polymorphism.

Program Definition ConstFunctor {D : Category} (C : Category) (a : Obj D) : Functor C D :=
  {|
    FApp := fun X => a;
    FAppH := fun X Y => fun f => \Id a
  |}.
Next Obligation.
Proof.
  rewrite Hom_IdL.
  reflexivity.
Qed.

Program Definition IdFunctor (C : Category) : Functor C C :=
  {|
    FApp := fun X => X;
    FAppH := fun X Y => fun f => f
  |}.

Program Definition Functor_Comp {C1 C2 C3 : Category} (F : Functor C2 C3) (G : Functor C1 C2) : Functor C1 C3 :=
  {|
    FApp := fun (X : Obj C1) => FApp F (FApp G X : Obj _);
    FAppH := fun (X Y : Obj C1) => fun (f : Hom X Y) => FAppH F (FAppH G f)
  |}.
Next Obligation.
  rewrite FAppH_comp_eq.
  rewrite FAppH_comp_eq.
  reflexivity.
Qed.
Next Obligation.
  rewrite Functor_id_eq.
  rewrite Functor_id_eq.
  reflexivity.
Qed.

Lemma Functor_Comp_assoc : forall {C1 C2 C3 C4 : Category} (F1 : Functor C3 C4) (F2 : Functor C2 C3) (F3 : Functor C1 C2),
    Functor_Comp (Functor_Comp F1 F2) F3 = Functor_Comp F1 (Functor_Comp F2 F3).
Proof.
  move => C1 C2 C3 C4 F1 F2 F3.
  apply: ToFunctorEq => X Y f /=.
  exact: Hom_eq'_refl.
Qed.

Lemma Functor_Comp_IdL :
  forall {C D : Category} (F : Functor C D),
    Functor_Comp (IdFunctor D) F = F.
Proof.
  move => C D F.
  apply: ToFunctorEq => X Y f /=.
  exact: Hom_eq'_refl.
Qed.

Lemma Functor_Comp_IdR :
  forall {C D : Category} (F : Functor C D),
    Functor_Comp F (IdFunctor C) = F.
Proof.
  move => C D F.
  apply: ToFunctorEq => X Y f /=.
  exact: Hom_eq'_refl.
Qed.


Require Import eq.
Require Import utils.
Require Import injective.

(* defines a map v -> v which permutes x and y                      *)
Definition permute (v:Type) (p:Eq v) (x y:v) (u:v) : v :=
    match p u x with
    | left  _       => y        (* if u = x return y    *)
    | right _       =>
        match p u y with
        | left  _   => x        (* if u = y return x    *)
        | right _   => u        (* otherwise return u   *)
        end
     end.

Arguments permute {v} _ _ _ _.

Lemma permute_x : forall (v:Type) (p:Eq v) (x y:v), permute p x y x = y.
Proof.
    intros v p x y. unfold permute. destruct (p x x) as [H|H].
    - reflexivity.
    - exfalso. apply H. reflexivity.
Qed.

Lemma permute_y : forall (v:Type) (p: Eq v) (x y:v), permute p x y y = x.
Proof.
    intros v p x y. unfold permute.
    destruct (p y x) as [H0|H0].
    - assumption.
    - destruct (p y y) as [H1|H1].
        + reflexivity.
        + exfalso. apply H1. reflexivity.
Qed.

Lemma permute_not_xy : forall (v:Type) (p:Eq v) (x y z:v),
    z <> x -> z <> y -> permute p x y z = z.
Proof.
    intros v p x y z Hx Hy. unfold permute.
    destruct (p z x) as [H0|H0].
    - exfalso. apply Hx. assumption.
    - destruct (p z y) as [H1|H1].
        + exfalso. apply Hy. assumption.
        + reflexivity.
Qed.

Lemma permute_inv : forall (v:Type) (p:Eq v) (x y:v), permute p x x y = y.
Proof.
    intros v p x y. unfold permute. destruct (p y x) as [H|H]; subst;
    reflexivity.
Qed.

Lemma permute_injective : forall (v:Type) (p:Eq v) (x y:v),
    injective (permute p x y).
Proof.
    intros v p x y s t. unfold permute.
    destruct    (p s x) as [Hsx|Hsx],
                (p t x) as [Htx|Htx]; subst; intros H'.
    - reflexivity.
    - destruct (p t y) as [Hty|Hty]; subst.
        + reflexivity.
        + exfalso. apply Hty. reflexivity.
    - destruct (p s y) as [Hsy|Hsy]; subst.
        + reflexivity.
        + exfalso. apply Hsy. reflexivity.
    - destruct (p s y) as [Hsy|Hsy], (p t y) as [Hty|Hty]; subst.
        + reflexivity.
        + exfalso. apply Htx. reflexivity.
        + exfalso. apply Hsx. reflexivity.
        + reflexivity.
Qed.

Lemma permute_comp : forall (v w:Type) (p:Eq v) (q:Eq w) (x y u:v) (f:v -> w),
    injective f -> f (permute p x y u) = permute q (f x) (f y) (f u).
Proof.
    intros v w p q x y u f I. unfold permute.
    destruct    (p u x) as [Hux|Hux],
                (p u y) as [Huy|Huy]; subst.
    - destruct (q (f y) (f y)) as [Fyy|Fyy]; reflexivity.
    - destruct (q (f x) (f x)) as [Fxx|Fxx].
        + reflexivity.
        + destruct (q (f x) (f y)) as [Fxy|Fxy].
            { rewrite Fxy. reflexivity. }
            { exfalso. apply Fxx. reflexivity. }
    - destruct (q (f y) (f x)) as [Fyx|Fyx].
        + rewrite Fyx. reflexivity.
        + destruct (q (f y) (f y)) as [Fyy|Fyy].
            { reflexivity. }
            { exfalso. apply Fyy. reflexivity. }
    - destruct (q (f u) (f x)) as [Fux|Fux].
        + exfalso. apply Hux. apply I. assumption.
        + destruct (q (f u) (f y)) as [Fuy|Fuy].
            { exfalso. apply Huy. apply I. assumption. }
            { reflexivity. }
Qed.

Lemma permute_commute : forall (v:Type) (p:Eq v) (x y u:v),
    permute p x y u = permute p y x u.
Proof.
    intros v p x y u. unfold permute.
    destruct (p u x) as [Hx|Hx], (p u y) as [Hy|Hy];
    try (reflexivity).
    rewrite <- Hx, <- Hy. reflexivity.
Qed.

Lemma permute_involution : forall (v:Type) (p:Eq v) (x y z:v),
    permute p x y (permute p x y z) = z.
Proof.
    intros v p x y z. unfold permute at 2.
    destruct (p z x) as [Hzx|Hzx], (p z y) as [Hzy|Hzy]; subst.
    - apply permute_x.
    - apply permute_y.
    - apply permute_x.
    - apply permute_not_xy; assumption.
Qed.

Lemma permute_thrice : forall (v:Type) (p:Eq v) (x y z u:v),
    x <> z  ->
    y <> z  ->
    permute p x y (permute p y z (permute p x y u)) = permute p x z u.
Proof.
    intros v p x y z u Hxz Hyz.
    unfold permute at 3. destruct (p u x) as [Hux|Hux].
    - rewrite permute_x, Hux, permute_x. apply permute_not_xy;
      apply neq_sym; assumption.
    - destruct (p u y) as [Huy|Huy]; subst.
        + destruct (p x y) as [Hxy|Hxy]; subst.
            { apply permute_inv. }
            { rewrite (permute_not_xy v p y z x); try (assumption).
              rewrite permute_x. symmetry. apply permute_not_xy; assumption.
            }
        + destruct (p x y) as [Hxy|Hxy]; subst.
            { apply permute_inv. }
            { destruct (p u z) as [Huz|Huz]; subst.
                { rewrite permute_y, permute_y, permute_y. reflexivity. }
                { rewrite (permute_not_xy v p y z u); try (assumption).
                  rewrite (permute_not_xy v p x z u); try (assumption).
                  apply permute_not_xy; assumption.
                }
            }
Qed.

(*
    intros v p x y z u Hxy Hxz Hyz.
    unfold permute at 3. destruct (p u x) as [Hux|Hux].
    - rewrite permute_x. rewrite Hux. rewrite permute_x. apply permute_not_xy.
        + apply neq_sym. assumption.
        + apply neq_sym. assumption.
    - destruct (p u y) as [Huy|Huy] eqn:Puy.
        + rewrite (permute_not_xy v p y z x); try (assumption).
            { rewrite permute_x, Huy. symmetry. apply permute_not_xy.
                { apply neq_sym. assumption. }
                { assumption. }
            }
        + unfold permute at 2. rewrite Puy. destruct (p u z) as [Huz|Huz].
            { rewrite permute_y, Huz, permute_y. reflexivity. }
            { rewrite permute_not_xy; try (assumption).
              rewrite permute_not_xy; try (assumption). reflexivity.
            }
Qed.
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

(**************************************************************************)
(* This file deals with divisibility for natural numbers.                 *)
(* It contains the definitions of:                                        *)
(*      edivn m d   == the pair composed of the quotient and remainder    *)
(*                     of the euclidian division of m by d                *)
(*          m %/ d  == quotient of m by d                                 *)
(*          m %% d  == remainder of m dy d                                *)
(*  m = n %[mod d]  <=> m equals n modulo d                               *)
(*  m == n %[mod d] <=> m equals n modulo d (boolean version)             *)
(*  m <> n %[mod d] <=> m differs from n modulo d                         *)
(*  m != n %[mod d] <=> m differs from n modulo d (boolean version)       *)
(*           d %| m <=> d divides m                                       *)
(*         gcdn m n == the GCD of m and n                                 *)
(*        egcdn m n == the extended GCD of m and n                        *)
(*         lcmn m n == the LCM of m and n                                 *)
(*      coprime m n <=> m and n are coprime                               *)
(*  chinese m n r s == witness of the chinese remainder theorem           *)
(**************************************************************************)

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

(** Euclidian division *)

Definition edivn_rec d := fix loop (m q : nat) {struct m} :=
  if m - d is m'.+1 then loop m' q.+1 else (q, m).

Definition edivn m d := if d > 0 then edivn_rec d.-1 m 0 else (0, m).

CoInductive edivn_spec (m d : nat) : nat * nat -> Type :=
  EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r).

Lemma edivnP : forall m d, edivn_spec m d (edivn m d).
Proof.
rewrite /edivn => m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
rewrite subn_if_gt; case: ltnP => [// | le_dm].
rewrite -{1}(subnKC le_dm) -addSn addnA -mulSnr; apply: IHn.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_eq : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> d q r lt_rd; have d_gt0: 0 < d by exact: leq_trans lt_rd.
case: edivnP lt_rd => q' r'; rewrite d_gt0 /=.
wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
rewrite -(leq_pmul2r d_gt0); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.

Definition divn m d := (edivn m d).1.

Notation "m %/ d" := (divn m d) (at level 40, no associativity) : nat_scope.

(* We redefine modn so that it is structurally decreasing. *)

Definition modn_rec d := fix loop (m : nat) :=
  if m - d is m'.+1 then loop m' else m.

Definition modn m d := if d > 0 then modn_rec d.-1 m else m.

Notation "m %% d" := (modn m d) (at level 40, no associativity) : nat_scope.
Notation "m = n %[mod d ]" := (m %% d = n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  =  n '/'  %[mod  d ] ']'") : nat_scope.
Notation "m == n %[mod d ]" := (m %% d == n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  ==  n '/'  %[mod  d ] ']'") : nat_scope.
Notation "m <> n %[mod d ]" := (m %% d <> n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  <>  n '/'  %[mod  d ] ']'") : nat_scope.
Notation "m != n %[mod d ]" := (m %% d != n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  !=  n '/'  %[mod  d ] ']'") : nat_scope.

Lemma modn_def : forall m d, m %% d = (edivn m d).2.
Proof.
rewrite /modn /edivn => m [|d] //=.
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=.
rewrite ltnS !subn_if_gt; case: (d <= m) => // le_mn.
by apply: IHn; apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_def : forall m d, edivn m d = (m %/ d, m %% d).
Proof. by move=> m d; rewrite /divn modn_def; case edivn. Qed.

Lemma divn_eq : forall m d, m = m %/ d * d + m %% d.
Proof. by move=> m d; rewrite /divn modn_def; case edivnP. Qed.

Lemma div0n : forall d, 0 %/ d = 0. Proof. by case. Qed.
Lemma divn0 : forall m, m %/ 0 = 0. Proof.  by []. Qed.
Lemma mod0n :  forall d, 0 %% d = 0. Proof. by case. Qed.
Lemma modn0 :  forall m, m %% 0 = m. Proof. by []. Qed.

Lemma divn_small : forall m d, m < d -> m %/ d = 0.
Proof. by move=> m d lt_md; rewrite /divn (edivn_eq 0). Qed.

Lemma divn_addl_mul : forall q m d, 0 < d -> (q * d + m) %/ d = q + m %/ d.
Proof.
move=> q m d d_gt0; rewrite {1}(divn_eq m d) addnA -muln_addl.
by rewrite /divn edivn_eq // modn_def; case: edivnP; rewrite d_gt0.
Qed.

Lemma mulnK : forall m d, 0 < d -> m * d %/ d = m.
Proof.
by move=> m d d_gt0; rewrite -[m * d]addn0 divn_addl_mul // div0n addn0.
Qed.

Lemma mulKn : forall m d, 0 < d -> d * m %/ d = m.
Proof. by move=> *; rewrite mulnC mulnK. Qed.

Lemma modn1 : forall m, m %% 1 = 0.
Proof. by move=> m; rewrite modn_def; case: edivnP => ? []. Qed.

Lemma divn1 : forall m, m %/ 1 = m.
Proof. by move=> m; rewrite {2}(@divn_eq m 1) // modn1 addn0 muln1. Qed.

Lemma divnn : forall d, d %/ d = (0 < d).
Proof. by case=> // d; rewrite -{1}[d.+1]muln1 mulKn. Qed.

Lemma divn_pmul2l : forall p m d, p > 0 -> p * m %/ (p * d) = m %/ d.
Proof.
move=> p m d p_gt0; case: (posnP d) => [-> | d_gt0]; first by rewrite muln0.
rewrite {2}/divn; case: edivnP; rewrite d_gt0 /= => q r ->{m} lt_rd.
rewrite muln_addr mulnCA divn_addl_mul; last by rewrite muln_gt0 p_gt0.
by rewrite addnC divn_small // ltn_pmul2l.
Qed.
Implicit Arguments divn_pmul2l [p m d].

Lemma divn_pmul2r : forall p m d, p > 0 -> m * p %/ (d * p) = m %/ d.
Proof. by move=> p m d p_gt0; rewrite -!(mulnC p) divn_pmul2l. Qed.
Implicit Arguments divn_pmul2r [p m d].

Lemma ltn_mod : forall m d, (m %% d < d) = (0 < d).
Proof. by move=> m [|d] //; rewrite modn_def; case: edivnP. Qed.

Lemma ltn_pmod : forall m d, 0 < d -> m %% d < d.
Proof. by move=> m d; rewrite ltn_mod. Qed.

Lemma leq_floor : forall m d, m %/ d * d <= m.
Proof. by move=> m d; rewrite {2}(divn_eq m d) leq_addr. Qed.

Lemma leq_mod : forall m d, m %% d  <= m.
Proof. by move=> m d; rewrite {2}(divn_eq m d) leq_addl. Qed.

Lemma leq_div : forall m d, m %/ d <= m.
Proof. move=> m [|d] //; exact: leq_trans (leq_pmulr _ _) (leq_floor _ _). Qed.

Lemma ltn_ceil : forall m d, 0 < d -> m < (m %/ d).+1 * d.
Proof.
by move=> m d ? /=; rewrite {1}(divn_eq m d) -addnS mulSnr leq_add2l ltn_mod.
Qed.

Lemma ltn_divl : forall m n d, d > 0 -> (m %/ d < n) = (m < n * d).
Proof.
move=> m n d d_gt0; apply/idP/idP.
  rewrite -(leq_pmul2r d_gt0); exact: leq_trans (ltn_ceil _ _).
rewrite !ltnNge -(@leq_pmul2r d n) //; apply: contra => le_nd_floor.
exact: leq_trans le_nd_floor (leq_floor _ _).
Qed.

Lemma leq_divr : forall m n d, d > 0 -> (m <= n %/ d) = (m * d <= n).
Proof. by move=> m n d d_gt0; rewrite leqNgt ltn_divl // -leqNgt. Qed.

Lemma ltn_Pdiv : forall m d, 1 < d -> 0 < m -> m %/ d < m.
Proof. by move=> m d d_gt1 m_gt0; rewrite ltn_divl ?ltn_Pmulr // ltnW. Qed.

Lemma divn_gt0 : forall d m, 0 < d -> (0 < m %/ d) = (d <= m).
Proof. by move=> d m d_gt0; rewrite leq_divr ?mul1n. Qed.

Lemma divn_divl : forall m n p, m %/ n %/ p = m %/ (n * p).
Proof.
move=> m [|n] [|p]; rewrite ?muln0 ?div0n //.
rewrite {1}(divn_eq m (n.+1 * p.+1)) mulnA mulnAC !divn_addl_mul //.
by rewrite addnC divn_small // ltn_divl // mulnC ltn_mod.
Qed.

Lemma divnAC : forall m n p, m %/ n %/ p =  m %/ p %/ n.
Proof. by move=> m n p; rewrite !divn_divl mulnC. Qed.

Lemma modn_small : forall m d, m < d -> m %% d = m.
Proof. by move=> m d lt_md; rewrite {2}(divn_eq m d) divn_small. Qed.

Lemma modn_mod : forall m d, m %% d = m %[mod d].
Proof. by move=> m [|d] //; apply: modn_small; rewrite ltn_mod. Qed.

Lemma modn_addl_mul : forall p m d, p * d + m = m %[mod d].
Proof.
move=> p m d; case: (posnP d) => [-> | d_gt0]; first by rewrite muln0.
by rewrite {1}(divn_eq m d) addnA -muln_addl modn_def edivn_eq // ltn_mod.
Qed.

Lemma modn_pmul2l : forall p m d, 0 < p -> p * m %% (p * d) = p * (m %% d).
Proof.
move=> p m d p_gt0; apply: (@addnI (p * (m %/ d * d))).
by rewrite -muln_addr -divn_eq mulnCA -(divn_pmul2l p_gt0) -divn_eq.
Qed.
Implicit Arguments modn_pmul2l [p m d].

Lemma modn_addl : forall m d, d + m = m %[mod d].
Proof. by move=> m d; rewrite -{1}[d]mul1n modn_addl_mul. Qed.

Lemma modn_addr : forall m d, m + d = m %[mod d].
Proof. by move=> *; rewrite addnC modn_addl. Qed.

Lemma modnn : forall d, d %% d = 0.
Proof. by move=> d; rewrite -{1}[d]addn0 modn_addl mod0n. Qed.

Lemma modn_mull : forall p d, p * d %% d = 0.
Proof. by move=> p d; rewrite -[p * d]addn0 modn_addl_mul mod0n. Qed.

Lemma modn_mulr : forall p d, d * p %% d = 0.
Proof. by move=> p d; rewrite mulnC modn_mull. Qed.

Lemma modn_addml : forall m n d, m %% d + n = m + n %[mod d].
Proof. by move=> m n d; rewrite {2}(divn_eq m d) -addnA modn_addl_mul. Qed.

Lemma modn_addmr : forall m n d, m + n %% d = m + n %[mod d].
Proof. by move=> m n d; rewrite !(addnC m) modn_addml. Qed.

Lemma modn_add2m : forall m n d, m %% d  + n %% d = m + n %[mod d].
Proof. by move=> m n d; rewrite modn_addml modn_addmr. Qed.

Lemma modn_add2l : forall p m n d,
  (p + m == p + n %[mod d]) = (m == n %[mod d]).
Proof.
move=> p m n [|d]; first by rewrite !modn0 eqn_addl.
apply/eqP/eqP=> eq_mn; last by rewrite -modn_addmr eq_mn modn_addmr.
rewrite -(modn_addl_mul p m) -(modn_addl_mul p n) !mulnSr -!addnA.
by rewrite -modn_addmr eq_mn modn_addmr.
Qed.

Lemma modn_add2r : forall p m n d,
  (m + p == n + p %[mod d]) = (m == n %[mod d]).
Proof. by move=> p *; rewrite -!(addnC p) modn_add2l. Qed.

Lemma modn_mulml : forall m n d, m %% d * n = m * n %[mod d].
Proof.
by move=> m n d; rewrite {2}(divn_eq m d) muln_addl mulnAC modn_addl_mul.
Qed.

Lemma modn_mulmr : forall m n d, m * (n %% d) = m * n %[mod d].
Proof. by move=> m n d; rewrite !(mulnC m) modn_mulml. Qed.

Lemma modn_mul2m : forall m n d, m %% d * (n %% d) = m * n %[mod d].
Proof. by move=> m n d; rewrite modn_mulml modn_mulmr. Qed.

Lemma modn2 : forall m, m %% 2 = odd m.
Proof. by elim=> //= m IHm; rewrite -addn1 -modn_addml IHm; case odd. Qed.

Lemma divn2 : forall m, m %/ 2 = m./2.
Proof.
by move=> m; rewrite {2}(divn_eq m 2) modn2 muln2 addnC half_bit_double.
Qed.

Lemma odd_mod : forall m d, odd d = false -> odd (m %% d) = odd m.
Proof.
by move=> m d d_even; rewrite {2}(divn_eq m d) odd_add odd_mul d_even andbF.
Qed.

Lemma modn_exp : forall m n a, (a %% n) ^ m = a ^ m %[mod n].
Proof.
by elim=> // m Hrec n a; rewrite !expnS -modn_mulmr Hrec modn_mulml modn_mulmr.
Qed.

(** Divisibility **)

Definition dvdn d m := m %% d == 0.

Notation "m %| d" := (dvdn m d) (at level 70, no associativity) : nat_scope.

Definition multn := [rel m d | d %| m].

Lemma dvdn2 : forall n, (2 %| n) = ~~ odd n.
Proof. by move=> n; rewrite /dvdn modn2; case (odd n). Qed.

Lemma dvdnP : forall d m, reflect (exists k, m = k * d) (d %| m).
Proof.
move=> d m; apply: (iffP eqP) => [Hm | [k ->]]; last by rewrite modn_mull.
by exists (m %/ d); rewrite {1}(divn_eq m d) Hm addn0.
Qed.
Implicit Arguments dvdnP [d m].
Prenex Implicits dvdnP.

Lemma dvdn0 : forall d, d %| 0.
Proof. by case. Qed.

Lemma dvd0n : forall n, (0 %| n) = (n == 0).
Proof. by case. Qed.

Lemma dvdn1 : forall d, (d %| 1) = (d == 1).
Proof. by case=> [|[|n]] //; rewrite /dvdn modn_small. Qed.

Lemma dvd1n : forall m, 1 %| m.
Proof. by move=> m; rewrite /dvdn modn1. Qed.

Lemma dvdn_gt0 : forall d m, m > 0 -> d %| m -> d > 0.
Proof. by do 2!case. Qed.

Lemma dvdnn : forall m, m %| m.
Proof. by move=> m; rewrite /dvdn modnn. Qed.

Lemma dvdn_mull : forall d m n, d %| n -> d %| m * n.
Proof. by move=> d m n; case/dvdnP=> n' ->; rewrite /dvdn mulnA modn_mull. Qed.

Lemma dvdn_mulr : forall d m n, d %| m -> d %| m * n.
Proof. by move=> d m n d_m; rewrite mulnC dvdn_mull. Qed.

Hint Resolve dvdn0 dvd1n dvdnn dvdn_mull dvdn_mulr.

Lemma dvdn_mul : forall d1 d2 m1 m2, d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2.
Proof.
move=> d1 d2 m1 m2; case/dvdnP=> q1 ->; case/dvdnP=> q2 ->.
by rewrite mulnCA -mulnA 2?dvdn_mull.
Qed.

Lemma dvdn_trans : forall n d m, d %| n -> n %| m -> d %| m.
Proof. move=> n d m Hn; move/dvdnP => [n1 ->]; exact: dvdn_mull. Qed.

Lemma dvdn_eq : forall d m, (d %| m) = (m %/ d * d == m).
Proof.
move=> d m; apply/eqP/eqP=> [modm0 | <-]; last exact: modn_mull.
by rewrite {2}(divn_eq m d) modm0 addn0.
Qed.

Lemma divnK : forall d m, d %| m -> m %/ d * d = m.
Proof. by move=> m d; rewrite dvdn_eq; move/eqP. Qed.

Lemma leq_divl : forall d m n, d %| m -> (m %/ d <= n) = (m <= n * d).
Proof. by case=> [[]//|d] m n dv_d_m; rewrite -(@leq_pmul2r d.+1) ?divnK. Qed.

Lemma ltn_divr : forall d m n, d %| m -> (n < m %/ d) = (n * d < m).
Proof. by move=> d m n dv_d_m; rewrite !ltnNge leq_divl. Qed.

Lemma eqn_div : forall d m n, d > 0 -> d %| m -> (n == m %/ d) = (n * d == m).
Proof. by move=> d m n d_gt0 dv_d_m; rewrite -(eqn_pmul2r d_gt0) divnK. Qed.

Lemma eqn_mul : forall d m n, d > 0 -> d %| m -> (m == n * d) = (m %/ d == n).
Proof. by move=> d m n d_gt0 dv_d_m; rewrite eq_sym -eqn_div // eq_sym. Qed.

Lemma divn_mulAC : forall d m n, d %| m -> m %/ d * n = m * n %/ d.
Proof.
case=> [[]//|d] m n dv_d_m; apply/eqP.
by rewrite eqn_div ?dvdn_mulr // mulnAC divnK.
Qed.

Lemma divn_mulA : forall d m n, d %| n -> m * (n %/ d) = m * n %/ d.
Proof. by move=> d m n dv_d_m; rewrite !(mulnC m) divn_mulAC. Qed.

Lemma divn_mulCA : forall d m n,
  d %| m -> d %| n -> m * (n %/ d) = n * (m %/ d).
Proof. by move=> d m n dv_d_m dv_d_n; rewrite mulnC divn_mulAC ?divn_mulA. Qed.

Lemma divn_divr : forall m n p, p %| n -> m %/ (n %/ p) = m * p %/ n.
Proof. by move=> m n [|p] dv_n; rewrite -{2}(divnK dv_n) // divn_pmul2r. Qed.

Lemma modn_dvdm : forall m n d, d %| m -> n %% m = n %[mod d].
Proof.
move=> m n d; case/dvdnP=> q def_m.
by rewrite {2}(divn_eq n m) {3}def_m mulnA modn_addl_mul.
Qed.

Lemma dvdn_leq : forall d m, 0 < m -> d %| m -> d <= m.
Proof.
by move=> d m m_gt0; case/dvdnP=> [[|k] Dm]; rewrite Dm // leq_addr in m_gt0 *.
Qed.

Lemma gtnNdvd : forall n d, 0 < n -> n < d -> (d %| n) = false.
Proof. by move=> n d n_gt0 ltnd; rewrite /dvdn eqn0Ngt modn_small ?n_gt0. Qed.

Lemma eqn_dvd : forall m n, (m == n) = (m %| n) && (n %| m).
Proof.
case=> [|m] [|n] //; apply/idP/andP; first by move/eqP->; auto.
rewrite eqn_leq => [[Hmn Hnm]]; apply/andP; have:= dvdn_leq; auto.
Qed.

Lemma dvdn_pmul2l : forall p d m, 0 < p -> (p * d %| p * m) = (d %| m).
Proof. by case=> // p d m _; rewrite /dvdn modn_pmul2l // muln_eq0. Qed.
Implicit Arguments dvdn_pmul2l [p m d].

Lemma dvdn_pmul2r : forall p d m, 0 < p -> (d * p %| m * p) = (d %| m).
Proof. by move=> n d m Hn; rewrite -!(mulnC n) dvdn_pmul2l. Qed.
Implicit Arguments dvdn_pmul2r [p m d].

Lemma dvdn_exp2l : forall p m n, m <= n -> p ^ m %| p ^ n.
Proof. by move=> p m n; move/subnK <-; rewrite expn_add dvdn_mull. Qed.

Lemma dvdn_Pexp2l : forall p m n, p > 1 -> (p ^ m %| p ^ n) = (m <= n).
Proof.
move=> p m n p_gt1; case: leqP => [|gt_n_m]; first exact: dvdn_exp2l.
by rewrite gtnNdvd ?ltn_exp2l ?expn_gt0 // ltnW.
Qed.

Lemma dvdn_exp2r : forall m n k, m %| n -> m ^ k %| n ^ k.
Proof. by move=> m n k; case/dvdnP=> q ->; rewrite expn_mull dvdn_mull. Qed.

Lemma dvdn_addr : forall m d n, d %| m -> (d %| m + n) = (d %| n).
Proof. by move=> n d m; move/dvdnP=> [k ->]; rewrite /dvdn modn_addl_mul. Qed.

Lemma dvdn_addl : forall n d m, d %| n -> (d %| m + n) = (d %| m).
Proof. by move=> n d m; rewrite addnC; exact: dvdn_addr. Qed.

Lemma dvdn_add : forall d m n, d %| m -> d %| n -> d %| m + n.
Proof. by move=> n d m; move/dvdn_addr->. Qed.

Lemma dvdn_add_eq : forall d m n, d %| m + n -> (d %| m) = (d %| n).
Proof. by move=> *; apply/idP/idP; [move/dvdn_addr <-| move/dvdn_addl <-]. Qed.

Lemma dvdn_subr : forall d m n, n <= m -> d %| m -> (d %| m - n) = (d %| n).
Proof. by move=> d m n le_n_m dv_d_m; apply: dvdn_add_eq; rewrite subnK. Qed.

Lemma dvdn_subl : forall d m n, n <= m -> d %| n -> (d %| m - n) = (d %| m).
Proof. by move=> d m n le_n_m dv_d_m; rewrite -(dvdn_addl _ dv_d_m) subnK. Qed.

Lemma dvdn_sub : forall d m n, d %|m -> d %| n -> d %| m - n.
Proof.
move=> d n m; case: (leqP m n) => Hm; first by move/dvdn_subr <-.
by rewrite (eqnP (ltnW Hm)) dvdn0.
Qed.

Lemma dvdn_exp : forall k d m, 0 < k -> d %| m -> d %| (m ^ k).
Proof. by case=> // *; rewrite expnS dvdn_mulr. Qed.

Hint Resolve dvdn_add dvdn_sub dvdn_exp.

Lemma eqn_mod_dvd : forall d m n, n <= m -> (m == n %[mod d]) = (d %| m - n).
Proof.
by move=> d m n le_mn; rewrite -{1}[n]add0n -{1}(subnK le_mn) modn_add2r mod0n.
Qed.

Lemma divn_addl : forall m n d, d %| m -> (m + n) %/ d = m %/ d + n %/ d.
Proof. by move=> m n [//|d] dv_m; rewrite -{1}(divnK dv_m) divn_addl_mul. Qed.

Lemma divn_addr : forall m n d, d %| n -> (m + n) %/ d = m %/ d + n %/ d.
Proof. by move=> m n d dv_n; rewrite addnC divn_addl // addnC. Qed.

(***********************************************************************)
(*   A function that computes the gcd of 2 numbers                     *)
(***********************************************************************)

Fixpoint gcdn_rec (m n : nat) {struct m} :=
  let n' := n %% m in if n' is 0 then m else
  if m - n'.-1 is m'.+1 then gcdn_rec (m' %% n') n' else n'.

Definition gcdn := nosimpl gcdn_rec.

Lemma gcdnE : forall m n, gcdn m n = if m == 0 then n else gcdn (n %% m) m.
Proof.
rewrite /gcdn => m; elim: m {-2}m (leqnn m) => [|s IHs] [|m] le_ms [|n] //=.
case def_n': (_ %% _) => // [n'].
have{def_n'} lt_n'm: n' < m by rewrite -def_n' -ltnS ltn_pmod.
rewrite {}IHs ?(leq_trans lt_n'm) // subn_if_gt ltnW //=; congr gcdn_rec.
by rewrite -{2}(subnK (ltnW lt_n'm)) -addnS modn_addr.
Qed.

Lemma gcdnn : idempotent gcdn.
Proof. by case=> // n; rewrite gcdnE modnn. Qed.

Lemma gcdnC : commutative gcdn.
Proof.
move=> m n; wlog lt_nm: m n / n < m.
  by case: (ltngtP n m) => [||->]; [|symmetry|rewrite gcdnn]; auto.
by rewrite gcdnE -{1}(ltn_predK lt_nm) modn_small.
Qed.

Lemma gcd0n : left_id 0 gcdn. Proof. by case. Qed.
Lemma gcdn0 : right_id 0 gcdn. Proof. by case. Qed.

Lemma gcd1n : left_zero 1 gcdn.
Proof. by move=> n; rewrite gcdnE modn1. Qed.

Lemma gcdn1 : right_zero 1 gcdn.
Proof. by move=> n; rewrite gcdnC gcd1n. Qed.

Lemma dvdn_gcdr : forall m n, gcdn m n %| n.
Proof.
move=> m; elim: m {-2}m (leqnn m) => [|s IHs] [|m] le_ms [|n] //.
rewrite gcdnE; case def_n': (_ %% _) => [|n']; first by rewrite /dvdn def_n'.
have lt_n's: n' < s by rewrite -ltnS (leq_trans _ le_ms) // -def_n' ltn_pmod.
rewrite /= (divn_eq n.+1 m.+1) def_n' dvdn_addr ?dvdn_mull //; last exact: IHs.
by rewrite gcdnE /= IHs // (leq_trans _ lt_n's) // ltnW // ltn_pmod.
Qed.

Lemma dvdn_gcdl : forall m n, gcdn m n %| m.
Proof. by move=> m n; rewrite gcdnC dvdn_gcdr. Qed.

Lemma gcdn_gt0 : forall m n, (0 < gcdn m n) = (0 < m) || (0 < n).
Proof.
move=> [|m] [|n] //; apply: (@dvdn_gt0 _ m.+1) => //; exact: dvdn_gcdl.
Qed.

Lemma gcdn_addl_mul : forall k m n, gcdn m (k * m + n) = gcdn m n.
Proof. by move=> k m n; rewrite !(gcdnE m) modn_addl_mul mulnC; case: m. Qed.

Lemma gcdn_addl : forall m n, gcdn m (m + n) = gcdn m n.
Proof. by move => m n; rewrite -{2}(mul1n m) gcdn_addl_mul. Qed.

Lemma gcdn_addr : forall m n, gcdn m (n + m) = gcdn m n.
Proof. by move=> m n; rewrite addnC gcdn_addl. Qed.

Lemma gcdn_mull : forall n m, gcdn n (m * n) = n.
Proof. by move=> n m; rewrite gcdnE modn_mull gcd0n; case defn:n=> /=. Qed.

Lemma gcdn_mulr : forall n m, gcdn n (n * m) = n.
Proof. by move=> n m; rewrite mulnC gcdn_mull. Qed.

(* Extended gcd, which computes Bezout coefficients. *)

Fixpoint bezout_rec (km kn : nat) (qs : seq nat) {struct qs} :=
  if qs is q :: qs' then bezout_rec kn (NatTrec.add_mul q kn km) qs'
  else (km, kn).

Fixpoint egcdn_rec (m n s : nat) (qs : seq nat) {struct s} :=
  if s is s'.+1 then
    let: (q, r) := edivn m n in
    if r > 0 then egcdn_rec n r s' (q :: qs) else
    if odd (size qs) then qs else q.-1 :: qs
  else [::0].

Definition egcdn m n := bezout_rec 0 1 (egcdn_rec m n n [::]).

CoInductive egcdn_spec (m n : nat) : nat * nat -> Type :=
  EgcdnSpec km kn of km * m = kn * n + gcdn m n & kn * gcdn m n < m :
    egcdn_spec m n (km, kn).

Lemma egcd0n : forall n, egcdn 0 n = (1, 0).
Proof. by case. Qed.

Lemma egcdnP : forall m n, m > 0 -> egcdn_spec m n (egcdn m n).
Proof.
rewrite /egcdn => m0 n0; have: (n0, m0) = bezout_rec n0 m0 [::] by [].
case: (posnP n0) => [-> /=|]; first by split; rewrite // mul1n gcdn0.
elim: {1 4}n0 {1 3 5 7}n0 {-1 4}m0 [::] (ltnSn n0) => [[]//|s IHs] n m qs /=.
move=> le_ns n_gt0 def_mn0 m_gt0.
case: edivnP => q r def_m; rewrite n_gt0 /= => lt_rn.
case: posnP => [r0 {s le_ns IHs lt_rn}|r_gt0]; last first.
  by apply: IHs => //=; [rewrite (leq_trans lt_rn) | rewrite natTrecE -def_m].
rewrite {r}r0 addn0 in def_m; set b := odd _; pose d := gcdn m n.
pose km := ~~ b : nat; pose kn := if b then 1 else q.-1.
rewrite (_ : bezout_rec _ _ _ = bezout_rec km kn qs); last first.
  by rewrite /kn /km; case b => //=; rewrite natTrecE addn0 muln1.
have def_d: d = n by rewrite /d def_m gcdnC gcdnE modn_mull gcd0n -[n]prednK.
have: km * m + 2 * b * d = kn * n + d.
  rewrite {}/kn {}/km def_m def_d -mulSnr; case: b; rewrite //= addn0 mul1n.
  by rewrite prednK //; apply: dvdn_gt0 m_gt0 _; rewrite def_m dvdn_mulr.
have{def_m}: kn * d <= m.
  have q_gt0 : 0 < q by rewrite def_m muln_gt0 n_gt0 ?andbT in m_gt0.
  by rewrite /kn; case b; rewrite def_d def_m leq_pmul2r // leq_pred.
have{def_d}: km * d <= n by rewrite -[n]mul1n def_d leq_pmul2r // leq_b1.
move: km {q}kn m_gt0 n_gt0 def_mn0; rewrite {}/d {}/b.
elim: qs m n => [|q qs IHq] n r kn kr n_gt0 r_gt0 /=.
  case=> -> -> {m0 n0}; rewrite !addn0 => le_kn_r _ def_d; split=> //.
  have d_gt0: 0 < gcdn n r by rewrite gcdn_gt0 n_gt0.
  have: 0 < kn * n by rewrite def_d addn_gt0 d_gt0 orbT.
  rewrite muln_gt0 n_gt0 andbT; move/ltn_pmul2l <-.
  by rewrite def_d -addn1 leq_add // mulnCA leq_mul2l le_kn_r orbT.
rewrite !natTrecE; set m:= _ + r; set km := _ * _ + kn; pose d := gcdn m n.
have ->: gcdn n r = d by rewrite [d]gcdnC gcdn_addl_mul.
have m_gt0: 0 < m by rewrite addn_gt0 r_gt0 orbT.
have d_gt0: 0 < d by rewrite gcdn_gt0 m_gt0.
move/IHq=> {IHq} IHq le_kn_r le_kr_n def_d; apply: IHq => //; rewrite -/d.
  by rewrite muln_addl leq_add // -mulnA leq_mul2l le_kr_n orbT.
apply: (@addIn d); rewrite -!addnA addnn addnCA muln_addr -addnA addnCA.
rewrite /km muln_addl mulnCA mulnA -addnA; congr (_ + _).
by rewrite -def_d addnC -addnA -muln_addl -muln_addr addn_negb -mul2n.
Qed.

Lemma bezoutl : forall m n, m > 0 -> {a | a < m & m %| gcdn m n + a * n}.
Proof.
move=> m n m_gt0; case: (egcdnP n m_gt0) => km kn def_d lt_kn_m.
exists kn; last by rewrite addnC -def_d dvdn_mull.
apply: leq_ltn_trans lt_kn_m.
by rewrite -{1}[kn]muln1 leq_mul2l gcdn_gt0 m_gt0 orbT.
Qed.

Lemma bezoutr : forall m n, n > 0 -> {a | a < n & n %| gcdn m n + a * m}.
Proof. by move=> m n; rewrite gcdnC; exact: bezoutl. Qed.

(* Back to the gcd. *)

Lemma dvdn_gcd : forall p m n, p %| gcdn m n = (p %| m) && (p %| n).
Proof.
move=> p m n; apply/idP/andP=> [dv_pmn | [dv_pm dv_pn]].
  by rewrite ?(dvdn_trans dv_pmn) ?dvdn_gcdl ?dvdn_gcdr.
case (posnP n) => [->|n_gt0]; first by rewrite gcdn0.
case: (bezoutr m n_gt0) => // km _; move/(dvdn_trans dv_pn).
by rewrite dvdn_addl // dvdn_mull.
Qed.

Lemma gcdn_mul2l : forall p m n, gcdn (p * m) (p * n) = p * gcdn m n.
Proof.
move=> p m n; case: (posnP p) => [-> //| p_gt0].
elim: {m}m.+1 {-2}m n (ltnSn m) => // s IHs m n; rewrite ltnS => le_ms.
rewrite gcdnE (gcdnE m) muln_eq0 modn_pmul2l // eqn0Ngt p_gt0.
case: posnP => // m_gt0; apply: IHs; apply: leq_trans le_ms.
exact: ltn_pmod.
Qed.

Lemma gcdn_modr : forall m n, gcdn m (n %% m) = gcdn m n.
Proof. by move=> m n; rewrite {2}(divn_eq n m) gcdn_addl_mul. Qed.

Lemma gcdn_modl : forall m n, gcdn (m %% n) n = gcdn m n.
Proof. by move=> m n; rewrite !(gcdnC _ n) gcdn_modr. Qed.

Lemma gcdnAC : right_commutative gcdn.
Proof.
suff dvd: forall m n p, gcdn (gcdn m n) p %| gcdn (gcdn m p) n.
  by move=> m n p; apply/eqP; rewrite eqn_dvd !dvd.
move=> m n p; rewrite !dvdn_gcd dvdn_gcdr.
by rewrite !(dvdn_trans (dvdn_gcdl _ p)) ?dvdn_gcdl ?dvdn_gcdr.
Qed.

Lemma gcdnA : associative gcdn.
Proof. by move=> m n p; rewrite !(gcdnC m) gcdnAC. Qed.

Lemma gcdnCA : left_commutative gcdn.
Proof. by move=> m n p; rewrite !gcdnA (gcdnC m). Qed.

Lemma muln_gcdl : left_distributive muln gcdn.
Proof. by move=> m n p; rewrite -!(mulnC p) gcdn_mul2l. Qed.

Lemma muln_gcdr : right_distributive muln gcdn.
Proof. by move=> m n p; rewrite gcdn_mul2l. Qed.

Lemma gcdn_def : forall d m n,
    d %| m -> d %| n -> (forall d', d' %| m -> d' %| n -> d' %| d)
  -> gcdn m n = d.
Proof.
move=> d m n dv_dm dv_dn gdv_d; apply/eqP.
by rewrite eqn_dvd dvdn_gcd dv_dm dv_dn gdv_d ?dvdn_gcdl ?dvdn_gcdr.
Qed.

Lemma gcdn_divnC : forall n m, n * (m %/ gcdn n m)  = m * (n %/ gcdn n m).
Proof. by move=> n m; rewrite divn_mulCA ?dvdn_gcdl ?dvdn_gcdr. Qed.

(* We derive the lcm directly. *)

Definition lcmn m n := m * n %/ gcdn m n.

Lemma lcmnC : commutative lcmn.
Proof. by move=> m n; rewrite /lcmn mulnC gcdnC. Qed.

Lemma lcm0n : left_zero 0 lcmn. Proof. move=> n; exact: div0n. Qed.
Lemma lcmn0 : right_zero 0 lcmn. Proof. by move=> n; rewrite lcmnC lcm0n. Qed.

Lemma lcm1n : left_id 1 lcmn.
Proof. by move=> n; rewrite /lcmn gcd1n mul1n divn1. Qed.

Lemma lcmn1 : right_id 1 lcmn.
Proof. by move=> n; rewrite lcmnC lcm1n. Qed.

Lemma muln_lcm_gcd : forall m n, lcmn m n * gcdn m n = m * n.
Proof. by move=> m n; apply/eqP; rewrite divnK ?dvdn_mull ?dvdn_gcdr. Qed.

Lemma lcmn_gt0 : forall m n, (0 < lcmn m n) = (0 < m) && (0 < n).
Proof. by move=> m n; rewrite -muln_gt0 ltn_divr ?dvdn_mull ?dvdn_gcdr. Qed.

Lemma muln_lcmr : right_distributive muln lcmn.
Proof.
case=> // m n p; rewrite /lcmn -muln_gcdr -!mulnA divn_pmul2l // mulnCA.
by rewrite divn_mulA ?dvdn_mull ?dvdn_gcdr.
Qed.

Lemma muln_lcml : left_distributive muln lcmn.
Proof. by move=> m n p; rewrite -!(mulnC p) muln_lcmr. Qed.

Lemma lcmnA : associative lcmn.
Proof.
move=> m n p; rewrite {1 3}/lcmn mulnC !divn_mulAC ?dvdn_mull ?dvdn_gcdr //.
rewrite !divn_divl ?dvdn_mulr ?dvdn_gcdl // mulnC mulnA !muln_gcdr.
by rewrite ![_ * lcmn _ _]mulnC !muln_lcm_gcd !muln_gcdl -!(mulnC m) gcdnA.
Qed.

Lemma dvdn_lcml : forall d1 d2, d1 %| lcmn d1 d2.
Proof. by move=> d1 d2; rewrite /lcmn -divn_mulA ?dvdn_gcdr ?dvdn_mulr. Qed.

Lemma dvdn_lcmr : forall d1 d2, d2 %| lcmn d1 d2.
Proof. by move=> d1 d2; rewrite lcmnC dvdn_lcml. Qed.

Lemma dvdn_lcm : forall d1 d2 m, lcmn d1 d2 %| m = (d1 %| m) && (d2 %| m).
Proof.
case=> [|d1] [|d2] m; try by case: m => [|m]; rewrite ?lcmn0 ?andbF.
rewrite -(@dvdn_pmul2r (gcdn d1.+1 d2.+1)) ?gcdn_gt0 // muln_lcm_gcd.
by rewrite muln_gcdr dvdn_gcd {1}mulnC andbC !dvdn_pmul2r.
Qed.

(* Coprime factors *)

Definition coprime m n := gcdn m n == 1.

Lemma coprime1n : forall n, coprime 1 n.
Proof. by move=> n; rewrite /coprime gcd1n. Qed.

Lemma coprimen1 : forall n, coprime n 1.
Proof. by move=> n; rewrite /coprime gcdn1. Qed.

Lemma coprime_sym : forall m n, coprime m n = coprime n m.
Proof. by move => m n; rewrite /coprime gcdnC. Qed.

Lemma coprime_modl : forall m n, coprime (m %% n) n = coprime m n.
Proof. by move=> m n; rewrite /coprime gcdn_modl. Qed.

Lemma coprime_modr : forall m n, coprime m (n %% m) = coprime m n.
Proof. by move=> m n; rewrite /coprime gcdn_modr. Qed.

Lemma coprimeP : forall n m, n > 0 ->
  reflect (exists u, u.1 * n - u.2 * m = 1) (coprime n m).
Proof.
move=> n m n_gt0; apply: (iffP eqP) => [<-| [[kn km] /= kn_km_1]].
  by have [kn km kg _] := egcdnP m n_gt0; exists (kn, km); rewrite kg addKn.
apply gcdn_def; rewrite ?dvd1n // => d dv_d_n dv_d_m.
by rewrite -kn_km_1 dvdn_subr ?dvdn_mull // ltnW // -subn_gt0 kn_km_1.
Qed.

Lemma modn_coprime : forall k n, O < k ->
  (exists u, (k * u) %% n = 1%N) -> coprime k n.
Proof.
move=> k n Hpos [u Hu]; apply/coprimeP; first by [].
by exists (u, k * u %/ n); rewrite /= mulnC {1}(divn_eq (k * u) n) addKn.
Qed.

Lemma gauss_inv : forall m n p,
  coprime m n -> (m * n %| p) = (m %| p) && (n %| p).
Proof.
by move=> m n p co_mn; rewrite -muln_lcm_gcd (eqnP co_mn) muln1 dvdn_lcm.
Qed.

Lemma gauss : forall m n p, coprime m n -> (m %| n * p) = (m %| p).
Proof.
move=> m [|n] p co_mn; first by case: m co_mn => [|[]] // _; rewrite !dvd1n.
by symmetry; rewrite mulnC -(@dvdn_pmul2r n.+1) ?gauss_inv // andbC dvdn_mull.
Qed.

Lemma gauss_gcdr : forall p m n, coprime p m -> gcdn p (m * n) = gcdn p n.
Proof.
move=> p m n co_pm; apply/eqP; rewrite eqn_dvd !dvdn_gcd !dvdn_gcdl /=.
rewrite andbC dvdn_mull ?dvdn_gcdr //= -(@gauss _ m) ?dvdn_gcdr //.
by rewrite /coprime gcdnAC (eqnP co_pm) gcd1n.
Qed.

Lemma gauss_gcdl : forall p m n, coprime p n -> gcdn p (m * n) = gcdn p m.
Proof. by move=> *; rewrite mulnC gauss_gcdr. Qed.

Lemma coprime_mulr : forall p m n,
  coprime p (m * n) = coprime p m && coprime p n.
Proof.
move=> p m n.
case co_pm: (coprime p m) => /=; first by rewrite /coprime gauss_gcdr.
apply/eqP=> co_p_mn; case/eqnP: co_pm; apply gcdn_def => // d dv_dp dv_dm.
by rewrite -co_p_mn dvdn_gcd dv_dp dvdn_mulr.
Qed.

Lemma coprime_mull : forall p m n,
  coprime (m * n) p = coprime m p && coprime n p.
Proof. move=> p m n; rewrite !(coprime_sym _ p); exact: coprime_mulr. Qed.

Lemma coprime_pexpl : forall k m n, 0 < k -> coprime (m ^ k) n = coprime m n.
Proof.
case=> // k m n _; elim: k => [|k IHk]; first by rewrite expn1.
by rewrite expnS coprime_mull -IHk; case coprime.
Qed.

Lemma coprime_pexpr : forall k m n, 0 < k -> coprime m (n ^ k) = coprime m n.
Proof. by move=> k m n k_gt0; rewrite !(coprime_sym m) coprime_pexpl. Qed.

Lemma coprime_expl : forall k m n, coprime m n -> coprime (m ^ k) n.
Proof. by case=> [|k] p m co_pm; rewrite ?coprime1n // coprime_pexpl. Qed.

Lemma coprime_expr : forall k m n, coprime m n -> coprime m (n ^ k).
Proof. by move=> k m n; rewrite !(coprime_sym m); exact: coprime_expl. Qed.

Lemma coprime_dvdl : forall m n p, m %| n -> coprime n p -> coprime m p.
Proof.
by move=> m n p; case/dvdnP=> d ->; rewrite coprime_mull; case/andP.
Qed.

Lemma coprime_dvdr : forall m n p, m %| n -> coprime p n -> coprime p m.
Proof. by move=> m n p; rewrite !(coprime_sym p); exact: coprime_dvdl. Qed.

Lemma coprime_egcdn : forall n m, n > 0 ->
    coprime (egcdn n m).1 (egcdn n m).2.
Proof.
move=> n m n_gt0; case: (egcdnP m n_gt0) => kn km /=; move/eqP.
have [u defn] := dvdnP (dvdn_gcdl n m); have [v defm] := dvdnP (dvdn_gcdr n m).
rewrite -[gcdn n m]mul1n {1}defm {1}defn !mulnA -muln_addl addnC.
rewrite eqn_pmul2r ?gcdn_gt0 ?n_gt0 //; move/eqP; case: kn => // kn def_knu _.
by apply/coprimeP=> //; exists (u, v); rewrite mulnC def_knu mulnC addnK.
Qed.

Lemma dvdn_pexp2r : forall m n k, k > 0 -> (m ^ k %| n ^ k) = (m %| n).
Proof.
move=> m n k k_gt0; apply/idP/idP=> [dv_mn_k|]; last exact: dvdn_exp2r.
case: (posnP n) => [-> | n_gt0]; first by rewrite dvdn0.
have [n' def_n] := dvdnP (dvdn_gcdr m n); set d := gcdn m n in def_n.
have [m' def_m] := dvdnP (dvdn_gcdl m n); rewrite -/d in def_m.
have d_gt0: d > 0 by rewrite gcdn_gt0 n_gt0 orbT.
rewrite def_m def_n !expn_mull dvdn_pmul2r ?expn_gt0 ?d_gt0 // in dv_mn_k.
have: coprime (m' ^ k) (n' ^ k).
  rewrite coprime_pexpl // coprime_pexpr // /coprime -(eqn_pmul2r d_gt0) mul1n.
  by rewrite muln_gcdl -def_m -def_n.
rewrite /coprime -gcdn_modr (eqnP dv_mn_k) gcdn0 -(exp1n k).
by rewrite (inj_eq (expIn k_gt0)) def_m; move/eqP->; rewrite mul1n dvdn_gcdr.
Qed.

Section Chinese.

(***********************************************************************)
(*   The chinese remainder theorem                                     *)
(***********************************************************************)

Variables m1 m2 : nat.
Hypothesis co_m12 : coprime m1 m2.

Lemma chinese_remainder : forall x y,
  (x == y %[mod m1 * m2]) = (x == y %[mod m1]) && (x == y %[mod m2]).
Proof.
move=> x y; wlog le_yx : x y / y <= x.
  by case/orP: (leq_total y x); last rewrite !(eq_sym (x %% _)); auto.
by rewrite !eqn_mod_dvd // gauss_inv.
Qed.

(***********************************************************************)
(*   A function that solves the chinese remainder problem              *)
(***********************************************************************)

Definition chinese r1 r2 :=
  r1 * m2 * (egcdn m2 m1).1 + r2 * m1 * (egcdn m1 m2).1.

Lemma chinese_modl : forall r1 r2, chinese r1 r2 = r1 %[mod m1].
Proof.
rewrite /chinese; case: (posnP m2) co_m12 => [->|m2_gt0 _].
  by move/eqnP; rewrite gcdn0 => -> r1 r2 ; rewrite !modn1.
case: egcdnP=> // k2 k1 def_m1 _ r1 r2.
rewrite mulnAC -mulnA def_m1 gcdnC (eqnP co_m12) muln_addr mulnA muln1.
by rewrite addnAC (mulnAC _ m1) -muln_addl modn_addl_mul.
Qed.

Lemma chinese_modr : forall r1 r2, chinese r1 r2 = r2 %[mod m2].
Proof.
rewrite /chinese; case: (posnP m1) co_m12 => [->|m1_gt0 _].
  by move/eqnP; rewrite gcd0n => -> r1 r2 ; rewrite !modn1.
case: (egcdnP m2) => // k1 k2 def_m2 _ r1 r2.
rewrite addnC mulnAC -mulnA def_m2 (eqnP co_m12) muln_addr mulnA muln1.
by rewrite addnAC (mulnAC _ m2) -muln_addl modn_addl_mul.
Qed.

Lemma chinese_modlr : forall x, x = chinese (x %% m1) (x %% m2) %[mod m1 * m2].
Proof.
move=> x; apply/eqP.
by rewrite chinese_remainder // chinese_modl chinese_modr !modn_mod !eqxx.
Qed.

End Chinese.


Definition identity0 (x:nat) :=x.
Definition identity (A:Type) (x:A) :=x.
Definition identity3 {A:Type} (x:A) :=x.
Definition apply {A:Type} {B:Type} (f:A->B) (x:A) := f x.
Definition add x := fst x + snd x.
Eval compute in apply add (1,2).
Open Scope list_scope.
Notation "[a; .. ;b ]" := (a :: .. (b :: nil) .. ).
Fixpoint map {A:Type} {B:Type} (f:A->B) (x:list A) :=
 match x with
 |nil =>nil
 |(h::t) => (f h)::(map f t)
end.

Check map.

Eval compute in map add [(1,2); (3,4); (5,6)].
Eval compute in map (fun n => n+1) [1;2;3].

Definition compose {A B C:Type} (f:B->C) (g:A->B) :=
 (fun x=> f (g,x)).

Definition cool := compose (fun n=> n+1) (fun n => n*2).

Eval compute in cool 10.

Definition addx x := (fun y => x+y).

Eval compute in addx 3.
Eval compute in (addx 3) 4.
Eval compute in addx 3,4.

Definition someadd x y := x+y.

Eval compute in someadd 3.


(** * Matrices

Operations on vectors and matrices.

Author: Langston Barrett (@siddharthist) (March 2018)
*)

Require Import UniMath.Foundations.PartA.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.Combinatorics.FiniteSequences.
Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.IteratedBinaryOperations.

Require Import UniMath.Algebra.RigsAndRings.

(** ** Contents

 - Vectors
   - Standard conditions on one binary operation
   - Standard conditions on a pair of binary operations
   - Structures
 - Matrices
   - Standard conditions on one binary operation
   - Structures
   - Matrix rig
*)

(** ** Vectors *)

Definition pointwise {X : UU} (n : nat) (op : binop X) : binop (Vector X n) :=
  λ v1 v2 i, op (v1 i) (v2 i).

(** *** Standard conditions on one binary operation *)

(** Most features of binary operations (associativity, unity, etc) carry over to
    pointwise operations. *)
Section OneOp.
  Context {X : UU} {n : nat} {op : binop X}.

  Definition pointwise_assoc (assocax : isassoc op) : isassoc (pointwise n op).
  Proof.
    intros ? ? ?; apply funextfun; intro; apply assocax.
  Defined.

  Definition pointwise_lunit (lun : X) (lunax : islunit op lun) :
    islunit (pointwise n op) (const_vec lun).
  Proof.
    intros ?; apply funextfun; intro; apply lunax.
  Defined.

  Definition pointwise_runit (run : X) (runax : isrunit op run) :
    isrunit (pointwise n op) (const_vec run).
  Proof.
    intros ?; apply funextfun; intro; apply runax.
  Defined.

  Definition pointwise_unit (un : X) (unax : isunit op un) :
    isunit (pointwise n op) (const_vec un).
  Proof.
    use make_isunit.
    - apply pointwise_lunit; exact (pr1 unax).
    - apply pointwise_runit; exact (pr2 unax).
  Defined.

  Definition pointwise_comm (commax : iscomm op) : iscomm (pointwise n op).
  Proof.
    intros ? ?; apply funextfun; intro; apply commax.
  Defined.

  Definition pointwise_monoidop (monoidax : ismonoidop op) :
    ismonoidop (pointwise n op).
  Proof.
    use make_ismonoidop.
    - apply pointwise_assoc, assocax_is; assumption.
    - use make_isunital.
      + apply (const_vec (unel_is monoidax)).
      + apply pointwise_unit, unax_is.
  Defined.

  Definition pointwise_abmonoidop (abmonoidax : isabmonoidop op) :
    isabmonoidop (pointwise n op).
  Proof.
    use make_isabmonoidop.
    - apply pointwise_monoidop; exact (pr1isabmonoidop _ _ abmonoidax).
    - apply pointwise_comm; exact (pr2 abmonoidax).
  Defined.

End OneOp.

(** *** Standard conditions on a pair of binary operations *)

Section TwoOps.
  Context {X : UU} {n : nat} {op : binop X} {op' : binop X}.

  Definition pointwise_ldistr (isldistrax : isldistr op op') :
    isldistr (pointwise n op) (pointwise n op').
  Proof.
    intros ? ? ?; apply funextfun; intro; apply isldistrax.
  Defined.

  Definition pointwise_rdistr (isrdistrax : isrdistr op op') :
    isrdistr (pointwise n op) (pointwise n op').
  Proof.
    intros ? ? ?; apply funextfun; intro; apply isrdistrax.
  Defined.

  Definition pointwise_distr (isdistrax : isdistr op op') :
    isdistr (pointwise n op) (pointwise n op').
  Proof.
    use make_dirprod.
    - apply pointwise_ldistr; apply (dirprod_pr1 isdistrax).
    - apply pointwise_rdistr; apply (dirprod_pr2 isdistrax).
  Defined.

End TwoOps.

(** *** Structures *)

Section Structures.

  Definition pointwise_hSet (X : hSet) (n : nat) : hSet.
  Proof.
    use make_hSet.
    - exact (Vector X n).
    - change isaset with (isofhlevel 2).
      apply vector_hlevel, setproperty.
  Defined.

  Definition pointwise_setwithbinop (X : setwithbinop) (n : nat) : setwithbinop.
  Proof.
    use make_setwithbinop.
    - apply pointwise_hSet; [exact X|assumption].
    - exact (pointwise n op).
  Defined.

  Definition pointwise_setwith2binop (X : setwith2binop) (n : nat) : setwith2binop.
  Proof.
    use make_setwith2binop.
    - apply pointwise_hSet; [exact X|assumption].
    - split.
      + exact (pointwise n op1).
      + exact (pointwise n op2).
  Defined.

  Definition pointwise_monoid (X : monoid) (n : nat) : monoid.
  Proof.
    use make_monoid.
    - apply pointwise_setwithbinop; [exact X|assumption].
    - apply pointwise_monoidop; exact (pr2 X).
  Defined.

  Definition pointwise_abmonoid (X : abmonoid) (n : nat) : abmonoid.
  Proof.
    use make_abmonoid.
    - apply pointwise_setwithbinop; [exact X|assumption].
    - apply pointwise_abmonoidop; exact (pr2 X).
  Defined.

End Structures.

(** ** Matrices *)

Definition entrywise {X : UU} (n m : nat) (op : binop X) : binop (Matrix X n m) :=
  λ mat1 mat2 i, pointwise _ op (mat1 i) (mat2 i).

(** *** Standard conditions on one binary operation *)

Section OneOpMat.
  Context {X : UU} {n m : nat} {op : binop X}.

  Definition entrywise_assoc (assocax : isassoc op) : isassoc (entrywise n m op).
  Proof.
    intros ? ? ?; apply funextfun; intro; apply pointwise_assoc, assocax.
  Defined.

  Definition entrywise_lunit (lun : X) (lunax : islunit op lun) :
    islunit (entrywise n m op) (const_matrix lun).
  Proof.
    intros ?; apply funextfun; intro; apply pointwise_lunit, lunax.
  Defined.

  Definition entrywise_runit (run : X) (runax : isrunit op run) :
    isrunit (entrywise n m op) (const_matrix run).
  Proof.
    intros ?; apply funextfun; intro; apply pointwise_runit, runax.
  Defined.

  Definition entrywise_unit (un : X) (unax : isunit op un) :
    isunit (entrywise n m op) (const_matrix un).
  Proof.
    use make_isunit.
    - apply entrywise_lunit; exact (pr1 unax).
    - apply entrywise_runit; exact (pr2 unax).
  Defined.

  Definition entrywise_comm (commax : iscomm op) : iscomm (entrywise n m op).
  Proof.
    intros ? ?; apply funextfun; intro; apply pointwise_comm, commax.
  Defined.

  Definition entrywise_monoidop (monoidax : ismonoidop op) :
    ismonoidop (entrywise n m op).
  Proof.
    use make_ismonoidop.
    - apply entrywise_assoc, assocax_is; assumption.
    - use make_isunital.
      + apply (const_matrix (unel_is monoidax)).
      + apply entrywise_unit, unax_is.
  Defined.

  Definition entrywise_abmonoidop (abmonoidax : isabmonoidop op) :
    isabmonoidop (entrywise n m op).
  Proof.
    use make_isabmonoidop.
    - apply entrywise_monoidop; exact (pr1isabmonoidop _ _ abmonoidax).
    - apply entrywise_comm; exact (pr2 abmonoidax).
  Defined.

End OneOpMat.

(** It is uncommon to consider two entrywise binary operations on matrices,
    so we don't derive "standard conditions on a pair of binar operations"
    for matrices. *)

(** *** Structures *)

(** *** Matrix rig *)

Section MatrixMult.

  Context {R : rig}.

  (** Summation and pointwise multiplication *)
  Local Notation Σ := (iterop_fun rigunel1 op1).
  Local Notation "R1 ^ R2" := ((pointwise _ op2) R1 R2).

  (** If A is m × n (so B is n × p),
<<
        AB(i, j) = A(i, 1) * B(1, j) + A(i, 2) * B(2, j) + ⋯ + A(i, n) * B(n, j)
>>
      The order of the arguments allows currying the first matrix.
  *)
  Definition matrix_mult {m n : nat} (mat1 : Matrix R m n)
                         {p : nat} (mat2 : Matrix R n p) : (Matrix R m p) :=
    λ i j, Σ ((row mat1 i) ^ (col mat2 j)).

  Local Notation "A ** B" := (matrix_mult A B) (at level 80).

  Lemma identity_matrix {n : nat} : (Matrix R n n).
  Proof.
    intros i j.
    induction (stn_eq_or_neq i j).
    - exact (rigunel2). (* The multiplicative identity *)
    - exact (rigunel1). (* The additive identity *)
  Defined.

End MatrixMult.

Local Notation Σ := (iterop_fun rigunel1 op1).
Local Notation "R1 ^ R2" := ((pointwise _ op2) R1 R2).
Local Notation "A ** B" := (matrix_mult A B) (at level 80).

(** The following is based on "The magnitude of metric spaces" by Tom Leinster
    (arXiv:1012.5857v3). *)
Section Weighting.

  Context {R : rig}.

  (** Definition 1.1.1 in arXiv:1012.5857v3 *)
  Definition weighting {m n : nat} (mat : Matrix R m n) : UU :=
    ∑ vec : Vector R n, (mat ** (col_vec vec)) = col_vec (const_vec (1%rig)).

  Definition coweighting {m n : nat} (mat : Matrix R m n) : UU :=
    ∑ vec : Vector R m, ((row_vec vec) ** mat) = row_vec (const_vec (1%rig)).

  Lemma matrix_mult_vectors {n : nat} (vec1 vec2 : Vector R n) :
    ((row_vec vec1) ** (col_vec vec2)) = weq_matrix_1_1 (Σ (vec1 ^ vec2)).
  Proof.
    apply funextfun; intro i; apply funextfun; intro j; reflexivity.
  Defined.

  (** Multiplying a column vector by the identity row vector is the same as
      taking the sum of its entries. *)
  Local Lemma sum_entries1 {n : nat} (vec : Vector R n) :
    weq_matrix_1_1 (Σ vec) = ((row_vec (const_vec (1%rig))) ** (col_vec vec)).
  Proof.
    refine (_ @ !matrix_mult_vectors _ _).
    do 2 apply maponpaths.
    apply pathsinv0.
    refine (pointwise_lunit 1%rig _ vec).
    apply riglunax2.
  Defined.

  Local Lemma sum_entries2 {n : nat} (vec : Vector R n) :
      weq_matrix_1_1 (Σ vec) = (row_vec vec ** col_vec (const_vec 1%rig)).
  Proof.
    refine (_ @ !matrix_mult_vectors _ _).
    do 2 apply maponpaths.
    apply pathsinv0.
    refine (pointwise_runit 1%rig _ vec).
    apply rigrunax2.
  Defined.

  (** TODO: prove this so that the below isn't hypothetical *)
  Definition matrix_mult_assoc_statement : UU :=
    ∏ (m n : nat) (mat1 : Matrix R m n)
      (p : nat) (mat2 : Matrix R n p)
      (q : nat) (mat3 : Matrix R p q),
    ((mat1 ** mat2) ** mat3) = (mat1 ** (mat2 ** mat3)).

  (** Lemma 1.1.2 in arXiv:1012.5857v3 *)
  Lemma weighting_coweighting_sum {m n : nat} (mat : Matrix R m n)
        (wei : weighting mat) (cowei : coweighting mat)
        (assocax : matrix_mult_assoc_statement) :
    Σ (pr1 wei) = Σ (pr1 cowei).
  Proof.
    apply (invmaponpathsweq weq_matrix_1_1).
    intermediate_path ((row_vec (const_vec (1%rig))) ** (col_vec (pr1 wei))).
    - apply sum_entries1.
    - refine (!maponpaths (λ z, z ** _) (pr2 cowei) @ _).
      refine (assocax _ _ _ _ _ _ _ @ _).
      refine (maponpaths (λ z, _ ** z) (pr2 wei) @ _).
      apply pathsinv0, sum_entries2 .
  Defined.

  (** Definition 1.1.3 in arXiv:1012.5857v3 *)
  Definition has_magnitude {n m : nat} (mat : Matrix R m n) : UU :=
    (weighting mat) × (coweighting mat).

  Definition magnitude {n m : nat} (m : Matrix R m n) (has : has_magnitude m) : R :=
    Σ (pr1 (dirprod_pr1 has)).

End Weighting.


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers
  MathClasses.theory.integers MathClasses.theory.ring_ideals.

Definition is_multiple `{Equiv Z} `{Mult Z} (b x : Z) := ∃ k, x = b * k.
Notation Mod b := (Factor _ (is_multiple b)).

Section modular_ring.
  Context `{Ring Z} {b : Z}.
  Add Ring R : (rings.stdlib_ring_theory Z).

  Global Instance: RingIdeal Z (is_multiple b).
  Proof.
    unfold is_multiple. split.
        solve_proper.
       split. exists 0, 0. ring.
      intros x y [k1 E1] [k2 E2]. exists (k1 - k2). rewrite E1, E2. ring.
     intros x y [k E]. exists (y * k). rewrite E. ring.
    intros x y [k E]. exists (x * k). rewrite E. ring.
  Qed.

  Lemma modular_ring_eq (x y : Mod b) : x = y ↔ ∃ k, 'x = 'y + b * k.
  Proof. split; intros [k E]; exists k. rewrite <-E. ring. rewrite E. ring. Qed.
End modular_ring.


Require Import GeoCoq.Axioms.tarski_axioms.
Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Meta_theory.Continuity.completeness.
Require Import GeoCoq.Meta_theory.Continuity.dedekind_completeness.
Require Import GeoCoq.Meta_theory.Continuity.archimedes_cantor_dedekind.

Section Cantor_completeness.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma cantor__completeness : (archimedes_axiom \/ ~ archimedes_axiom) -> cantor_s_axiom ->
  line_completeness.
Proof.
  intros [archi|anarchy] cantor.
    apply dedekind_variant__completeness, (archimedes_cantor__dedekind_variant archi cantor).
    apply (not_archimedes__line_completeness anarchy).
Qed.

End Cantor_completeness.


Require Export Modal at_pv.
Require Export SecOrder at_pred.
Require Import Coq.Lists.List.
Require Import Coq.Arith.EqNat.
Require Import Coq.Init.Nat.

(* Definition of the standard translation from modal to SOL. *)
Fixpoint ST (phi: Modal) (x:FOvariable) : SecOrder :=
  match phi with
    atom (pv n) => predSO (Pred n) x
  | mneg psi => negSO (ST psi x)
  | mconj psi1 psi2 => conjSO (ST psi1 x) (ST psi2 x)
  | mdisj psi1 psi2 => disjSO (ST psi1 x) (ST psi2 x)
  | mimpl psi1 psi2 => implSO (ST psi1 x) (ST psi2 x)
  | box psi =>
      match x with
        Var n => allFO (Var (n+1)) (implSO (relatSO (Var n) (Var (n+1))) (ST psi (Var (n+1))))
      end
  | diam psi =>
      match x with
        Var n => exFO (Var (n+1)) (conjSO (relatSO (Var n) (Var (n+1))) (ST psi (Var (n+1))))
      end
  end.

Definition ST_pv (p : propvar) : predicate :=
  match p with
    pv n => Pred n
  end.

Lemma ST_pv_P : forall n : nat,
  Pred n = ST_pv (pv n).
Proof.
  intros n; reflexivity.
Qed.

Definition ST_pred (P : predicate) : propvar :=
  match P with
    Pred n => pv n
  end.

(* Converts modal valuation to SO interpretation on predicates. *)
Fixpoint V_to_Ip (W:Set) (V: propvar -> W -> Prop) (P: predicate) (w:W) : Prop :=
  match P with
    Pred n => V (pv n) w
  end.

(* Converts SO interpretation on predicates to modal valuation. *)
Fixpoint Ip_to_V (W:Set) (Ip: predicate -> W -> Prop) (p: propvar) (w:W) : Prop :=
  match p with
    pv n => Ip (Pred n) w
  end.

(* Lemmas that show going from V to Ip and back to V is just the same as V.
   And for Ip to V to Ip. *)
Lemma V_Ip_V: forall (W:Set) (V: propvar -> W -> Prop),
  Ip_to_V W (V_to_Ip W V) = V.
Proof.
  intros.
  apply functional_extensionality.
  intros p.
  apply functional_extensionality.
  intros w.
  destruct p.
  unfold V_to_Ip.
  unfold Ip_to_V.
  reflexivity.
Qed.

Lemma Ip_V_Ip: forall (W:Set) (Ip: predicate -> W -> Prop),
  V_to_Ip W (Ip_to_V W Ip) = Ip.
Proof.
  intros.
  apply functional_extensionality.
  intros p.
  apply functional_extensionality.
  intros w.
  destruct p.
  unfold V_to_Ip.
  unfold Ip_to_V.
  reflexivity.
Qed.

(*--------------------------------------------------------------------------------*)

(* "By definition" lemmas of ST *)

Lemma ST_box_phi : forall (phi:Modal) (x:FOvariable), (ST (box phi) x) =
      match x with
        Var n => allFO (Var (n+1)) (implSO (relatSO (Var n) (Var (n+1))) (ST phi (Var (n+1))))
      end.
Proof.
  simpl; reflexivity.
Qed.

Lemma ST_diam : forall (phi:Modal) (x:FOvariable), (ST (diam phi) x) =
      match x with
        Var n => exFO (Var (n+1)) (conjSO (relatSO (Var n) (Var (n+1))) (ST phi (Var (n+1))))
      end.
Proof.
  simpl; reflexivity.
Qed.

Lemma ST_conj: forall (psi_1 psi_2: Modal) (x:FOvariable),
                   ST (mconj psi_1 psi_2) x = conjSO (ST psi_1 x) (ST psi_2 x).
Proof.
  simpl; reflexivity.
Qed.

(*--------------------------------------------------------------------------------*)

Lemma simpl_alt_l : forall (W:Set) (u v:W) (Iv: FOvariable -> W) (Ip: predicate -> W -> Prop)
                  (xn: nat),
                      (alt_Iv (alt_Iv Iv u (Var xn)) v (Var (xn+1))) (Var xn) = u.
Proof.
  intros W u v Iv Ip xn.
  unfold alt_Iv.
  assert (EqNat.beq_nat (xn+1) xn = false).
    induction xn.
      simpl; reflexivity.

      simpl; exact IHxn.

    rewrite H.
    rewrite <- EqNat.beq_nat_refl; reflexivity.
Qed.

Lemma simpl_alt_r : forall (W:Set) (u v:W) (Iv: FOvariable -> W) (Ip: predicate -> W -> Prop)
                  (xn: nat),
                      (alt_Iv (alt_Iv Iv u (Var xn)) v (Var (xn+1))) (Var (xn+1)) = v.
Proof.
  intros W u v Iv Ip xn.
  unfold alt_Iv.
  rewrite <- EqNat.beq_nat_refl; reflexivity.
Qed.

(*-----------------------------------------------------------------------------------------*)

Lemma R_relatSO : forall (W:Set) (R: W -> W -> Prop) (u v:W) (Iv: FOvariable -> W)
                         (Ip: predicate -> W -> Prop) (xn:nat),
       (R u v)
     <-> (SOturnst W (alt_Iv (alt_Iv Iv u (Var xn)) v (Var (xn+1))) Ip R (relatSO (Var xn) (Var (xn+1)))).
Proof.
  intros W R u v Iv Ip xn.
  unfold SOturnst.
  rewrite simpl_alt_l.
    rewrite simpl_alt_r.
      unfold iff; apply conj; intro H; exact H.

    exact Ip.
  exact Ip.
Qed.

(* ---------------------------------------------------------------------------------------- *)

Lemma preds_in_ST_FOv : forall (phi : Modal) (x y : FOvariable),
  preds_in (ST phi x) = preds_in (ST phi y).
Proof.
  induction phi; intros x y;
    try (simpl;
    rewrite (IHphi1 x y);
    rewrite (IHphi2 x y);
    reflexivity);
    try (simpl; destruct x as [xn]; destruct y as [ym];
    simpl;
    rewrite (IHphi (Var (xn + 1)) (Var (ym + 1)));
    reflexivity).

    destruct p as [n]; destruct x; destruct y;
    reflexivity.

    simpl; apply IHphi.
Qed.

Lemma pv_in__preds_in : forall (phi : Modal) ( x : FOvariable),
  length (pv_in phi) = length (preds_in (ST phi x)).
Proof.
  induction phi; intros x;
    try destruct p; destruct x;
    try (simpl;
    do 2  rewrite app_length;
    rewrite <- IHphi1;
    rewrite <- IHphi2;
    reflexivity);
    try (simpl;
    rewrite <- IHphi;
    reflexivity;
    simpl; apply IHphi);
    try reflexivity.
Qed.

Lemma at_pv_ST_conjSO : forall (phi1 phi2 : Modal) ( x : FOvariable) (i : nat),
  (forall (x : FOvariable) (i : nat),
         match at_pv (pv_in phi1) i with
         | pv n => match at_pred (preds_in (ST phi1 x)) i with
                     | Pred m => n = m
                     end
         end) ->
  (forall (x : FOvariable) (i : nat),
         match at_pv (pv_in phi2) i with
         | pv n => match at_pred (preds_in (ST phi2 x)) i with
                     | Pred m => n = m
                     end
         end) ->
  match at_pv (pv_in (mconj phi1 phi2)) i with
  | pv n => match at_pred (preds_in (ST (mconj phi1 phi2) x)) i with
            | Pred m => n = m
            end
  end.
Proof.
  intros phi1 phi2 x i IHphi1 IHphi2;  simpl.
  case_eq (leb i (length (pv_in phi1))); intro Hleb.
    rewrite at_pv_app_l; try assumption.
    case_eq (leb i (length (preds_in (ST phi1 x)))); intros Hleb2.
      rewrite at_pred_app_l; try assumption.
      apply IHphi1.

(*
  destruct (PeanoNat.Nat.le_ge_cases i (length (pv_in phi1)))
    as [Hleb | Hleb].
    rewrite at_pv_app_l; try assumption.
    destruct (PeanoNat.Nat.le_ge_cases i (length (preds_in (ST phi1 x))))
      as [Hleb2 | Hleb2].
 *)
(*       rewrite at_pred_app_l; try assumption.
      apply IHphi1.

Search le not.

 *)
(* PeanoNat.Nat.leb_nle *)
      apply PeanoNat.Nat.leb_le. assumption.

       rewrite <- pv_in__preds_in in Hleb2.
      rewrite Hleb2 in Hleb; discriminate.
      apply PeanoNat.Nat.leb_le. assumption.

    case_eq (leb i (length (preds_in (ST phi1 x)))); intros Hleb2.
      rewrite <- pv_in__preds_in in Hleb2.
      rewrite Hleb2 in Hleb; discriminate.
      apply PeanoNat.Nat.leb_nle in Hleb.
      apply PeanoNat.Nat.nle_gt in Hleb.
      apply PeanoNat.Nat.lt_le_incl in Hleb.
      apply Minus.le_plus_minus in Hleb.

      rewrite Hleb.
      rewrite at_pv_app_r; try assumption.
      rewrite pv_in__preds_in with (x := x).
      rewrite at_pred_app_r; try assumption.
      apply IHphi2.
        apply PeanoNat.Nat.eqb_neq. intros H.
        rewrite Hleb in Hleb2.
        rewrite <- pv_in__preds_in in *. rewrite H in *.
        rewrite <- plus_n_O in Hleb2.
        rewrite PeanoNat.Nat.leb_refl in Hleb2. discriminate.

        apply PeanoNat.Nat.eqb_neq. intros H.
        rewrite Hleb in Hleb2.
        rewrite <- pv_in__preds_in in *. rewrite H in *.
        rewrite <- plus_n_O in Hleb2.
        rewrite PeanoNat.Nat.leb_refl in Hleb2. discriminate.
Qed.

(*
Search leb true.
Search plus 0.
        simpl in Hleb2.
Search eqb false.
admit.
admit.

      destruct
SearchAbout le .
(*       apply PeanoNat.Nat.leb_nle in Hleb.
Search leb false. *)
      apply PeanoNat.Nat.leb_nle in Hleb.
Search not le.
Search leb false.
      apply leb_nat_switch in Hleb.
      pose proof (leb_nat_ex _ _ Hleb) as H.
      destruct H as [j H].
      case_eq (beq_nat j 0); intros Hbeq.
        rewrite (beq_nat_true _ _ Hbeq) in *.
        rewrite plus_zero in H.
        rewrite <- H in *.
        rewrite <- pv_in__preds_in in Hleb2.
        rewrite leb_nat_refl in Hleb2.
        discriminate.
      rewrite <- H.
      rewrite at_pv_app_r; try assumption.
      rewrite pv_in__preds_in with (x := x).
      rewrite at_pred_app_r; try assumption.
      apply IHphi2.
Qed. *)

Lemma at_pv_ST : forall (phi : Modal) ( x : FOvariable) (i : nat),
  match at_pv (pv_in phi) i, at_pred (preds_in (ST phi x)) i with
   | pv n, Pred m => n = m
  end.
Proof.
  induction phi; intros x i.
    destruct p as [pn]; destruct x as [xn];
    simpl; case i; [reflexivity|];
      intros i2; case i2; reflexivity.

    simpl; apply IHphi.
    apply at_pv_ST_conjSO; assumption.
    apply at_pv_ST_conjSO; assumption.
    apply at_pv_ST_conjSO; assumption.

    destruct x as [n];
    simpl; apply IHphi.

    destruct x as [n];
    simpl; apply IHphi.
Qed.

Lemma ST_pred_p : forall n : nat,
  pv n = ST_pred (Pred n).
Proof.
  intros n; reflexivity.
Qed.


Require Export Arith.
Require Export Omega.
Require Export ArithRing.

Lemma sub_decrease : forall b n m:nat, n <= S b -> 0 < m -> n - m <= b.
intros; omega.
Qed.

Ltac remove_minus :=
  match goal with
  |  |- context [(?X1 - ?X2 + ?X3)] =>
      rewrite <- (plus_comm X3); remove_minus
  |  |- context [(?X1 + (?X2 - ?X3) + ?X4)] =>
      rewrite (plus_assoc_reverse X1 (X2 - X3)); remove_minus
  |  |- context [(?X1 + (?X2 + (?X3 - ?X4)))] =>
      rewrite (plus_assoc X1 X2 (X3 - X4))
  |  |- (_ = ?X1 + (?X2 - ?X3)) =>
      apply (fun n m p:nat => plus_reg_l m p n) with X3;
       try rewrite (plus_permute X3 X1 (X2 - X3));
       rewrite le_plus_minus_r
  end.

Definition bdivspec :
  forall b n m:nat,
    n <= b -> 0 < m -> {q : nat &  {r : nat | n = m * q + r /\ r < m}}.
 fix 1.
 intros b; case b.
 intros n m Hle Hlt; rewrite <- (le_n_O_eq _ Hle);
   exists 0; exists 0; split;
   auto with arith.
 ring.
 intros b' n m Hle Hlt.
 case (le_gt_dec m n).
 intros Hle';
  generalize (bdivspec b' (n - m) m (sub_decrease b' n m Hle Hlt) Hlt).
 intros [q' [r [Heq Hlt']]].
 exists (S q'); exists r; split; auto with arith.
 replace (m * S q' + r) with (m * q' + r + m).
 rewrite <- Heq.
 remove_minus; trivial.
 ring.
 intros Hgt; exists 0; exists n; split; auto with arith.
 ring.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl.  rewrite IHx. lfind.  reflexivity.
Admitted.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite rev_append. simpl. rewrite (eq_refl : Cons n Nil = rev (Cons n Nil)). rewrite IHx. rewrite rev_rev. simpl. reflexivity.
Qed.


(* Examples *)
Require Import ZArith Reals List QFourier.

From mathcomp Require Import all_ssreflect all_algebra.

Import GRing.Theory Num.Theory.
Open Scope ring_scope.

(* Examples *)
Lemma ex1: forall x1 x2 x3: rat,
  x1 <= x2 -> x1 <= x3 -> x2 + 1%:R * x3 <= x1 -> x3 < 1.
Proof. qfourier. Qed.

Lemma ex2: forall x1 x2 x3: rat,
  3%:R / 4%:R * x1 + 10%:R <= 3%:R / 4%:R * x2 + 10%:R -> 1/2%:R * x2  = 1/2%:R * x3 -> x1 <= x3.
Proof. qfourier. Qed.


(* Exercise 18 *)

Require Import BenB.

Variables A B C D : Prop.

(* Double negation *)

Theorem exercise_018 : (~~(A->B) -> (A->B)).
Proof.
imp_i a1.
neg_e' (~(A -> B)) a2.
hyp a1.
hyp a2.
Qed.


Require Import option.

Inductive exp : Set :=
| Nat  : nat  -> exp
| Bool : bool -> exp
| Plus : exp  -> exp -> exp
| And  : exp  -> exp -> exp
.

Inductive type : Set :=
| TNat  : type
| TBool : type
.

Inductive hasType : exp -> type -> Prop :=
| HtNat  : forall (n:nat),  hasType (Nat n) TNat
| HtBool : forall (b:bool), hasType (Bool b) TBool
| HtPlus : forall (e1 e2:exp),
    hasType e1 TNat ->
    hasType e2 TNat ->
    hasType (Plus e1 e2) TNat
| HtAnd  : forall (e1 e2:exp),
    hasType e1 TBool ->
    hasType e2 TBool ->
    hasType (And e1 e2) TBool
.

(* The lazy way                                                                 *)
Definition eq_type_dec : forall (t t':type), {t = t'} + {t <> t'}.
    decide equality.
Defined.

(*
Print eq_type_dec.
*)

(* The usual way                                                                *)
Definition eq_type_dec' : forall (t t':type), {t = t'} + {t <> t'}.
    intros t t'. destruct t, t'.
    - left. reflexivity.
    - right. intros H. inversion H.
    - right. intros H. inversion H.
    - left. reflexivity.
Defined.

(*
Print eq_type_dec'.
*)

Definition nat_not_bool : TNat <> TBool := fun p =>
    match p with end.

Definition bool_not_nat : TBool <> TNat := fun p =>
    match p with end.

(* The hand-crafted way                                                         *)
Definition eq_type_dec'' (t t':type) : {t = t'} + {t <> t'} :=
    match t as s return {s = t'} + {s <> t'} with
    | TNat  =>
        match t' as s' return {TNat = s'} + {TNat <> s'} with
        | TNat  => left eq_refl
        | TBool => right nat_not_bool
        end
    | TBool =>
        match t' as s' return {TBool = s'} + {TBool <> s'} with
        | TNat  => right bool_not_nat
        | TBool => left eq_refl
        end
    end.

(*
Print eq_type_dec''.
*)

(* Hoping to turn 'Typ' into a monad - ish                                      *)
Definition Typ (e:exp) : Type := option {t:type | hasType e t}.

Definition return_ (e:exp) (t:type) (p:hasType e t) : Typ e :=
    Some (exist _ t p).

(* This signature looks very good in that it seems to guarantee correctness     *)
(* since if it returns a type t, this type will be accompanied by a proof of    *)
(* hasType e t. Unfortunately, this is only half of a correctness proof:        *)
(* We have to guarantee that if hasType e t holds, typeCheck is not None        *)
(* Proving correctness and reasoning about typeCheck appears to be difficult    *)
(* It would be better to design a new signature which ensures correctness       *)
Definition typeCheck : forall (e:exp), option {t:type | hasType e t}.
    refine (fix F (e:exp) : option {t:type | hasType e t} :=
        match e as e' return option {t:type | hasType e' t} with
        | Nat _      => Some (exist _ TNat (HtNat _))
        | Bool _     => Some (exist _ TBool (HtBool _))
        | Plus e1 e2 =>
            match (F e1) with
            | None  => None
            | Some (exist _ t1 p1) =>
                match (F e2) with
                | None  => None
                | Some (exist _ t2 p2) =>
                    match eq_type_dec t1 TNat with
                    | right _  => None
                    | left  _  =>
                        match eq_type_dec t2 TNat with
                        | right _  => None
                        | left _   => Some (exist _ TNat (HtPlus _ _ _ _))
                        end
                    end

                end
            end
        | And e1 e2  =>
            match (F e1) with
            | None  => None
            | Some (exist _ t1 p1)  =>
                match (F e2) with
                | None  => None
                | Some (exist _ t2 p2)  =>
                    match eq_type_dec t1 TBool with
                    | right _  => None
                    | left _   =>
                        match eq_type_dec t2 TBool with
                        | right _  => None
                        | left _   => Some (exist _ TBool (HtAnd _ _ _ _))
                        end
                    end
                end
            end
        end).
    - simpl in p1. subst. assumption.
    - simpl in p2. subst. assumption.
    - simpl in p1. subst. assumption.
    - simpl in p2. subst. assumption.
Defined.

(*
Print typeCheck.
*)

Definition isNat (e:exp)(t' : {t:type | hasType e t}) : bool :=
    match t' with
    | exist _ t _   =>
        match eq_type_dec t TNat with
        | right _   => false
        | left  _   => true
        end
    end.

Arguments isNat {e} _.

Lemma isNatHasTypeNat : forall (e:exp) (t' : {t:type | hasType e t}),
    isNat t' = true -> hasType e TNat.
Proof.
    intros e [t p]. simpl. destruct (eq_type_dec t) as [H|H].
    - rewrite H in p. intros. assumption.
    - intros H'. inversion H'.
Qed.

Definition isBool (e:exp)(t' : {t:type | hasType e t}) : bool :=
    match t' with
    | exist _ t _   =>
        match eq_type_dec t TBool with
        | right _   => false
        | left  _   => true
        end
    end.

Arguments isBool {e} _.

Lemma isBoolHasTypeBool : forall (e:exp) (t' : {t:type | hasType e t}),
    isBool t' = true -> hasType e TBool.
Proof.
    intros e [t p]. simpl. destruct (eq_type_dec t) as [H|H].
    - rewrite H in p. intros. assumption.
    - intros H'. inversion H'.
Qed.

(* This is a lot more readable than the initial typeCheck implementation        *)
Definition typeCheck' : forall (e:exp), option {t:type | hasType e t}.
    refine (fix F (e:exp) : option {t:type | hasType e t} :=
        match e as e' return option {t:type | hasType e' t} with
        | Nat _      => Some (exist _ TNat (HtNat _))
        | Bool _     => Some (exist _ TBool (HtBool _))
        | Plus e1 e2 =>
            t1 <- F e1 ;
            t2 <- F e2 ;
            p1  <- guard (isNat t1) ;
            p2  <- guard (isNat t2) ;
            Some (exist _ TNat (HtPlus _ _ _ _))
        | And e1 e2  =>
            t1 <- F e1 ;
            t2 <- F e2 ;
            p1 <- guard (isBool t1) ;
            p2 <- guard (isBool t2) ;
            Some (exist _ TBool (HtAnd _ _ _ _))
        end).
    - apply isNatHasTypeNat   with t1. assumption.
    - apply isNatHasTypeNat   with t2. assumption.
    - apply isBoolHasTypeBool with t1. assumption.
    - apply isBoolHasTypeBool with t2. assumption.
Defined. (* not 'Qed' which would make function opaque                          *)

(* Throws away the proof element                                                *)
Definition typeOf (e:exp) (t':{t:type | hasType e t}) : type :=
    match t' with
    | exist _ t _  => t
    end.

Arguments typeOf {e} _.

(*
Compute typeOf <$> (typeCheck (Nat 5)).
Compute typeOf <$> (typeCheck (Bool true)).
Compute typeOf <$> (typeCheck (Plus (Nat 5) (Plus (Nat 6) (Nat 0)))).
Compute typeOf <$> (typeCheck (And (Bool true) (Bool false))).
Compute typeOf <$> (typeCheck (Plus (Bool true) (Nat 5))).
Compute typeOf <$> (typeCheck' (Nat 5)).
Compute typeOf <$> (typeCheck' (Bool true)).
Compute typeOf <$> (typeCheck' (Plus (Nat 5) (Plus (Nat 6) (Nat 0)))).
Compute typeOf <$> (typeCheck' (And (Bool true) (Bool false))).
Compute typeOf <$> (typeCheck' (Plus (Bool true) (Nat 5))).
*)

Lemma hasType_unique : forall (e:exp) (t t':type),
    hasType e t -> hasType e t' -> t = t'.
Proof.
    destruct e as [n|b|e1 e2|e1i e2];
    intros t t' H H';
    inversion H; inversion H';
    reflexivity.
Qed.

(* This correctness result is pretty much guaranteed by the type system         *)
Lemma typeCheck_correct1 : forall (e:exp) (t:type),
    typeOf <$> typeCheck e = Some t -> hasType e t.
Proof.
    intros e t H. destruct (typeCheck e) as [[t' H']|];
    simpl in H; inversion H. subst. assumption.
Qed.

(* Identical proof, all coming from the type signature of typeCheck             *)
Lemma typeCheck_correct1' : forall (e:exp) (t:type),
    typeOf <$> typeCheck' e = Some t -> hasType e t.
Proof.
    intros e t H. destruct (typeCheck' e) as [[t' H']|];
    simpl in H; inversion H. subst. assumption.
Qed.

(*
Lemma typeCheck_correct2 : forall (e:exp) (t:type),
    hasType e t -> typeOf <$> typeCheck e = Some t.
Proof.
    intros e t H. induction H as [n|b|e1 e2 H1 IH1 H2 IH2|e1 e2 H1 IH1 H2 IH2].
    - reflexivity.
    - reflexivity.
    - simpl. destruct (typeCheck e1) as [|t1 p1] eqn:E1, (typeCheck e2) as [|t2 p2] eqn:E2.
        + simpl in IH1. inversion IH1. subst.

Show.
*)

(*
(* It is all very nice to define typeCheck with 'do' notations, but correct?    *)
Lemma typeCheck_correct : forall (e:exp),
    typeOf <$> typeCheck e = typeOf <$> typeCheck' e.
Proof.
    induction e as [n|b|e1 IH1 e2 IH2|e1 IH1 e2 IH2].
    - simpl. reflexivity.
    - simpl. reflexivity.
    -
Show.
*)