Require Import List.

Inductive quicksort1 : list nat -> list nat -> Prop :=
| Q1nil: quicksort1 nil nil
| Q1cons (head : nat) (tail l r : list nat) :
    quicksort1 (filter (fun x => Nat.ltb x head) tail) l ->
    quicksort1 (filter (fun x => Nat.leb head x) tail) r ->
    quicksort1 (head :: tail) (l ++ (cons head nil) ++ r).

Inductive quicksort2 : list nat -> list nat -> Prop :=
| Q2nil: quicksort2 nil nil
| Q2cons (head : nat) (tail l r : list nat) :
    quicksort2 (filter (fun x => Nat.leb x head) tail) l ->
    quicksort2 (filter (fun x => Nat.ltb head x) tail) r ->
    quicksort2 (head :: tail) (l ++ (cons head nil) ++ r).

Definition task :=
  forall x ret1 ret2, quicksort1 x ret1 -> quicksort2 x ret2 -> ret1 = ret2.


Require Import Basics.

(* Check that below three functions are working. *)
(* If they don't work, run build.sh *)
Check test.
Check true || true.
Check Basics.test.

(* The function should return true if either or both of its inputs are false. *)
Definition nandb (b1:bool) (b2:bool) : bool :=
  match (b1, b2) with
  | (false, false) => true
  | (false, _) => true
  | (_, false) => true
  | _ => false
  end.

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

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

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

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

(* This function should return true when all of its inputs are true, and false otherwise. *)

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool := andb (andb b1 b2) b3.

(* This doesn't work unless symbols are defined in that module. Why ? *)
(* Definition andb3_symbol (b1:bool) (b2:bool) (b3:bool) : bool := b1 && b2 && b3. *)

Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.

Check negb.

Fixpoint factorial (n:nat) : nat :=
  match n with
    | O => S O
    | S p => mult n (factorial p)
  end.

Compute (factorial 5).

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

(* The blt_nat function tests natural numbers for less-than, yielding a boolean. *)

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

Check test.

Definition blt_nat (n m : nat) : bool :=
  match (n,m) with
    | (O,O) => false
    | _ => if (beq_nat n m)
           then false
           else leb n m
  end.

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n -> m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> plus_1_l.
  rewrite <- H.
  reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  intros H.
  destruct c.
  reflexivity.
  rewrite <- H.
  destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H1 b.
  rewrite -> H1.
  rewrite -> H1.
  reflexivity.
Qed.

Lemma andb_true_l : forall (b : bool), (true && b) = b.
Proof.
  intros b.
  destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b.
  rewrite -> andb_true_l.
  destruct c.
  reflexivity.
  simpl. simpl. intros H1. rewrite -> H1. reflexivity.
  destruct c.
  simpl. intros H1. rewrite -> H1. reflexivity.
  simpl. reflexivity.
Qed.


From mathcomp Require Import ssreflect.

Module Lesson1.

Inductive bool : Type :=
| true
| false.

Check false : bool.
Check false.

Check bool : Type.
Check (bool -> bool) : Type.
Check (fun (b : bool) => b) : (bool -> bool). (* Lambda  id *)
Check (fun t: Type => t): (Type -> Type).
Check ((fun t: Type => t) bool): Type.

Check (fun b => b).

Check ((fun b => b) true).

Check (fun (f : bool -> bool) => f true).

Compute (fun b : bool => b) true.

Definition idb := (fun b : bool => b).

Check idb.
Check idb true : bool.
Check (fun (f : bool -> bool) => f true) idb.

Fail Check (fun (f : bool -> bool) => f true) false.

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

Check negb true : bool.

(* cbv - call by value *)
Eval cbv beta delta in negb true.

Variable c : bool.

Compute negb c.

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

Definition andb' (b c : bool) : bool :=
  match c with
  | false => false
  | true => b
  end.

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

Compute orb true false.
Compute orb false false.
Compute orb false true.

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

Inductive nat : Type :=
| Z
| S of nat. (* 'of' taken from ssreflect, S : nat -> nat*)

Inductive nat2 : Type :=
| Z2 : nat2
| S2 : nat2 -> nat2.

Check S Z.

Definition succn := S.

Compute succn (S Z).

Definition predn' (n : nat) : nat :=
  match n with
  | S m => m
  | Z => Z
  end.

(*
  Definition predn : forall n : nat, (n <> Z) -> nat :=
    match n with
    | S m => m
    | Z => Z
    end.
*)

(* {struct n} indicates which parameter recursion run on *)
Fixpoint addn (n m : nat) {struct n} : nat :=
  match n with
  | Z => m
  | S n' => S (addn n' m)
  end.

Compute addn (S Z) (S Z).

Fixpoint addn' (n m : nat) : nat :=
  if n is S n' then S (addn' n' m) else m.

Definition addn_no_sugar :=
  fix addn (n m : nat) {struct n} : nat :=
    match n with
    | Z => m
    | S n' => S (addn n' m)
    end.

Fail Fixpoint addn_loop (n m : nat) {struct n} : nat :=
  if n is S n' then addn_loop n m else m.

Fixpoint is_even (n : nat) : bool :=
  if n is S n' then is_odd n' else true
with is_odd (n : nat) : bool :=
  if n is S n' then is_even n' else false.

Compute is_even (S (S (S Z))).
Compute is_even (S (S Z)).
Compute is_odd (S (S (S Z))).
Compute is_odd (S (S Z)).

Definition dec2 (n : nat) : nat :=
  match n with
  | S (S n') => n'
  | _ => Z
  end.

Compute dec2 (S(S(S(Z)))).
Compute dec2 (S(S Z)).
Compute dec2 (S Z).

Fixpoint subn (m n : nat) {struct m} : nat :=
  match (m, n) with
  | (m, Z) => m
  | (Z, n) => Z
  | (S m', S n') => subn m' n'
  end.

Compute subn Z Z.
Compute subn (S Z) Z.
Compute subn (S Z) (S Z).
Compute subn (S (S Z)) (S Z).
Compute subn (S Z) (S (S Z)).

Fixpoint muln (m n : nat) : nat :=
  match n with
  | Z => Z
  | S Z => m
  | S n' => addn m (muln m n')
  end.

Compute muln Z Z.
Compute muln (S Z) Z.
Compute muln (S Z) (S Z).
Compute muln (S (S Z)) (S Z).
Compute muln (S (S Z)) (S (S Z)).

Fixpoint leq (m n : nat) : bool :=
  match (m, n) with
  | (Z, Z) => true
  | (Z, _) => true
  | (_, Z) => false
  | (S m', S n') => leq m' n'
  end.

Compute leq Z Z.
Compute leq (S Z) Z.
Compute leq (S Z) (S Z).
Compute leq (S (S Z)) (S Z).
Compute leq (S (S Z)) (S (S Z)).
Compute leq (S Z) (S (S Z)).

Fixpoint divn_helper (m n rest acc: nat) {struct m} : nat :=
  match (m, rest) with
  | (S m', S Z) => divn_helper m' n n (S acc)
  | (S m', S rest') => divn_helper m' n rest' acc
  | (S _, Z) => Z
  | (Z, Z) => S acc
  | (Z, _) => acc
  end.

Definition divn (m n : nat) : nat :=
  divn_helper m n n Z.

Compute divn (S (S Z)) (S Z).

End Lesson1.


Inductive N : Set :=
  | zero : N
  | succ : N -> N.

Fixpoint plus (m n : N) :=
  match m with
    | zero => n
    | succ m' => succ (plus m' n)
  end.

Lemma plus_succ: forall m n, succ (plus n m) = plus n (succ m).
Proof.
  intros.
  induction n.
  auto.
  simpl.
  f_equal.
  assumption.
Qed.

Lemma plus_n_zero: forall n, n = plus n zero.
Proof.
  induction n.
  auto.
  simpl.
  f_equal.
  assumption.
Qed.

Theorem plus_comm: forall m n, plus m n = plus n m.
Proof.
  intros.
  induction m.
  simpl.
  apply plus_n_zero.
  simpl.
  rewrite IHm.
  apply plus_succ.
Qed.

Print plus_comm.


Require Import Lia.
Require Import Bool.
Require Import List.
Require Import Arith.Arith.
Import ListNotations.

Require Extraction.

(** * Heading test *)

(** Define extraction to Ocaml. *)
(** Quite unsafe! *)
Module ExtractionDefs.
Module ExtrNatToInt64.
Extract Inductive nat => "int64"
  [ "Int64.zero" "(fun x -> Int64.succ x)" ]
  "(fun zero succ n -> if Int64.compare n 0 = 0 then zero () else succ (Int64.pred n))".
Extract Constant plus => "Int64.add".
Extract Constant mult => "Int64.mul".
Extract Constant leb => "(fun x y -> Int64.compare x y <= 0)".
End ExtrNatToInt64.

Extract Inductive bool => "bool" [ "true" "false" ].

End ExtractionDefs.

(** https://codeforces.com/contest/1519/problem/A *)

Definition absLeq (x y d : nat) := x-y <= d /\ y-x <= d.

Definition can_distribute (r b d : nat) : bool :=
  (b <=? (r * (d + 1))) && (r <=? (b * (d + 1))).

(** Define problem specification *)

(** A few lemmas about arithmetic that will come in handy.
    We make heavy use of the [lia] to avoid having to deal with most of these proofs by hand, but for some cases (multiplication by non-constants, we need to help guide the solver: *)

Lemma d_leq_mult_d : forall d r, r > 0 -> d <= r * d.
Proof.
  intros.
  induction d; lia.
Qed.

Lemma d_bound : forall r b d x y,
  r > 0 ->
  b <= r + d ->
  y <= x * (d+1) ->
  b + y <= (r + x) * (d + 1).
Proof.
  intros.
  assert ((r+x)*(d+1) = x*(d+1) + r*(d+1)). { lia. } rewrite H2.
  assert (r+d <= r*(d+1)); try lia.
  pose proof (d_leq_mult_d d r). lia.
Qed.

Module InductiveSpec.
Inductive correct_distribution (d : nat) : nat -> nat -> Prop :=
  | no_packets : correct_distribution d 0 0
  | add_packet : forall r b r' b',
      correct_distribution d r b ->
      r' > 0 ->
      b' > 0 ->
      absLeq r' b' d ->
      correct_distribution d (r'+r) (b'+b).
Hint Constructors correct_distribution : core.

Lemma distribution_flip : forall r b d,
  correct_distribution d r b <-> correct_distribution d b r.
  assert (H:forall r b d, correct_distribution d r b -> correct_distribution d b r). {
  intros r b d H.
  induction H.
  - auto.
  - constructor; auto. unfold absLeq in *. lia. }

  split; apply H.
Qed.

Lemma can_make_distr : forall r b d,
    r <= b ->
    b <= r * (d+1) ->
    correct_distribution d r b.
Proof.
  intros r b d r_leq_b H.
  generalize dependent b.
  induction r; intros.
  - assert (b = 0). lia. subst. auto.
  - remember (min (b - r) (d + 1)) as t.
    specialize IHr with (b-t).
    assert (Hb: b = t+(b-t)). { lia. } rewrite Hb.
    assert (Hr: S r = 1 + r). { lia. } rewrite Hr.
    constructor; unfold absLeq; try apply IHr; try lia.
Qed.

Definition algorithm_iff_correct_distribution :=
  forall r b d,
    can_distribute r b d = true <-> correct_distribution d r b.
Theorem algorithm_correct : algorithm_iff_correct_distribution.
  unfold algorithm_iff_correct_distribution.
  split; intros.
  - unfold can_distribute in H.
    rewrite andb_true_iff in H. repeat rewrite Nat.leb_le in H. destruct H as [H1 H2].
    (* Case on whether r <= b or b <= r. *)
    assert (r <= b \/ b <= r) as [Hrb | Hbr]. lia.
    + apply can_make_distr; auto.
    + apply distribution_flip. apply can_make_distr; auto.
  - unfold can_distribute.
    rewrite andb_true_iff. repeat rewrite Nat.leb_le.
    induction H.
    + lia.
    + split; apply d_bound; unfold absLeq in H2; try lia.
Qed.

End InductiveSpec.

Module ListSpec.

(** Prove that our program returns true if and only if there exists a correct distribution. *)
Definition packet : Set := nat * nat.

Fixpoint packet_sum (l : list packet) := match l with
  | [] => (0,0)
  | (r,b) :: rest => let (x,y) := packet_sum rest in (r+x,b+y)
  end.

(** There exists a *correct distribution* for (r,b,d) if and only if there exists a set of packets which sum to (r,d), where each packet has a nonzero number of red and blue elements. *)
Definition correct_distribution (r b d : nat) :=
  exists l, packet_sum l = (r,b) /\ Forall (fun '(x,y) => absLeq x y d /\ x > 0 /\ y > 0) l.

Example ex1 : correct_distribution 1 1 0.
Proof.
  exists [(1,1)].
  split; unfold absLeq; auto.
  repeat constructor; lia.
Qed.

Example ex2 : correct_distribution 2 7 3.
Proof.
  exists [(1,4);(1,3)].
  split; unfold absLeq; auto.
  repeat constructor; lia.
Qed.

(** We can exchange the uses of r and b: *)
Lemma distribution_flip : forall r b d,
  correct_distribution r b d <-> correct_distribution b r d.
Proof.
  assert (H:forall r b d, correct_distribution r b d -> correct_distribution b r d). {
  unfold correct_distribution.
  intros r b d [l [H2 H3]].
  generalize dependent r.
  generalize dependent b.
  induction l; intros.
  + simpl in H2. inversion H2; subst. exists []; auto.
  + destruct a as [r' b']. simpl in H2.
    remember (packet_sum l) as X. destruct X as [x y].
    inversion H2; subst.
    specialize IHl with y x.
    destruct IHl; auto. inversion H3; auto.
    destruct H.
    exists ((b',r')::x0).
    split. simpl. rewrite H. auto.
    constructor; auto. inversion H3; subst. destruct H5 as [Ha [Hr Hb]]. split; auto; unfold absLeq in *; try lia.
  }
  split; apply H.
Qed.

(** The crucial lemma proving that our algorithm's conditions is sufficient: *)
Lemma can_make_distr : forall r b d,
    r <= b ->
    b <= r * (d+1) ->
    correct_distribution r b d.
Proof.
  intros r b d r_leq_b H.
  generalize dependent b.
  induction r; intros.
  - assert (b = 0). lia. subst. exists []. auto.
  - remember (min (b - r) (d + 1)) as t.
    specialize IHr with (b-t).
    assert (Hr : r <= b - t). { lia. } apply IHr in Hr.
    destruct Hr as [l [Hl1 Hl2]].
    exists ((1,t) :: l); split.
    + simpl. rewrite Hl1.
      assert (Htb: t + (b - t) = b). { lia. } rewrite Htb.
      reflexivity.
    + constructor; try auto; split; try lia. unfold absLeq; lia.
    + simpl in H.
      pose proof (Nat.min_spec (b-r) (d+1)) as [[Hmin1 minEq] | [Hmin2 minEq]]; rewrite minEq in Heqt.
      subst. assert (b - (b - r) = r). lia. rewrite H0.
      rewrite plus_comm. rewrite <- mult_n_Sm. lia.

      subst. lia.
Qed.

Definition algorithm_iff_correct_distribution :=
  forall r b d,
    can_distribute r b d = true <-> correct_distribution r b d.
Theorem algorithm_correct : algorithm_iff_correct_distribution.
Proof.
  unfold algorithm_iff_correct_distribution.
  intros.
  split; intros.
  - unfold can_distribute in H.
    rewrite andb_true_iff in H. repeat rewrite Nat.leb_le in H. destruct H as [H1 H2].
    (* Case on whether r <= b or b <= r. *)
    assert (r <= b \/ b <= r) as [Hrb | Hbr]. lia.
    + apply can_make_distr; auto.
    + apply distribution_flip. apply can_make_distr; auto.

  - destruct H as [l [H1 H2]].
    unfold can_distribute.
    rewrite andb_true_iff. repeat rewrite Nat.leb_le.
    generalize dependent b.
    generalize dependent r.
    induction l; intros.
    + simpl in H1. inversion H1; subst. lia.
    + destruct a as [r' b']. simpl in H1. remember (packet_sum l) as X. destruct X as [x y]. inversion H1; subst. clear H1.
      inversion H2; subst. apply IHl with x y in H3; auto.
      unfold absLeq in H1.
      split; apply d_bound; lia.
Qed.
End ListSpec.

(** Extract the program to Ocaml.
   See sol.ml for the boilerplate input/output plumbing. *)
Extraction "imp.ml" can_distribute.


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

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

(* Why3 assumption *)
Definition even (n:Z): Prop := exists k:Z, (n = (2%Z * k)%Z).

(* Why3 assumption *)
Definition odd (n:Z): Prop := exists k:Z, (n = ((2%Z * k)%Z + 1%Z)%Z).

Lemma even_is_Zeven :
  forall n, even n <-> Zeven n.
Proof.
intros n.
refine (conj _ (Zeven_ex n)).
intros (k,H).
rewrite H.
apply Zeven_2p.
Qed.

Lemma odd_is_Zodd :
  forall n, odd n <-> Zodd n.
Proof.
intros n.
refine (conj _ (Zodd_ex n)).
intros (k,H).
rewrite H.
apply Zodd_2p_plus_1.
Qed.

(* Why3 goal *)
Lemma even_or_odd :
forall (n:Z), (even n) \/ (odd n).
Proof.
intros n.
destruct (Zeven_odd_dec n).
left.
now apply <- even_is_Zeven.
right.
now apply <- odd_is_Zodd.
Qed.

(* Why3 goal *)
Lemma even_not_odd :
forall (n:Z), (even n) -> ~ (odd n).
Proof.
intros n H1 H2.
apply (Zeven_not_Zodd n).
now apply -> even_is_Zeven.
now apply -> odd_is_Zodd.
Qed.

(* Why3 goal *)
Lemma odd_not_even :
forall (n:Z), (odd n) -> ~ (even n).
Proof.
intros n H1.
contradict H1.
now apply even_not_odd.
Qed.

(* Why3 goal *)
Lemma even_odd :
forall (n:Z), (even n) -> (odd (n + 1%Z)%Z).
Proof.
intros n H.
apply <- odd_is_Zodd.
apply Zeven_plus_Zodd.
now apply -> even_is_Zeven.
easy.
Qed.

(* Why3 goal *)
Lemma odd_even :
forall (n:Z), (odd n) -> (even (n + 1%Z)%Z).
Proof.
intros n H.
apply <- even_is_Zeven.
apply Zodd_plus_Zodd.
now apply -> odd_is_Zodd.
easy.
Qed.

(* Why3 goal *)
Lemma even_even :
forall (n:Z), (even n) -> (even (n + 2%Z)%Z).
Proof.
intros n H.
apply <- even_is_Zeven.
apply Zeven_plus_Zeven.
now apply -> even_is_Zeven.
easy.
Qed.

(* Why3 goal *)
Lemma odd_odd :
forall (n:Z), (odd n) -> (odd (n + 2%Z)%Z).
Proof.
intros n H.
apply <- odd_is_Zodd.
apply Zodd_plus_Zeven.
now apply -> odd_is_Zodd.
easy.
Qed.

(* Why3 goal *)
Lemma even_2k :
forall (k:Z), (even (2%Z * k)%Z).
Proof.
intros k.
now exists k.
Qed.

(* Why3 goal *)
Lemma odd_2k1 :
forall (k:Z), (odd ((2%Z * k)%Z + 1%Z)%Z).
Proof.
intros k.
now exists k.
Qed.


Require Import ZArith.
Require Import QArith.
Open Scope Q_scope.

Inductive Seq (T:Set) := mkSeq (seq_elt:nat->T).
Definition elt {T:Set} (seq: Seq T) n := match seq with
                                         | mkSeq _ f => f n
                                         end.

Inductive converging_qseq: Seq Q -> Prop :=
 ex_limit (s:Seq Q) (a:Q) (H: forall eps:Q, eps>0 -> exists (n0:nat), forall (n:nat), (n0 <= n)%nat -> a - eps < elt s n /\
                                                                       a + eps > elt s n)
 : converging_qseq s.

Definition qseq_const := fun a => mkSeq Q (fun n => a).
Definition qseq_plus sx sy := mkSeq Q (fun n => elt sx n + elt sy n).

Open Scope Q_scope.
Lemma lt_lower: forall a p, p > 0 -> a - p < a.
Proof. intros. unfold Qminus. rewrite <- Qplus_0_r with (x:=a) at 2.
       rewrite Qplus_comm. rewrite (Qplus_comm a 0). apply (Qplus_lt_le_compat (-p) 0 a a ).
       - unfold Qlt. simpl. rewrite Z.mul_comm. rewrite (Z.mul_1_l (-Qnum p)).
         unfold Qlt in H. simpl in H. rewrite Z.mul_comm in H. rewrite (Z.mul_1_l (Qnum p)) in H.
         apply Z.opp_lt_mono. rewrite Z.opp_involutive. rewrite Z.opp_0. exact H.
       - apply Z.le_refl.
Qed.

Theorem converging_const: forall a, converging_qseq (qseq_const a).
Proof. intros. apply (ex_limit (qseq_const a) a).
       intros eps Heps. exists 0%nat. intros.
       split.
       - simpl. apply lt_lower. exact Heps.
       - simpl. rewrite <- Qplus_0_l at 1.  rewrite (Qplus_comm a eps). rewrite Qplus_lt_l. exact Heps.
Qed.

Lemma split_halfs: forall a, a == a * (1#2) + a * (1#2).
Proof. intros. ring_simplify. easy.
Qed.

Lemma dswap: forall a b c d, a+b+c+d == (a+c) +(b+d).
  intros. ring_simplify. easy.
Qed.

Theorem converging_sum: forall s1 s2, converging_qseq s1 -> converging_qseq s2 -> converging_qseq (qseq_plus s1 s2).
Proof. intros s1 s2 H1 H2. destruct H1 as [s1 a Ha]. destruct H2 as [s2 b Hb].
       apply (ex_limit (qseq_plus s1 s2) (a+b)). intros.

       assert (0 < 1#2) as Heps2. { unfold Qlt. simpl. apply Z.lt_0_1. }
       assert (HH := Qmult_lt_compat_r 0 eps (1#2) Heps2 H).  rewrite Qmult_0_l in HH.
       assert (Ha := Ha (eps * (1#2) ) HH).
       assert (Hb := Hb (eps * (1#2) ) HH).
       destruct Ha as [na Ha]. destruct Hb as [nb Hb].
       set (mab := max na nb).
       exists mab. intros n Hmax.

       split.
       (* lower bound *)
       - rewrite (split_halfs eps) at 1. unfold Qminus. rewrite Qopp_plus. rewrite Qplus_assoc.
         rewrite dswap. simpl.
         apply Qplus_lt_le_compat.
         + apply Ha.  apply Nat.le_trans with (m:= mab). apply Nat.le_max_l. exact Hmax.
         + unfold Qminus in Hb. apply Qlt_le_weak. apply Hb.
           apply Nat.le_trans with (m:= mab). apply Nat.le_max_r. exact Hmax.
       (* upper bound *)
       - rewrite (split_halfs eps). rewrite Qplus_assoc, dswap.
         apply Qplus_lt_le_compat.
         + apply Ha. apply Nat.le_trans with (m:= mab). apply Nat.le_max_l. exact Hmax.
         + apply Qlt_le_weak. apply Hb. apply Nat.le_trans with (m:= mab). apply Nat.le_max_r. exact Hmax.
Qed.


Require Import FSets.
Require Import FSetAVL.
Require Import ZArith.
Require Import Omega.
Open Scope Z_scope.
Set Implicit Arguments.

(** For the purpose of the demo, let's show how basic things are defined,
    without interfering with Coq's stdlib, thanks to the following module. *)
Module LOCAL.

(** * Ordered types *)

(* Starting point: the OrderedType interface of Ocaml:

module type OrderedType =
  sig
    type t
    val compare : t -> t -> int
  end
*)

(* The corresponding OrderedType in Coq: *)

(*excerpt from OrderedType.v *)
Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type :=
  | LT : lt x y -> Compare lt eq x y
  | EQ : eq x y -> Compare lt eq x y
  | GT : lt y x -> Compare lt eq x y.

Extraction Compare.

Module Type OrderedType.

  Parameter t : Type.

  Parameter eq : t -> t -> Prop.
  Parameter lt : t -> t -> Prop.

  Axiom eq_refl : forall x : t, eq x x.
  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.

  Parameter compare : forall x y : t, Compare lt eq x y.

End OrderedType.
(*/excerpt*)

(** * An example of OrderedType : *)
(** [Z] integers seen as Orderered Types : Z_as_OT *)

(* excerpt from OrderedTypeEx.v *)
Module Z_as_OT <: OrderedType.

  Definition t := Z.
  Definition eq (x y:Z) := (x=y).
  Definition lt (x y:Z) := (x<y).

  Section xyz.
  Variables x y z : Z.

  Lemma eq_refl : x=x .
  Proof. auto. Qed.

  Lemma eq_sym : x=y -> y=x.
  Proof. auto. Qed.

  Lemma eq_trans : x=y -> y=z -> x=z.
  Proof. auto with zarith. Qed.

  Lemma lt_trans : x<y -> y<z -> x<z.
  Proof. auto with zarith. Qed.

  Lemma lt_not_eq : x<y -> ~ x=y.
  Proof. auto with zarith. Qed.

  Definition compare : Compare lt eq x y.
  Proof.
    case_eq (x ?= y); intros.
    apply EQ; unfold eq; apply Zcompare_Eq_eq; auto.
    apply LT; unfold lt, Zlt; auto.
    apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto.
  Defined.

  End xyz.
End Z_as_OT.
(* /excerpt *)

(* Extraction Z_as_OT. Extraction under a module that dont work for the moment *)

End LOCAL.

Extraction LOCAL.Z_as_OT.

(** * Let's now build some sets of [Z] integers ... *)

Module M := FSetAVL.Make(Z_as_OT).

(* This module M provides plenty of functions on Z-sets *)
Check M.add.

(* Let's play with them : *)
Definition ens1 := M.add 3 (M.add 0 (M.add 2 (M.empty))).
Definition ens2 := M.add 0 (M.add 2 (M.add 4 (M.empty))).
Definition ens3 := M.inter ens1 ens2.
Eval compute in (M.mem 2 ens3).
Eval compute in (M.elements ens3).

(* M also provides some basic properties, for instance: *)
Check (M.elements_3 ens3).
(* elements always returns a sorted list
   with respect to the underlying order. *)

(* The M.t type for sets is meant to be used as an abstract type
   since it will vary amongst the different implementations of FSets.
   An M.t can and should always be inspected by using [mem], [elements], etc.
   But for once, let's have a look at the raw aspect of a set: *)
Set Printing Implicit.
Import M.MSet.Raw.
Eval compute in ens1.
(* Here for FSetAVL, a set is a pair of a tree (see 1st line) and some proofs *)
Eval compute in ens3. (* The proofs parts can grow quite fast *)
Unset Printing Implicit.

(* Here, in order to avoid the continuous expansion of proofs parts,
   we can work on "pure" or "raw" datatypes
   (i.e. without built-in invariants). *)
Module R:=M.MSet.Raw.

Definition raw1 := R.add 3 (R.add 0 (R.add 2 R.empty)).
Definition raw2 := R.add 0 (R.add 2 (R.add 4 R.empty)).
Definition raw3 := R.inter raw1 raw2.

Eval compute in raw3.
Eval compute in (R.elements raw3).

(* ... but then there is more work for deriving properties. *)

Instance : Ok raw3.
Proof. unfold raw3; auto with *. Qed.

Check (elements_spec1 raw3).
Check (@elements_spec2 raw3 _).

(** * union *)

(* This function is now based on a structural recursion.
   It used to be a well-founded one (via Function's measure),
   for this version see FSetFullAVL. *)
Eval vm_compute in (@R.union raw1 raw2).

Extraction M.

(** * Some sets of sets ... *)

Module MM := FSetAVL.Make(M).

Definition eens1 := MM.add ens1 (MM.add ens2 (MM.empty)).

(* ... that can now computes in Coq (due to the new [compare]) *)
Eval vm_compute in List.map M.elements (MM.elements eens1).

(** * Some more intense tests. *)

Fixpoint multiples (m:Z)(start:Z)(n:nat) {struct n} : list Z :=
  match n with
   | O => nil
   | S n => start::(multiples m (m+start) n)
  end.

Eval compute in (multiples 2 0 200%nat).

Definition bigens1 := fold_right M.add M.empty (multiples 2 0 400%nat).
Definition bigens2 := fold_right M.add M.empty (multiples 3 0 400%nat).
Time Eval compute in (M.elements (M.inter bigens1 bigens2)).
(* takes a few seconds, but we can also take advantage of Coq new virtual
    machine (VM), that performs the same job in almost no time. *)
Time Eval vm_compute in (M.elements (M.inter bigens1 bigens2)).

Definition bigens3 := fold_right M.add M.empty (multiples 2 0 (100*100)%nat).
Definition bigens4 := fold_right M.add M.empty (multiples 3 0 (100*100)%nat).
Time Eval vm_compute in (M.elements (M.inter bigens3 bigens4)).
(* 11s for this intersection of 2 sets of 10000 elements !!
   In fact, 5s per construction of each bigens, but the inter
   is done in no time:
*)
Time Eval vm_compute in (M.elements (M.inter bigens3 bigens4)).
(* 0.8s *)

(** * Proving with FSets : the facts/properties functors *)

(* The properties provided by FSetAVL are deliberately minimalistic.
   They correspond to the minimal specifications present in FSetInterface.
   This way, building new implementations is fairly simple.
   Now, lots of additional facts can be derived from this common interface. *)

(* Simple ones are locating in the functor FSetFacts.Facts *)
Module MF := FSetFacts.Facts M.

(* It contains mainly rephrasing of the specifications in alternative styles
  like equivalences or boolean *)
Check MF.add_iff.
Check MF.add_b.

(* More complex properties are located in the functors FSetProperties.Properties *)
Module MP := FSetProperties.Properties M.

(* For instance: usual stuff about set operations: *)
Check MP.union_inter_1.

(* Also useful: one induction principle (in fact several) *)
Check MP.set_induction.

(* And lot of stuff concerning the hard-to-handle [fold] function *)
Check MP.fold_add.

(* Most advance property: the law on cardinal of unions *)
Check MP.union_inter_cardinal.

(** * What about maps ? it's the same ! *)

Require Import FMapAVL.

(* Now, the elements of the OrderedType will serve as keys for the maps. *)
Module F := FMapAVL.Make(Z_as_OT).

(* And as in Ocaml, maps contains data whose type is polymorphic: *)
Check F.add.

(* Let's for instance define a map with Z keys and lists as data *)
Definition map1 :=
  F.add 2 (1::2::nil)
   (F.add 3 nil
     (F.add 1 (0::nil)
       (F.empty _))).

Eval compute in (F.find 1 map1).
Eval compute in (F.mem 1 map1).

Eval compute in (F.map (@length _) map1).(F.this).

(* Not in Ocaml's map: [elements] *)

Eval compute in (F.elements (F.map (@length _) map1)).

(* ... and [map2] *)

Check F.map2.

(* Unlike keys, we need no particular structure over datas.
    Only two exceptions: [equal] and [compare]. *)

Check F.equal.

(* Concerning [compare], we need a ternary decidable comparison
 over datas. We hence diverge slightly apart from Ocaml, by placing
 this [compare] in a separate functor requiring 2 [OrderedType],
 one for the keys and one for the datas, see FMapAVL.Make_ord *)

(* FMaps also come with additional properties in the same spirit as for
   FSets, see file FMapFacts.v *)

(** How to get more efficient AVL trees after extraction :
     the [Int] module to get rid of [Z] not-so-fast integers. *)

(* [FSetAVL] now uses an abstract [Int] structure for every height of trees.
   This gives a first [FSetAVL.IntMake(I:Int)(X:OrderedType)].
   Then the [Int] part can either be filled with [Z_as_Int] for computing
   in Coq, giving the above [FSetAVL.Make], or instead extracted as is,
   and filled after extraction by some fast ocaml code based on machine
   integers.
*)

Print R.tree.
Eval compute in Int.Z_as_Int.t.

(*excerpt from Int.v*)
Module Type Int.

 Parameter t : Set.

 Parameter i2z : t -> Z.

 Parameter _0 : t.
 Parameter _1 : t.
 Parameter plus : t -> t -> t.
 Parameter opp : t -> t.
 Parameter minus : t -> t -> t.
 Parameter mult : t -> t -> t.
 Parameter max : t -> t -> t.

(* Concerning logical relations, there is no need for additional
   parameters: we take directly advantage of the [Z] ones, via
   [i2z]. This simplifies the writing of translation tactics from
   [t] to [Z].  *)

 Notation "x == y" := (i2z x = i2z y)
   (at level 70, y at next level, no associativity) : Int_scope.
 Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
 Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
 Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
 Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.

 (* We also need some decidability facts. *)

 Open Scope Int_scope.
 Parameter gt_le_dec : forall x y: t, {x > y} + {x <= y}.
 Parameter ge_lt_dec :  forall x y : t, {x >= y} + {x < y}.
 Parameter eq_dec : forall x y : t, { x == y } + {~ x==y }.
 Open Scope Z_scope.

 (* Specification of previous parameters. *)

 (* First, [i2z] is an injection. *)

 Axiom i2z_eq : forall n p, n == p -> n = p.

 (* Then, all the operators are morphisms. *)

 Axiom i2z_0 : i2z _0 = 0.
 Axiom i2z_1 : i2z _1 = 1.
 Axiom i2z_plus : forall n p, i2z (plus n p) = i2z n + i2z p.
 Axiom i2z_opp : forall n, i2z (opp n) = -i2z n.
 Axiom i2z_minus : forall n p, i2z (minus n p) = i2z n - i2z p.
 Axiom i2z_mult : forall n p, i2z (mult n p) = i2z n * i2z p.
 Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).

End Int.
(*/excerpt*)

(** * The Weak Sets and Maps *)

(* Sometimes, one may need finite sets and maps over a base type
   that does not come with a decidable order. As long as this type
   can still be equipped with a decidable equality, the FSetWeak and
   FMapWeak counterparts of FSets and FMap provides such structures.
*)

Module W := FSetWeakList.Make (Z_as_DT).

(* Of course, we cannot provide efficient functions anymore : the
   underlying structure is unsorted lists (but without redundancies). *)

Eval compute in (W.elements (W.add 1 (W.add 3 (W.add 2 W.empty)))).

(* Apart from efficiency questions and the lack of order-related functions
   like [min_elt], FSetWeak/FMapWeak are as close as possible
   to FSet/FMap (same function signatures, same properties, etc).
*)


From mathcomp Require Import all_ssreflect.
From Equations Require Import Equations.
Require Import Arith.
Import Wellfounded.

Section wf_rel.

Variable T : finType.

Variable rel : T -> T -> bool.

Hypothesis rel_trans :
  forall (t1 t2 t3 : T), rel t1 t2 -> rel t2 t3 -> rel t1 t3.

Hypothesis rel_anti_refl :
  forall (t : T), ~ rel t t.

Definition rel_inv (t1 t2 : T) := rel t2 t1.

Definition subSetRel (t : T) := finset (rel_inv t).

Lemma decrease_card :
  forall (t1 t2 : T),
  t2 \in subSetRel t1 -> #|subSetRel t2| < #|subSetRel t1|.
Proof.
move => t1 t2 h.
rewrite /subSetRel in_set /rel_inv in h.
have proper : subSetRel t2 \proper subSetRel t1.
  have subset : subSetRel t2 \subset subSetRel t1.
    apply /subsetP.
    rewrite /subSetRel /sub_mem => x.
    rewrite !in_set /rel_inv => in1.
    by apply: (rel_trans x t2 t1).
  have diff : subSetRel t2 != subSetRel t1.
    rewrite eqEsubset.
    apply /nandP.
    rewrite subset /=.
    apply /orP.
    rewrite /=.
    apply /subsetPn.
    exists t2.
      by rewrite in_set.
    rewrite in_set /rel_inv.
    apply/negP.
    by apply: rel_anti_refl.
  by rewrite properEneq subset diff.
rewrite properEcard in proper.
move/andP: proper.
move => proper.
destruct proper.
apply: H0.
Qed.

Definition f (t : T) : nat := #|subSetRel t|.

Definition rel_in_nat (t1 t2 : T) :=  lt (f t1) (f t2).

Lemma rel_to_nat : Relation_Definitions.inclusion T rel rel_in_nat.
Proof.
rewrite /Relation_Definitions.inclusion.
move => t1 t2 h.
rewrite /rel_in_nat /f.
apply /ltP.
apply: decrease_card.
by rewrite in_set /rel_inv.
Qed.

Lemma wf_rel_in_nat : well_founded rel_in_nat.
Proof.
rewrite /rel_in_nat.
apply: (wf_inverse_image T nat lt f).
by apply: lt_wf.
Qed.

Lemma wf_rel : well_founded rel.
Proof.
apply: wf_incl.
apply: rel_to_nat.
by apply : wf_rel_in_nat.
Qed.

End wf_rel.


(* -- DISCLAIMER: definitions in this file remain to be renamed,
      e.g. mmin and mmax. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Minimum/Maximum w.r.t. an order relation                                *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibReflect LibOperation
  LibRelation LibOrder LibEpsilon.
Generalizable Variables A.

(* This module offers the functions [mmin] and [mmax] which produce
   the minimum and maximum elements of a non-empty, bounded set. *)

(**************************************************************************)
(* * Lower bound and minimum*)

(* [lower_bound le P x] means that [x] is a lower bound for the
   set [P] with respect to the ordering [le]. *)

Definition lower_bound A (le:binary A) (P:A->Prop) (x:A) :=
  forall y, P y -> le x y.

(* [min_element le P x] means that [x] is a minimal element of
   [P], i.e., it is both a member of [P] and a lower bound for
   [P]. *)

Definition min_element A (le:binary A) (P:A->Prop) (x:A) :=
  P x /\ lower_bound le P x.

(* [mmin le P] is a minimal element of [P] with respect to [le],
   when such an element exists. *)

Definition mmin `{Inhab A} (le:binary A) (P:A->Prop) :=
  epsilon (min_element le P).

(**************************************************************************)
(* * Upper bound and maximum *)

(* [upper_bound le P x] means that [x] is a lower bound for the
   set [P] with respect to the ordering [le]. *)

Definition upper_bound A (le:binary A) (P:A->Prop) (x:A) :=
  forall y, P y -> le y x.

(* [max_element le P x] means that [x] is a maximal element of
   [P], i.e., it is both a member of [P] and a lower bound for
   [P]. *)

Definition max_element A (le:binary A) (P:A->Prop) (x:A) :=
  P x /\ upper_bound le P x.

(* [mmax le P] is a minimal element of [P] with respect to [le],
   when such an element exists. *)

Definition mmax `{Inhab A} (le:binary A) (P:A->Prop) :=
  epsilon (max_element le P).

(**************************************************************************)
(* * Least upper bound and greatest lower bound *)

(* [lub le P x] means that [x] is a least upper bound
   for the set [P] with respect to the ordering [le]. *)

Definition lub A (le:binary A) (P:A->Prop) (x:A) :=
  min_element le (upper_bound le P) x.

(* [glb le P x] means that [x] is a greatest lower bound
   for the set [P] with respect to the ordering [le]. *)

Definition glb A (le:binary A) (P:A->Prop) (x:A) :=
  max_element le (lower_bound le P) x.

(**************************************************************************)
(* * Connexion between lower and bounds *)

Lemma upper_bound_inverse : forall A (le:binary A),
  upper_bound le = lower_bound (inverse le).
Proof using.
  extens. intros P x. unfolds lower_bound, upper_bound. iff*.
Qed.

Lemma max_element_inverse : forall A (le:binary A) (P:A->Prop) (x:A),
  max_element le P x = min_element (inverse le) P x.
Proof using.
  extens. unfold max_element, min_element. rewrite* upper_bound_inverse.
Qed.

Lemma mmax_inverse : forall `{Inhab A} (le:binary A) (P:A->Prop),
  mmax le P = mmin (inverse le) P.
Proof using.
  intros. applys epsilon_eq. intros x. rewrite* max_element_inverse.
Qed.

(**************************************************************************)
(* * Elimination roperties *)

(* [bounded_has_minimal le] means that, at type [A], it is
   the case that every non-empty set that admits a lower
   bound has a minimal element. *)

Definition bounded_has_minimal A (le:binary A) :=
  (* Recall that [ex P] means that [P] has an inhabitant; i.e.,
     it is equivalent to [exists x, P x]. *)
  forall P,
  ex P ->
  ex (lower_bound le P) ->
  ex (min_element le P).

(* If the set [P] is non-empty and admits a lower bound, and if the type
   [A] is such that every such set has a minimal element, then [P] has a
   minimal element, and this element is [mmin le P]. *)

Lemma mmin_spec : forall `{Inhab A} (le:binary A) (P:A->Prop) m,
  m = mmin le P ->
  ex P ->
  ex (lower_bound le P) ->
  bounded_has_minimal le ->
  min_element le P m.
Proof using.
  intros. subst. unfold mmin. epsilon* m.
Qed.

(**************************************************************************)
(* * Application to [nat] *)

From TLC Require Import LibNat.

(* The type [nat] enjoys this property. *)

Lemma increment_lower_bound_nat : forall (P : nat->Prop) x,
  lower_bound le P x ->
  ~ P x ->
  lower_bound le P (x + 1)%nat.
Proof using.
  introv hlo ?. intros y ?.
  destruct (eq_nat_dec x y).
    { subst. tauto. }
    { forwards: hlo; eauto. nat_math. }
Qed.

Lemma bounded_has_minimal_nat :
  @bounded_has_minimal nat le.
Proof using.
  (* Assume a set [P], such that [y] is an inhabitant of [P]
     and [x] is a lower bound for [P]. *)
  intros P [ y ? ].
  (* We reason by induction on the difference [y + 1 - x].
     Reasoning with [y - x] would work too, but this choice
     is more elegant, as it makes the base case a contradiction,
     and avoids a little duplication. *)
  cut (
    forall (k x : nat), (y + 1 - x)%nat = k ->
    lower_bound le P x ->
    exists z, min_element le P z
  ). { intros ? [ x ? ]. eauto. }
  induction k; introv ? hlo.
  (* Base. *)
  (* Our hypotheses imply that [x] must be less than or equal to
     [y]. Because in this case the difference [y + 1 - x] is zero,
     this leads to a contradiction. *)
  { false. forwards: hlo; eauto. nat_math. }
  (* Step. *)
  (* Eeither [P x] holds, or it does not. If it does, then [x]
     is the desired minimal element. If it does not, this implies
     that [x + 1] is a lower bound for [P], and the induction
     hypothesis can be used. *)
  destruct (prop_inv (P x)).
    { exists x. split; eauto. }
    { eapply (IHk (x + 1)%nat). nat_math. eauto using increment_lower_bound_nat. }
Qed.

#[global]
Hint Resolve bounded_has_minimal_nat : bounded_has_minimal.

(* Furthermore, at type [nat], every set admits a lower bound. *)

Lemma admits_lower_bound_nat : forall (P : nat->Prop),
  ex (lower_bound le P).
Proof using.
  exists 0%nat. unfold lower_bound. nat_math.
Qed.

#[global]
Hint Resolve admits_lower_bound_nat : admits_lower_bound.

(* At type [nat], every non-empty set that admits an upper bound
   has a maximal element. *)

Lemma bounded_has_maximal_nat :
  @bounded_has_minimal nat (inverse le).
Proof using.
  (* Assume a set [P], such that [y] is an inhabitant of [P]
     and [x] is an upper bound for [P]. *)
  intros P [ y ? ] [ x h ].
  assert (y <= x).
    { forwards: h. eauto. eauto. }
  (* We apply our previous result to the image of [P] through
     the function that maps [i] to [x - i]. (We note that this
     function is its own inverse.) This yields a minimal
     element [z] of this image. Thus, [x - z] is the desired
     maximal element of [P]. *)
  assert (self_inverse: forall i, i <= x -> (x - (x - i))%nat = i).
    intros. nat_math.
  forwards [ z [ ? hz ]]: (@bounded_has_minimal_nat (fun i => P (x - i)%nat)).
    { exists (x - y)%nat. rewrite self_inverse by eauto. eauto. }
    { eauto using admits_lower_bound_nat. }
  exists (x - z)%nat.
  clear dependent y.
  split; [ assumption | ].
  intros y ?.
  assert (y <= x).
    { forwards: h. eauto. eauto. }
  forwards: hz (x - y)%nat.
    { rewrite self_inverse by eauto. eauto. }
  unfold inverse. nat_math.
Qed.

#[global]
Hint Resolve bounded_has_maximal_nat : bounded_has_minimal.

Lemma mmin_spec_nat:
  forall (P:nat->Prop) m,
  m = mmin le P ->
  ex P ->
  P m /\ (forall x, P x -> m <= x).
Proof using.
  introv E Q. applys (@mmin_spec _ _ _ P m E Q).
  applys admits_lower_bound_nat.
  applys bounded_has_minimal_nat.
Qed.

(**************************************************************************)
(* * Typeclasses *)

(* [MMin P] is [mmin le P], in a context where the desired
   ordering can be inferred. *)

Definition MMin `{Inhab A} `{Le A} := mmin le.

(* [MMax P] is [mmax le P], in a context where the desired
   ordering can be inferred. *)

Definition MMax `{Inhab A} `{Le A} := mmax le.


Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Nat.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Algebra.Matrix.

Require Import UniMath.Algebra.Domains_and_Fields.
Require Import UniMath.Algebra.Matrix.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Algebra.IteratedBinaryOperations.

Require Import UniMath.Algebra.GaussianElimination.Auxiliary.
Require Import UniMath.Algebra.GaussianElimination.Vectors.
Require Import UniMath.Algebra.GaussianElimination.Matrices.
Require Import UniMath.Algebra.GaussianElimination.Elimination.

(**
  In this module, we define a back-substitution procedure that works on
  nxn matrices that are upper triangular with all non-zero diagonal.

  We use this procedure to show that any nxn matrix either not invertible,
  or calculate its inverse.

  Primary Author: Daniel @Skantz (November 2022)
*)

Definition matrix_inverse_or_non_invertible_stmt
  { n : nat } {F : fld}
  (A : Matrix F n n)
  := coprod (@matrix_inverse F n A)
            (@matrix_inverse F n A -> empty).

Definition back_sub_stmt
  { n : nat } {F : fld}
  (mat : Matrix F n n)
  (vec : Vector F n)
  (ut : @is_upper_triangular F _ _ mat)
  (df : @diagonal_all_nonzero F _ mat)
  := ∑ v : (Vector F n),
    (@matrix_mult F _ _ mat _ (col_vec v)) = (col_vec vec).

Section BackSub.

  Context (F : fld).

  Local Notation Σ := (iterop_fun (@ringunel1 F) op1).
  Local Notation "A ** B" := (@matrix_mult F _ _ A _ B) (at level 40, left associativity).
  Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity).

  (** output: a solution [x]_[row] to [mat ** x = b]_[row] if one exists
     - given mat upper triangular, non-zero diagonal. Later applied inductively in [back_sub]. *)
  Definition back_sub_step { n : nat } ( row : (⟦ n ⟧)%stn )
    (mat : Matrix F n n) (x : Vector F n) (b : Vector F n) : Vector F n.
  Proof.
    intros i.
    destruct (nat_eq_or_neq row i).
    - exact (((b i) * fldmultinv' (mat i i))
           - ((Σ (mat i *pw x) - (x  i)* (mat i i))
           * (fldmultinv' (mat i i))))%ring.
    - exact (x i).
  Defined.

  (** procedure gives [x_i] s.t. [(mat ** x)_i = b_i], given previous assumptions *)
  Lemma back_sub_step_inv0 { n : nat }
    (row : ⟦ n ⟧%stn) (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    (p: @is_upper_triangular F n n mat)
    (p' : (mat row row != 0)%ring)
    : (mat ** (col_vec (back_sub_step row mat x b))) row = (col_vec b) row.
  Proof.
    unfold back_sub_step, col_vec.
    unfold fldmultinv'.
    rewrite matrix_mult_eq; unfold matrix_mult_unf, pointwise.
    set (m := n - (S row)).
    assert (split_eq : n = (S row) + m).
    { unfold m.
      rewrite natpluscomm, minusplusnmm.
      - apply idpath.
      - exact (pr2 row). }
    destruct (stn_inhabited_implies_succ row)
      as [s_row s_row_eq], (!s_row_eq).
    apply funextfun; intros ?.
    rewrite (@vecsum_dni _ (s_row) _ row)
    , nat_eq_or_neq_refl.
    destruct (fldchoice0 _) as [? | neq].
    {contradiction. }
    etrans.
    { apply maponpaths_2; apply maponpaths.
      apply funextfun; intros q.
      unfold funcomp.
      now rewrite (nat_eq_or_neq_right (dni_neq_i row q)). }
    rewrite (@vecsum_dni F (s_row) _ row).
    etrans.
    { apply maponpaths.
      etrans.
      { apply maponpaths.
        rewrite (@ringcomm2 F).
        apply maponpaths.
        now rewrite (@ringcomm2 F). }
      apply (@ringminusdistr' F (mat row row)).
    }
    etrans.
    { apply maponpaths; apply map_on_two_paths.
      - rewrite <- (@rigassoc2 F), (@fldmultinvrax F).
      { now rewrite (@riglunax2 F). }
      - apply maponpaths.
        rewrite <- (@rigassoc2 F), (@fldmultinvrax F).
        apply (@riglunax2 F). }
    etrans.
    { do 3 apply maponpaths.
      now rewrite (@rigcomm2 F), (@ringplusminus F). }
    rewrite (@rigcomm1 F); rewrite (@rigassoc1 F).
    now rewrite (@ringlinvax1 F), (@rigrunax1 F).
  Defined.

  (** [back_sub_step] only modifies target element *)
  Lemma back_sub_step_inv1
    { n : nat } (row : ⟦ n ⟧%stn)
    (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    : ∏ i : ⟦ n ⟧%stn, i ≠ row ->
      (col_vec (back_sub_step row mat x b) i = (col_vec x) i).
  Proof.
    intros i ne.
    unfold back_sub_step, col_vec.
    apply funextfun. intros j; simpl.
    destruct (nat_eq_or_neq row i) as [eq | ?];
      try apply idpath.
    rewrite eq in ne.
    contradiction (isirrefl_natneq _ ne).
  Defined.

  Lemma back_sub_step_inv2
    { n : nat }
    (row : ⟦ n ⟧%stn)
    (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    (is_ut: @is_upper_triangular F n n mat)
    : ∏ i : ⟦ n ⟧%stn, i ≥ row
    -> (mat i i != 0)%ring
    -> (mat ** (col_vec x)) i = (col_vec b) i
    -> (mat ** (col_vec (back_sub_step row mat x b))) i = (col_vec b) i.
  Proof.
    unfold transpose, flip.
    intros i le neq0 H.
    rewrite <- H.
    destruct (natlehchoice row i) as [lt | eq]. {apply le. }
    - rewrite matrix_mult_eq in *.
      apply pathsinv0.
      rewrite matrix_mult_eq.
      unfold matrix_mult_unf in *.
      apply funextfun; intros ?.
      apply maponpaths, funextfun; intros i'.
      destruct (stn_eq_or_neq i' (row)) as [eq | neq].
      2 : { now rewrite back_sub_step_inv1. }
      rewrite is_ut. 2: { rewrite eq. assumption. }
      do 2 rewrite (@rigmult0x F).
      apply idpath.
    - rewrite (stn_eq _ _ eq)
      , back_sub_step_inv0; try assumption.
      now rewrite H.
  Defined.

  (** Back-substituting repeatedly using step procedure defined earlier.
      Carries an additional [row] parameter that allows for partially applying the substition,
      that is used later for showing that diagonal must be non-zero. *)
  Definition back_sub_internal
    { n : nat }
    (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    (sep : ⟦ S n ⟧%stn)
    (row : ⟦ S n ⟧%stn)
    : Vector F n.
  Proof.
    destruct sep as [sep p].
    induction sep as [| m IH]. {exact x. }
    destruct (natlthorgeh (dualelement (m,, p)) row).
    2: {exact x. }
    refine (back_sub_step (dualelement (m,, p)) mat (IH _) b).
    apply (istransnatlth _ _ _ (natgthsnn m) p).
  Defined.

  Lemma back_sub_internal_inv0
    { n : nat }
    (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    (ut : @is_upper_triangular F _ _ mat)
    (sep : ⟦ S n ⟧%stn)
    (row : ⟦ S n ⟧%stn)
    : ∏ (i : ⟦ n ⟧%stn), i >= row
    -> (col_vec (back_sub_internal mat x b sep row)) i = (col_vec x) i.
  Proof.
    destruct sep as [sep p].
    induction sep as [| sep IH].
    { intros i H; now destruct (natchoice0 (S n)) in H. }
    unfold back_sub_internal.
    intros i i_lt_row.
    rewrite nat_rect_step.
    destruct (natlthorgeh _ _) as [lt | geh].
    2: {reflexivity. }
    assert (p': sep < S n). { apply (istransnatlth _ _ _ (natgthsnn sep) p). }
    rewrite <- (IH p'); try assumption.
    unfold back_sub_internal.
    rewrite back_sub_step_inv1; try easy.
    {apply maponpaths_2, maponpaths, proofirrelevance, propproperty. }
    apply natgthtoneq.
    refine (natlthlehtrans _ _ _ lt i_lt_row).
  Defined.

  Lemma back_sub_internal_inv1
    { n : nat }
    (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    (ut : @is_upper_triangular F _ _ mat)
    (sep : ⟦ S n ⟧%stn)
    (row : ⟦ S n ⟧%stn)
    : ∏ i : stn n, i >= row
    -> (back_sub_internal mat x b sep row) i = x i.
  Proof.
    intros.
    rewrite (@col_vec_inj_pointwise F n
      (back_sub_internal mat x b sep row) x i).
    - apply idpath.
    - now apply (back_sub_internal_inv0).
  Defined.

  Lemma back_sub_internal_inv2
    { n : nat }
    (mat : Matrix F n n)
    (x : Vector F n) (b : Vector F n)
    (ut : @is_upper_triangular F _ _ mat)
    (sep : ⟦ S n ⟧%stn)
    (row : ⟦ S n ⟧%stn)
    : ∏ (i : ⟦ n ⟧%stn), i ≥ (dualelement sep)
    -> (mat i i != 0)%ring
    -> i < row
    -> (mat ** (col_vec (back_sub_internal mat x b sep row))) i = (col_vec b) i.
  Proof.
    unfold transpose, flip.
    intros i i_le_sep neq0 lt.
    unfold back_sub_internal.
    destruct sep as [sep p].
    induction sep as [| sep IH].
    { apply fromempty, (dualelement_sn_stn_nge_0 _ _ i_le_sep). }
    rewrite nat_rect_step.
    destruct (natlehchoice (dualelement (sep,, p)) i) as [leh | eq].
    { refine (istransnatleh _ i_le_sep).
      now apply (@dualelement_sn_le). }
    - destruct (natlthorgeh _ _) as [? | contr_geh].
      2 : { contradiction (isirreflnatlth _
              (natlthlehtrans _ _ _ (istransnatlth _ _ _ leh lt) contr_geh)).
      }
      rewrite back_sub_step_inv2; try easy.
      { unfold dualelement. unfold dualelement in leh.
        destruct (natchoice0 _) as [contr_eq | ?].
        {apply fromstn0. now rewrite contr_eq. }
        now apply natgthtogeh. }
      rewrite IH; try reflexivity.
        now apply dualelement_lt_to_le_s.
    - destruct (natlthorgeh _ _) as [? | contr_geh].
      + rewrite (stn_eq _ _ eq).
        now rewrite back_sub_step_inv0.
      + rewrite <- (stn_eq _ _ eq) in lt.
        contradiction (isirreflnatlth _ (natlthlehtrans _ _ _ lt contr_geh)).
  Defined.

  Definition back_sub
    {n : nat}
    (mat : Matrix F n n)
    (vec : Vector F n)
  := back_sub_internal mat vec vec (n,, natgthsnn _) (n,, natgthsnn _).

  Lemma back_sub_inv0
    { n : nat }
    (mat : Matrix F n n) (b : Vector F n)
    (ut : @is_upper_triangular F _ _ mat)
    (df : @diagonal_all_nonzero F _ mat)
    : back_sub_stmt mat b ut df.
  Proof.
    exists (back_sub mat b).
    intros; unfold back_sub.
    destruct (natchoice0 n) as [eq0 | ?].
    { apply funextfun. intros i. apply fromstn0. now rewrite eq0. }
    apply funextfun; intros i.
    apply back_sub_internal_inv2;
      try assumption; unfold dualelement; try easy.
    2: {exact (pr2 i). }
    destruct (natchoice0 _) as [eq0 | ?].
    { apply fromempty; now apply negpaths0sx in eq0. }
    simpl; now rewrite natminuseqn, minuseq0'.
  Defined.

End BackSub.

Section BackSubZero.

  (** First, Helper functions for finding first zero value in a vector.
      Then proof we can't have invertible, upper triangular matrix unless
      non-zero diagonal *)

  Context (F : fld).

  Local Notation Σ := (iterop_fun (@ringunel1 F) op1).
  Local Notation "A ** B" := (@matrix_mult F _ _ A _ B) (at level 40, left associativity).
  Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity).
  Local Notation "0" := (@rigunel1 F).

  (* For using nonzeroax *)
  Local Definition flip_fld_bin
    (e : F) : F.
  Proof.
  destruct (fldchoice0 e).
  - exact 1%ring.
  - exact 0%ring.
  Defined.

  Local Definition flip_fld_bin_vec
  {n : nat} (v : Vector F n) := λ i : (stn n), flip_fld_bin (v i).

  (* Below, we find the first zero value in a vector [v] by looking for the leading element
     in the transformed vector. Perhaps not a pretty solution, maybe we instead want to generalize
     the notion of leading entry. *)

  Local Definition vector_all_nonzero_compute_internal
  {n : nat} (v : Vector F n)
  : coprod (∏ j : (stn n), (v j) != 0%ring)
          (∑ i : (stn n), ((v i) = 0%ring)
        × (forall j : stn n, (j < (pr1 i) -> (v j) != 0%ring))).
  Proof.
  pose (leading_entry := leading_entry_compute F (flip_fld_bin_vec v)).
  destruct (maybe_choice' leading_entry) as [some | none].
  - right; use tpair; simpl. {apply some. }
    destruct (@leading_entry_compute_inv2 F _ (flip_fld_bin_vec v) (pr1 some) (pr2 some))
      as [some_neq_0 prev_eq_0].
    unfold is_leading_entry, flip_fld_bin_vec, flip_fld_bin in * |-.
    destruct (fldchoice0 (v _)); try contradiction.
    use tpair; try assumption.
    intros ? lt.
    specialize (prev_eq_0 _ lt).
    now destruct (fldchoice0 (v j)).
  - left; intros j.
    rewrite <- (@leading_entry_compute_inv1 _ _ (flip_fld_bin_vec v) none j).
    try apply (pr2 (dualelement j)).
    destruct (fldchoice0 (v j)) as [eq | neq];
      unfold is_leading_entry, flip_fld_bin_vec, flip_fld_bin in *
      ; destruct (fldchoice0 _); try assumption.
    + rewrite eq; intros contr_neq.
      contradiction (nonzeroax _ (pathsinv0 contr_neq)).
    + destruct (fldchoice0 (v j)) as [contr_eq | ?].
      * rewrite contr_eq in neq.
        contradiction.
      * contradiction.
  Defined.

  Local Definition vector_all_nonzero_compute
  {n : nat} (v : Vector F n)
  : coprod (∏ j : (stn n), (v j) != 0%ring)
           (∑ i : (stn n), (v i)  = 0%ring).
  Proof.
    destruct (@vector_all_nonzero_compute_internal n v) as [l | r]. {now left. }
    right; exists (pr1 r); exact (pr1 (pr2 r)).
  Defined.

  (** Showing that right invertible matrix, upper triangular,
     must have all non-zero diagonal. *)

  (** Ax = 0 would have two solutions for x, but A invertible... *)
  Lemma back_sub_zero
    { n : nat }
    (mat : Matrix F n n)
    (ut : @is_upper_triangular F _ _ mat)
    (zero: ∑ i : stn n, (mat i i = 0)%ring
      × (forall j : stn n, j < i -> ((mat j j) != 0)%ring))
    (inv : @matrix_left_inverse F _ _ mat)
    : empty.
  Proof.
    unfold transpose, flip.
    destruct (natchoice0 (pr1 zero)) as [eq0_1 | gt].
    { apply (zero_row_to_non_right_invertibility (transpose mat) (pr1 zero));
        try assumption.
      2: { now apply (@matrix_left_inverse_to_transpose_right_inverse F). }
      apply funextfun; intros k.
      destruct (natchoice0 k) as [eq0_2 | ?].
      - rewrite <- (pr1 (pr2 zero)).
        unfold const_vec.
        rewrite eq0_1 in eq0_2.
        now rewrite (stn_eq _ _ eq0_2).
      - unfold transpose, flip.
        rewrite ut; try reflexivity.
        now rewrite <- eq0_1.
    }
    assert (contr_exists :  ∑ x : (Vector F n), (∑ i' : stn n,
      (x i' != 0) × (mat ** (col_vec x)) = (@col_vec F _ (const_vec 0)))).
    2: { assert (eqz : (mat ** (@col_vec F _ (const_vec 0)))
          = (@col_vec F _ (const_vec 0))).
        { rewrite matrix_mult_eq; unfold matrix_mult_unf.
          apply funextfun; intros k.
          unfold col_vec, const_vec.
          etrans.
          { rewrite vecsum_eq_zero.
            - apply idpath.
            - intros ?; apply rigmultx0. }
          reflexivity.
        }
        assert (contr_eq' : (@ringunel1 F) != (@ringunel1 F)).
        2: {contradiction. }
        rewrite <- eqz in contr_exists.
        destruct contr_exists as [x1 [x2 [x3 contr_exists]]].
        destruct inv as [inv isinv].
        rewrite <- contr_exists in eqz.
        assert (eq : @matrix_mult F _ _ inv _
          (@matrix_mult F _ _ mat _ (col_vec x1)) =
           @matrix_mult F _ _ inv _ (@col_vec F _ (const_vec 0))).
        {now rewrite eqz. }
        rewrite <- matrix_mult_assoc, isinv, matlunax2 in eq.
        pose (eq' := @matrix_mult_zero_vec_eq _ _ _ inv).
        unfold col_vec, const_vec in * |-.
        rewrite eq' in eq.
        destruct zero as [zero iszero].
        apply toforallpaths in eq.
        set (idx0 := (make_stn _ 0 (stn_implies_ngt0 zero))).
        assert (contr_eq' :
          (λ (_ : _) (_ : _), (@rigunel1 F)) idx0 =
          (λ (_ : _) (_ : (⟦ 1 ⟧)%stn), x1 x2) idx0
        ). { now rewrite eq. }
        apply toforallpaths in contr_eq'.
        rewrite contr_eq' in x3.
        2: { exact (make_stn _ _ (natgthsnn 0)). }
        contradiction.
    }
    destruct zero as [zero iszero].
    use tpair.
    { apply back_sub_internal.
      - exact mat.
      - intros j.
        destruct (natlthorgeh (pr1 zero) j).
        + exact 0.
        + destruct (natgehchoice (pr1 zero) j); try assumption.
          * exact 0.
          * exact (@rigunel2 F).
      - exact (const_vec 0).
      - exact (n,, natgthsnn _).
      - exact (pr1 zero,, (istransnatlth _ _ _ (pr2 zero) (natgthsnn _))).
    }
    exists zero.
    use tpair.
    - rewrite back_sub_internal_inv1; try assumption.
      2: {apply isreflnatleh. }
      destruct (natlthorgeh _ _) as [lt | ge].
      * contradiction (isirreflnatgth _ lt).
      * simpl; clear gt. destruct (natgehchoice _ _) as [gt | eq].
        {contradiction (isirreflnatlth _ gt). }
        apply (@nonzeroax F).
    - apply funextfun; intros j.
      destruct (natlthorgeh j zero) as [? | ge].
      + rewrite back_sub_internal_inv2; try easy.
        * apply dualelement_sn_stn_ge_n.
        * now apply (pr2 iszero).
      + rewrite matrix_mult_eq; unfold matrix_mult_unf.
        unfold col_vec, const_vec.
        apply funextfun; intros ?.
        eapply (@vecsum_eq_zero F).
        intros k.
        destruct (natgthorleh j k) as [? | le].
        {rewrite ut; try assumption; apply rigmult0x. }
        destruct (stn_eq_or_neq (zero) k) as [eq | ?].
        * rewrite <- eq in *.
          rewrite <- (stn_eq _ _ (isantisymmnatgeh _ _ le ge)).
          rewrite (pr1 iszero); apply rigmult0x.
        * etrans. 2: {apply rigmultx0. }
          apply maponpaths.
          rewrite back_sub_internal_inv1; try assumption.
          2: {apply (istransnatleh ge le). }
          destruct (natlthorgeh _ _) as [? | ?]; try reflexivity.
          destruct (natgehchoice _ _) as [? | eq];
            try reflexivity.
          rewrite (stn_eq _ _ eq) in * |-.
          contradiction (isirrefl_natneq k).
  Defined.

End BackSubZero.

(** Some results that are useful in the next section. *)
Section Misc.

  Context (F: fld).

  (** Row echelon form implies upper triangularity*)
  Lemma row_echelon_partial_to_upper_triangular_partial
    { m n : nat }
    (mat : Matrix F m n)
    (p : n > 0)
    (iter : ⟦ S m ⟧%stn)
    : @is_row_echelon_partial F m n mat iter
   -> @is_upper_triangular_partial F m n iter mat.
  Proof.
    unfold is_row_echelon_partial, is_upper_triangular_partial.
    destruct iter as [iter p'].
    unfold is_row_echelon_partial_1, is_row_echelon_partial_2.
    induction iter as [| iter IH].
    { intros ? ? ? ? contr; contradiction (negnatlthn0 n contr). }
    intros [re_1 re_2] i j lt lt'.
    simpl in p'.
    pose (iter_lt_sn := (istransnatlth _ _ _ p' (natgthsnn m))).
    destruct (natlehchoice i iter) as [? | eq]. {now apply natlthsntoleh. }
    - destruct (maybe_choice' (leading_entry_compute _ (mat i))) as [t | none].
      + destruct t as [t eq].
        rewrite (IH iter_lt_sn); try easy.
        use tpair; simpl.
        * intros i_1 i_2 j_1 j_2 i1_lt_iter H ? ?.
          rewrite (re_1 i_1 i_2 j_1 j_2); try easy.
          apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn iter)).
        * intros i_1 i_2 i1_lt_iter ? ?; rewrite (re_2 i_1 i_2); try easy.
          apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn iter)).
      + now rewrite (leading_entry_compute_inv1 _ _ none).
    - assert (eq' : i = (iter,, p')). { apply subtypePath_prop; apply eq. }
      destruct (maybe_choice' (leading_entry_compute F (mat i))) as [[t jst] | none].
      2: { now rewrite (leading_entry_compute_inv1 _ _ none). }
      destruct (natlthorgeh j t) as [j_lt_t | contr_gt].
      { rewrite (pr2 (leading_entry_compute_inv2 _ _ _ jst)); try easy. }
      pose (H1 := leading_entry_compute_inv2 _ _ _ jst).
      destruct (natchoice0 i) as [contr0 | ?].
      { apply fromempty; refine (negnatgth0n _ _); rewrite contr0; apply lt. }
      destruct (prev_stn i) as [u u_lt]; try assumption.
      destruct (maybe_choice' (leading_entry_compute _ (mat u)))
        as [[prev eq''] | none_prev].
      + pose (H2 := (leading_entry_compute_inv2 _ _ _ eq'')).
        contradiction (pr1 H2); rewrite (IH iter_lt_sn); try easy.
        * use tpair; simpl.
          -- intros i_1 i_2 j_1 j_2 i1_lt_iter H' ? ?.
             rewrite (re_1 i_1 i_2 j_1 j_2); try easy.
             apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn iter)).
          -- intros i_1 i_2 i1_lt_iter ? ?; rewrite (re_2 i_1 i_2); try easy.
             apply (istransnatlth _ _ _ i1_lt_iter (natgthsnn _)).
        * destruct (natgthorleh u prev) as [gt | leh]; try assumption.
          contradiction (pr1 H1); rewrite (re_1 u i t prev); try easy.
          -- apply natgehsntogth; rewrite u_lt, eq'; apply natgehsnn.
          -- apply natgehsntogth; rewrite u_lt, eq'; apply isreflnatleh.
          -- destruct (natgthorleh t prev) as [gt | leh']; try assumption.
             apply (istransnatleh contr_gt); refine (istransnatleh _ leh).
             apply natlehsntolth, natlthsntoleh; rewrite u_lt; apply lt.
        * apply natgehsntogth; rewrite u_lt, eq'; apply (isreflnatleh).
      + rewrite (re_2 u i ); try easy.
        * simpl; apply natlthtolths. rewrite <- eq.
          try apply (natlehlthtrans _ _ _ contr_gt lt ).
          apply natgehsntogth; rewrite u_lt, eq'; apply isreflnatleh.
        * apply funextfun; intros j';
          rewrite ((leading_entry_compute_inv1 _ _ none_prev) j');
          reflexivity.
        * try apply (natlehlthtrans _ _ _ contr_gt lt).
          apply natgehsntogth; rewrite u_lt, eq'; apply isreflnatleh.
  Defined.

  Lemma row_echelon_to_upper_triangular
    { m n : nat }
    (mat : Matrix F m n)
    : is_row_echelon mat
    -> @is_upper_triangular F _ _ mat.
  Proof.
    destruct (natchoice0 n) as [contr_eq0 | p].
    { intros ? ? j; apply fromstn0; now rewrite contr_eq0. }
    intros H; unfold is_upper_triangular; intros.
    rewrite (row_echelon_partial_to_upper_triangular_partial mat p (m,, natgthsnn _))
    ; try easy. 2: {exact (pr2 i). }
    use tpair; intros i_1 i_2 j_1 j_2; intros; simpl.
    - destruct (H i_1 i_2) as [H1 _]; now rewrite (H1 j_2 j_1).
    - destruct (H i_1 i_2) as [_ H2]; now rewrite H2.
  Defined.

End Misc.

Section Inverse.

  (** Some additional properties of matrix inverses,
      having now defined Gaussian elimination and
      back-substitution.

      Computes a matrix inverse or shows it is non-invertible. *)

  Context (F : fld).

  Local Notation Σ := (iterop_fun (@ringunel1 F) op1).
  Local Notation "A ** B" := (@matrix_mult F _ _ A _ B) (at level 40, left associativity).
  Local Notation "R1 *pw R2" := ((pointwise _ op2) R1 R2) (at level 40, left associativity).

  (** Construct the inverse,
    if additionally mat is upper triangular with non-zero diagonal *)
  Definition upper_triangular_right_inverse_construction
    { n : nat }
    (mat : Matrix F n n)
    := transpose (λ i : (stn n), (back_sub _ mat (@identity_matrix F n i))).

  Lemma left_invertible_upper_triangular_to_diagonal_all_nonzero
    {n : nat }
    (A : Matrix F n n)
    (p : @is_upper_triangular F _ _ A)
    (p': @matrix_left_inverse F _ _ A)
    : (@diagonal_all_nonzero F _ A).
  Proof.
    destruct (@vector_all_nonzero_compute_internal _ _ (@diagonal_sq F _ A)) as [l | r].
    { unfold diagonal_all_nonzero; intros; unfold diagonal_sq in l; apply l. }
    unfold diagonal_sq in r; apply fromempty; now apply (@back_sub_zero _ _ A p).
  Defined.

  Lemma matrix_right_inverse_construction_inv
    { n : nat } (mat : Matrix F n n)
    (ut : @is_upper_triangular F _ _ mat)
    (df: @diagonal_all_nonzero F _ mat)
    : (mat ** (upper_triangular_right_inverse_construction mat))
      = (@identity_matrix F n).
  Proof.
    apply funextfun; intros i.
    unfold matrix_mult, row, col, transpose, flip.
    apply funextfun; intros ?.
    unfold upper_triangular_right_inverse_construction.
    rewrite (@col_vec_mult_eq F _ _ mat _ (@identity_matrix F _ x)).
    - destruct (stn_eq_or_neq i x) as [eq | neq].
      { now rewrite eq. }
      rewrite id_mat_ij; try rewrite id_mat_ij; try easy.
      apply (issymm_natneq _ _ neq).
    - unfold upper_triangular_right_inverse_construction.
      pose (back_sub_inv := @back_sub_inv0).
      destruct (natchoice0 n) as [eq | ?].
      {apply fromstn0; now rewrite eq. }
      apply (back_sub_inv _ _ _ _ ut df).
  Defined.

  Lemma matrix_left_inverse_implies_right { n : nat } (A B: Matrix F n n)
    : (B ** A) = (@identity_matrix F n)
    -> (@matrix_right_inverse F n n A).
  Proof.
    intros ?.
    destruct (natchoice0 n) as [eq0 | gt]. { destruct eq0; now use tpair. }
    pose (C := pr1 (gaussian_elimination _ A)).
    pose (is_gauss := pr2 (gaussian_elimination _ A)).
    destruct is_gauss as [inv is_re].
    pose (CA := C ** A).
    pose (D := @upper_triangular_right_inverse_construction _ CA).
    exists (D ** C).
    assert (CA_ut : is_upper_triangular CA).
    { apply (@row_echelon_to_upper_triangular _ _ _ CA), is_re. }
    assert (nonz : @diagonal_all_nonzero F _ CA).
    { apply left_invertible_upper_triangular_to_diagonal_all_nonzero;
      try assumption.
      apply left_inv_matrix_prod_is_left_inv.
      - exists (pr1 inv).
        apply (pr2 (pr2 inv)).
      - now exists B.
    }
    pose (invmat := @matrix_right_inverse_construction_inv _ _ CA_ut nonz).
    unfold CA in invmat.
    rewrite matrix_mult_assoc in invmat.
    assert (eq : (C ** A ** D) = (A ** D ** C)).
    { unfold CA in invmat. unfold D, CA.
      rewrite matrix_mult_assoc, invmat.
      pose (left_inv_eq_right := @matrix_left_inverse_equals_right_inverse).
      apply pathsinv0.
      pose (gauss_mat_invertible := inv).
      apply (matrix_inverse_to_right_and_left_inverse) in gauss_mat_invertible.
      destruct gauss_mat_invertible as [gauss_mat gauss_mat_invertible].
      pose (left_inv_eq_right_app
        := left_inv_eq_right F n _ n C gauss_mat ((A ** D),, invmat)).
      set (constr := (upper_triangular_right_inverse_construction
        (@matrix_mult F _ _ C _ A))).
      assert (eq: (@matrix_mult F _ _ A n constr) = (pr1 gauss_mat)).
      { apply pathsinv0. apply (left_inv_eq_right_app). }
      rewrite eq.
      apply gauss_mat.
    }
    refine (_ @ invmat); rewrite <- matrix_mult_assoc; refine (!eq @ _).
    apply matrix_mult_assoc.
  Defined.

  Lemma matrix_right_inverse_implies_left
    { n : nat } (A B: Matrix F n n)
    : @matrix_right_inverse F _ _ A -> (@matrix_left_inverse F _ _ A).
  Proof.
    intros [rinv isrinv].
    pose (linv := @make_matrix_left_inverse F _ _ n A rinv isrinv).
    pose (linv_to_rinv := @matrix_left_inverse_implies_right _ _ _ isrinv).
    exists rinv.
    pose (inv_eq := @matrix_left_inverse_equals_right_inverse _ n _ n _ linv linv_to_rinv).
    simpl in inv_eq; rewrite inv_eq;
    apply linv_to_rinv.
  Defined.

  Theorem matrix_inverse_or_non_invertible { n : nat }
    (A : Matrix F n n)
    : @matrix_inverse_or_non_invertible_stmt _ _ A.
  Proof.
    unfold matrix_inverse_or_non_invertible_stmt.
    destruct (natchoice0 n) as [eq0 | gt].
    { left; destruct eq0; apply (@nil_matrix_invertible F 0 A). }
    set (B:= @gauss_clear_all_rows_as_left_matrix _ _ _ A gt).
    set (BA := B ** A).
    set (C := upper_triangular_right_inverse_construction BA).
    assert (ut : is_upper_triangular BA).
    { unfold BA.
      pose (is_echelon := @gauss_clear_all_rows_inv3 F _ _ A gt).
      rewrite <- (gauss_clear_all_rows_as_matrix_eq _ _ gt) in is_echelon.
      now apply row_echelon_to_upper_triangular. }
    destruct (vector_all_nonzero_compute _ (λ i : stn n, BA i i)) as [nz | [idx isnotz]].
    - left.
      set (BAC_id := @matrix_right_inverse_construction_inv _ _ ut nz).
      assert (rinv_eq : (C ** BA) = identity_matrix).
      { apply (@matrix_right_inverse_implies_left _ _ C (C,, BAC_id)). }
      exists (C ** B); simpl; use tpair.
      2: { simpl; rewrite matrix_mult_assoc; apply rinv_eq. }
      rewrite <- matrix_mult_assoc.
      unfold BA in BAC_id.
      assert (linv_eq : ((B ** A ** C) = (A ** C ** B))).
      { rewrite matrix_mult_assoc in BAC_id |- *.
        unfold C in *; clear C;
        set (C := (upper_triangular_right_inverse_construction BA)).
        pose (B_rinv := @make_matrix_right_inverse F _ _ n B (A ** C) BAC_id).
        pose (linv := @matrix_right_inverse_implies_left _ _ C B_rinv).
        pose (eq := @matrix_left_inverse_equals_right_inverse F n _ n B linv ((A ** C),, BAC_id)).
        etrans.
        { change (@matrix_mult F _ _ A _ C) with (pr1 B_rinv).
          rewrite (pr2 B_rinv); reflexivity. }
        change (pr1 (@matrix_mult F _ _ A _ C,, BAC_id))
          with (@matrix_mult F _ _ A _ C) in *.
        rewrite <- eq, (pr2 linv).
        apply idpath.
      }
      simpl in * |- ;
      now rewrite <- BAC_id, <- linv_eq.
    - right.
      intros [invM [isl isr]].
      pose (isinv := @make_matrix_left_inverse _ _ _ n _ _ isr).
      assert (isinvprod : (matrix_left_inverse BA)).
      { apply left_inv_matrix_prod_is_left_inv; try assumption.
        apply (@matrix_inverse_to_right_and_left_inverse F _ B),
          gauss_clear_all_rows_matrix_invertible. }
      pose (contr_eq := @left_invertible_upper_triangular_to_diagonal_all_nonzero _ _ ut isinvprod idx).
      rewrite isnotz in contr_eq.
      contradiction.
  Defined.

End Inverse.


(* Discrete Mathematics in Coq, based on definitions in Epp, 4th Edition *)

Require Import Omega.
Require Import Nat.
Require Import List.
Require Import Arith.
Require Import Coq.Program.Wf.

(* Section 2.1 *)

(* This is the encoding of a definition of a statement, p. 24.
   It's called "lem" because the formal name for this property is the
   "Law of the Excluded Middle."

   Not all logics include this notion, so it's not built into Coq. Instead,
   we declare it as an axiom. A logic that doesn't have L.E.M. is called
   constructive. A logic that does include L.E.M. is called classical. *)
Axiom lem : forall p, p \/ ~p.

Theorem and_comm : forall p q, p /\ q <-> q /\ p.
Proof.
  intro p.
  intro q.
  split.
  - intro p_and_q.
    destruct p_and_q.
    split.
    + assumption.
    + assumption.
  - intro q_and_p.
    destruct q_and_p.
    split.
    + assumption.
    + assumption.
Qed.

Theorem or_comm : forall p q, p \/ q <-> q \/ p.
Proof.
  intro p. intro q.
  split.
  - intro p_or_q.
    destruct p_or_q.
    + right.
      assumption.
    + left.
      assumption.
  - intro q_or_p.
    destruct q_or_p.
    + right.
      assumption.
    + left.
      assumption.
Qed.

Theorem and_assoc : forall p q r, (p /\ q) /\ r <-> p /\ (q /\ r).
Proof.
  intro p. intro q. intro r.
  split.
  - intro pq_r.
    destruct pq_r.
    destruct H.
    split.
    + assumption.
    + split.
      * assumption.
      * assumption.
  - intro p_qr.
    destruct p_qr.
    destruct H0.
    split.
    + split.
      * assumption.
      * assumption.
    + assumption.
Qed.

Theorem or_assoc : forall p q r, (p \/ q) \/ r <-> p \/ (q \/ r).
Proof.
  intro p. intro q. intro r.
  split.
  - intro pq_r.
    destruct pq_r.
    + destruct H.
      * left.
        assumption.
      * right.
        left.
        assumption.
    + right.
      right.
      assumption.
  - intro p_qr.
    destruct p_qr.
    + left.
      left.
      assumption.
    + destruct H.
      * left.
        right.
        assumption.
      * right.
        assumption.
Qed.

Theorem and_distrib : forall p q r,
    p /\ (q \/ r) <-> (p /\ q) \/ (p /\ r).
Proof.
  intro p. intro q. intro r.
  split.
  - intro and_or.
    destruct and_or.
    destruct H0.
    + left.
      split.
      * assumption.
      * assumption.
    + right.
      split.
      * assumption.
      * assumption.
  - intro and_or_and.
    destruct and_or_and.
    + destruct H.
      split.
      * assumption.
      * left.
        assumption.
    + destruct H.
      split.
      * assumption.
      * right.
        assumption.
Qed.

Theorem or_distrib : forall p q r, p \/ (q /\ r) <-> (p \/ q) /\ (p \/ r).
Proof.
  intro p. intro q. intro r.
  split.
  - intro or_and.
    destruct or_and.
    + split.
      * left.
        assumption.
      * left.
        assumption.
    + destruct H.
      split.
      * right.
        assumption.
      * right.
        assumption.
  - intro or_and_or.
    destruct or_and_or.
    destruct H.
    + left.
      assumption.
    + destruct H0.
      * left.
        assumption.
      * right.
        split.
        -- assumption.
        -- assumption.
Qed.

Theorem and_ident : forall p, p /\ True <-> p.
Proof.
  intro p.
  split.
  - intro p_and_true.
    destruct p_and_true.
    assumption.
  - intro pf_p.
    split.
    + assumption.
    + constructor.
Qed.

Theorem or_ident : forall p, p \/ False <-> p.
Proof.
  intro p.
  split.
  - intro p_or_false.
    destruct p_or_false.
    + assumption.
    + contradiction.
  - intro pf_p.
    left.
    assumption.
Qed.

Theorem and_neg : forall p, p /\ ~p <-> False.
Proof.
  intro p.
  split.
  - intro p_and_not_p.
    destruct p_and_not_p.
    contradiction.
  - intro false.
    contradiction.
Qed.

Theorem or_neg : forall p, p \/ ~p <-> True.
Proof.
  intro p.
  split.
  - intro p_or_not_p.
    constructor.
  - intro true.
    apply lem.
Qed.

Theorem double_neg : forall p, ~(~p) <-> p.
Proof.
  intro p.
  split.
  - intro not_not_p.
    pose proof (lem p).
    destruct H.
    + assumption.
    + contradiction.
  - intro pf_p.
    intro not_p.
    contradiction.
Qed.

Theorem and_idempotent : forall p, p /\ p <-> p.
Admitted. (* This is what you tell Coq when you don't want to prove it.
             Here, I'm leaving this as an exercise. *)

Theorem or_idempotent : forall p, p \/ p <-> p.
Admitted.

Theorem and_bound : forall p, p /\ False <-> False.
Admitted.

Theorem or_bound : forall p, p \/ True <-> True.
Admitted.

Theorem and_deMorgan : forall p q, ~(p /\ q) <-> ~p \/ ~q.
Proof.
  intro p. intro q.
  split.
  - intro not_p_and_q.
    pose proof (lem p) as lem_p.
    pose proof (lem q) as lem_q.
    destruct lem_p.
    + destruct lem_q.
      * exfalso. (* Use this when you know you have a contradiction *)
        apply not_p_and_q. (* If you're proving False, you can apply a ~(...) to
                              change the goal to prove (...). *)
        split.
        -- assumption.
        -- assumption.
      * right.
        assumption.
    + left.
      assumption.
  - intro not_p_or_not_q.
    destruct not_p_or_not_q.
    + intro p_and_q.
      destruct p_and_q.
      contradiction.
    + intro p_and_q.
      destruct p_and_q.
      contradiction.
Qed.

Theorem or_deMorgan : forall p q, ~(p \/ q) <-> ~p /\ ~q.
Proof.
  intro p. intro q.
  split.
  - intro not_p_or_q.
    split.
    + intro pf_p.
      apply not_p_or_q.
      left.
      assumption.
    + intro pf_q.
      apply not_p_or_q.
      right.
      assumption.
  - intro not_p_and_not_q.
    destruct not_p_and_not_q.
    intro p_or_q.
    destruct p_or_q.
    + contradiction.
    + contradiction.
Qed.

Theorem and_absorption : forall p q, p /\ (p \/ q) <-> p.
Admitted.

Theorem or_absorption : forall p q, p \/ (p /\ q) <-> p.
Admitted.

Theorem not_true : ~ True <-> False.
Proof.
  split.
  - intro not_true.
    contradiction.
  - intro false.
    contradiction.
Qed.

Theorem not_false : ~ False <-> True.
Proof.
  split.
  - intro not_false.
    constructor.
  - intro true.
    intro false.
    contradiction.
Qed.

Theorem problem_2_1_53 :
  forall p q, ~((~p /\ q) \/ (~p /\ ~q)) \/ (p /\ q) <-> p.
Proof.
  intro p. intro q.
  rewrite or_deMorgan. (* rewrite uses a proof of equivalence to rewrite the goal *)
  rewrite and_deMorgan.
  rewrite and_deMorgan.
  rewrite double_neg.
  rewrite double_neg.
  rewrite <- or_distrib. (* this variant rewrites right-to-left *)
  rewrite and_comm.
  rewrite and_neg.
  rewrite or_ident.
  rewrite or_absorption.
  reflexivity. (* this solves a reflexive equivalence goal *)
Qed.

Theorem problem_2_1_52 : forall p q, ~(p \/ ~q) \/ (~p /\ ~q) <-> ~p.
Admitted. (* Exercise *)

(* Section 2.2 *)

Theorem implication : forall (p q : Prop), (p -> q) <-> (~p \/ q).
(* Note that Coq allows us to say what we're quantifying over. Above, it could
   always infer it. But, (->) is overloaded, so we need to tell Coq. *)
Proof.
  intro p. intro q.
  split.
  - intro implic.
    pose proof (lem p) as lem_p.
    destruct lem_p.
    + right.
      (* Here, we know (p -> q) and we're trying to prove q. If we `apply implic`, then
         our goal will reduce to just p. *)
      apply implic.
      assumption.
    + left.
      assumption.
  - intro or.
    intro pf_p. (* we can assume p here, because we're proving (p -> q) *)
    destruct or.
    + contradiction.
    + assumption.
Qed.

Theorem neg_implication : forall (p q : Prop), ~(p -> q) <-> p /\ ~q.
Admitted.

Theorem contrapositive : forall (p q : Prop), (p -> q) <-> (~q -> ~p).
Proof.
  intro p. intro q.
  rewrite implication.
  rewrite implication.
  rewrite double_neg.
  rewrite or_comm.
  reflexivity.
Qed.

(* Section 3.2 *)

Theorem forall_deMorgan : forall {A} {P : A -> Prop},
    ~(forall x, P x) <-> exists y, ~(P y).
Proof.
  intro A. intro P.
  split.
  - intro not_forall.
    rewrite <- double_neg.
    intro not_exists.
    apply not_forall.
    intro x.
    rewrite <- double_neg.
    intro not_pred.
    apply not_exists.
    exists x. (* This is how we choose the value of an existential variable. *)
    assumption.
  - intro ex.
    destruct ex. (* You can use destruct to get a given existential variable. *)
    intro all.
    specialize (all x). (* instantiate a forall *)
    contradiction.
Qed.

Theorem exists_deMorgan : forall {A} {P : A -> Prop},
    ~(exists x, P x) <-> forall y, ~(P y).
Proof.
  intro A. intro P.
  split.
  - intro not_exists.
    intro y.
    intro pred_y.
    apply not_exists.
    exists y.
    assumption.
  - intro all.
    intro ex.
    destruct ex.
    specialize (all x).
    contradiction.
Qed.

(* Section 3.3 *)

(* There exists a positive integer m such that for all
   positive integers n, m <= n. *)
Theorem example_3_3_5 : exists m,
    m > 0 /\ forall n, n > 0 -> m <= n.
Proof.
  exists 1.
  split.
  - omega.
  - intro n.
    intro n_gt_0.
    omega.
Qed.

(* Section 4.1 *)
Definition even n := exists k, n = 2 * k.
Definition odd n  := exists k, n = 2 * k + 1.

Definition prime n := n > 1 /\ forall r s, (r > 0 /\ s > 0 /\ n = r * s) -> (r = n \/ s = n).
Definition composite n := exists r s, r > 0 /\ s > 0 /\ n = r * s /\ 1 < r < n /\ 1 < s < n.

Theorem two_prime : prime 2.
Proof.
  unfold prime. (* This unfolds a definition in the goal. *)
  split.
  - omega.
  - intro r.
    intro s.
    intro Hyp.
    destruct Hyp.
    destruct H0.
    destruct r. (* either r is 0 or greater than 0. *)
    + omega.
    + destruct s.
      * omega.
      * destruct r.
        -- destruct s.
           ++ omega.
           ++ destruct s.
              ** omega.
              ** omega.
        -- destruct s.
           ++ omega.
           ++ simpl in H1.
              rewrite <- plus_n_Sm in H1.
              inversion H1.
Qed.
(* That proof got a little ugly, because we had to look at all possibilities for r and s
   below two. *)

Theorem six_composite : composite 6.
Proof.
  unfold composite.
  exists 2.
  exists 3.
  split.
  - omega.
  - split.
    + omega.
    + split.
      * omega.
      * split.
        -- omega.
        -- omega.
Qed.

(* Coq can do induction! *)
Theorem even_or_odd : forall n, even n \/ odd n.
Proof.
  intro n.
  induction n.
  - left.
    unfold even.
    exists 0.
    omega.
  - destruct IHn.
    + right.
      unfold even in H.
      destruct H.
      unfold odd.
      exists x.
      omega.
    + left.
      unfold odd in H.
      destruct H.
      unfold even.
      exists (x + 1).
      omega.
Qed.

Theorem not_odd__even : forall n, ~ (odd n) <-> even n.
Proof.
  intro n.
  split.
  * intro not_odd.
    pose proof (even_or_odd n).
    destruct H.
    - assumption.
    - contradiction.
  * intro pf_even.
    intro pf_odd.
    destruct pf_even.
    destruct pf_odd.
    subst. (* This performs all substitutions Coq can find. *)
    omega.
Qed.

Theorem problem_4_1_28 : forall n, odd n -> odd (n * n).
Proof.
  intro n. intro Hodd.
  unfold odd in *. (* unfold everywhere *)
  destruct Hodd.
  (* (2x+1)(2x+1) = 4x^2 + 4x + 1 = 2(2*x^2 + 2*x) + 1 *)
  exists (2 * x * x + 2 * x).
  subst.
  ring. (* like omega, but works better with multiplication *)
Qed.

Theorem problem_4_1_27 : forall n m, (odd m /\ odd n) -> odd (m + n).
Admitted.

Theorem problem_4_1_30 : forall m, even m -> odd (3 * m + 5).
Admitted.

Inductive ltpair : (nat * nat) -> (nat * nat) -> Prop :=
| lt_left : forall a b c d, a < c -> ltpair (a,b) (c,d)
| lt_right : forall a b d, b < d -> ltpair (a,b) (a,d).

Program Fixpoint Ack m n { measure (m,n) (ltpair) } :=
  match m with
  | 0 => n + 1
  | S m' => match n with
            | 0 => Ack m' 1
            | S n' => Ack m' (Ack m n')
            end
  end.
Next Obligation.
  apply lt_left.
  omega.
Qed.
Next Obligation.
  apply lt_right.
  omega.
Qed.
Next Obligation.
  apply lt_left.
  omega.
Qed.
Next Obligation.
Admitted. (* Not enough time to figure this one out. *)