Set Warnings "-notation-overridden,-parsing".
From LF Require Export tactics.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Lemma succ_inj : injective S.
Proof.
  intros n m H.
  injection H as H1.
  apply H1.
Qed.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - reflexivity.
  - reflexivity.
Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB.
  split.
  - apply HA.
  - apply HB.
Qed.

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n.
  induction n.
  - split.
    reflexivity.
    destruct m eqn:m'.
    + reflexivity.
    + discriminate.
  - intros.
    split.
    discriminate.
    discriminate.
Qed.

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn.
  rewrite Hm.
  reflexivity.
Qed.

Lemma and_example2' :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m [Hn Hm].
  rewrite Hn.
  rewrite Hm.
  reflexivity.
Qed.

Lemma and_example2'' :
  forall n m : nat, n = 0 -> m = 0 -> n + m = 0.
Proof.
  intros n m Hn Hm.
  rewrite Hn.
  rewrite Hm.
  reflexivity.
Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  intros n m H.
  assert (H' : n = 0 /\ m = 0).
  { apply and_exercise. apply H. }
  destruct H' as [Hn Hm].
  rewrite Hn. reflexivity.
Qed.

Lemma proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q [HP HQ].
  apply HP.
Qed.

Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q H.
  destruct H as [HP HQ].
  apply HQ.
Qed.

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ].
  split.
    - apply HQ.
    - apply HP.
Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split.
  split.
  apply HP.
  apply HQ.
  apply HR.
Qed.

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m [Hn | Hm].
  - rewrite Hn.
    reflexivity.
  - rewrite Hm.
    rewrite <- mult_n_O.
    reflexivity.
Qed.

Lemma or_intro :
  forall A B : Prop, A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intros [|n].
  - left.
    reflexivity.
  - right.
    reflexivity.
Qed.

Module MyNot.
Definition not (P:Prop) := P -> False.
Notation "~ x" := (not x) : type_scope.
Check not.
End MyNot.

Theorem ex_falso_quodlibet :
  forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  destruct contra.
Qed.

Fact not_implies_our_not :
  forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  unfold not.
  intros P H Q HP.
  destruct H.
  apply HP.
Qed.

Notation "x <> y" := (~ (x = y)) : type_scope.

Theorem zero_not_one : 0 <> 1.
Proof.
  unfold not.
  intros contra.
  discriminate.
Qed.

Theorem not_False :
  ~ False.
Proof.
  unfold not.
  intros H.
  destruct H.
Qed.

Theorem contradiction_implies_anything :
  forall P Q : Prop,
  (P /\ ~ P) -> Q.
Proof.
  intros P Q [HP HNA].
  unfold not in HNA.
  apply HNA in HP.
  destruct HP.
Qed.

Theorem double_neg :
  forall P : Prop,
  P -> ~~P.
Proof.
  intros P H.
  unfold not.
  intros G.
  apply G.
  apply H.
Qed.

Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H.
  unfold not.
  intros.
  apply H0.
  apply H.
  apply H1.
Qed.

Theorem not_both_true_and_false :
  forall P : Prop,
  ~(P /\ ~P).
Proof.
  unfold not.
  intros P contra.
  apply contradiction_implies_anything with(P:=P).
  apply contra.
Qed.

Theorem not_true_is_false :
  forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  - reflexivity.
Qed.

Theorem not_true_is_false' : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - unfold not in H.
    exfalso.
    apply H. reflexivity.
  - reflexivity.
Qed.

Lemma True_is_true : True.
Proof. apply I. Qed.

Module MyIff.
Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).
Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.
End MyIff.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q [HAB HBA].
  split.
  - apply HBA.
  - apply HAB.
Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros b.
  split.
  - apply not_true_is_false.
  - intros H.
    rewrite H.
    intros H'.
    discriminate H'.
Qed.

Theorem or_distributes_over_and :
  forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R.
  split.
  - intros.
    destruct H.
    + split.
      left. apply H.
      left. apply H.
    + split.
      destruct H.
      right. apply H.
      destruct H.
      right. apply H0.
  - intros.
    destruct H as [HL HR].
    destruct HL.
    destruct HR.
    left.
    apply H.
    left.
    apply H.
    destruct HR.
    left.
    apply H0.
    right.
    split.
    apply H.
    apply H0.
Qed.

From Coq Require Import Setoids.Setoid.

Lemma or_assoc :
  forall P Q R : Prop,
  P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R.
  split.
  - intros.
    destruct H as [H | [H | H]].
    + left. left. apply H.
    + left. right. apply H.
    + right. apply H.
  - intros [[H | H] | H].
    + left. apply H.
    + right. left. apply H.
    + right. right. apply H.
Qed.

Lemma mult_eq_0 :
  forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H.
  destruct n.
  - left.
    reflexivity.
  - destruct m.
    + right.
      reflexivity.
    + discriminate.
Qed.

Lemma mult_0 :
  forall n m,
  n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  split.
  - apply mult_eq_0.
  - apply or_example.
Qed.

Lemma mult_0_3 :
  forall n m p,
  n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p.
  rewrite mult_0.
  rewrite mult_0.
  rewrite or_assoc.
  reflexivity.
Qed.

Lemma apply_iff_example :
  forall n m : nat,
  n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H.
  apply mult_0.
  apply H.
Qed.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l ->
    In (f x) (map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  - simpl.
    intros [].
  - simpl.
    intros [H | H].
    + rewrite H.
      left.
      reflexivity.
    + right.
      apply IHl'.
      apply H.
Qed.

Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
  In y (map f l) <->
  exists x, f x = y /\ In x l.
Proof.
  intros.
  split.
  induction l.
  - simpl.
    intros [].
  - simpl.
    intros [H | H].
    + exists x.
      split.
      apply H.
      left.
      reflexivity.
    + apply IHl in H.
      destruct H as [w [F I]].
      exists w.
      split.
      apply F.
      right.
      apply I.
  - intros [w [F I]].
    rewrite <- F.
    apply In_map.
    apply I.
Qed.

Fixpoint All {T} (P : T -> Prop) (l : list T) : Prop :=
  match l with
    | [] => True
    | h :: t => P h /\ All P t
  end.

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
  (forall x, In x l -> P x) <->
  All P l.
Proof.
  intros.
  split.
  - induction l.
    + intros.
      simpl.
      reflexivity.
    + intros.
      simpl.
      split.
      apply H.
      * simpl.
        left.
        reflexivity.
      * apply IHl.
        intros.
        apply H.
        simpl.
        right.
        apply H0.
  - induction l.
    + simpl.
      intros.
      exfalso.
      apply H0.
    + simpl.
      intros [H H0] x' [H1 | H1].
      * rewrite <- H1.
        apply H.
      * apply IHl.
        apply H0.
        apply H1.
Qed.

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop :=
  (fun x => if oddb x then Podd x else Peven x).

Theorem combine_odd_even_intro :
  forall(Podd Peven : nat -> Prop) (n : nat),
  (oddb n = true -> Podd n) ->
  (oddb n = false -> Peven n) ->
  combine_odd_even Podd Peven n.
Proof.
  intros.
  destruct (oddb n) eqn:H1.
  - unfold combine_odd_even.
    rewrite H1.
    apply H.
    reflexivity.
  - unfold combine_odd_even.
    rewrite H1.
    apply H0.
    reflexivity.
Qed.

Theorem combine_odd_even_elim_odd :
  forall(Podd Peven : nat -> Prop) (n : nat),
  combine_odd_even Podd Peven n ->
  oddb n = true ->
  Podd n.
Proof.
  intros.
  unfold combine_odd_even in H.
  rewrite H0 in H.
  apply H.
Qed.

Theorem combine_odd_even_elim_even :
  forall(Podd Peven : nat -> Prop) (n : nat),
  combine_odd_even Podd Peven n ->
  oddb n = false ->
  Peven n.
Proof.
  intros.
  unfold combine_odd_even in H.
  rewrite H0 in H.
  apply H.
Qed.

Check plus_comm.

Lemma plus_comm3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite plus_comm.
Abort.

Lemma plus_comm3_take2 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  assert (H : y + z = z + y).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

Lemma plus_comm3_take3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite (plus_comm y z).
  reflexivity.
Qed.

Lemma in_not_nil :
  forall A (x : A) (l : list A),
  In x l -> l <> [].
Proof.
  intros A x l H.
  unfold not.
  intro Hl.
  destruct l.
  - simpl in H.
    destruct H.
  - discriminate Hl.
Qed.

Lemma in_not_nil_42 :
  forall l : list nat,
  In 42 l -> l <> [].
Proof.
  intros l H.
  Fail apply in_not_nil.
Abort.

Lemma in_not_nil_42_take2 :
  forall l : list nat,
  In 42 l -> l <> [].
Proof.
  intros l H.
  apply in_not_nil with (x := 42).
  apply H.
Qed.

Lemma in_not_nil_42_take3 :
  forall l : list nat,
  In 42 l -> l <> [].
Proof.
  intros l H.
  apply in_not_nil in H.
  apply H.
Qed.

Lemma in_not_nil_42_take4 :
  forall l : list nat,
  In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil nat 42).
  apply H.
Qed.

Lemma in_not_nil_42_take5 :
  forall l : list nat,
  In 42 l -> l <> [].
Proof.
  intros l H.
  apply (in_not_nil _ _ _ H).
Qed.

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
  In n (map (fun m => m * 0) ns) ->
  n = 0.
Proof.
  intros n ns H.
  destruct
  (proj1 _ _ (In_map_iff _ _ _ _ _) H) as
  [m [Hm _]].
  rewrite mult_0_r in Hm.
  rewrite <- Hm.
  reflexivity.
Qed.

Example function_equality_ex1 :
  (fun x => 3 + x) = (fun x => (pred 4) + x).
Proof. reflexivity. Qed.

Axiom functional_extensionality :
  forall {X Y: Type} {f g : X -> Y},
  (forall (x:X), f x = g x) -> f = g.

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality.
  intros x.
  apply plus_comm.
Qed.

Print Assumptions function_equality_ex2.

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X} (l : list X) : list X :=
  rev_append l [].

Lemma rev_append_order :
  forall X (l1 l2 l3: list X),
  rev_append l1 l2 ++ l3 = rev_append l1 (l2 ++ l3).
Proof.
  induction l1.
  - reflexivity.
  - intros.
    destruct l2.
    + apply IHl1.
    + apply IHl1.
Qed.

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intros.
  apply functional_extensionality.
  induction x.
  - unfold tr_rev.
    reflexivity.
  - simpl.
    rewrite <- IHx.
    unfold tr_rev.
    simpl.
    rewrite rev_append_order.
    simpl.
    reflexivity.
Qed.

Example even_42_bool : evenb 42 = true.
Proof. reflexivity. Qed.

Example even_42_prop : exists k, 42 = double k.
Proof. exists 21. reflexivity. Qed.

Theorem evenb_double : forall k, evenb (double k) = true.
Proof.
  intros k.
  induction k as [|k' IHk'].
  - reflexivity.
  - simpl.
    apply IHk'.
Qed.

Theorem evenb_double_conv : forall n,
  exists k,
  n = if evenb n then double k
                else S (double k).
Proof.
  induction n.
  - exists 0.
    reflexivity.
  - rewrite evenb_S.
    destruct IHn as [k' H].
    destruct (evenb n).
    + simpl.
      rewrite H.
      exists k'.
      reflexivity.
    + simpl.
      exists (S k').
      rewrite H.
      reflexivity.
Qed.

Theorem even_bool_prop : forall n,
  evenb n = true <-> exists k, n = double k.
Proof.
  intros n.
  split.
  - intros H.
    destruct (evenb_double_conv n) as [k Hk].
    rewrite Hk.
    rewrite H.
    exists k.
    reflexivity.
  - intros [k Hk].
    rewrite Hk.
    apply evenb_double.
Qed.

Lemma eqb_refl:
  forall x: nat,
  (x =? x) = true.
Proof.
  intros.
  induction x.
  reflexivity.
  simpl.
  apply IHx.
Qed.

Theorem eqb_eq : forall n1 n2 : nat,
  n1 =? n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply eqb_true.
  - intros H.
    rewrite H.
    rewrite <- eqb_refl with(x:=n2).
    reflexivity.
Qed.

Example not_even_1001 : evenb 1001 = false.
Proof.
  reflexivity.
Qed.

Example not_even_1001' : ~(exists k, 1001 = double k).
Proof.
  rewrite <- even_bool_prop.
  unfold not.
  simpl.
  intro H.
  discriminate H.
Qed.

Lemma plus_eqb_example : forall n m p : nat,
    n =? m = true -> n + p =? m + p = true.
Proof.
  intros n m p H.
  rewrite eqb_eq in H.
  rewrite H.
  rewrite eqb_eq.
  reflexivity.
Qed.

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2.
  split.
  - intros.
    split.
    + destruct b1.
      * reflexivity.
      * discriminate.
    + destruct b2.
      * reflexivity.
      * destruct b1.
        discriminate.
        discriminate.
  - intros.
    destruct  H.
    rewrite H.
    rewrite H0.
    reflexivity.
Qed.

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  split.
  - intros.
    destruct H.
    destruct b1.
    + left.
      reflexivity.
    + right.
      reflexivity.
  - intros [H1 | H2].
    + rewrite H1.
      reflexivity.
    + rewrite H2.
      destruct b1.
      reflexivity.
      reflexivity.
Qed.

Theorem eqb_neq : forall x y : nat,
  x =? y = false <-> x <> y.
Proof.
  intros x y.
  rewrite <- not_true_iff_false.
  rewrite -> eqb_eq.
  reflexivity.
Qed.

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool)
                  (l1 l2 : list A) : bool :=
  match l1, l2 with
  | nil, nil => true
  | nil, h' :: t' => false
  | h :: t, nil => false
  | h :: t, h' :: t' => eqb h h' && eqb_list eqb t t'
  end.

Lemma eqb_list_true_iff :
  forall A (eqb : A -> A -> bool),
  (forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
  forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof.
  induction l1.
  - destruct l2.
    * simpl.
      split.
      + intros.
        reflexivity.
      + intros.
        reflexivity.
    * simpl.
      split.
      + intros.
        discriminate.
      + intros.
        discriminate.
  - destruct l2.
    * simpl.
      split.
      + intros.
        discriminate.
      + intros.
        discriminate.
    * simpl.
      split.
      + intros.
        apply andb_true_iff in H0.
        destruct H0 as [H1 H2].
        apply H in H1.
        apply IHl1 in H2.
        rewrite H1, H2.
        reflexivity.
      + intros.
        injection H0 as H1 H2.
        apply H in H1.
        rewrite H1.
        apply IHl1.
        apply H2.
Qed.

Theorem forallb_true_iff :
  forall X test (l : list X),
  forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  induction l.
  - split.
    + simpl.
      reflexivity.
    + simpl.
      reflexivity.
  - split.
    + intros.
      simpl in H.
      apply andb_true_iff in H.
      destruct H as [H1 H2].
      rewrite IHl in H2.
      simpl.
      split.
      * apply H1.
      * apply H2.
    + intros.
      simpl in H.
      destruct H as [H1 H2].
      simpl.
      rewrite H1.
      apply IHl.
      apply H2.
Qed.


(**
 * Logic in Coq
 **)

(**********************************************************************)

(* Propositions and proofs *)

Check list.
(* [list] is a type-level function *)

Definition natlist : Type := list nat.
(* explicit application of type-level functions *)
Check natlist.

(* What, then, is the type of a theorem? *)

Theorem obvious_fact : 1 + 1 = 2.
Proof. trivial. Qed.
Check obvious_fact.

(**
Coq responds:
<<
obvious_fact : 1 + 1 = 2
>>

If [1+1 = 2] is a type, what are its values?

    Proofs of [1 + 1 = 2]!

There might be many such proofs; here are two:

- reduce [1+1] to [2], then note that [x=x].

- subtract [1] from both sides
    resulting in [1 + 1 - 1 = 2 - 1]
  reduce both sides to [1],
  then note that [x = x].

What proof does Coq have for [1 + 1 = 2]? *)

Print obvious_fact.

(**
Coq responds:
<<
obvious_fact = eq_refl : 1 + 1 = 2
>>
So what is [eq_refl]?
*)

Print eq_refl.

(** Amidst all the output that produces, you will spy
<<
eq_refl : x = x
>>
That is, [eq_refl] has type [x = x].
*)

(**********************************************************************)

(**
** [Prop] and [Set]
*)

Check 42.

Check nat.

(**
The Coq documentation describes [Set] as being the type of _program specifications_, which describe
computations.
*)

Check Set.

(* What is the type of [1 + 1 = 2]? *)

Check 1 + 1 = 2.

(**
[Prop] is the type of all the things that can be proved (not necessarily hold).
*)

Check 1 + 1 = 3.

Check Prop.

Check true.

Check True.

(**
The type of [Prop] is also [Type].
*)

(* Consider *)

Check 1 + 1.
Check 3.
Check 1 + 1 = 3.

(* [=] takes two [nat]s and returns a [Prop].

   What can we learn about it? *)

Locate "=".

(**
Coq tells us two possible meanings for [=], and the second is what we want:
<<
"x = y" := eq x y
>>
*)

Check @eq.

(* [eq] builds a proposition that can be proved using two values of the same type *)

Check eq (fun x => x + 1) (fun n => n + 2 - 1).

Theorem t1 : eq (fun x => x + 1) (fun n => n + 2 - 1).
Proof.
Admitted.

(**********************************************************************)

(**
** Propositional logic

Here are the _connectives_ in Coq:

- Implication: [P -> Q].
- Conjunction: [P /\ Q].
- Disjunction: [P \/ Q].
- Negation: [~P].

* None of these connectives are baked in, but encoded.
*)

Check and.
Check or.
Check not.

(**
<<
and : Prop -> Prop -> Prop
or  : Prop -> Prop -> Prop
not : Prop -> Prop
>>

Observe that we use [->] as implication but also as the type of functions.

This is not an accident!

[P -> Q] can be thought of as:

  - The type of functions that take a [P] and return [Q]
  - A proposition that asserts [P] implies [Q]

They are the same in Coq! Let's see this in action.

*)

(**********************************************************************)

(** Implication *)

Theorem p_implies_p : forall P: Prop, P -> P.

(**
So why does this proposition hold? If you've already assumed [P], then
necessarily [P] follows from your assumptions:  that's what it means to be an
assumption.

The Coq proof below uses that reasoning.
*)

Proof.
    intros P P_assumed.
    assumption. (* new tactic *)
Qed.

(* Let's look at the type of [p_implies_p]. *)

Check p_implies_p.

(** What is that evidence?  We can use [Print] to find out: *)

Print p_implies_p.

(**
Coq responds
<<
p_implies_p =
fun (P : Prop) (P_assumed : P) => P_assumed
     : forall P : Prop, P -> P
>>

The proof is essentially the identity function for a given [P] that we want to prove.

Can also be done directly as a [Definition]:
*)

Definition p_implies_p_direct : forall P:Prop, P -> P :=
  fun p ev_p => ev_p.

(**
  + Rarely do we construct such direct proofs
  + Tactics help us construct complicated proofs.
*)

Theorem syllogism : forall P Q : Prop,
  (P -> Q) -> P -> Q.

(**
How would you convince a human that this theorem holds?
  + Assume that [P -> Q].
  + Also assume [P].  Since
  + [P] holds, and since [P] implies [Q], we know that [Q] must also hold.

The Coq proof below uses that style of argument.
*)

Proof.
  intros P Q evPimpQ evP.
  apply evPimpQ. (* new tactic *)
  assumption.
Qed.

(**
  + [apply] applies given evidence to goal.
  + Does _backward reasoning_

Let's look at the proof that these tactics cause Coq to create:
*)

Print syllogism.

(**
We see that
<<
syllogism =
fun (P Q : Prop) (evPimpQ : P -> Q) (evP : P) => evPimpQ evP
     : forall P Q : Prop, (P -> Q) -> P -> Q
>>

Equivalent to the OCaml function

let apply f v = f v
*)

Theorem syllogism' : forall P Q : Prop,
  (P -> Q) -> P -> Q.
Proof.
  intros.
  apply H in H0.
  (* Can also [apply] to assumptions to do _forwards reasoning *)
  assumption.
Qed.

Theorem imp_trans : forall P Q R : Prop,
  (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  intros P Q R. intros evPimpQ. intros evQimpR. intros.

  apply evQimpR.
  apply evPimpQ.
  assumption.
Qed.

(** Let's look at the resulting proof: *)

Print imp_trans.

(**
Coq says
<<
imp_trans =
fun (P Q R : Prop) (evPimpQ : P -> Q) (evQimpR : Q -> R) (evP : P) =>
evQimpR (evPimpQ evP)
     : forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R
>>

Equivalent to the OCaml function

let composition f g v = g (f v)

let succ x = x + 1

let succ2 = succ o succ

let (|>) = v |> f |> g

(**********************************************************************)

** Conjunction

Now we turn our attention to the conjunction connective.  Here's
a first theorem to prove.
*)

Theorem and_fst : forall P Q, P /\ Q -> P.

(** Why does that hold, intuitively?
     + Suppose we have evidence of [P /\ Q], we have evidence of [P].
     + Use that evidence of [P] to show [P] holds.
*)

Proof.
    intros P Q PandQ.
    destruct PandQ as [P_holds Q_holds].
    assumption.
Qed.

(** Let's look at the proof of [and_fst]. *)

Print and_fst.

(**
Coq says that
<<
and_fst =
fun (P Q : Prop) (PandQ : P /\ Q) =>
match PandQ with
| conj P_holds _ => P_holds
end
     : forall P Q : Prop, P /\ Q -> P
>>

What is [conj]?
*)

Check conj.

Locate "/\".

Print and.

(*

type ('a,'b) and = Conj : 'a * 'b -> ('a,'b) and

*)

(* Takeaway: In order to construct a proof for [P /\ Q], you need [P] and [Q] and use the [conj] constructor to put them together *)

Theorem and_snd : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q PandQ.
  destruct PandQ.
  assumption.
Qed.

Print and_snd.

(** Here is another proof involving [and]. *)

Theorem and_ex : 42=42 /\ 43=43.

(** Why does that hold, intuitively?  Because equality is reflexive, regardless
of how many times we connect that fact with [/\]. *)

Proof.
  split. (* new tactic *)
  trivial. trivial.
Qed.

(* What is [and_ex]? *)

Print and_ex.

(**
Coq responds:
<<
and_ex = conj eq_refl eq_refl
     : 42 = 42 /\ 43 = 43
>>

So [and_ex] is [conj] applied to [eq_refl] as its first argument and [eq_refl] as its second argument.
*)

(* As another example of conjunction, let's prove that it is commutative. *)

Theorem and_comm: forall P Q, P /\ Q -> Q /\ P.
Proof.
    intros P Q PandQ.
    destruct PandQ.
    split.
    all: assumption.
Qed.

Print and_comm.

(**********************************************************************)

(** Disjunction

Let's start with disjunction by proving a theorem very similar to the first
theorem we proved for conjunction: *)

Theorem or_left : forall (P Q : Prop), P -> P \/ Q.

(** As always, what's the intuition?

Let's formalize that argument in Coq. *)

Proof.
    intros P Q P_holds.
    left. (* new tactic *)
    assumption.
Qed.

Print or_left.

(**
Coq responds
<<
or_left =
fun (P Q : Prop) (P_holds : P) => or_introl P_holds
     : forall P Q : Prop, P -> P \/ Q
>>

That function's arguments are no mystery by now, but what is its body?
We need to find out more about [or_introl].
*)

Locate "\/".
(** "\/" is infix notation for [or A B] *)

Print or.

Print or_introl.
(* [or_introl] is one of two constructors of the type [or]:
<<
Inductive or (A B : Prop) : Prop :=
    or_introl : A -> A \/ B
  | or_intror : B -> A \/ B
>>
*)

Theorem or_comm : forall P Q, P \/ Q -> Q \/ P.

(** Why does this hold?

That's what the Coq proof below does. *)

Proof.
    intros P Q PorQ.
    destruct PorQ.
    - right. assumption.
    - left. assumption.
Qed.

Print or_comm.

(**
Coq responds
<<
or_comm =
fun (P Q : Prop) (PorQ : P \/ Q) =>
match PorQ with
| or_introl H => or_intror H
| or_intror H => or_introl H
end
     : forall P Q : Prop, P \/ Q -> Q \/ P)
>>

Next, let's prove a theorem involving both conjunction and disjunction. *)

Theorem or_distr_and : forall P Q R,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).

Proof.
  intros P Q R PorQR.
  destruct PorQR.

  - split.
    + left. assumption.
    + left. assumption.
  - destruct H.
    split.
    + right. assumption.
    + right. assumption.
Qed.

(** We can make the proof shorter with [;] *)

Theorem or_distr_and_shorter : forall P Q R,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros.
  destruct H.
  - split; left; assumption.
  - destruct H.
    split; right; assumption.
Qed.

(**********************************************************************)

(** [False] and [True]

[False] is the proposition that can never hold

Here's the definition of [False]: *)

Print False.

(**
Coq responds
<<
Inductive False : Prop :=
>>

Has no constructors. And hence, we cannot provide evidence that [False] holds.

Let's prove the Principle of Explosion. *)

Theorem explosion : forall P:Prop, False -> P.
Proof.
    intros P false_holds.
    contradiction. (* new tactic *)
Qed.

(** The second line of the proof uses a new tactic, [contradiction].  This tactic looks for any contradictions or assumptions of [False], and uses those to conclude the proof.  In this case, it immediately finds [False] as an assumption named [false_holds].*)

Print explosion.
Print False_ind.

(**
  + The [return P] in the pattern match above is a type annotation
  + [False_ind] uses the evidence of [False] to return the evidence for any [P].
*)

(* We can directly define this function *)

Definition explosion' : forall (P:Prop), False -> P :=
  fun (P : Prop) (f (* no valid values for [f] *) : False) =>
    match f with
    end.

(** We can never prove [P -> P /\ False], because there is no way to construct the evidence for the right side. *)

Theorem p_imp_p_and_false : forall P:Prop, P -> P /\ False.
Proof.
  intros P P_holds. split. assumption.  (* now we're stuck *)
Abort.

(** But we can always prove [P -> P \/ False] by just focusing on the non-false
part of the disjunction. *)

Theorem p_imp_p_or_false : forall P:Prop, P -> P \/ False.
Proof.
  intros P P_holds. left. assumption.
Qed.

(** [True] is the proposition that is always true *)

Print True.

Theorem p_imp_p_and_true : forall P:Prop, P -> P /\ True.
Proof.
  intros P P_holds. split. assumption.
  exact I. (* new tactic *)
Qed.

(** The final tactic in that proof, [exact], can be used whenever you already
know exactly the program expression you want to write to provide evidence for
the goal you are trying to prove.  In this case, we know that [I] always
provides evidence for [true].  Instead of [exact] we could also have used
[trivial], which is capable of proving trivial propositions like [True]. *)

(**********************************************************************)

(** Negation *)

Locate "~".
Print not.

(**
Coq responds
<<
not = fun A : Prop => A -> False
     : Prop -> Prop
>>

  + Unlike "/\" and "\/" negation is a function not an inductive type.
  + [~P] is effectively syntactic sugar for [P -> False].
*)

Theorem notFalse : ~False -> True.
(** Intuition:  anything implies [True] *)
Proof.
  unfold not. (* new tactic *)
  intros.
  exact I.
Qed.

Print notFalse.
(* Ignores the argument *)

Theorem notTrue: ~True -> False.
Proof.
  unfold not.
  intros t_imp_f.
  apply t_imp_f.
  exact I.
Qed.

(** The program that proof produces is interesting: *)

Print notTrue.

(**
Coq responds
<<
notTrue = fun t_imp_f : True -> False => t_imp_f I
     : ~ True -> False
>>

* Proof is a higher-order function
  + Takes [t_imp_f] function and uses [I] to get the proof for [False]
* We can never apply this function
  + cannot produce a term that returns [False]
*)

Theorem contra_implies_anything : forall (P Q : Prop), P /\ ~P -> Q.
(** Intuition:  principle of explosion *)
Proof.
    unfold not.
    intros.
    destruct H.
    apply H0 in H.
    contradiction. (* detects contradiction *)
Qed.

(**********************************************************************)

(** deMorgan's laws *)

Theorem deMorgan : forall P Q : Prop,
  ~(P \/ Q) -> ~P /\ ~Q.

(** Intuition: if evidence for [P] or [Q] would lead to an explosion (i.e., [False]), then evidence for [P] would lead to an explosion, and evidence for [Q] would also lead to an explosion. *)

Proof.
  unfold not.
  intros P Q PorQ_imp_false.
  split.
  - intros P_holds. apply PorQ_imp_false. left. assumption.
  - intros Q_holds. apply PorQ_imp_false. right. assumption.
Qed.

(* Something interesting happens here *)
Theorem deMorgan2 : forall P Q : Prop,
  ~(P /\ Q) -> ~P \/ ~Q.
Proof.
  unfold not.
  intros P Q PQ_imp_false.
  left.
  intros P_holds. apply PQ_imp_false. split. assumption.
Abort.
(* stuck! *)

(** There's no reason that
      "if evidence for P and Q would produce an explosion"
         implies
      "either evidence for P would produce an explosion, or evidence for Q would".

    + It's the combined evidence for [P] and [Q] that produces the explosion
    + nothing is said about evidence for them individually.
    + Coq uses _Constructive logic_; [deMorgan2] holds in _classical logic_
*)

Theorem excluded_middle : forall P, P \/ ~P.
Proof.
  intros P.
  right.
  unfold not.
  intros.
Abort.

(* Coq uses constructive logic since the act of proving programs is by building evidence bottom up. No bottom up evidence for [P \/ ~P]. *)

Require Coq.Logic.Classical.

Module LetsDoClassicalReasoning.

Import Coq.Logic.Classical.

Print classic.

(**
Coq responds:
<<
*** [ classic : forall P : Prop, P \/ ~ P ]
>>

The [***] indicates that [classic] is an _axiom_ that the library simply asserts without proof.  Using that axiom, all the usual theorems of classical logic can be proved, such as double negation: *)

End LetsDoClassicalReasoning.

(**********************************************************************)

(** Equality and implication *)

Locate "=".
Check @eq.
(* Builds a proposition that asserts the equality of the two arguments*)

Definition eq42 := @eq nat 42.
Check eq42.
Check (eq42 42). (* 42 = 42 *)
Check (eq42 43). (* 42 = 43 *)

(* There's only one way to construct a value of type [eq],
   that's with the [eq_refl] constructor. *)
Print eq.
Check @eq_refl.

Check @eq_refl nat 42.
(*
  + [@eq_refl] only takes just a single argument of type [nat]
    * An argument can only be equal to itself
  + Takeaway: Equality not baked into Coq, but an inductive type.
*)

Theorem direct_eq : 42 = 42.
Proof.
  exact (eq_refl 42).
Qed.

Theorem direct_eq2 : 42 = 43.
Proof.
  (* No way to construct evidence for [42 = 43] *)
Abort.

(** Implication too is defined. *)

Locate "->".

(**
Coq responds:
<<
"A -> B" := forall _ : A, B
>>

A function that takes the evidence for [A] and produces evidence for [B]. *)

Definition pnqiq : forall P Q, P /\ Q -> Q := fun P Q pnq =>
  match pnq with
  | conj evP evQ => evQ
  end.

Definition pnqiq' : forall P Q, forall (_: P /\ Q), Q := pnqiq.

(**

+ Only truly primitive pieces are [Inductive] definitions and [forall] types.
   + Everything else --- equality, implication, conjunction, disjunction, True, False, negation --- can all be expressed in terms of those two primitives.
*)


Set Implicit Arguments.
Require Export Lia.
Require Export ArithRing.
Require Export Coq.Numbers.Natural.Peano.NPeano.
  (* [Nat] is a sub-module of [NPeano], which seems to contain many things.
     E.g. it defines [Nat.div], [Nat.pow], [Nat.log2].
     E.g. it defines [Nat.max], which is the same as [max].
     E.g. it has many properties of [max], see [Coq.Structures.GenericMinMax].
     Unfortunately [Nat.le] is NOT the same as [le], which is [Peano.le].
     For this reason, we do NOT import [Nat]. *)
  Notation log2 := Nat.log2.
From TLC Require Import LibTactics.
Ltac unpack := jauto_set_hyps; intros. (* TEMPORARY also in TLCBuffer *)
From iris_time.union_find.math Require Import LibFunOrd.

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

(* A few simplification lemmas. *)

Lemma plus_lt_plus:
  forall a x y,
  x < y ->
  x + a < y + a.
Proof using.
  intros. lia.
Qed.

Lemma plus_le_plus:
  forall a x y,
  x <= y ->
  x + a <= y + a.
Proof using.
  intros. lia.
Qed.

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

(* [a <= b] is equivalent to [b = a + n] for some unknown [n]. *)

Lemma leq_to_eq_plus:
  forall a b,
  a <= b ->
  exists n,
  b = a + n.
Proof.
  intros. exists (b - a). lia.
Qed.

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

(* Make [lia] a hint. *)

Hint Extern 1 => lia : lia.

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

(* This lemma allows simplifying a [max] expression, by cases. *)

Lemma max_case:
  forall m1 m2,
  m2 <= m1 /\ max m1 m2 = m1 \/
  m1 <= m2 /\ max m1 m2 = m2.
Proof using. lia. Qed.

(* This tactic looks for a [max] expression in the hypotheses or in the goal
   and applies the above lemma. *)

Ltac max_case_m_n_as m n h :=
  let i := fresh in
  destruct (max_case m n) as [ [ h i ] | [ h i ] ];
  rewrite i in *;
  clear i.

Ltac max_case_as h :=
  match goal with
  | |- context[max ?m ?n] =>
      max_case_m_n_as m n h
  | foo: context[max ?m ?n] |- _ =>
      max_case_m_n_as m n h
  end.

Ltac max_case :=
  let h := fresh in
  max_case_as h.

(* [max m1 m2] is an upper bound for [m1] and [m2]. This can be sufficient
   to reason about [max] without introducing a case split. *)

Lemma max_ub:
  forall m1 m2,
  m1 <= max m1 m2 /\ m2 <= max m1 m2.
Proof using.
  intros. eauto using Nat.le_max_l, Nat.le_max_r.
Qed.

Ltac max_ub_m_n_as m n h1 h2 :=
  destruct (max_ub m n) as [ h1 h2 ];
  generalize dependent (max m n);
  intros.

Ltac max_ub_as h1 h2 :=
  match goal with
  | |- context[max ?m ?n] =>
      max_ub_m_n_as m n h1 h2
  | foo: context[max ?m ?n] |- _ =>
      max_ub_m_n_as m n h1 h2
  end.

Ltac max_ub :=
  let h1 := fresh in
  let h2 := fresh in
  max_ub_as h1 h2.

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

(* Properties of multiplication. *)

Lemma mult_positive:
  forall m n,
  0 < m ->
  0 < n ->
  0 < m * n.
Proof using. lia. Qed.

Hint Resolve mult_positive : positive.

Lemma mult_magnifies_left:
  forall m n,
  0 < n ->
  m <= n * m.
Proof using.
  intros.
  destruct n; [ lia | simpl ].
  generalize (n * m); intro.
  lia.
Qed.

Lemma mult_magnifies_right:
  forall m n,
  0 < n ->
  m <= m * n.
Proof using. nia. Qed.

Lemma mult_magnifies_right_strict:
  forall m n,
  0 < m ->
  1 < n ->
  m < m * n.
Proof using. nia. Qed.

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

(* Properties of division. *)

(* It is strange that the Coq standard library offers [divmod_spec],
   but lacks its corollary [div_spec]. *)

Lemma div_spec:
  forall n k,
  0 < k ->
  exists r,
  k * (n / k) + r = n /\ 0 <= r < k.
Proof using.
  intros. unfold Nat.div.
  destruct k; [ false; lia | simpl ].
  forwards: Nat.divmod_spec n k 0 k. eauto.
  destruct (Nat.divmod n k 0 k) as [ q r ]. unpack. simpl.
  exists (k - r). lia.
Qed.

(* Avoid undesired simplifications. *)
(* TEMPORARY [plus] should be opaque too? *)
Global Opaque mult Nat.div max.

(* A tactic to reason about [n/2] in terms of its specification. *)

Ltac div2 :=
  match goal with |- context[?n/2] =>
    let h := fresh in
    forwards h: div_spec n 2; [ lia |
      gen h; generalize (n/2); intros; unpack
    ]
  end.

(* [./2] is monotonic. *)

Lemma div2_monotonic:
  forall m n,
  m <= n ->
  m / 2 <= n / 2.
Proof using.
  intros. repeat div2. lia.
Qed.

Lemma div2_step:
  forall n,
  (n + 2) / 2 = n/2 + 1.
Proof using.
  intros. repeat div2. lia.
Qed.

Lemma div2_monotonic_strict:
  forall m n,
  m + 2 <= n ->
  m / 2 < n / 2.
Proof using.
  intros. cut (m/2 + 1 <= n/2). lia.
  rewrite <- div2_step.
  eauto using div2_monotonic.
Qed.

Lemma mult_div_2:
  forall n,
  2 * (n / 2) <= n.
Proof using.
  intros. div2. lia.
Qed.

Lemma div_mult_2:
  forall n,
  (2 * n) / 2 = n.
Proof using.
  intros. div2. lia.
Qed.

(* A collection of lemmas about division by two and ordering. *)

Lemma prove_div2_le:
  forall m n,
  m <= 2 * n + 1 -> (* tight *)
  m / 2 <= n.
Proof using.
  intros. div2. lia.
Qed.

Lemma use_div2_plus1_le:
  forall m n,
  (n + 1) / 2 <= m -> (* tight *)
  n <= 2 * m.
Proof using.
  intros m n. div2. lia.
Qed.

Lemma use_div2_le:
  forall m n,
  n / 2 <= m -> (* tight *)
  n <= 2 * m + 1.
Proof using.
  intros m n. div2. lia.
Qed.

Lemma prove_le_div2:
  forall m n,
  2 * m <= n -> (* tight *)
  m <= n / 2.
Proof using.
  intros. div2. lia.
Qed.

Lemma use_le_div2:
  forall m n,
  n <= m / 2 -> (* tight *)
  2 * n <= m.
Proof using.
  intros m n. div2. lia.
Qed.

Lemma prove_div2_lt:
  forall m n,
  m < 2 * n -> (* tight *)
  m / 2 < n.
Proof using.
  intros. div2. lia.
Qed.

Lemma use_div2_lt:
  forall m n,
  m / 2 < n -> (* tight *)
  m < 2 * n.
Proof using.
  intros m n. div2. lia.
Qed.

Lemma prove_lt_div2:
  forall m n,
  2 * m < n - 1 -> (* tight *)
  m < n / 2.
Proof using.
  intros. div2. lia.
Qed.

Lemma prove_lt_div2_zero:
  forall n,
  1 < n -> (* tight *)
  0 < n / 2.
Proof using.
  intros. div2. lia.
Qed.

Lemma use_lt_div2:
  forall m n,
  m < (n + 1) / 2 -> (* tight *)
  2 * m < n.
Proof using.
  intros m n. div2. lia.
Qed.

Hint Resolve prove_lt_div2_zero : positive.

Hint Resolve prove_div2_le use_div2_plus1_le use_div2_le prove_le_div2
use_le_div2 prove_div2_lt use_div2_lt prove_lt_div2 use_lt_div2 :
div2.

Goal
  forall n,
  n <= 2 * (n / 2) + 1.
Proof using.
  eauto with div2.
Qed.

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

(* The [pow] function. *)

Lemma power_positive:
  forall k n,
  0 < n ->
  0 < n^k.
Proof using.
  induction k; simpl; intros.
  lia.
  eauto using mult_positive.
Qed.

Hint Resolve power_positive : positive.

Lemma power_plus:
  forall k1 k2 n,
  n^(k1 + k2) = n^k1 * n^k2.
Proof using.
  induction k1; simpl; intros.
  lia.
  rewrite IHk1. ring.
Qed.

Lemma power_of_zero:
  forall k,
  0 < k ->
  0^k = 0.
Proof using.
  induction k; simpl; intros; lia.
Qed.

Lemma power_monotonic_in_k:
  (* We must assume [n > 0], because [0^0] is 1, yet [0^1] is 0. *)
  forall n,
  0 < n ->
  monotonic le le (fun k => n^k).
Proof using.
  intros. intros k1 k2 ?.
  assert (f: k2 = k1 + (k2 - k1)). lia.
  rewrite f. rewrite power_plus.
  eapply mult_magnifies_right.
  eapply power_positive.
  assumption.
Qed.

Lemma power_strictly_monotonic_in_k:
  forall n,
  1 < n ->
  monotonic lt lt (fun k => n^k).
Proof using.
  intros. intros k1 k2 ?.
  assert (f: k2 = k1 + S (k2 - k1 - 1)). lia.
  rewrite f. rewrite power_plus.
  eapply mult_magnifies_right_strict.
    { eauto with positive lia. }
    { simpl.
      eapply Nat.lt_le_trans with (m := n). lia.
      eapply mult_magnifies_right.
      eauto with positive lia. }
Qed.

Lemma power_strictly_monotonic_in_n:
  forall k,
  0 < k ->
  monotonic lt lt (fun n => n^k).
Proof using.
  (* We first prove that this holds when [n1] is nonzero,
     and reformulate the hypothesis [k > 0] so that it is
     amenable to induction. *)
  assert (f:
    forall k n1 n2,
    0 < n1 < n2 ->
    n1^(S k) < n2^(S k)
  ).
  { induction k; simpl; intros.
    lia.
    eapply Nat.lt_le_trans; [ eapply Mult.mult_lt_compat_r | eapply Mult.mult_le_compat_l ]. (* wow *)
      lia.
      eapply power_positive with (k := S k). lia.
      forwards: IHk. eauto. simpl in *. lia. }
  (* There remains to treat separately the case where [n1] is 0. *)
  intros. intros n1 n2 ?.
  destruct (Compare_dec.le_gt_dec n1 0).
    { assert (n1 = 0). lia. subst.
      rewrite power_of_zero by assumption.
      eapply power_positive. lia. }
    { destruct k; [ lia | ].
      eapply f. lia. } (* ouf *)
Qed.

Hint Resolve power_monotonic_in_k power_strictly_monotonic_in_k
power_strictly_monotonic_in_n : monotonic typeclass_instances.

Lemma power_monotonic_in_n:
  forall k,
  monotonic le le (fun n => n^k).
Proof using.
  intros. destruct k.
  { subst. simpl. repeat intro. lia. }
  { eauto with monotonic lia. }
Qed.

Hint Resolve power_monotonic_in_n : monotonic typeclass_instances.

(* TEMPORARY maybe explicitly use [inverse_monotonic] in lemmas below *)

Lemma power_inverse_monotonic_in_k:
  forall n,
  1 < n ->
  forall k1 k2,
  n^k1 <= n^k2 ->
  k1 <= k2.
Proof using.
  intros.
  eapply monotonic_lt_lt_implies_inverse_monotonic_le_le with (f := fun k => n^k);
  eauto using power_strictly_monotonic_in_k.
Qed.

Lemma power_strictly_inverse_monotonic_in_k:
  forall n k1 k2,
  0 < n ->
  n^k1 < n^k2 ->
  k1 < k2.
Proof using.
  intros.
  eapply monotonic_le_le_implies_inverse_monotonic_lt_lt with (f := fun k => n^k);
  eauto using power_monotonic_in_k.
Qed.

Lemma power_strictly_inverse_monotonic_in_k_variant:
  forall n k1 k2,
  0 < n ->
  n^k1 < n^(1 + k2) ->
  k1 <= k2.
Proof using.
  intros. cut (k1 < 1 + k2). { lia. }
  eauto using power_strictly_inverse_monotonic_in_k.
Qed.

Lemma power_strictly_inverse_monotonic_in_k_frame:
  forall n k1 k2,
  1 < n ->
  n^k2 <= n^k1 < n^(1 + k2) ->
  k1 = k2.
Proof using.
  intros.
  assert (k2 <= k1).
    { eapply power_inverse_monotonic_in_k with (n := n); eauto with lia. }
  assert (k1 < 1 + k2).
    { eapply power_strictly_inverse_monotonic_in_k with (n := n); eauto with lia. }
  lia.
Qed.

Lemma power_inverse_monotonic_in_n:
  forall k,
  0 < k ->
  forall n1 n2,
  n1^k <= n2^k ->
  n1 <= n2.
Proof using.
  intros.
  eapply monotonic_lt_lt_implies_inverse_monotonic_le_le with (f := fun n => n^k);
  eauto using power_strictly_monotonic_in_n.
Qed.

(* A lower bound on [2^n]. *)

Lemma n_lt_power:
  forall n,
  n < 2^n.
Proof using.
  induction n; simpl; lia.
Qed.

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

(* Base 2 logarithm. *)

(* The Coq standard library gives us the following:
     Lemma log2_spec : forall n, 0<n ->
       2^(log2 n) <= n < 2^(S (log2 n)).
*)

Ltac log2_spec :=
  match goal with |- context[log2 ?n] =>
    let h := fresh in
    forwards h: Nat.log2_spec n; [ eauto with positive lia |
      gen h; generalize (log2 n); intros; unpack
    ]
  end.

(* The above specification is functional, i.e., it defines [log2 n] in a
   unique manner. *)

Lemma log2_uniqueness_half:
  forall n k1 k2,
  2^k1 <= n < 2^(1 + k1) ->
  2^k2 <= n < 2^(1 + k2) ->
  k1 <= k2.
Proof using.
  simpl. intros. unpack.
  eapply power_strictly_inverse_monotonic_in_k_variant with (n := 2). lia.
  eauto using Nat.le_lt_trans.
Qed.

Lemma log2_uniqueness:
  forall n k1 k2,
  2^k1 <= n < 2^(1 + k1) ->
  2^k2 <= n < 2^(1 + k2) ->
  k1 = k2.
Proof using.
  intros.
  forwards: log2_uniqueness_half n k1 k2; eauto.
  forwards: log2_uniqueness_half n k2 k1; eauto.
  lia.
Qed.

(* When applied to a power of two, [log2] yields the exponent. *)

Lemma log2_pow:
  forall k,
  log2 (2^k) = k.
Proof using.
  intros k. log2_spec.
  symmetry. eapply power_strictly_inverse_monotonic_in_k_frame with (n := 2). lia.
  eauto.
Qed.

(* This is just a repetition of one half of [log2_spec]. *)

Lemma pow_log2:
  forall n,
  0 < n ->
  2 ^ (log2 n) <= n.
Proof using.
  intros. eapply Nat.log2_spec. eauto.
Qed.

Lemma pow_succ_log2:
  forall n,
  n < 2^(1 + log2 n).
Proof using.
  intros. destruct n.
  { subst. simpl. lia. }
  { eapply Nat.log2_spec. lia. }
Qed.

(* The inductive step of many arguments that involve divide-and-conquer. *)

Lemma log2_step:
  forall n,
  2 <= n ->
  1 + log2 (n/2) = log2 n.
Proof using.
  intros. repeat log2_spec.
  eapply log2_uniqueness; [ | eauto ].
  simpl. eauto with div2.
Qed.

(* [log2] is monotonic. *)

Lemma log2_monotonic:
  monotonic le le log2.
Proof using.
  intros m n ?.
  (* A special case for [m = 0]. *)
  destruct m.
  { subst. unfold log2. simpl. lia. }
  (* Case [m > 0]. *)
  do 2 log2_spec.
  eapply power_strictly_inverse_monotonic_in_k_variant with (n := 2); simpl; lia.
Qed.

Hint Resolve log2_monotonic : monotonic typeclass_instances.

(* A collection of lemmas involving [log2] and ordering. *)

Lemma prove_le_log2:
  forall k n,
  2^k <= n ->
  k <= log2 n.
Proof using.
  intros.
  forwards: log2_monotonic. eauto.
  rewrite log2_pow in *.
  assumption.
Qed.

Lemma prove_log2_le:
  forall k n,
  n <= 2^k ->
  log2 n <= k.
Proof using.
  intros.
  forwards: log2_monotonic. eauto.
  rewrite log2_pow in *.
  assumption.
Qed.

Lemma prove_log2_lt:
  forall k n,
  0 < n ->
  n < 2^k ->
  log2 n < k.
Proof using.
  intros.
  eapply monotonic_le_le_implies_inverse_monotonic_lt_lt with (f := fun n => 2^n).
    { eauto with monotonic. }
  eauto using Nat.le_lt_trans, pow_log2.
Qed.

Hint Resolve prove_le_log2 prove_log2_le prove_log2_lt : log2.

(* An upper bound on [log2 n]. *)

Lemma log2_lt_n:
  forall n,
  0 < n ->
  log2 n < n.
Proof using.
  eauto using prove_log2_lt, n_lt_power.
Qed.

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

(* The existence of the function [log2] means that the sequence [n], [n/2],
   [n/4], etc. tends towards zero. We can exploit this by giving the following
   induction principle. *)

Lemma div2_induction:
  forall (P : nat -> Prop),
  P 0 ->
  (forall n, P (n/2) -> P n) ->
  forall n, P n.
Proof using.
  introv hbase hstep.
  assert (f: forall k n, log2 n < k -> P n).
  { induction k; intros.
    false. lia.
    (* Special cases for [n = 0] and [n = 1]. *)
    destruct n as [|n']. { eauto. }
    destruct n' as [|n'']. eauto.
    (* In the general case, [2 <= n], we use [log2_step]. *)
    eapply hstep. eapply IHk.
    cut (1 + log2 ((S (S n'')) / 2) <= k). { lia. }
    rewrite log2_step by lia.
    lia.
  }
  intros. eapply f with (k := log2 n + 1). lia.
Qed.

(* The following variant of the above induction principle allows
   establishing a property [P] that mentions both [log2 n] and [n]. *)

Lemma log2_induction:
  forall (P : nat -> nat -> Prop),
  P 0 0 ->
  P 0 1 ->
  (forall k n, 2 <= n -> P k (n/2) -> P (1+k) n) ->
  forall n, P (log2 n) n.
Proof using.
  introv h00 h01 hkn.
  (* Maybe one could give a direct proof; anyway, we choose to give
     a proof based on the previous induction principle. *)
  assert (forall n, 1 <= n -> P (log2 n) n).
  { eapply (@div2_induction (fun n => 1 <= n -> P (log2 n) n)).
    (* The base case cannot arise. *)
    { intro. false. lia. }
    (* Step. *)
    { intros n IH ?.
      (* Special case for [n = 1]. *)
      destruct (Nat.eq_decidable n 1); [ subst n; exact h01 | ].
      (* In the general case, [2 <= n], we use [log2_step]. *)
      assert (2 <= n). { lia. }
      rewrite <- log2_step by assumption.
      eauto with div2. }
  }
  intro n.
  (* Special case for [n = 0]. *)
  destruct n; [ exact h00 | ].
  (* General case. *)
  eauto with lia.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Arith.
Require Import Compare.
Require Export Nfinite_prod.
Require Export Ndiv.
Open Scope nat_scope.

(** * Definition of a binomial coefficient using Pascal relation*)
(** Simple definition *)
Fixpoint Nsimple_binomial (n k : nat) : nat :=
match n with
| 0 =>
  match k with
  | 0 => 1
  | S _ => 0
  end
| S n' =>
  match k with
  | 0 => 1
  | S k' => (Nsimple_binomial n' k') + (Nsimple_binomial n' k)
  end
end.

(** Alternative definition *)
Definition Nbinomial (n k : nat) : nat :=
match leb k n with
| true => Nsimple_binomial n k
| false => 0
end.

(** * Properties of binomial coefficients *)

(** n choose k is zero if k is greater than n (simple version) *)
Lemma Nsimple_binomial_outside : forall n m,
  n < m -> Nsimple_binomial n m = 0.
Proof.
induction n.
intros.
compute.
destruct m.
apply lt_irrefl in H.
contradiction.
reflexivity.
intros.
unfold Nsimple_binomial. fold Nsimple_binomial.
destruct m.
apply lt_n_O in H.
contradiction.
assert (n<m).
auto with arith.
rewrite IHn.
simpl.
assert (n<S m).
auto with arith.
apply IHn.
auto.
auto.
Qed.

(** n choose k is zero if k is greater than n (alternative definition) *)
Lemma Nbinomial_outside : forall n m,
  n < m -> Nbinomial n m = 0.
Proof.
intros.
apply leb_correct_conv in H.
unfold Nbinomial.
rewrite H.
reflexivity.
Qed.

(** Special values of binomial coefficients *)
Lemma Nbinomial_0 : forall n, Nbinomial n 0 = 1.
Proof.
destruct n.
compute. reflexivity.
unfold Nbinomial.
assert (leb 0 (S n)=true).
apply leb_correct.
auto with arith.
rewrite H. clear H.
unfold Nsimple_binomial.
reflexivity.
Qed.

Lemma Nbinomial_diag : forall n, Nbinomial n n = 1.
Proof.
induction n.
compute. reflexivity.
unfold Nbinomial.
assert (leb (S n) (S n)=true).
apply leb_correct.
auto with arith.
rewrite H. clear H.
unfold Nsimple_binomial. fold Nsimple_binomial.
unfold Nbinomial in IHn.
assert (leb n n=true).
apply leb_correct.
auto with arith.
rewrite H in IHn.
rewrite IHn.
rewrite Nsimple_binomial_outside.
auto with arith.
auto with arith.
Qed.

Theorem Nbinomial_n_1 : forall n, 1 <= n -> Nbinomial n 1 = n.
induction n.
compute. reflexivity.
intros.
unfold Nbinomial.
assert (leb 1 (S n)=true).
apply leb_correct.
exact H.
rewrite H0.
unfold Nsimple_binomial.
fold Nsimple_binomial.
destruct n.
compute. reflexivity.
assert (Nbinomial (S n) 1=S n).
apply IHn.
auto with arith.
clear IHn.
unfold Nbinomial in H1.
clear H0.
assert (leb 1 (S n)=true).
apply leb_correct.
auto with arith.
rewrite H0 in H1. clear H0.
rewrite H1.
compute. reflexivity.
Qed.

(** Pascal relation and a generalization for alternative definition *)
Lemma Nbinomial_pascal': forall n k,
  S k <= n -> Nbinomial n k + Nbinomial n (S k) = Nbinomial (S n) (S k).
Proof.
intros.
unfold Nbinomial.
assert (leb k n=true).
apply leb_correct. auto with arith.
assert (leb (S k) (S n)=true).
apply leb_correct. auto with arith.
assert (leb (S k) n=true).
apply leb_correct. auto with arith.
rewrite H0. clear H0.
rewrite H1. clear H1.
rewrite H2. clear H2.
unfold Nsimple_binomial. fold Nsimple_binomial.
reflexivity.
Qed.

Lemma Nbinomial_pascal: forall n k,
  k <= n -> Nbinomial n k + Nbinomial n (S k) = Nbinomial (S n) (S k).
Proof.
intros.
assert (S k<=n -> Nbinomial n k + Nbinomial n (S k) = Nbinomial (S n) (S k)).
intro.
apply Nbinomial_pascal'.
exact H0.
assert (k=n -> Nbinomial n k + Nbinomial n (S k) = Nbinomial (S n) (S k)).
intro.
rewrite H1.
assert (Nbinomial n (S n)=0).
apply Nbinomial_outside.
auto with arith.
rewrite H2. clear H2.
rewrite Nbinomial_diag.
rewrite Nbinomial_diag.
auto with arith.
apply le_le_S_eq in H.
elim H.
exact H0.
exact H1.
Qed.

(** Expression of binomial coefficients using factorial and partial factorial *)
Theorem Nbinomial_factorial : forall n k,
  1 <= k -> k <= n -> (fact k) * Nbinomial n k = Nfinite_prod_0_n (pred k) (fun x => n - x).
Proof.
induction n.
intros.
destruct k.
apply le_Sn_O in H.
contradiction.
rewrite Nbinomial_outside.
rewrite mult_0_r.
assert (Nfinite_prod_0_n (pred (S k)) (fun x : nat => 0 - x) =
  Nfinite_prod_0_n (pred (S k)) (fun x : nat => 0)).
apply Nfinite_prod_eq_compat.
auto with arith.
rewrite H1. clear H1.
symmetry.
apply Nfinite_prod_0_absord with k.
auto with arith.
reflexivity.
auto with arith.
intros.
apply le_le_S_eq in H0.
destruct H0.
assert (Q: S k<=S n).
exact H0.
apply (le_trans k) in H0.

destruct k.
apply le_Sn_O in H.
contradiction.

rewrite <- Nbinomial_pascal.
rewrite mult_plus_distr_l.
apply le_le_S_eq in H.
destruct H.
apply le_le_S_eq in H0.
destruct H0.

rewrite IHn.
unfold fact. fold fact.
rewrite <- mult_assoc.
rewrite IHn.
assert (exists k', k=S k').
destruct k.
apply le_Sn_n in H. contradiction.
exists k. reflexivity.
destruct H1.
rewrite H1.

assert (pred (S(S x))=S(pred (S x))).
rewrite pred_of_minus.
rewrite <- minus_Sn_m.
rewrite pred_of_minus.
reflexivity.
auto with arith.
rewrite H2.
rewrite Nfinite_prod_split_upper.
rewrite Nfinite_prod_split_lower.
assert (Nfinite_prod_0_n (pred (S x)) (fun k0 : nat => S n - S k0) =
  Nfinite_prod_0_n (pred (S x)) (fun k0 : nat => n - k0)).
apply Nfinite_prod_subtle_eq_compat.
intros.
auto with arith.
rewrite H3. clear H3.
assert (Nfinite_prod_0_n (pred (S x)) (fun x0 : nat => n - x0) * (n - S (pred (S x))) =
  (n - S (pred (S x))) * Nfinite_prod_0_n (pred (S x)) (fun x0 : nat => n - x0)).
auto with arith.
rewrite H3. clear H3.
rewrite <- mult_plus_distr_r.
rewrite <- minus_n_O.
assert (S (S x) + (n - S (pred (S x))) = S n).
rewrite <- pred_Sn.
assert (n-S x=S n-S(S x)).
auto with arith.
rewrite H3.
symmetry.
apply le_plus_minus.
rewrite <- H1.
auto with arith.
auto with arith.
auto with arith.
apply le_trans with (S k).
auto with arith.
auto with arith.
auto with arith.
auto with arith.
assert (k=n).
auto with arith.
rewrite H1.
rewrite Nbinomial_diag.
rewrite Nbinomial_outside.
rewrite mult_0_r.
rewrite plus_0_r.
rewrite mult_1_r.
rewrite Nfinite_prod_index_reversal.
rewrite <- H1.
rewrite Nfactorial_is_finite_prod.
rewrite <- pred_Sn.
apply Nfinite_prod_subtle_eq_compat.
intros.
assert (exists p, k=k0+p).
apply Nle_plus.
exact H2.
destruct H3.
rewrite plus_comm in H3.
rewrite H3.
rewrite plus_comm.
assert (x-0=k0+x-(k0+0)).
apply minus_plus_simpl_l_reverse.
rewrite <- minus_n_O in H4.
rewrite plus_0_r in H4.
rewrite <- H4.
assert (S(k0+x)=S k0+x).
auto with arith.
rewrite H5. clear H4. clear H5.
assert (S k0-0=x+S k0-(x+0)).
apply minus_plus_simpl_l_reverse.
rewrite plus_0_r in H4.
rewrite <- minus_n_O in H4.
rewrite plus_comm in H4.
exact H4.
auto with arith.
assert (0=k).
auto with arith.
rewrite <- H1.
unfold fact. unfold iter_nat. unfold pred.
unfold Nfinite_prod_0_n.
unfold Nbinomial.
assert (leb 0 n=true).
apply leb_correct.
auto with arith.
rewrite H2. clear H2.
assert (leb 1 n=true).
apply leb_correct.
rewrite <- H1 in Q.
auto with arith.
rewrite H2.
assert (Nbinomial n 0=1).
apply Nbinomial_0.
assert (Nbinomial n 1=n).
apply Nbinomial_n_1.
rewrite <- H1 in Q.
auto with arith.
unfold Nbinomial in H3.
unfold Nbinomial in H4.
rewrite H2 in H4.
assert (leb 0 n=true).
auto.
rewrite H5 in H3.
rewrite H3.
rewrite H4.
simpl.
auto with arith.
auto with arith.
auto with arith.
rewrite H0.
rewrite Nbinomial_diag.
rewrite <- pred_Sn.
rewrite Nfactorial_is_finite_prod.
rewrite Nfinite_prod_index_reversal.
rewrite mult_1_r.
apply Nfinite_prod_subtle_eq_compat.
intros.
apply minus_Sn_m.
exact H1.
Qed.

(** Divisibility of binomial coefficients in prime case *)
Theorem Nbinomial_div : forall p k,
  0 < k < p -> Nprime p -> (p | Nbinomial p k).
intros.
assert((p|(fact k)*Nbinomial p k)).
rewrite Nbinomial_factorial.
apply Nfinite_prod_div with 0.
destruct H.
destruct k.
inversion H.
simpl. auto with arith.
rewrite <- minus_n_O. apply Ndiv_n_n.
destruct H.
destruct k.
inversion H.
auto with arith.
destruct H.
auto with arith.
apply Ngauss with (fact k).
auto.
clear H1.
generalize k H.
clear H k.
induction k.
intros.
inversion H. inversion H1.
intros.
destruct H.
unfold fact. fold fact.
destruct k.
simpl.
apply Nrel_prime_1.

apply Nrel_prime_mult_compat.
apply Nrel_prime_comm.
apply Nprime_le_rel_prime.
auto.
split.
auto with arith.
auto.
apply IHk.
split.
auto with arith.
auto with arith.
Qed.


Require Import init.

Require Export relation.
Require Export plus_group.

Class OrderLplus U `{Plus U, Order U} := {
    le_lplus : ∀ {a b} c, a ≤ b → c + a ≤ c + b
}.
Class OrderRplus U `{Plus U, Order U} := {
    le_rplus : ∀ {a b} c, a ≤ b → a + c ≤ b + c
}.
Class OrderPlusLcancel U `{Plus U, Order U} := {
    le_plus_lcancel : ∀ {a b} c, c + a ≤ c + b → a ≤ b
}.
Class OrderPlusRcancel U `{Plus U, Order U} := {
    le_plus_rcancel : ∀ {a b} c, a + c ≤ b + c → a ≤ b
}.

Class OrderPlus U `{
    OPP : AllPlus U,
    OPO : TotalOrder U,
    UOP : @OrderLplus U UP UO,
    UOPR : @OrderRplus U UP UO,
    UOPC : @OrderPlusLcancel U UP UO,
    UOPCR : @OrderPlusRcancel U UP UO
}.

(* begin hide *)
Section OrderPlusImply.

Context {U} `{OrderPlus U}.

Global Instance le_lplus_rplus : OrderRplus U.
Proof.
    split.
    intros a b c leq.
    do 2 rewrite (plus_comm _ c).
    apply le_lplus.
    exact leq.
Qed.

Global Instance le_lcancel_rcancel : OrderPlusRcancel U.
Proof.
    split.
    intros a b c leq.
    do 2 rewrite (plus_comm _ c) in leq.
    apply le_plus_lcancel in leq.
    exact leq.
Qed.

Global Instance le_plus_linv_lcancel : OrderPlusLcancel U.
Proof.
    split.
    intros a b c leq.
    apply le_lplus with (-c) in leq.
    do 2 rewrite plus_llinv in leq.
    exact leq.
Qed.
Global Instance le_plus_rinv_rcancel : OrderPlusRcancel U.
Proof.
    split.
    intros a b c leq.
    apply le_rplus with (-c) in leq.
    do 2 rewrite plus_rrinv in leq.
    exact leq.
Qed.

End OrderPlusImply.

Section OrderPlus.

Context {U} `{OrderPlus U}.

(* end hide *)
Theorem le_lrplus : ∀ {a b c d}, a ≤ b → c ≤ d → a + c ≤ b + d.
Proof.
    intros a b c d ab cd.
    apply le_rplus with c in ab.
    apply le_lplus with b in cd.
    exact (trans ab cd).
Qed.

Theorem lt_lplus : ∀ {a b} c, a < b → c + a < c + b.
Proof.
    intros a b c [leq neq].
    split.
    -   apply le_lplus.
        exact leq.
    -   intro contr.
        apply plus_lcancel in contr.
        contradiction.
Qed.

Theorem lt_rplus : ∀ {a b} c, a < b → a + c < b + c.
Proof.
    intros a b c [leq neq].
    split.
    -   apply le_rplus.
        exact leq.
    -   intro contr.
        apply plus_rcancel in contr.
        contradiction.
Qed.

Theorem lt_lrplus : ∀ {a b c d}, a < b → c < d → a + c < b + d.
Proof.
    intros a b c d ab cd.
    apply lt_rplus with c in ab.
    apply lt_lplus with b in cd.
    exact (trans ab cd).
Qed.

Theorem le_lt_lrplus : ∀ {a b c d}, a ≤ b → c < d → a + c < b + d.
Proof.
    intros a b c d ab cd.
    apply le_rplus with c in ab.
    apply lt_lplus with b in cd.
    exact (le_lt_trans ab cd).
Qed.

Theorem lt_le_lrplus : ∀ {a b c d}, a < b → c ≤ d → a + c < b + d.
Proof.
    intros a b c d ab cd.
    apply lt_rplus with c in ab.
    apply le_lplus with b in cd.
    exact (lt_le_trans ab cd).
Qed.

Theorem lt_plus_lcancel : ∀ {a b} c, c + a < c + b → a < b.
Proof.
    intros a b c [leq neq].
    split.
    -   apply le_plus_lcancel in leq.
        exact leq.
    -   intro contr.
        rewrite contr in neq.
        contradiction.
Qed.

Theorem lt_plus_rcancel : ∀ {a b} c, a + c < b + c → a < b.
Proof.
    intros a b c [leq neq].
    split.
    -   apply le_plus_rcancel in leq.
        exact leq.
    -   intro contr.
        rewrite contr in neq.
        contradiction.
Qed.

Theorem le_plus_llmove : ∀ a b c, a + b ≤ c ↔ b ≤ -a + c.
Proof.
    intros a b c.
    split; intros eq.
    -   apply le_lplus with (-a) in eq.
        rewrite plus_llinv in eq.
        exact eq.
    -   apply le_lplus with a in eq.
        rewrite plus_lrinv in eq.
        exact eq.
Qed.
Theorem le_plus_lrmove : ∀ a b c, a + b ≤ c ↔ a ≤ c - b.
Proof.
    intros a b c.
    split; intros eq.
    -   apply le_rplus with (-b) in eq.
        rewrite plus_rrinv in eq.
        exact eq.
    -   apply le_rplus with b in eq.
        rewrite plus_rlinv in eq.
        exact eq.
Qed.
Theorem le_plus_rlmove : ∀ a b c, a ≤ b + c ↔ -b + a ≤ c.
Proof.
    intros a b c.
    split; intros eq.
    -   apply le_lplus with (-b) in eq.
        rewrite plus_llinv in eq.
        exact eq.
    -   apply le_lplus with b in eq.
        rewrite plus_lrinv in eq.
        exact eq.
Qed.
Theorem le_plus_rrmove : ∀ a b c, a ≤ b + c ↔ a - c ≤ b.
Proof.
    intros a b c.
    split; intros eq.
    -   apply le_rplus with (-c) in eq.
        rewrite plus_rrinv in eq.
        exact eq.
    -   apply le_rplus with c in eq.
        rewrite plus_rlinv in eq.
        exact eq.
Qed.

Theorem le_plus_0_ab_na_b : ∀ a b, 0 ≤ a + b ↔ -a ≤ b.
Proof.
    intros a b.
    rewrite le_plus_rlmove.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem le_plus_0_ab_nb_a : ∀ a b, 0 ≤ a + b ↔ -b ≤ a.
Proof.
    intros a b.
    rewrite le_plus_rrmove.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem le_plus_ab_0_a_nb : ∀ a b, a + b ≤ 0 ↔ a ≤ -b.
Proof.
    intros a b.
    rewrite le_plus_lrmove.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem le_plus_ab_0_b_na : ∀ a b, a + b ≤ 0 ↔ b ≤ -a.
Proof.
    intros a b.
    rewrite le_plus_llmove.
    rewrite plus_rid.
    reflexivity.
Qed.

Theorem le_plus_a_0_ab_b : ∀ a b, a ≤ 0 ↔ a + b ≤ b.
Proof.
    intros a b.
    split; intros leq.
    -   apply le_rplus with b in leq.
        rewrite plus_lid in leq.
        exact leq.
    -   apply le_plus_rcancel with b.
        rewrite plus_lid.
        exact leq.
Qed.
Theorem le_plus_a_0_ba_b : ∀ a b, a ≤ 0 ↔ b + a ≤ b.
Proof.
    intros a b.
    split; intros leq.
    -   apply le_lplus with b in leq.
        rewrite plus_rid in leq.
        exact leq.
    -   apply le_plus_lcancel with b.
        rewrite plus_rid.
        exact leq.
Qed.
Theorem le_plus_0_a_b_ab : ∀ a b, 0 ≤ a ↔ b ≤ a + b.
Proof.
    intros a b.
    split; intros leq.
    -   apply le_rplus with b in leq.
        rewrite plus_lid in leq.
        exact leq.
    -   apply le_plus_rcancel with b.
        rewrite plus_lid.
        exact leq.
Qed.
Theorem le_plus_0_a_b_ba : ∀ a b, 0 ≤ a ↔ b ≤ b + a.
Proof.
    intros a b.
    split; intros leq.
    -   apply le_lplus with b in leq.
        rewrite plus_rid in leq.
        exact leq.
    -   apply le_plus_lcancel with b.
        rewrite plus_rid.
        exact leq.
Qed.

Theorem le_plus_0_nab_a_b : ∀ a b, 0 ≤ -a + b ↔ a ≤ b.
Proof.
    intros a b.
    rewrite <- le_plus_llmove.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem le_plus_anb_0_a_b : ∀ a b, a - b ≤ 0 ↔ a ≤ b.
Proof.
    intros a b.
    rewrite <- le_plus_rrmove.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem le_plus_nab_0_b_a : ∀ a b, -a + b ≤ 0 ↔ b ≤ a.
Proof.
    intros a b.
    rewrite <- le_plus_rlmove.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem le_plus_0_anb_b_a : ∀ a b, 0 ≤ a - b ↔ b ≤ a.
Proof.
    intros a b.
    rewrite <- le_plus_lrmove.
    rewrite plus_lid.
    reflexivity.
Qed.

Theorem lt_plus_llmove : ∀ a b c, a + b < c ↔ b < -a + c.
Proof.
    intros a b c.
    split; intros eq.
    -   apply lt_lplus with (-a) in eq.
        rewrite plus_llinv in eq.
        exact eq.
    -   apply lt_lplus with a in eq.
        rewrite plus_lrinv in eq.
        exact eq.
Qed.
Theorem lt_plus_lrmove : ∀ a b c, a + b < c ↔ a < c - b.
Proof.
    intros a b c.
    split; intros eq.
    -   apply lt_rplus with (-b) in eq.
        rewrite plus_rrinv in eq.
        exact eq.
    -   apply lt_rplus with b in eq.
        rewrite plus_rlinv in eq.
        exact eq.
Qed.
Theorem lt_plus_rlmove : ∀ a b c, a < b + c ↔ -b + a < c.
Proof.
    intros a b c.
    split; intros eq.
    -   apply lt_lplus with (-b) in eq.
        rewrite plus_llinv in eq.
        exact eq.
    -   apply lt_lplus with b in eq.
        rewrite plus_lrinv in eq.
        exact eq.
Qed.
Theorem lt_plus_rrmove : ∀ a b c, a < b + c ↔ a - c < b.
Proof.
    intros a b c.
    split; intros eq.
    -   apply lt_rplus with (-c) in eq.
        rewrite plus_rrinv in eq.
        exact eq.
    -   apply lt_rplus with c in eq.
        rewrite plus_rlinv in eq.
        exact eq.
Qed.

Theorem lt_plus_0_ab_na_b : ∀ a b, 0 < a + b ↔ -a < b.
Proof.
    intros a b.
    rewrite lt_plus_rlmove.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem lt_plus_0_ab_nb_a : ∀ a b, 0 < a + b ↔ -b < a.
Proof.
    intros a b.
    rewrite lt_plus_rrmove.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem lt_plus_ab_0_a_nb : ∀ a b, a + b < 0 ↔ a < -b.
Proof.
    intros a b.
    rewrite lt_plus_lrmove.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem lt_plus_ab_0_b_na : ∀ a b, a + b < 0 ↔ b < -a.
Proof.
    intros a b.
    rewrite lt_plus_llmove.
    rewrite plus_rid.
    reflexivity.
Qed.

Theorem lt_plus_a_0_ab_b : ∀ a b, a < 0 ↔ a + b < b.
Proof.
    intros a b.
    split; intros ltq.
    -   apply lt_rplus with b in ltq.
        rewrite plus_lid in ltq.
        exact ltq.
    -   apply lt_plus_rcancel with b.
        rewrite plus_lid.
        exact ltq.
Qed.
Theorem lt_plus_a_0_ba_b : ∀ a b, a < 0 ↔ b + a < b.
Proof.
    intros a b.
    split; intros ltq.
    -   apply lt_lplus with b in ltq.
        rewrite plus_rid in ltq.
        exact ltq.
    -   apply lt_plus_lcancel with b.
        rewrite plus_rid.
        exact ltq.
Qed.
Theorem lt_plus_0_a_b_ab : ∀ a b, 0 < a ↔ b < a + b.
Proof.
    intros a b.
    split; intros ltq.
    -   apply lt_rplus with b in ltq.
        rewrite plus_lid in ltq.
        exact ltq.
    -   apply lt_plus_rcancel with b.
        rewrite plus_lid.
        exact ltq.
Qed.
Theorem lt_plus_0_a_b_ba : ∀ a b, 0 < a ↔ b < b + a.
Proof.
    intros a b.
    split; intros ltq.
    -   apply lt_lplus with b in ltq.
        rewrite plus_rid in ltq.
        exact ltq.
    -   apply lt_plus_lcancel with b.
        rewrite plus_rid.
        exact ltq.
Qed.

Theorem lt_plus_0_nab_a_b : ∀ a b, 0 < -a + b ↔ a < b.
Proof.
    intros a b.
    rewrite <- lt_plus_llmove.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem lt_plus_anb_0_a_b : ∀ a b, a - b < 0 ↔ a < b.
Proof.
    intros a b.
    rewrite <- lt_plus_rrmove.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem lt_plus_nab_0_b_a : ∀ a b, -a + b < 0 ↔ b < a.
Proof.
    intros a b.
    rewrite <- lt_plus_rlmove.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem lt_plus_0_anb_b_a : ∀ a b, 0 < a - b ↔ b < a.
Proof.
    intros a b.
    rewrite <- lt_plus_lrmove.
    rewrite plus_lid.
    reflexivity.
Qed.

Theorem neg_pos : ∀ a, a ≤ 0 ↔ 0 ≤ -a.
Proof.
    intros a.
    rewrite <- le_plus_ab_0_a_nb.
    rewrite plus_lid.
    reflexivity.
Qed.
Theorem neg_pos2 : ∀ a, a < 0 ↔ 0 < -a.
Proof.
    intros a.
    rewrite <- lt_plus_ab_0_a_nb.
    rewrite plus_lid.
    reflexivity.
Qed.

Theorem pos_neg : ∀ a, 0 ≤ a ↔ -a ≤ 0.
Proof.
    intros a.
    rewrite <- le_plus_0_ab_na_b.
    rewrite plus_rid.
    reflexivity.
Qed.
Theorem pos_neg2 : ∀ a, 0 < a ↔ -a < 0.
Proof.
    intros a.
    rewrite <- lt_plus_0_ab_na_b.
    rewrite plus_rid.
    reflexivity.
Qed.

Theorem le_neg : ∀ a b, a ≤ b ↔ -b ≤ -a.
Proof.
    intros a b.
    rewrite <- le_plus_0_anb_b_a.
    rewrite le_plus_0_ab_na_b.
    reflexivity.
Qed.
Theorem lt_neg : ∀ a b, a < b ↔ -b < -a.
Proof.
    intros a b.
    rewrite <- lt_plus_0_anb_b_a.
    rewrite lt_plus_0_ab_na_b.
    reflexivity.
Qed.

Theorem le_half_rneg : ∀ a b, a ≤ -b ↔ b ≤ -a.
Proof.
    intros a b.
    rewrite le_neg.
    rewrite neg_neg.
    reflexivity.
Qed.
Theorem lt_half_rneg : ∀ a b, a < -b ↔ b < -a.
Proof.
    intros a b.
    rewrite lt_neg.
    rewrite neg_neg.
    reflexivity.
Qed.
Theorem le_half_lneg : ∀ a b, -a ≤ b ↔ -b ≤ a.
Proof.
    intros a b.
    rewrite le_neg.
    rewrite neg_neg.
    reflexivity.
Qed.
Theorem lt_half_lneg : ∀ a b, -a < b ↔ -b < a.
Proof.
    intros a b.
    rewrite lt_neg.
    rewrite neg_neg.
    reflexivity.
Qed.

Theorem le_pos_plus : ∀ {a b}, 0 ≤ a → 0 ≤ b → 0 ≤ a + b.
Proof.
    intros a b a_pos b_pos.
    rewrite <- (plus_rid 0).
    apply le_lrplus; assumption.
Qed.
Theorem lt_pos_plus : ∀ {a b}, 0 < a → 0 < b → 0 < a + b.
Proof.
    intros a b a_pos b_pos.
    rewrite <- (plus_rid 0).
    apply lt_lrplus; assumption.
Qed.
Theorem le_lt_pos_plus : ∀ {a b}, 0 ≤ a → 0 < b → 0 < a + b.
Proof.
    intros a b a_pos b_pos.
    rewrite <- (plus_rid 0).
    apply le_lt_lrplus; assumption.
Qed.
Theorem lt_le_pos_plus : ∀ {a b}, 0 < a → 0 ≤ b → 0 < a + b.
Proof.
    intros a b a_pos b_pos.
    rewrite <- (plus_rid 0).
    apply lt_le_lrplus; assumption.
Qed.

Theorem le_neg_plus : ∀ {a b}, a ≤ 0 → b ≤ 0 → a + b ≤ 0.
Proof.
    intros a b a_neg b_neg.
    rewrite <- (plus_rid 0).
    apply le_lrplus; assumption.
Qed.
Theorem lt_neg_plus : ∀ {a b}, a < 0 → b < 0 → a + b < 0.
Proof.
    intros a b a_neg b_neg.
    rewrite <- (plus_rid 0).
    apply lt_lrplus; assumption.
Qed.
Theorem le_lt_neg_plus : ∀ {a b}, a ≤ 0 → b < 0 → a + b < 0.
Proof.
    intros a b a_neg b_neg.
    rewrite <- (plus_rid 0).
    apply le_lt_lrplus; assumption.
Qed.
Theorem lt_le_neg_plus : ∀ {a b}, a < 0 → b ≤ 0 → a + b < 0.
Proof.
    intros a b a_neg b_neg.
    rewrite <- (plus_rid 0).
    apply lt_le_lrplus; assumption.
Qed.
(* begin hide *)
End OrderPlus.
(* end hide *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (lf3 : natural) : natural :=
  plus lf1 (plus lf3 Zero).


Require Import Coq.Program.Basics.
Require Import Coq.Program.Combinators.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Le.
Require Import PeanoNat.
Require Import List.
Import ListNotations.

Set Implicit Arguments.

(** Nominal Sets *)
(* In 2011, Andrew Pitts published his paper 'Nominal Sets'. We formalize parts of
chapter 1 to 3 of his paper, which can be found at:
#
http://www.cs.nott.ac.uk/~pszvc/mgs/MGS2011_nominal_sets.pdf# *)

(** * Groups *)
(* In this section we define groups and prove very basic lemmas about them.
   These lemmas will later be used to simplify statements about group elements. *)

(* Groups are a type having an identity element, an inverse function and an operation on
   elements. The elements respeect the left and right identity as well as inverse laws. *)
Structure group :=
  {
    group_obj :> Type;
    group_id : group_obj;
    group_inv : group_obj -> group_obj;
    group_op : group_obj -> group_obj -> group_obj;
    group_assoc : forall x y z, group_op (group_op x y) z = group_op x (group_op y z);
    group_left_id : forall x, group_op group_id x = x;
    group_right_id : forall x, group_op x group_id = x;
    group_left_inv : forall x, group_op (group_inv x) x = group_id;
    group_right_inv : forall x, group_op x (group_inv x) = group_id;
  }.

Notation "1" := (group_id _).
Notation "x ^-1" := (group_inv _ x) (at level 30, format "x ^-1").
Notation "x * y" := (group_op _ x y).

(* We show that the right inverse is unique in order to prove the following two well known
   lemmas about inverses. These lemmas can be used to simplify goals. *)
Lemma group_inv_unique (G: group) (g h: G) : g * h = 1 -> g^-1 = h.
Proof.
  intros H. rewrite <- (group_right_id _ (g^-1)). rewrite <- H, <- group_assoc.
  now rewrite group_left_inv, group_left_id.
Qed.

Lemma group_inv_id (G: group) : 1^-1 = (group_id G).
Proof.
  apply group_inv_unique. now apply group_left_id.
Qed.

Lemma group_inv_op (G: group) (g h: G) : (g * h)^-1 = h^-1 * g^-1.
Proof.
  apply group_inv_unique. rewrite group_assoc, <- (group_assoc _ h).
  rewrite group_right_inv, group_left_id. now apply group_right_inv.
Qed.

(* A homomorphism between groups G and H is a function from G to H which respects the
   group laws. *)
Structure homomorphism (G H: group) :=
  {
    hom :> G -> H;
    hom_id: hom 1 = 1;
    hom_op: forall x y, hom (x * y) = (hom x) * (hom y);
    hom_inv: forall x, hom (x^-1) = (hom x)^-1;
  }.

(** * G-sets *)
(* Now we define G-sets and show that these are compositional for product, sum and
   function types. *)

(* A G-set is a type X with a group action on X which respects the group structure of G. *)
Structure G_set (G: group) :=
  {
    G_set_X :> Type;
    action: G -> G_set_X -> G_set_X;
    G_set_id: forall x,  (action 1 x) = x;
    G_set_assoc: forall g h x, (action g (action h x)) = (action (g * h) x);
  }.

Notation "g ** x" := (action _ g x) (at level 45, right associativity).

(* We define the tactic gsimpl to simplify goals by using the group and G-set laws. *)
Ltac gsimpl :=
  repeat progress rewrite ?group_left_id, ?group_right_id, ?group_left_inv, ?group_right_inv,
  ?group_inv_id, ?group_inv_op,
  ?G_set_id, ?G_set_assoc.

(* A group element g acts on a pair (x, y) by acting on x and y simpultaneously. *)
Definition prod_action (G: group) (X Y: G_set G) (g: G) (p: X * Y) : X * Y :=
  match p with
  | (x, y) => (g ** x, g ** y)
  end.

Arguments prod_action {G X Y}.

(* Using above action the product of two G-sets X and Y is again a G-set. *)
Canonical Structure G_set_prod (G: group) (X Y: G_set G) : G_set G.
apply (@Build_G_set G (X * Y)%type prod_action).
- intros [x y]. cbn. now gsimpl.
- intros g h [x y]. cbn. now gsimpl.
Defined.

(* Similar to the action on pairs, g acts on a sum s by acting on the by s encapsulated value. *)
Definition sum_action (G: group) (X Y: G_set G) (g: G) (s: X + Y) : X + Y :=
  match s with
  | inl x => inl (g ** x)
  | inr y => inr (g ** y)
  end.

Arguments sum_action {G X Y}.

(* Above action yields a G-set on the sum of two G-sets. *)
Canonical Structure G_set_sum (G: group) (X Y: G_set G) : G_set G.
apply (@Build_G_set G (X + Y) sum_action).
- intros [x|y]; cbn; now gsimpl.
- intros g h [x|y]; cbn; now gsimpl.
Defined.

(* We define the following action on functions from G-set X to G-set Y. *)
Definition func_action (G: group) (X Y: G_set G) (g: G) (F: X -> Y) : X -> Y :=
  fun x => g ** F (g^-1 ** x).

Arguments func_action {G X Y}.

(* By this action we obtain a G-set on functions from G-set X to G-set Y. *)
Canonical Structure func (G: group) (X Y: G_set G) : G_set G.
apply (@Build_G_set G (X -> Y) func_action).
- intros F. unfold func_action. extensionality x. now gsimpl.
- intros g h F. extensionality x. unfold func_action. now gsimpl.
Defined.

(* A function F is called equivariant if the group action and the application of F commute. *)
Definition equiv_func {G: group} {X Y: G_set G} (F: X -> Y) :=
  forall (x: X) (g: G), F (g ** x) = g ** F x.

(* We call a subset (given as predicate P) of a G-set X equivariant if it is closed under
   group actions. *)
Definition equiv_subset (G: group) (X: G_set G) (P: X -> Prop) :=
  forall g x, P x -> P (g ** x).

(** * Permutations *)
(* In this section we define permutations and show that they form a group called Perm.
   For Perm-sets X (G-sets with Perm as underlying group) we define the notion of support
   and use it to state when a name is unused/fresh for a given element of X. *)

(* We use the natural numbers as atoms, i.e. names. This is convenient since for a finite
   structure we can easily find an unused/fresh name. *)
Definition atom := nat.

(* Permutations are bijective functions over atoms. We model this by requiring the existence
   of an inverse function. *)
Structure perm :=
  {
    perm_f:> atom -> atom;
    perm_g: atom -> atom;
    perm_right_inv: forall a, perm_f (perm_g a) = a;
    perm_left_inv: forall a, perm_g (perm_f a) = a;
  }.

(* Permutations form a group. Thus we define identity and inverse permutations, as well as
   the composition operation on permutations. *)
Definition perm_id : perm.
  apply (@Build_perm (@id atom) (@id atom)); intros a; reflexivity.
Defined.

Definition perm_inv (pi: perm) : perm.
  destruct pi as [f g H1 H2]. apply (Build_perm g f H2 H1).
Defined.

Definition perm_op (pi pi': perm) : perm.
  destruct pi as [f g H1 H2]. destruct pi' as [f' g' H3 H4].
  apply (Build_perm (compose f f') (compose g' g)).
  - intros a. unfold compose. now rewrite H3, H1.
  - intros a. unfold compose. now rewrite H2, H4.
Defined.

(* The following axiom states that permutations are uniquely determined by their behavior
   on atoms. *)
Axiom perm_eq : forall (pi pi': perm), (forall a, pi a = pi' a) -> pi = pi'.

(* Using the above definitions we obtain the symmetric group, i.e. group of permutations.
   We denote this group by Perm. *)
Canonical Structure group_perm : group.
apply (@Build_group _ perm_id perm_inv perm_op).
- intros pi1 pi2 pi3. apply perm_eq. intros a. destruct pi1, pi2, pi3. unfold perm_op.
  cbn. now rewrite compose_assoc.
- intros pi. apply perm_eq. intros a. destruct pi. unfold perm_op. cbn.
  now rewrite compose_id_left.
- intros pi. apply perm_eq. intros a. destruct pi. unfold perm_op. cbn.
  now rewrite compose_id_right.
- intros pi. apply perm_eq. intros a. destruct pi. unfold perm_op. cbn.
  unfold id, compose. auto.
- intros pi. apply perm_eq. intros a. destruct pi. unfold perm_op. cbn.
  unfold id, compose. auto.
Defined.

(* We choose a convenient name for the type of Perm-sets. *)
Definition perm_set := G_set group_perm.

(* A list of atoms A supports an element x of a Perm-set X if each permutation which
   holds all elements of A does not change x aswell. This means all atoms which are
   not in A do not play a role in x in some sense. *)
Definition support {X: perm_set} (A: list atom) (x: X) :=
  forall (pi: perm), (forall a, In a A -> pi a = a) -> pi ** x = x.

(* In the special case of functions on Perm-sets we can characterize support more precisely. *)
Lemma support_func (X Y: perm_set) (A: list atom) (F: X -> Y) :
  support A F <-> forall (pi: perm), (forall a, In a A -> pi a = a) -> forall x, F (pi ** x) = pi ** F x.
Proof.
  split; intros H.
  - intros pi H' x. specialize (H pi H').
    assert (E: F (pi ** x) = (pi ** F) (pi ** x)) by now rewrite H.
    rewrite E. cbn. unfold func_action. now gsimpl.
  - intros pi H'. specialize (H (pi^-1)). extensionality x. cbn. unfold func_action.
    rewrite H; gsimpl; auto. intros a Aa. specialize (H' a Aa). destruct pi as [pi pi' Hpi Hpi'].
    now rewrite <- H' at 1.
Qed.

(* If all elements of a Perm-set X are supported, i.e. there is a list A supports the
   element, then then we call X nominal. *)
Definition nominal (X: perm_set) := forall (x: X), { A : _ & support A x}.

(* The predicate supp is the intersection of all supports of the given element x.
   It characterizes the atoms that are relevant for x in some sense. *)
Definition supp {X: perm_set} (x: X) := fun a => forall A, support A x -> In a A.

(* The predicate supp is true only for elements of every support A. *)
Lemma supp_sub_support (X: perm_set) A (x: X) :
  support A x -> forall a, supp x a -> In a A.
Proof.
  intros S a H. apply H, S.
Qed.

(* We say an atom a is fresh in y if it is not in (supp y). This means is not
   relevant for y. *)
Definition atom_freshness {Y: perm_set} a (y: Y) := ~ supp y a.

Notation "a # y" := (atom_freshness a y) (at level 40).

(* In general, x is fresh for y if the intersection of (supp x) and (supp y) is empty.
   So, there is no atom relevant for both of them. *)
Definition freshness {X Y: perm_set} (x: X) (y: Y) :=
  forall a, ~ (supp x a /\ supp y a).

(** ** Finite Permutations *)
(* In this subsection we consider the special case of finite permutations. Those are
   permutations that change only finitely many atoms. *)

(* Finite permutations change only finitely many atoms. *)
Definition fin_perm (pi: perm) := exists l, forall a, ~ In a l -> pi a = a.

(* Transpositions swap two atoms a and b. *)
Definition transp (a b c: atom) :=
  if (Nat.eq_dec c a) then b else if (Nat.eq_dec c b) then a else c.

(* We define a tactic to simplify transpositions. *)
Ltac transpsimpl :=
  match goal with
  | [ |- context C[transp] ] => unfold transp; transpsimpl
  | [ |- context C[Nat.eq_dec ?a ?a] ] => let H := fresh "H" in destruct (Nat.eq_dec a a) as [_|H];
                                                              [| exfalso; apply H; reflexivity]
  | [ |- context C[Nat.eq_dec ?a ?b] ] => let H := fresh "H" in destruct (Nat.eq_dec a b) as [H|H];
                                                              [rewrite H|]
  | _ => try congruence
  end.

(* Transpositions are involutions, i.e. self-invers. *)
Lemma transp_involution a b c : transp a b (transp a b c) = c.
Proof.
  repeat transpsimpl; congruence.
Qed.

(* Clearly, transpositions are permutations. *)
Canonical Structure transp_perm (a b: atom) : perm :=
  Build_perm (transp a b) (transp a b) (transp_involution a b) (transp_involution a b).

(* Especially, transpositions are finite transpositions. *)
Lemma transp_fin_perm (a b: atom) : fin_perm (transp_perm a b).
Proof.
  exists [a;b]. cbn. intros x H. repeat transpsimpl; exfalso; auto.
Qed.

(* We define a tactic to simplify transpositions seen as permutations. *)
Ltac transptac :=
  match goal with
  | [ |- context C[transp_perm] ] => (progress cbn); transptac
  | _ => repeat transpsimpl
  end.

(** * Fresh Names *)
(* In this section we show how to get a fresh name/atom for a element x given a
   support A for x. One possibility is to compute the maximum of A and taking the
   successor of it. This atom is not contained in A and thus fresh for x. *)

Module fresh_atom.
  (* Compute the maximum of al list A by folding A. *)
  Definition max_list A := fold_left max A 0.

  (* Take the successor of the maximum to obtain a new atom. *)
  Definition new_atom A := S (max_list A).

  (* We prove that (fold_left max A) is monotone and increasing for a list A. *)
  Lemma fold_max_mono A n m : n <= m -> fold_left max A n <= fold_left max A m.
  Proof.
    revert n m. induction A as [|a A IH]; auto with arith.
    intros n m H. cbn. now apply IH, Nat.max_le_compat_r.
  Qed.

  Lemma fold_max_inc A b : b <= fold_left max A b.
  Proof.
    induction A as [|a A IH]; auto.
    cbn. eapply le_trans. now apply IH. apply fold_max_mono, Nat.le_max_l.
  Qed.

  (* We use both above lemmas to show that the maximum of A is larger or equal to
     all elements of A. *)
  Lemma all_le A : forall a, In a A -> a <= max_list A.
  Proof.
    induction A as [| b A IH]; intros a; [intros []|intros [E|H]].
    - rewrite E. cbn. apply fold_max_inc.
    - eapply le_trans. now apply IH. cbn. apply fold_max_mono. auto with arith.
  Qed.

  (* Using above lemma we see that the new atom cannot be contained in A. *)
  Lemma new_atom_fresh A a : new_atom A <= a -> ~ In a A.
  Proof.
    intros H H'. eapply Nat.nle_succ_diag_l.
    eapply Nat.le_trans; [exact H | now apply all_le].
  Qed.

  (* Thus, the new atom is a witness for a fresh one. *)
  Lemma fresh_atom A: {a: atom | ~ In a A}.
  Proof.
    exists (new_atom A). intros H. now eapply new_atom_fresh, H.
  Qed.

End fresh_atom.

(* We can show now that if x has a support than we can compute a fresh atom for x
   using the above construcion . *)
Lemma support_fresh_atom (X: perm_set) A (x: X) : support A x -> {a | a # x}.
Proof.
  intros H. destruct (fresh_atom.fresh_atom A) as [a H'].
  exists a. intros Su. unfold supp in Su. apply H', Su, H.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.

Lemma firstn_app_L : forall T n (a b : list T),
  n <= length a ->
  firstn n (a ++ b) = firstn n a.
Proof.
  induction n; destruct a; simpl in *; intros; auto.
  exfalso; omega.
  f_equal. eapply IHn; eauto. omega.
Qed.

Lemma firstn_app_R : forall T n (a b : list T),
  length a <= n ->
  firstn n (a ++ b) = a ++ firstn (n - length a) b.
Proof.
  induction n; destruct a; simpl in *; intros; auto.
  exfalso; omega.
  f_equal. eapply IHn; eauto. omega.
Qed.

Lemma firstn_all : forall T n (a : list T),
  length a <= n ->
  firstn n a = a.
Proof.
  induction n; destruct a; simpl; intros; auto.
  exfalso; omega.
  simpl. f_equal. eapply IHn; omega.
Qed.

Lemma firstn_0 : forall T n (a : list T),
  n = 0 ->
  firstn n a = nil.
Proof.
  intros; subst; auto.
Qed.

Lemma firstn_cons : forall T n a (b : list T),
  0 < n ->
  firstn n (a :: b) = a :: firstn (n - 1) b.
Proof.
  destruct n; intros.
  omega.
  simpl. cutrewrite (n - 0 = n); [ | omega ]. reflexivity.
Qed.

Hint Rewrite firstn_app_L firstn_app_R firstn_all firstn_0 firstn_cons using omega : list_rw.

Lemma skipn_app_R : forall T n (a b : list T),
  length a <= n ->
  skipn n (a ++ b) = skipn (n - length a) b.
Proof.
  induction n; destruct a; simpl in *; intros; auto.
  exfalso; omega.
  eapply IHn. omega.
Qed.

Lemma skipn_app_L : forall T n (a b : list T),
  n <= length a ->
  skipn n (a ++ b) = (skipn n a) ++ b.
Proof.
  induction n; destruct a; simpl in *; intros; auto.
  exfalso; omega.
  eapply IHn. omega.
Qed.

Lemma skipn_0 : forall T n (a : list T),
  n = 0 ->
  skipn n a = a.
Proof.
  intros; subst; auto.
Qed.

Lemma skipn_all : forall T n (a : list T),
  length a <= n ->
  skipn n a = nil.
Proof.
  induction n; destruct a; simpl in *; intros; auto.
  exfalso; omega.
  apply IHn; omega.
Qed.

Lemma skipn_cons : forall T n a (b : list T),
  0 < n ->
  skipn n (a :: b) = skipn (n - 1) b.
Proof.
  destruct n; intros.
  omega.
  simpl. cutrewrite (n - 0 = n); [ | omega ]. reflexivity.
Qed.

Hint Rewrite skipn_app_L skipn_app_R skipn_0 skipn_all skipn_cons using omega : list_rw.


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensiv.

Section Classical_Logic.

  Definition peirces := forall P Q : Prop, ((P -> Q) -> P) -> P.

  Definition nnpp := forall P : Prop, ~ ~ P -> P. (* double nagation *)

  Definition exmid := forall P : Prop, P \/ ~ P. (* 排中律 *)

  Definition dms := forall P Q : Prop, ~ (~ P /\ ~ Q) -> P \/ Q.

  Definition impor := forall P Q : Prop, (P -> Q) -> ~ P \/ Q.

  (* 上記の命題が、同値であることの証明をする。 *)

  Lemma nnpp__peirces : nnpp -> peirces.
  Proof.
    move=> nnpp P Q HPQP.
    apply: (nnpp P) => HnP.
    apply: (HnP).                           (* copyする。 *)
      by apply: HPQP => HP.
  Qed.

  Lemma exmid__peirces : exmid -> peirces.
  Proof.
    move=> exmid P Q HPQ_P.
    case: (exmid P) => [HP | HnP].
    - done.
    - by apply: HPQ_P => HP.
  Qed.

  Lemma dms__peirces : dms -> peirces.
  Proof.
    move=> dms P Q HPQP.
    case: (dms P Q).
    - case=> [HnP HnQ].
      apply: (HnP).
        by apply: HPQP => HP.
    - done.
    - move=> HQ.
        by apply HPQP => HP.
  Qed.

  Lemma peirces__nnpp : peirces -> nnpp.
  Proof.
    move=> peirces P HnnP.
    by apply: (peirces P False) => HnP.
  Qed.

  Lemma peirces__exmid : peirces -> exmid.
  Proof.
    move=> peirces P.
    apply: (peirces (P \/ ~ P) (~ (P \/ ~ P))) => HPP.
    right=> HP.
    apply: HPP.
    - by left.
    - by left.
  Qed.

  Lemma exmid__nnpp : exmid -> nnpp.
  Proof.
    move=> exmid P HnnP.
    by case: (exmid P) => [HP | HnP].
  Qed.

  Lemma nnpp__dms : nnpp -> dms.
  Proof.
    move=> nnpp P Q Hn_nPnQ.
    apply: nnpp => Hn_PQ.
    apply: Hn_nPnQ.
    split=> H.
    - apply Hn_PQ.
        by left.
    - apply Hn_PQ.
        by right.
  Qed.

  Lemma impor__nnpp : impor -> nnpp.
  Proof.
    move=> impor P HnnP.
      by case: (impor P P).
  Qed.

  (*
    情報論理学
    九州大学大学院システム情報科学研究院 情報学部門 長谷川先生
    平成24年4月
    http://opal.is.kyushu-u.ac.jp/~hasegawa/lecture/infologic/h24/il-txt-haifu-h24.pdf
    p.32, p.33 を参考にした。
   *)
  Lemma nnpp__exmid : nnpp -> exmid.
  Proof.
    move=> nnpp P.
    apply: nnpp => Hn_P_or_n_P.
    apply: (Hn_P_or_n_P).
    right=> HP.
    apply: Hn_P_or_n_P.
      by left.
  Qed.

  (* Coq'n Artの回答を参考にした。 *)
  Lemma dms__exmid : dms -> exmid.
  Proof.
    move=> dms P.
    apply: dms => Hn_nPnnP.
      by case: Hn_nPnnP => [HnP HnnP].
  Qed.

  Lemma impor__exmid : impor -> exmid.
  Proof.
    move=> impor P.
    case: (impor P P) => [| HnP | HP].
    - done.
    - by right.
    - by left.
  Qed.

  Lemma dms__nnpp : dms -> nnpp.
  Proof.
    move=> dms P HnnQ.
    case: (dms P P) => [H | HP | ].
    - apply: HnnQ=> HP.
        by case: H.
    - done.
    - done.
  Qed.

  Lemma exmid__dms : exmid -> dms.
  Proof.
    move=> exmid P Q Hn_nPnQ.
    case: (exmid P) => [HP | HnP].
    - by left.
    - case: (exmid Q) => [HQ | HnQ].
      + by right.
      + by case: Hn_nPnQ.
  Qed.

  Lemma exmid__impor : exmid -> impor.
  Proof.
    move=> exmid P Q HPQ.
    case: (exmid P) => [HP | HnP].
    - right.
        by apply: HPQ.
    - left.
        by apply: HnP.
  Qed.

  (* 上記以外の証明は、間接的に行うことになる。 *)

  Lemma impor__peirces : impor -> peirces.
  Proof.
    move=> impor.
    apply: nnpp__peirces.
    apply: exmid__nnpp.
    apply: impor__exmid.
    done.
  Qed.

End Classical_Logic.

(* END  *)


(** * Solution: The Sum Game *)

(** Suppose that the amount remaining before the cumulative sum is reached
    is [n]. Then if [n] is divisible by 11, the player who is next must lose,
    while if [n] is not divisible by 11, the player who is next must win.
    Since 100 is not divisible by 11, the player who is next wins.

    - If [n] is 0, the player who is next loses, by definition.

    - If the player who is next loses from [n], then the player who is
      next wins from [n + r] for any [r] between 1 and 10.

    - As a result, if the player who is next loses from [n], the player
      who is next also loses from [n + 11], since no matter what move
      the player makes, the opposing player can subtract a complementary
      amount to bring the state to [n].

    Using these facts, we can prove the goal in an inductive manner.
    Noting that [n] can be written as the product [p * 11 + r], where
    [r] is between 0 and 10, the proof proceeds by induction on [p].

    #
    Download the Coq source!
    #

    *)

Require Import problem.
Require Import Arith Omega.
Import PeanoNat.Nat.

Definition pre_strategy :=
  state -> {m | m < 10}.

Definition strategy (s: pre_strategy) :
  forall n : state, {m | action (S n) m}.
Proof.
  intros.
  destruct (s (S n)) as [m ?].
  exists ((S n) - (1 + m)).
  unfold action; constructor; omega.
Qed.

Definition winning_pre_strategy : pre_strategy.
Proof.
  intro n.
  exists (n mod 11 - 1).
  pose proof (Nat.mod_upper_bound n 11); omega.
Defined.

Definition winning_strategy := strategy winning_pre_strategy.

Theorem mod_principle k (Heq0: k <> 0) :
  forall (P: nat -> Prop)
    (Hsmall: forall n, n < k -> P n)
    (Hind: forall p, (forall n, n < k -> P (k *   p + n)) ->
                (forall n, n < k -> P (k * S p + n))),
    (forall n, P n).
Proof.
  intros.
  pose proof (div_mod n k ltac:(auto)).
  remember (n / k) as p. remember (n mod k) as r.
  rewrite H.
  pose proof (mod_upper_bound n k ltac:(assumption)).
  rewrite <- Heqr in H0.
  clear n H Heqp Heqr.
  generalize dependent r.
  induction p.
  - rewrite mul_0_r in *; simpl in *.
    auto.
  - apply Hind. apply IHp.
Qed.

Hint Constructors LoseFrom WinFrom.
Hint Constructors validDiff.

Lemma action_def : forall n n',
    1 <= n - n' ->
    n - n' <= 10 ->
    action n n'.
Proof.
  unfold action; eauto.
Qed.

Hint Resolve action_def.

Hint Extern 3 (_ <= _) => omega.

(** If [n] is 0, the player who is next loses, by definition. *)
Lemma LoseFrom0 : LoseFrom 0.
Proof.
  constructor.
  inversion 1.
  omega.
Qed.

(** If the player who is next loses from [n], then the player who is
    next wins from [n + r] for any [r] between 1 and 10. *)
Lemma WinFrom_n : forall n,
    LoseFrom n ->
    forall n' k,
      n' = n + S k ->
      k < 10 ->
      WinFrom n'.
Proof.
  intros. subst.
  econstructor; eauto.
  eauto.
Qed.

Ltac winfrom_n :=
  match goal with
  | [ H: LoseFrom ?n |- WinFrom ?n' ] =>
    apply (WinFrom_n _ H n' (n' - n - 1)); try omega
  end.

(** As a result, if the player who is next loses from [n], the player
    who is next also loses from [n + 11], since no matter what move
    the player makes, the opposing player can subtract a complementary
    amount to bring the state to [n]. *)
Lemma LoseFrom_n : forall n,
    LoseFrom n ->
    forall m, 11 + n = m ->
    LoseFrom m.
Proof.
  intros; subst.
  constructor; intros.
  inversion H0; subst.
  winfrom_n.
Qed.

Lemma mod_add_rem : forall k n r,
    k <> 0 ->
    r < k ->
    (k * n + r) mod k = r.
Proof.
  intros.
  rewrite plus_comm.
  rewrite mul_comm.
  rewrite mod_add by auto.
  apply mod_small; auto.
Qed.

(** Then if [n] is divisible by 11, the player who is next must lose,
    while if [n] is not divisible by 11, the player who is next must win. *)
Theorem solution_all : forall n,
    match n mod 11 with
    | 0 => LoseFrom n
    | S _ => WinFrom n
    end.
Proof.
  intros.
  induction n using (mod_principle 11 ltac:(omega)).
  - rewrite mod_small by auto.
    destruct n.
    + apply LoseFrom0.
    + pose proof LoseFrom0.
      winfrom_n.
  - rewrite mod_add_rem by omega. destruct n2.
    + specialize (H 0 ltac:(auto)).
      rewrite mod_add_rem in H by omega.
      eapply LoseFrom_n; eauto.
      omega.
    + specialize (H 0 ltac:(omega)).
      rewrite mod_add_rem in H by omega.
      eapply LoseFrom_n in H; eauto.
      winfrom_n.
Qed.

(** Since 100 is not divisible by 11, the player who is next wins. *)
Theorem solution : WinFrom 100.
Proof.
  apply (solution_all 100).
Qed.


(* About integer powers (monomorphic version) *)

Set Implicit Arguments.

Require Import ZArith  Div2  Program.

Open Scope Z_scope.

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

(**  Tests:

Compute power 2 40.
 = 1099511627776
     : Z
*)

Program
Fixpoint binary_power_mult (acc x:Z) (n:nat) {measure n} : Z
  (* acc * (power x n) *) :=
  match n with
    | 0%nat => acc
    | _ => if Even.even_odd_dec n
           then binary_power_mult acc (x * x) (div2 n)
           else binary_power_mult (acc * x) (x * x) (div2 n)
  end.
 Solve Obligations with program_simpl; intros; apply lt_div2; auto with arith.

Definition binary_power (x:Z)(n:nat) := binary_power_mult 1 x n.

(**  Tests:

Compute bunary_power 2 40.
 = 1099511627776
     : Z
*)

Example Ex1 : binary_power 2 234 = power 2 234.
Proof. reflexivity. Qed.