Require Export Arith.
Require Export ArithRing.
Require Export Omega.
Require Export Compare_dec.
Require Export Wf_nat.

Definition div4_spec:
 forall (n : nat),  ({q : nat & {r : nat | n = 4 * q + r /\ r < 4}}).
refine (fix
        div4_spec (n : nat) : {q : nat & {r : nat | n = 4 * q + r /\ r < 4}} :=
           match n return {q : nat & {r : nat | n = 4 * q + r /\ r < 4}} with
              S (S (S (S x'))) =>
                match div4_spec x' with existT _ q' (exist _ r' H) => _ end
             | _ => _
           end); clear div4_spec.
- exists 0, 0; omega.
- exists 0, 1; omega.
- exists 0, 2; omega.
- exists 0,  3; omega.
- exists (S q'), r'; omega.
Qed.

Definition sqrt_nat_F:
 forall n,
 (forall y,
  y < n ->  ({s : nat & {r : nat | y = s * s + r /\ y < (s + 1) * (s + 1)}})) ->
  ({s : nat & {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}}).
refine (fun n sqrt_nat =>
           match div4_spec n with
             existT _ 0 (exist _ 0 (conj Heq _)) => _
            | existT _ 0 (exist _ (S r') (conj Heq Hle)) => _
            | existT _ (S q') (exist _ r' (conj Heq Hle)) => _
           end).
- clear sqrt_nat;exists 0, 0; omega.
- exists 1, r';rewrite Heq; split.
  + ring.
  + omega.
 - assert (Hlt: S q' < n) by omega.
   destruct (sqrt_nat (S q') Hlt) as [s' [r'' [Heq' Hlt']]].
   case (le_lt_dec (4 * s' + 1) (4 * r'' + r')).
   + intros Hle'';
     exists (2 * s' + 1), ((4 * r'' + r') - (4 * s' + 1)).
    rewrite Heq,  Heq'; split.
    * replace ((2 * s' + 1) * (2 * s' + 1) + ((4 * r'' + r') - (4 * s' + 1)))
     with (4 * (s' * s') + ((4 * s' + 1) + ((4 * r'' + r') - (4 * s' + 1)))).
     rewrite le_plus_minus_r; [ring | assumption].
     ring.
    * replace (4 * (s' * s' + r'') + r') with ((4 * s') * s' + (4 * r'' + r')).
      replace (((2 * s' + 1) + 1) * ((2 * s' + 1) + 1))
      with ((4 * s') * s' + (8 * s' + 4)).
      apply plus_lt_compat_l.
      assert (H: r'' < 2 * s' + 1).
      { apply plus_lt_reg_l with (s' * s').
        rewrite <- Heq'.
        replace (s' * s' + (2 * s' + 1)) with ((s' + 1) * (s' + 1)).
        assumption.
        ring.
      }
      omega.
      ring.
      ring.
   + intros Hlt''; exists (2 * s'),  (4 * r'' + r');
     rewrite Heq,  Heq'.
     split.
     * ring.
     * replace (4 * (s' * s' + r'') + r') with ((4 * s') * s' + (4 * r'' + r')).
       replace ((2 * s' + 1) * (2 * s' + 1)) with ((4 * s') * s' + (4 * s' + 1)).
       omega.
       ring.
       ring.
Qed.

Definition sqrt_nat' :
  forall n,  ({s : nat & {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}}) :=
   well_founded_induction
    lt_wf
    (fun n => {s : nat & {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}})
    sqrt_nat_F.


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.Word.
Require Import
        Coq.omega.Omega
        Bedrock.Word.

Section Nat.
  Variable sz : nat.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnit monoid bool}.

  Definition format_nat (n : nat) (ce : CacheFormat) : B * CacheFormat :=
    format_word (natToWord sz n) ce.

  Definition decode_nat (b : B) (cd : CacheDecode) : nat * B * CacheDecode :=
    let (bundle, cd) := decode_word (sz:=sz) b cd in
    let (w, b) := bundle in
        (wordToNat w, b, cd).

  Local Open Scope nat.

  Theorem Nat_decode_correct :
    format_decode_correct monoid (fun n => n < pow2 sz) format_nat decode_nat.
  Proof.
    unfold format_decode_correct, format_nat, decode_nat.
    intros env env' xenv xenv' n n' bin' ext ext' Eeq Ppred Penc Pdec.
    destruct (decode_word (mappend bin' ext) env') as [[? ?] ?] eqn: ?.
    inversion Pdec; subst; clear Pdec.
    pose proof (Word_decode_correct env env' xenv xenv' (natToWord sz n) w
                  bin' ext ext' Eeq I Penc Heqp).
    intuition eauto.
    rewrite <- H.
    destruct (wordToNat_natToWord' sz n).
    assert (x = 0).
    { destruct x; eauto.
      rewrite <- H1 in Ppred. exfalso. simpl in Ppred.
      clear - Ppred.
      replace (wordToNat (natToWord sz n) + (pow2 sz + x * pow2 sz)) with
              (pow2 sz + (wordToNat (natToWord sz n) + x * pow2 sz)) in Ppred by omega.
      remember (wordToNat (natToWord sz n) + x * pow2 sz) as n'; clear Heqn'.
      omega. }
    rewrite H3 in H1. simpl in H1. rewrite <- plus_n_O in H1. rewrite H1. reflexivity.
  Qed.
End Nat.


(* 1. 介绍如何利用辅助引理来进行正向证明和反向证明的方法 *)
(* 2. 关于data constructors的reason*)
(* 3. 如何获得更强的归纳假设  *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export Poly.
Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  apply eq2. Qed.
Theorem silly2 : forall (n m o p : nat),
     n = m ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1. Qed.
Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m) ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1. Qed.
(* Exercise: 2 stars, standard, optional (silly_ex) *)
Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     oddb 3 = true ->
     evenb 4 = true.
Proof.
  intros n eq1. apply eq1.
Qed.
Theorem silly3_firsttry : forall (n : nat),
     true = (n =? 5) ->
     (S (S n)) =? 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl.
  apply H. Qed.

Theorem silly3: forall (n:nat),
  true = (n=?5)-> (S (S n)) =? 7 = true.
Proof.
  intros n eql. simpl. rewrite -> eql. destruct n.
  reflexivity. simpl. reflexivity.
  Qed.
(* Exercise: 3 stars, standard (apply_exercise1) *)
Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
 intros l l' H. rewrite <- rev_involutive.
 rewrite H. rewrite -> rev_involutive. rewrite -> rev_involutive.
  reflexivity. Qed.
Theorem rev_exercise1_apply : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
 intros l l' H.
 rewrite H.
 symmetry.
 apply rev_involutive.
 Qed.
(* apply with Tactic*)
Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity. Qed.
Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity. Qed.
Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  apply trans_eq with (m:=[c;d]).
  apply eq1. apply eq2.
  Qed.
(* Exercise: 3 stars, standard, optional (apply_with_exercise) *)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros n m' o p eq1 eq2.
  apply trans_eq with (m :=m').
  apply eq2. apply eq1.
  Qed.
(* The 内射injection and discriminate Tactics   *)
(* 通过在此时编写注入H，我们要求Coq使用构造函数的注入性生成可以从H推断出的所有方程式。
每个这样的方程式都作为前提添加到目标中。在本示例中，添加前提n = m。*)
Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.
Theorem S_injective' : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.
  injection H. intros Hnm. apply Hnm.
Qed.
Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  injection H. intros H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.
Theorem injection_ex2 : forall (n m:nat),
  [n] = [m] -> n = m.
Proof.
  intros n m H.
  injection H as Hnm. apply Hnm. Qed.
(* Exercise: 1 star, standard (injection_ex3) *)
Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j -> x = y.
Proof.
  intros X x y z l j.
  intros H HH.  injection HH.
  intros HH1 HH2. symmetry. apply HH2. Qed.
Theorem eqb_0_l : forall n,
   0 =? n = true -> n = 0.
Proof.
  intros n. intros H. destruct n. reflexivity. discriminate H. Qed.
Theorem discriminate_ex1 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros n contra. discriminate contra. Qed.
Theorem discriminate_ex2 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros n m contra. discriminate contra. Qed.
(* Exercise: 1 star, standard (discriminate_ex3) *)
Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
  intros X x y z l j.
  intros contra. discriminate contra. Qed.
Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq. reflexivity. Qed.
(* Using Tactics on Hypotheses *)
Theorem S_inj : forall (n m : nat) (b : bool),
     (S n) =? (S m) = b ->
     n =? m = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.
Theorem silly3' : forall(n : nat),
  (n =? 5 = true -> (S (S n)) =? 7 = true) ->
  true = (n =? 5) ->
  true = ((S (S n)) =? 7).
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.

Theorem plus_n_n_injective_1 : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
    - simpl. intros m H. destruct m as [|m'].
      + reflexivity.
      + inversion H.
    - simpl. intros m H. destruct m as [|m'].
      + inversion H.
      + apply f_equal.
  apply IHn'. inversion H.
  rewrite <- plus_n_Sm in H1.
  symmetry in H1. rewrite <- plus_n_Sm in H1.
  inversion H1. reflexivity.
Qed.
(*varying the Induction Hypothesis*)
(* 有时候，控制得到H是什么是很重要的。不同的intros时机会导致不同的H产生。
上一题就明显体现了这一点。
 *)
(* Exercise: 2 stars, standard (eqb_true)*)
Theorem eqb_true: forall n m,
  n =? m = true -> n=m.
Proof.
  intros n. induction n as [|n'].
  - intros m H. destruct m. reflexivity. inversion H.
  - intros m H. destruct m. inversion H. simpl in H.
  apply IHn' in H. rewrite H. reflexivity.
Qed.
Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  - (* m = O *) simpl. intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
        (* Stuck again here, just like before. *)
Abort.
Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* n and m are both in the context *)
  generalize dependent n.
  (* Now n is back in the goal and we can do induction on
     m and get a sufficiently general IH. *)
  induction m as [| m'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. injection eq as goal. apply goal. Qed.

Theorem eqb_id_true : forall x y,
  eqb_id x y = true -> x = y.
Proof.
  intros [m] [n]. simpl. intros H.
  assert (H' : m = n). { apply eqb_true. apply H. }
  rewrite H'. reflexivity.
Qed.

(* Exercise: 3 stars, standard, recommended (gen_dep_practice) *)
(* Prove this by induction on l. *)
(* nth_error:如果list不够n长，则nth_error返回None，否则返回从左向右数第n个元素*)
(* 求证：如果length l==n，那么nth_err l n返回一定是None*)
Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n -> nth_error l n = None.
Proof.
  intros n X l.
  generalize dependent n.
  induction l as [| l']. simpl. reflexivity.
  intros n H. rewrite <- H. apply IHl. reflexivity.
Qed.
(*Unfolding Definitions*)
Theorem mult_comm: forall n m:nat, n*m=m*n.
Proof.
intros n m.
generalize dependent m.
induction n as [| n IHn].
- induction m as [| m IHm]. reflexivity.
simpl. apply IHm.
- induction m as [| m IHm]. simpl.
apply IHn.
(* assert(S n * m + S n = m * S n + S n). *)
(* rewrite IHm. reflexivity. *)
assert(n * S m= n * m + n).
{
  rewrite IHn with (m:=S m).
  simpl. rewrite plus_comm. symmetry.
  rewrite IHn with (m:=m). reflexivity.
}
simpl in IHm. symmetry in IHm.
simpl.
assert(m + n * S m = n + m * S n).
rewrite H. rewrite IHm.
rewrite plus_assoc.
symmetry. rewrite plus_assoc.
rewrite plus_comm with (n:=m + n*m).
rewrite plus_assoc.
reflexivity.
rewrite H0. reflexivity.
Qed.

Theorem subthe1: forall n m p o:nat, n+m+(p+o)=n+p+(m+o).
Proof.
intros n m p o. rewrite plus_assoc.
symmetry. rewrite plus_assoc.
rewrite plus_comm with (m:=p).
rewrite plus_comm with (n:=n+m).
rewrite plus_assoc.
reflexivity.
Qed.
Theorem subthe2: forall n m p:nat, n*(m+p)=n*m+n*p.
Proof.
intros n m p. induction n as [| n' IHn']. simpl. reflexivity.
simpl. rewrite IHn'. apply subthe1.
Qed.
Theorem mult_assoc: forall n m p:nat,n*(m*p)=(n*m)*p.
Proof.
intros n m p. induction n as [| n' IHn].
- simpl. reflexivity.
- simpl. rewrite IHn. rewrite mult_comm with (n:=m+n'*m).
  rewrite subthe2 with(n:=p).
  rewrite mult_comm with(n:=p).
  rewrite mult_comm with(m:=n'*m).
  reflexivity.
Qed.
Definition square n:=n*n.
Lemma squar_mult: forall n m, square (n*m) = square n * square m.
Proof.
intros n m. unfold square.
rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
    { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.
Definition foo (x:nat) := 5.
Fact silly_fact_1: forall m, foo m+1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.
Definition bar x:=
  match x with
  | 0 => 5
  | S _ => 5
  end.
Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl. (* Does nothing! *)
Abort.
Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.
Fact silly_fact_2': forall m, bar m+1 = bar (m+1)+1.
Proof.
intros m.
unfold bar.
destruct m eqn:E.
  - reflexivity.
  - reflexivity.
Qed.
Definition sillyfun (n : nat) : bool :=
  if n =? 3 then false
  else if n =? 5 then false
  else false.
Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (n =? 3) eqn:E1.
    - (* n =? 3 = true *) reflexivity.
    - (* n =? 3 = false *) destruct (n =? 5) eqn:E2.
      + (* n =? 5 = true *) reflexivity.
      + (* n =? 5 = false *) reflexivity. Qed.
(* Here is an implementation of the split function mentioned in chapter Poly: *)
Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
      match split t with
      | (lx, ly) => (x :: lx, y :: ly)
      end
  end.
(* Prove that split and combine are inverses in the following sense: *)
Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l.
  induction l.
  - intros l1 l2 H. simpl in H.
    injection H as H. rewrite <- H. rewrite <- H0. simpl. reflexivity.
  - destruct x as (x,y).
    destruct l1 as [| x'].
    + intros l2 H. simpl in H.
      destruct (split l) in H. discriminate H.
    + destruct l2 as [| y'].
      * intros H. simpl in H. destruct (split l). discriminate H.
      * intros H. simpl.
        assert(G: split l = (l1, l2)). {
          simpl in H. destruct (split l).
          injection H as H. rewrite <- H0. rewrite <- H2. reflexivity.
        }
      apply IHl in G. rewrite <- G.
      simpl in H. destruct (split l) in H. injection H as H.
      rewrite <- H. rewrite <- H1. reflexivity.
Qed.
(*↑ referring to https://github.com/marshall-lee/software_foundations/blob/master/lf/Tactics.v*)
Definition sillyfun1 (n : nat) : bool :=
  if n =? 3 then true
  else if n =? 5 then true
  else false.
Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3).
  (* stuck... *)
Abort.
Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got
     stuck above, except that the context contains an extra
     equality assumption, which is exactly what we need to
     make progress. *)
    - (* e3 = true *) apply eqb_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    - (* e3 = false *)
     (* When we come to the second equality test in the body
        of the function we are reasoning about, we can use
        eqn: again in the same way, allowing us to finish the
        proof. *)
      destruct (n =? 5) eqn:Heqe5.
        + (* e5 = true *)
          apply eqb_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        + (* e5 = false *) discriminate eq. Qed.
(** **** Exercise: 2 stars, standard (destruct_eqn_practice)  *)
Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b. destruct b eqn:H0.
  - destruct (f true) eqn:H1.
    + destruct (f true)eqn:H2.
      * apply H2.
      * discriminate H1.
    + destruct (f false)eqn:H2.
      * apply H1.
      * apply H2.
  - destruct (f false) eqn:H1.
    + destruct (f true)eqn:H2.
      * apply H2.
      * apply H1.
    +  rewrite H1. apply H1.
Qed.
(** [] *)
(** We've now seen many of Coq's most fundamental tactics.  We'll
    introduce a few more in the coming chapters, and later on we'll
    see some more powerful _automation_ tactics that make Coq help us
    with low-level details.  But basically we've got what we need to
    get work done.
    Here are the ones we've seen:
      - [intros]: move hypotheses/variables from goal to context
      - [reflexivity]: finish the proof (when the goal looks like [e =
        e])
      - [apply]: prove goal using a hypothesis, lemma, or constructor
      - [apply... in H]: apply a hypothesis, lemma, or constructor to
        a hypothesis in the context (forward reasoning)
      - [apply... with...]: explicitly specify values for variables
        that cannot be determined by pattern matching
      - [simpl]: simplify computations in the goal
      - [simpl in H]: ... or a hypothesis
      - [rewrite]: use an equality hypothesis (or lemma) to rewrite
        the goal
      - [rewrite ... in H]: ... or a hypothesis
      - [symmetry]: changes a goal of the form [t=u] into [u=t]
      - [symmetry in H]: changes a hypothesis of the form [t=u] into
        [u=t]
      - [unfold]: replace a defined constant by its right-hand side in
        the goal
      - [unfold... in H]: ... or a hypothesis
      - [destruct... as...]: case analysis on values of inductively
        defined types
      - [destruct... eqn:...]: specify the name of an equation to be
        added to the context, recording the result of the case
        analysis
      - [induction... as...]: induction on values of inductively
        defined types
      - [injection]: reason by injectivity on equalities
        between values of inductively defined types
      - [discriminate]: reason by disjointness of constructors on
        equalities between values of inductively defined types
      - [assert (H: e)] (or [assert (e) as H]): introduce a "local
        lemma" [e] and call it [H]
      - [generalize dependent x]: move the variable [x] (and anything
        else that depends on it) from the context back to an explicit
        hypothesis in the goal formula *)

(* ################################################################# *)
(** * Additional Exercises *)

(** **** Exercise: 3 stars, standard (eqb_sym)  *)
Theorem eqb_sym : forall (n m : nat),
  (n =? m) = (m =? n).
Proof.
  intros n m.
  generalize dependent m.
  induction n as [| n' IHn].
  - induction m as [| m' IHm].
    + reflexivity.
    + simpl. reflexivity.
  - induction m as [| m' IHm].
    + simpl. reflexivity.
    + simpl. rewrite IHn with (m:=m'). reflexivity.
Qed.
(** **** Exercise: 3 stars, standard, optional (eqb_trans)  *)
Theorem eqb_trans : forall n m p,
  n =? m = true ->
  m =? p = true ->
  n =? p = true.
Proof.
  intros n m p.
  generalize dependent m.
  generalize dependent p.
  induction n as [| n' IHn].
  - induction m as [| m' IHm].
     + induction p as [| p' IHp].
        * simpl. reflexivity.
        * discriminate.
     + discriminate.
  - induction m as [| m' IHm].
     + induction p as [| p' IHp].
        * simpl. discriminate.
        * simpl. discriminate.
     + induction p as [| p' IHp].
        * simpl. discriminate.
        * simpl. apply IHn.
Qed.

(** **** Exercise: 3 stars, advanced (split_combine)

    We proved, in an exercise above, that for all lists of pairs,
    [combine] is the inverse of [split].  How would you formalize the
    statement that [split] is the inverse of [combine]?  When is this
    property true?

    Complete the definition of [split_combine_statement] below with a
    property that states that [split] is the inverse of
    [combine]. Then, prove that the property holds. (Be sure to leave
    your induction hypothesis general by not doing [intros] on more
    things than necessary.  Hint: what property do you need of [l1]
    and [l2] for [split (combine l1 l2) = (l1,l2)] to be true?) *)

Definition split_combine_statement : Prop
  (* ("[: Prop]" means that we are giving a name to a
     logical proposition here.) *)
  := forall X Y (l1:list X) (l2:list Y), length l1 = length l2->split (combine l1 l2) = (l1,l2).
Theorem split_combine : split_combine_statement.
Proof.
  intros X Y. induction l1 as [| x].
  - simpl. intros l2 H. destruct l2 as [| y].
    + reflexivity.
    + discriminate.
  - destruct l2 as [| y].
    + discriminate.
    + intros H. injection H as H.
      apply IHl1 in H. simpl.
      rewrite H. reflexivity.
Qed.

(** **** Exercise: 3 stars, advanced (filter_exercise)

    This one is a bit challenging.  Pay attention to the form of your
    induction hypothesis. *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros X test x l lf.
  induction l as [| x'].
  - simpl. discriminate.
  - simpl. destruct (test x') eqn:H.
    + intros H1. injection H1 as H1. rewrite H1 in H. apply H.
    +  apply IHl.
Qed.
(** **** Exercise: 4 stars, advanced, recommended (forall_exists_challenge)

    Define two recursive [Fixpoints], [forallb] and [existsb].  The
    first checks whether every element in a list satisfies a given
    predicate:

      forallb oddb [1;3;5;7;9] = true

      forallb negb [false;false] = true

      forallb evenb [0;2;4;5] = false

      forallb (eqb 5) [] = true

    The second checks whether there exists an element in the list that
    satisfies a given predicate:

      existsb (eqb 5) [0;2;3;6] = false

      existsb (andb true) [true;true;false] = true

      existsb oddb [1;0;0;0;0;3] = true

      existsb evenb [] = false

    Next, define a _nonrecursive_ version of [existsb] -- call it
    [existsb'] -- using [forallb] and [negb].

    Finally, prove a theorem [existsb_existsb'] stating that
    [existsb'] and [existsb] have the same behavior. *)

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_2 : forallb negb [false;false] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. (* FILL IN HERE *) Admitted.

Fixpoint existsb {X : Type} (test : X -> bool) (l : list X) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_4 : existsb evenb [] = false.
Proof. (* FILL IN HERE *) Admitted.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem existsb_existsb' : forall (X : Type) (test : X -> bool) (l : list X),
  existsb test l = existsb' test l.
Proof. (* FILL IN HERE *) Admitted.

(** [] *)


Require Export Coq.Reals.Rdefinitions.
Require Export Coq.Reals.Rfunctions.
Require Import RndHoare.sigma_algebra.
Require Import RndHoare.measurable_function.

Local Open Scope R.

Record Measure (Omega: Type) {sigma: SigmaAlgebra Omega}: Type := {
  measure_function: measurable_set Omega -> R;
  measure_function_proper: Proper (Same_MSet ==> eq) measure_function;
  coutable_addictive:
    forall P: nat -> measurable_set Omega,
      (forall i j, i <> j -> Disjoint _ (P i) (P j)) ->
      infinite_sum (fun i => measure_function (P i)) (measure_function (Countable_Union_MSet P))
}.

Global Existing Instance measure_function_proper.

Definition Measure_measure_function {Omega: Type} {sigma: SigmaAlgebra Omega} (m: Measure Omega): measurable_set Omega -> R := measure_function _ m.

Coercion Measure_measure_function: Measure >-> Funclass.

Definition GeneratedMeasure {A B} {sA: SigmaAlgebra A} {sB: SigmaAlgebra B} (f: MeasurableFunction A B) (mA: Measure A): Measure B.
  apply (Build_Measure _ _ (fun PB => mA (PreImage_MSet f PB))).
  + hnf; simpl; intros.
    apply measure_function_proper.
    apply PreImage_MSet_Proper; auto.
  + intros.
    destruct mA as [mA ?H ?H]; simpl in *.
    specialize (H1 (fun n => PreImage_MSet f (P n))).
    rewrite PreImage_Countable_Union_comm.
    apply H1.
    clear - H.
    intros.
    specialize (H i j H0).
    apply PreImage_Disjoint; auto.
Defined.

Lemma GeneratedMeasure_spec: forall {A B} {sA: SigmaAlgebra A} {sB: SigmaAlgebra B} (f: MeasurableFunction A B) (mA: Measure A) (PB: measurable_set B),
  mA (PreImage_MSet f PB) = (GeneratedMeasure f mA) PB.
Proof.
  intros.
  reflexivity.
Qed.

Parameter Lebegue_Int: forall {Omega: Type} {sigma: SigmaAlgebra Omega} (f: MeasurableFunction Omega R) (m: Measure Omega), R.

Axiom Int_Indicator: forall {Omega: Type} {sigma: SigmaAlgebra Omega} (P: measurable_set Omega) (m: Measure Omega), Lebegue_Int (IndicatorR P) m = m P.

Record ProbabilityMeasure (Omega: Type) {sigma: SigmaAlgebra Omega}: Type := {
  PS_MS :> Measure Omega;
  universe_measure_1: PS_MS (Full_MSet _) = 1
}.

Definition ProbabilityMeasure_measure_function {Omega: Type} {sigma: SigmaAlgebra Omega} (m: ProbabilityMeasure Omega): measurable_set Omega -> R := measure_function _ (PS_MS _ m).

Coercion ProbabilityMeasure_measure_function: ProbabilityMeasure >-> Funclass.

Definition GeneratedProbabilityMeasure {A B} {sA: SigmaAlgebra A} {sB: SigmaAlgebra B} (f: MeasurableFunction A B) (mA: ProbabilityMeasure A): ProbabilityMeasure B.
  destruct mA as [mA ?H].
  apply (Build_ProbabilityMeasure _ _ (GeneratedMeasure f mA)).
  rewrite <- GeneratedMeasure_spec.
  rewrite PreImage_Full; auto.
Defined.

Definition Probability {A} {sA: SigmaAlgebra A} (mA: ProbabilityMeasure A) (P: measurable_set A): R := mA P.

Definition Expectation {A} {sA: SigmaAlgebra A} (mA: ProbabilityMeasure A) (f: MeasurableFunction A R): R := Lebegue_Int f mA.


Inductive Tree:Set :=
  | Node: list Tree -> Tree.

Definition tail : forall (A : Type), list A -> list A
  := fun (A : Type) (l : list A) =>
  match l with
  | nil => nil
  | cons x l' => l'
  end.

Definition head : forall (A : Type), A -> list A -> A
  := fun (A : Type) (x : A) (l : list A) =>
  match l with
  | nil => x
  | cons a _ => a
  end.

Definition getNode : Tree -> list Tree
  := fun t => let (l) := t in l.

Lemma list_Tree_eq_LEM : forall l l',
  {Node l = Node l'} + {Node l <> Node l'} -> {l = l'} + {l <> l'}.
Proof.
  intros.
  destruct H.
  - left; exact (f_equal getNode e).
  - right; intro.
  apply n, (f_equal Node H).
Qed.

Theorem Tree_dec: forall a b:Tree, {a=b} + {a<>b}.
Proof.
  fix 1.
  destruct a; destruct b.
  generalize l l0; clear l; clear l0.
  induction l; induction l0.
  - left; reflexivity.
  - right; discriminate.
  - right; discriminate.
  - destruct (Tree_dec a a0).
    destruct (list_Tree_eq_LEM l l0 (IHl l0)).
    * left; subst; reflexivity.
    * right; subst.
    intro.
    assert (l = l0) by (apply (f_equal (tail Tree) (f_equal getNode H))).
    congruence.
    * right.
    intro.
    assert (a = a0) by (apply (f_equal (head Tree a) (f_equal getNode H))).
    congruence.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq tuple.
From mathcomp Require Import choice path finset finfun fintype bigop.
From mathcomp Require Import ssralg ssrnum matrix mxalgebra.
From mathcomp Require Import finmap.
From mathcomp Require Import vector perm.
Require Import triangulation.
Require Import determinant_complements.

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

Open Local Scope nat_scope.

Definition ord10:=@Ordinal 1 0 isT.
(*Definition ord20:=@Ordinal 2 0 isT.
Definition ord21:=@Ordinal 2 1 isT.
Definition ord30:=@Ordinal 3 0 isT.
Definition ord31:=@Ordinal 3 1 isT.
Definition ord32:=@Ordinal 3 2 isT.*)
Import GRing.Theory Num.Theory.

Open Local Scope ring_scope.

Variable R : realDomainType.

Definition my_type := GRing.Zmodule.sort (Num.RealDomain.zmodType R).
Definition my_mul :my_type -> my_type -> my_type := @GRing.mul R.
Definition my_add :my_type -> my_type -> my_type:= @GRing.add R.
Definition my_sub :my_type -> my_type -> my_type:= fun (x y : R) => x - y.
Definition my_opp :my_type -> my_type := @GRing.opp R.
Definition my_ring_theory := @mk_rt my_type 0 1 my_add my_mul my_sub my_opp (@eq _)
(@add0r R) (@addrC R) (@addrA R) (@mul1r R) (@mulrC R) (@mulrA R) (@mulrDl R)
(fun x y => erefl _) (@addrN R).

Add Ring my_ring : my_ring_theory.

Ltac rring :=
rewrite !mulr1 !mul1r -/my_mul -/my_opp -/my_add -/my_type;ring.

Definition P := 'rV[R]_2.
Definition xCoord (p : P) := p ord10 ord20.
Definition yCoord (p : P) := p ord10 ord21.

Definition matrix_oriented_surface (p a b : P) :=
  \matrix_( i<3, j<3) if i==ord30 then if j==ord30 then xCoord p
                                        else if j==ord31 then yCoord p
                                               else 1%R
                             else if i==ord31 then if j==ord30 then xCoord a
                                               else if j==ord31 then yCoord a
                                                    else 1%R
                                  else if j==ord30 then xCoord b
                                       else if j==ord31 then yCoord b
                                            else 1%R.

Definition oriented_surface (a b c : P):=
\det (matrix_oriented_surface a b c).

Definition is_left_of := is_left_of oriented_surface.

Definition is_left_or_on_line := is_left_or_on_line oriented_surface.

Definition T := 'rV[P]_3.

Definition vertex (t : T) := t ord10.

Definition vertex1 := vertex1 vertex.

Definition vertex2 := vertex2 vertex.

Definition vertex3 := vertex3 vertex.

Definition E := 'rV[P]_2.

Open Local Scope ring_scope.

Definition vertices_to_edge_aux (p1:P) (p2:P) :=
  \matrix_(j<1, i<2) (if i == ord20 then p1 else p2).

Definition vertices_to_edge (p1 : P) (p2 : P): E :=
  if xCoord p1 < xCoord p2 then
    vertices_to_edge_aux p1 p2
  else if xCoord p2 < xCoord p1 then
         vertices_to_edge_aux p2 p1
       else if yCoord p1 < yCoord p2 then
              vertices_to_edge_aux p1 p2
            else vertices_to_edge_aux p2 p1.

Definition edge t i :=
  if i == ord30 then vertices_to_edge (vertex1 t) (vertex2 t)
  else if i==ord31 then vertices_to_edge (vertex2 t) (vertex3 t)
       else vertices_to_edge (vertex3 t) (vertex1 t).

Definition vertex_edge (e:E) := e ord10.

Definition vertices_to_triangle (a b c : P) : T :=
  if is_left_or_on_line a b c then
    \matrix_(j<1, i<3) (if i == ord30 then a
                        else if i == ord31 then b
                             else c)
  else \matrix_(j<1, i<3) ( if i == ord30 then b
                            else if i == ord31 then a
                                 else c).

Lemma vertices_to_triangle_correct a b c:
    is_left_or_on_line a b c ->
    a = vertex (vertices_to_triangle a b c) ord30 /\
    b = vertex (vertices_to_triangle a b c) ord31 /\
    c = vertex (vertices_to_triangle a b c) ord32.
Proof.
by move => islor_abc; split;last split;
rewrite /vertices_to_triangle /vertex islor_abc => /=;
rewrite mxE.
Qed.

Definition vertex_set_edge := vertex_set_edge vertex_edge.

Lemma vertices_to_edge_correct a b:
 vertex_set_edge (vertices_to_edge a b) = [fset a;b].
Proof.
rewrite /vertices_to_edge.
by case:(xCoord a < xCoord b);case(yCoord a < yCoord b);
case:(xCoord b < xCoord a); apply /eqP;
rewrite eqEfsubset;apply/andP;split;apply/fsubsetP;move => x;
try (move => /fset2P [] ->;
rewrite /vertices_to_edge_aux;
rewrite /vertex_set_edge /triangulation.vertex_set_edge;
apply/imfsetP);
try(by exists ord20 => //=; rewrite /vertex_edge mxE );
try(by exists ord21 => //=; rewrite /vertex_edge mxE );
rewrite /vertex_set_edge /triangulation.vertex_set_edge;
move=>/imfsetP [[[|[|[|x']]] px'] _ ] => //=;
try (have:Ordinal px' = ord20 by apply ord_inj);
try (have:Ordinal px' = ord21 by apply ord_inj);
move ->; rewrite /vertex_edge mxE /= => ->;apply  /fset2P;
(try by left);
right.
Qed.

Lemma oriented_surface_x_x x y: oriented_surface x x y = 0%R.
Proof.
rewrite /oriented_surface /matrix_oriented_surface.
have ord301:(ord30 != ord31) by [].
apply:(determinant_alternate ord301).
move =>[[|[|[|k]]] pk] => //=;
rewrite !mxE => //=.
Qed.

Lemma eq_or_inf (a:R) b: a<b \/ a=b \/ a>b.
Proof.
case ab:(a < b);case ba:(b < a);try (by left);try (by right;right);right;left.
move:ab=> /negP /negP;rewrite -lerNgt => ab.
move:ba=> /negP /negP;rewrite -lerNgt => ba;symmetry;apply /eqP.
move:(ab);rewrite ler_eqVlt => /orP [] //=.
by rewrite ltrNge ba.
Qed.

Lemma coord_eq_imply_point_eq (a:P) b :
  xCoord a = xCoord b -> yCoord a = yCoord b -> a=b.
Proof.
move => xa xb.
rewrite -matrixP.
move => x y.
move:x=>[[|x'] px] => //=.
have:Ordinal px = ord10.
  by apply ord_inj.
move => ->.
by move:y=>[[|[|y']] py] => //=;
[have:Ordinal py = ord20|have:Ordinal py = ord21];(try by apply ord_inj) => //= ->.
Qed.

Lemma inf_imply_not_inf (a:R) b : a<b -> (b<a) = false.
Proof.
rewrite ltrNge ler_eqVlt.
move => /orP /Decidable.not_or [] _ H. by apply/negP.
Qed.

Lemma vertices_to_edge_sym a b :
 vertices_to_edge a b = vertices_to_edge b a.
Proof.

rewrite /vertices_to_edge.
have xCoord_disj := eq_or_inf (xCoord a) (xCoord b).
have yCoord_disj := eq_or_inf (yCoord a) (yCoord b);
move:xCoord_disj => [] [] xab;rewrite xab;
move:yCoord_disj => [] [] yab;(try rewrite yab);
try(have xba:=inf_imply_not_inf xab;rewrite xba);
try(have yba:=inf_imply_not_inf yab;rewrite yba) => //=;
(try rewrite !ltrr) => //=.
rewrite /vertices_to_edge_aux.
have ab :a=b by apply coord_eq_imply_point_eq.
by apply matrixP; rewrite ab.
Qed.

Definition in_circle_determinant (p a b c : P) :=
  let M:= \matrix_(i<4, j<4) if i == @Ordinal 4 0 isT then if j==@Ordinal 4 0 isT then
                                     xCoord a
                                         else if j==@Ordinal 4 1 isT  then
                                     yCoord a
                                         else if j== @Ordinal 4 2 isT  then
                         (xCoord a) ^+ 2
                            + (yCoord a)^+2
                                         else 1%R
                           else if i == @Ordinal 4 1 isT  then if j== @Ordinal 4 0 isT  then
                                     xCoord b
                                         else if j==@Ordinal 4 1 isT  then
                                     yCoord b
                                         else if j== @Ordinal 4 2 isT  then
                         (xCoord b)^+2
                            + (yCoord b)^+2
                                         else 1%R
                           else if i == @Ordinal 4 2 isT  then if j== @Ordinal 4 0 isT  then
                                     xCoord c
                                         else if j== @Ordinal 4 1 isT  then
                                     yCoord c
                                         else if j== @Ordinal 4 2 isT  then
                         (xCoord c)^+2
                            + (yCoord c)^+2
                                         else 1%R
                           else if j== @Ordinal 4 0 isT  then
                                     xCoord p
                                else if j== @Ordinal 4 1 isT  then
                                     yCoord p
                                         else if j== @Ordinal 4 2 isT  then
                                     (xCoord p)^+2 + (yCoord p)^+2
                                         else 1%R
  in (\det M).

Definition in_circle := in_circle in_circle_determinant.

Definition oriented_triangle := oriented_triangle vertex oriented_surface.

Definition vertex_set := vertex_set vertex.

Lemma vertices_to_triangle_correct2 : forall p1 p2 p3, forall t,
          (t = vertices_to_triangle p1 p2 p3) ->
  ((p1 \in vertex_set t) /\ (p2 \in vertex_set t) /\ (p3 \in vertex_set t)).
Proof.
move => p1 p2 p3 t ->.
split;last split;
rewrite /vertex_set /triangulation.vertex_set;
apply /imfsetP;rewrite /vertices_to_triangle;
case:(is_left_or_on_line p1 p2 p3);
try ( by exists ord30 => //=; rewrite /vertex mxE);
try ( by exists ord31 => //=; rewrite /vertex mxE);
try ( by exists ord32 => //=; rewrite /vertex mxE).
Qed.

Definition edges_set := edges_set edge.

Lemma vertex_set_edge_triangle :
  forall t, forall (a:P), a \in vertex_set t ->  forall (b:P), b \in vertex_set t -> a!=b ->
            (vertices_to_edge a b) \in edges_set t.
Proof.
move => t a a_t b b_t a_nb.
rewrite /edges_set /triangulation.edges_set.
move:a_t => /imfsetP [x _] a_tx.
move:b_t => /imfsetP [y _] b_ty.
move: a_tx;move: x =>[[|[|[|x']]] px] a_tx;rewrite a_tx;
(try have:Ordinal px = ord30 by apply ord_inj);
(try have:Ordinal px = ord31 by apply ord_inj);
(try have:Ordinal px = ord32 by apply ord_inj) => px_ord;
rewrite px_ord;rewrite px_ord in a_tx;
move: b_ty;move: y =>[[|[|[|y']]] py] b_ty; rewrite b_ty;
(try have:Ordinal py = ord30 by apply ord_inj);
(try have:Ordinal py = ord31 by apply ord_inj);
(try have:Ordinal py = ord32 by apply ord_inj) => py_ord;
rewrite py_ord;rewrite py_ord in b_ty =>  //=;
(try have ab : a = b by rewrite a_tx b_ty);
(try by move:a_nb;rewrite ab => /eqP);
apply /imfsetP;
[exists ord30|exists ord32|exists ord30|exists ord31|exists ord32|exists ord31] => //=;
rewrite /edge /vertex1 /vertex2 /vertex3 /triangulation.vertex1
/triangulation.vertex2 /triangulation.vertex3=> //=;
try (by rewrite vertices_to_edge_sym).
Qed.

Lemma oriented_surface_circular a b c:
  oriented_surface a b c = oriented_surface c a b.
Proof.
rewrite /oriented_surface.
rewrite !expand_det33.
rewrite /matrix_oriented_surface.
rewrite !mxE => /=.
rring.
Qed.

Lemma oriented_surface_change1 a b c:
        oriented_surface a b c = -oriented_surface a c b.
Proof.
rewrite /oriented_surface.
rewrite !expand_det33.
rewrite /matrix_oriented_surface.
rewrite !mxE => //=.
rring.
Qed.

Definition is_left_or_on_line_circular :=
  is_left_or_on_line_circular oriented_surface_circular.
Lemma vertices_to_triangle_oriented  a b c :
  oriented_triangle (vertices_to_triangle a b c).
Proof.
rewrite /vertices_to_triangle.
case islor_abc:(is_left_or_on_line a b c);
rewrite /oriented_triangle /triangulation.oriented_triangle;
rewrite /vertex /triangulation.vertex1 /triangulation.vertex2;
rewrite  /triangulation.vertex3;
rewrite !mxE => //=.
rewrite /is_left_or_on_line in islor_abc.
rewrite is_left_or_on_line_circular in islor_abc.
move:islor_abc.
rewrite /triangulation.is_left_or_on_line lerNgt.
move => /negP /negP.
by rewrite -oppr_gt0 -oriented_surface_change1
   -oriented_surface_circular ltr_def => /andP [].
Qed.

Definition is_left_of_circular := is_left_of_circular oriented_surface_circular.

Lemma edges_set_vertices_to_triangle a b c:
  is_left_of a b c ->
  edges_set (vertices_to_triangle a b c) =
  [fset (vertices_to_edge a b);
     vertices_to_edge a c;
     vertices_to_edge b c].
Proof.
rewrite /edges_set /triangulation.edges_set.
symmetry.
apply/eqP.
rewrite eqEfcard.
apply /andP;split.
  by apply/fsubsetP => x /fsetUP [/fset2P []|/fset1P] ->;
  apply /imfsetP;rewrite /edge /vertices_to_triangle;
  case islor:(is_left_or_on_line a b c) => /=;
  [exists ord30|exists ord30|exists ord32|exists ord31|exists ord31|exists ord32]=> //=;
  rewrite /vertex1 /vertex2 /vertex3 /triangulation.vertex1
  /triangulation.vertex2 /triangulation.vertex3 /vertex !mxE => //=;
  rewrite vertices_to_edge_sym.
suff card_fset3 : #|` [fset vertices_to_edge a b; vertices_to_edge a c; vertices_to_edge b c] | = 3%N.
  rewrite card_fset3 (leq_trans (leq_imfset_card _ _)) //.
  by rewrite card_finset card_ord.
case a_nb : (a == b);first move:a_nb => /eqP a_b;first move:H;
first by rewrite /is_left_of a_b /triangulation.is_left_of oriented_surface_x_x ltrr.
move:a_nb => /eqP /eqP a_nb.
rewrite /is_left_of is_left_of_circular in H.
case a_nc : (a == c);first move:a_nc => /eqP a_c;first move:H;
first by rewrite /is_left_of a_c /triangulation.is_left_of oriented_surface_x_x ltrr.
move:a_nc => /eqP /eqP a_nc.
rewrite /is_left_of is_left_of_circular in H.
case b_nc : (b == c);first move:b_nc => /eqP b_c;first move:H;
first by rewrite /is_left_of b_c /triangulation.is_left_of oriented_surface_x_x ltrr.
move:b_nc => /eqP /eqP b_nc.

case vab_nac :(vertices_to_edge a b == vertices_to_edge a c).
  have:false.
    move:vab_nac.
    by rewrite /vertices_to_edge;case:(xCoord a < xCoord b);case(xCoord b < xCoord a);
    case:(yCoord a < yCoord c);case:(xCoord a < xCoord c);case:(xCoord c < xCoord a);
    case:(yCoord a < yCoord b) => /=;
    rewrite /vertices_to_edge_aux => /eqP;
    rewrite -matrixP => H2;
    (try by (have abs := H2 ord10 ord21;move:abs;
    rewrite !mxE => //= H3;
    (try by move:b_nc;rewrite H3 => /eqP);
    (try by move:a_nb;rewrite H3 => /eqP);
    (try by move:a_nc;rewrite H3 => /eqP)));
    have abs := H2 ord10 ord20;move:(abs);
    rewrite !mxE => //= H3;
    (try by move:b_nc;rewrite H3 => /eqP);
    (try by move:a_nb;rewrite H3 => /eqP);
    (try by move:a_nc;rewrite H3 => /eqP).
 by [].
case vab_nbc :(vertices_to_edge a b == vertices_to_edge b c).
  have:false.
    move:vab_nbc.
    by rewrite /vertices_to_edge;case:(xCoord a < xCoord b);case:(xCoord b < xCoord a);
    case:(xCoord b < xCoord c);case:(xCoord c < xCoord b);case:(yCoord b  < yCoord c);
    case:(yCoord a < yCoord b) => /=;
    rewrite /vertices_to_edge_aux => /eqP;
    rewrite -matrixP => H2;
    (try by (have abs := H2 ord10 ord21;move:abs;
    rewrite !mxE => //= H3;
    (try by move:b_nc;rewrite H3 => /eqP);
    (try by move:a_nb;rewrite H3 => /eqP);
    (try by move:a_nc;rewrite H3 => /eqP)));
    have abs := H2 ord10 ord20;move:(abs);
    rewrite !mxE => //= H3;
    (try by move:b_nc;rewrite H3 => /eqP);
    (try by move:a_nb;rewrite H3 => /eqP);
    (try by move:a_nc;rewrite H3 => /eqP).
  by [].

case vbc_nac :(vertices_to_edge a c == vertices_to_edge b c).
  have:false.
    move:vbc_nac.
    rewrite /vertices_to_edge;case:(xCoord a < xCoord c);case:(xCoord c < xCoord a);
    case:(xCoord b < xCoord c);case:(xCoord c < xCoord b);case:(yCoord a  < yCoord c);
    case:(yCoord b < yCoord c) => /=;
    rewrite /vertices_to_edge_aux => /eqP;
    rewrite -matrixP => H2;
    (try by (have abs := H2 ord10 ord21;move:abs;
    rewrite !mxE => //= H3;
    (try by move:b_nc;rewrite H3 => /eqP);
    (try by move:a_nb;rewrite H3 => /eqP);
    (try by move:a_nc;rewrite H3 => /eqP)));
    have abs := H2 ord10 ord20;move:(abs);
    rewrite !mxE => //= H3;
    (try by move:b_nc;rewrite H3 => /eqP);
    (try by move:a_nb;rewrite H3 => /eqP);
    (try by move:a_nc;rewrite H3 => /eqP).
  by [].
rewrite !cardfsU !cardfs1 fsetI1 !inE.
move:vab_nac => /negP /negP vab_nac.
move:vab_nbc => /negP /negP vab_nbc.
move:vbc_nac => /negP /negP vbc_nac.

rewrite [vertices_to_edge a c == vertices_to_edge a b]eq_sym (negPf vab_nac) cardfs0.
rewrite fsetI1 !inE ![vertices_to_edge b c == _]eq_sym.
by rewrite  (negPf vab_nbc) (negPf vbc_nac) /= cardfs0.
Qed.

Definition V := P.

Definition points_to_vector : P -> P -> V  := fun a b =>
  \matrix_(j<1, i<2) (if i == ord20
                      then xCoord b - xCoord a
                      else yCoord b - yCoord a).

Definition scalar : V -> V -> R := fun a b =>
  (xCoord a * xCoord b)+(yCoord a * yCoord b).

Definition on_edge : E -> P-> bool := fun e p =>
  let p1 := e ord10 ord20 in
  let p2 := e ord10 ord21 in
  if oriented_surface p1 p2 p != 0
  then false
  else let p1p2 := points_to_vector p1 p2 in
       let p1p  := points_to_vector p1 p  in
       let sc   := scalar p1p2 p1p in
       if (0 <= sc) && (sc <= scalar p1p2 p1p2)
       then true
       else false.

Definition in_triangle := in_triangle vertex oriented_surface.

Definition is_on_line := is_on_line oriented_surface.

Lemma on_line_on_edge (a b c :P):
  is_left_of a b c -> forall q:P, is_on_line a c q ->
                          is_left_of a b q -> is_left_of b c q ->
                          on_edge (vertices_to_edge a c) q.
Proof.
move => islo_abc q il_acq islo_abq islo_bcq.
rewrite /is_on_line /triangulation.is_on_line in il_acq.
move:il_acq => /eqP il_acq.
rewrite /on_edge.
rewrite /vertices_to_edge.

have:(xCoord a < xCoord c) = true -> 0 <= scalar (points_to_vector a c) (points_to_vector a q) <= scalar (points_to_vector a c) (points_to_vector a c).
move => xac.
apply/andP;split.
rewrite /scalar.

case yac :(yCoord a < yCoord c).
  admit.

have:0 <= scalar (points_to_vector c a) (points_to_vector a q) <= scalar (points_to_vector c a) (points_to_vector c a).
  admit.

case xac:(xCoord a < xCoord c);
case xca:(xCoord c < xCoord a);
case yac:(yCoord a < yCoord c) => /=;
rewrite /vertices_to_edge_aux !mxE => /=;
(try rewrite il_acq);
rewrite oriented_surface_change1 oriented_surface_circular in  il_acq;
(try (move:il_acq => /eqP;rewrite oppr_eq0 => /eqP ->)) => /=;
(have:0==0 by (move => temp; apply/eqP)) => -> /=;
move => H1 H2.
admit.
admit.
admit.
admit.

(try rewrite H1); (try rewrite H2) => //=.
Qed.

Lemma vert_not_on_edges t p:   oriented_triangle t -> p \in vertex_set t ->
                         forall e, (e \in edges_set t -> on_edge e p -> false).
Proof.
move => or_t p_t e e_t e_p.
move:or_t.
rewrite /oriented_triangle => or_t.
case s0 : (oriented_surface (vertex1 t) (vertex2 t) (vertex3 t) != 0);last first.
  admit.
have: 0<(oriented_surface (vertex1 t) (vertex2 t) (vertex3 t)).
  rewrite ltr_def.
  apply/andP;split => //=.
move => islo.
Check edges_set.
move:e_t. => /imfsetP .
Check on_edge_on_line islo. e_p.


(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** Instance of Multisets for LL formulas *)

Require Export Multisets.
Require Import Eqset.
Require Export Syntax.
Export ListNotations.

Module M.
  Definition A : Set := lexp.
  Definition eqA := eqLExp.
  Definition eqA_dec := eqLExp_dec.
  Definition eq_dec := LExp_eq_dec.
End M.

Module MultisetLL := MultisetList M.
Export MultisetLL.


Require Coq.Arith.Arith.
Require Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Import ListNotations.
Import NPeano.

Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  apply eq2.
Qed.

Theorem silly_ex :
     (forall n, even n = true -> odd (S n) = true) ->
     even 3 = true ->
     odd 4 = true.
Proof.
  intros H.
  apply H.
Qed.

Theorem silly3_firsttry : forall (n : nat),
     true = EqNat.beq_nat n 5 ->
     EqNat.beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  apply H.
Qed.

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  intros l l' H.
  rewrite H.
  symmetry.
  apply rev_involutive.
Qed.

Theorem trans_eq : forall (X : Type) (n m o : X),
    n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2.
  rewrite eq1, eq2.
  reflexivity.
Qed.

Definition minustwo (n : nat) : nat :=
  n - 2.

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros n m o p H1 H2.
  apply trans_eq with m; assumption.
Qed.


Require Export MyList.
Require Export LabelAlgebra.
Require Export Two.

Set Implicit Arguments.

(** * A small lambda calculus, in de Bruijn notation. *)
Inductive term : Type :=
  | TBool : bool -> term
  | TNat : nat -> term
  | TVar : nat -> term
  | TAbs : term -> term
  | TApp : term -> term -> term
  | TDecl : term -> term
  | TIf : term -> term -> term -> term.

(** * Atoms, values. *)
Section Atoms.

Inductive atom : Type :=
  | Atom : value -> two -> atom
with value : Type :=
     | VBool : bool -> value
     | VNat : nat -> value
     | VClos : list atom -> term -> value.

Definition env := list atom.

(** Mutual folds. *)
Section folds.
Hypothesis
  (Patom : atom -> Type).
Hypothesis
  (Pvalue : value -> Type).
Hypothesis
  (Penv : list atom -> Type).
Hypothesis
  (Hatom : forall v, Pvalue v -> forall l, Patom (Atom v l)).
Hypothesis
  (Hbool : forall b, Pvalue (VBool b)).
Hypothesis
  (Hnat : forall n, Pvalue (VNat n)).
Hypothesis
  (Hclos : forall l, Penv l -> forall t, Pvalue (VClos l t)).
Hypothesis
  (Henv : forall l, (forall n a, atIndex l n = Some a -> Patom a) -> Penv l).

Definition env_fold'
           (atom_fold : forall a, Patom a) (e: env) : Penv e :=
  Henv
    e
    ((fix env_fold (e : env) :
        forall n a, atIndex e n = Some a -> Patom a :=
        match e as e
              return forall n a, atIndex e n = Some a -> Patom a
        with
          | nil =>
            fun n a H => atIndexNilSome n a H
          | a :: e =>
            fun n =>
              match n as n
                    return
                    forall b, atIndex (a :: e) n = Some b -> Patom b
              with
                | O => fun b Heq =>
                         match Heq with
                           | eq_refl => atom_fold a
                         end
                | S n => env_fold e n
              end
        end) e).

Fixpoint atom_fold (a : atom) : Patom a :=
match a with
  | Atom v l => Hatom (value_fold v) l
end
with value_fold (v : value) : Pvalue v :=
       match v with
         | VBool b => Hbool b
         | VNat n => Hnat n
         | VClos e t => Hclos (env_fold' atom_fold e) t
       end.

Definition env_fold : forall e, Penv e := env_fold' atom_fold.

Definition atom_value_env_fold :
  (forall a, Patom a)
  * (forall v, Pvalue v)
  * (forall e, Penv e) :=
  pair (pair atom_fold value_fold) env_fold.

End folds.

(** Mutual induction. *)
Section mutind.

Hypothesis
  (Patom : atom -> Prop).
Hypothesis
  (Pvalue : value -> Prop).
Hypothesis
  (Penv : env -> Prop).
Hypothesis
  (Hatom : forall v, Pvalue v -> forall l, Patom (Atom v l)).
Hypothesis
  (Hbool : forall b, Pvalue (VBool b)).
Hypothesis
  (Hnat : forall n, Pvalue (VNat n)).
Hypothesis
  (Hclos : forall l, Penv l -> forall t, Pvalue (VClos l t)).
Hypothesis
  (Henv :  forall l, (forall n a, atIndex l n = Some a -> Patom a) -> Penv l).

Definition atom_value_env_mutind :
  (forall a, Patom a)
  /\ (forall v, Pvalue v)
  /\ (forall e, Penv e) :=
  conj (atom_fold Patom Pvalue Penv Hatom Hbool Hnat Hclos Henv)
       (conj (value_fold Patom Pvalue Penv Hatom Hbool Hnat Hclos Henv)
             (env_fold Patom Pvalue Penv Hatom Hbool Hnat Hclos Henv)).

End mutind.

End Atoms.


Require Import List Reals Lia Lra.
From BY Require Import Rlemmas ListLemmas Rmin_list Zpower_nat Matrix Spectral.

Import ListNotations.

Local Open Scope R.
Local Open Scope mat_scope.

Local Coercion IZR : Z >-> R.

(***************************************************************************************)
(** The next section contains definitions of the various number series used to analyse *)
(** the complexity of the Rj number sequence (from AppendixE).                         *)
(** These are primarily used AppendixF.v                                               *)
(***************************************************************************************)

Definition M (e : nat) (q : Z) := [ 0 , 1 / (2 ^ e) ; - 1 / (2 ^ e) , q / (2 ^ (2 * e)) ].

Definition alpha_high w : R := (633/1024) ^ w.

Definition alpha (w : nat) : R :=
  match w with
  | 0%nat => 1 | 1%nat => 1 | 2%nat => 689491/2^20 | 3%nat => 779411/2^21
  | 4%nat => 880833/2^22 | 5%nat => 165219/2^20 | 6%nat => 97723/2^20 | 7%nat => 882313/2^24
  | 8%nat => 306733/2^23 | 9%nat => 92045/2^22 | 10%nat => 439213/2^25 | 11%nat => 281681/2^25
  | 12%nat => 689007/2^27 | 13%nat => 824303/2^28 | 14%nat => 257817/2^27 | 15%nat => 634229/2^29
  | 16%nat => 386245/2^29 | 17%nat => 942951/2^31 | 18%nat => 583433/2^31 | 19%nat => 713653/2^32
  | 20%nat => 432891/2^32 | 21%nat => 133569/2^31 | 22%nat => 328293/2^33 | 23%nat => 800421/2^35
  | 24%nat => 489233/2^35 | 25%nat => 604059/2^36 | 26%nat => 738889/2^37 | 27%nat => 112215/2^35
  | 28%nat => 276775/2^37 | 29%nat => 84973/2^36 | 30%nat => 829297/2^40 | 31%nat => 253443/2^39
  | 32%nat => 625405/2^41 | 33%nat => 95625/2^39 | 34%nat => 465055/2^42 | 35%nat => 286567/2^42
  | 36%nat => 175951/2^42 | 37%nat => 858637/2^45 | 38%nat => 65647/2^42 | 39%nat => 40469/2^42
  | 40%nat => 24751/2^42 | 41%nat => 240917/2^46 | 42%nat => 593411/2^48 | 43%nat => 364337/2^48
  | 44%nat => 889015/2^50 | 45%nat => 543791/2^50 | 46%nat => 41899/2^47 | 47%nat => 205005/2^50
  | 48%nat => 997791/2^53 | 49%nat => 307191/2^52 | 50%nat => 754423/2^54 | 51%nat => 57527/2^51
  | 52%nat => 281515/2^54 | 53%nat => 694073/2^56 | 54%nat => 212249/2^55 | 55%nat => 258273/2^56
  | 56%nat => 636093/2^58 | 57%nat => 781081/2^59 | 58%nat => 952959/2^60 | 59%nat => 291475/2^59
  | 60%nat => 718599/2^61 | 61%nat => 878997/2^62 | 62%nat => 534821/2^62 | 63%nat => 329285/2^62
  | 64%nat => 404341/2^63 | 65%nat => 986633/2^65 | 66%nat => 603553/2^65 | w => alpha_high w
  end.

Fixpoint alpha_aux w :=
  match w with
  | 0%nat => nil
  | S n => alpha_aux n ++ (alpha_high w / alpha w) :: nil
  end.

Lemma alpha67 i : (67 <= i)%nat -> alpha i = alpha_high i.
Proof. do 67 (destruct i as [|i]; [lia|]). reflexivity. Qed.

Lemma alpha_pos_nonneg w : (0 < alpha w).
Proof. do 67 (destruct w as [|w]; simpl; try lra); unfold alpha_high; apply pow_lt; lra. Qed.

Lemma alpha_pos w : (0 <= alpha w).
Proof. apply Rlt_le. apply alpha_pos_nonneg. Qed.

Definition alpha_quot w i :=
  (alpha (w + i)) / (alpha i).

Lemma alpha_quot_spec w i :
  (i >= 67)%nat -> alpha_quot w i = alpha_high w.
Proof.
  intros. unfold alpha_quot. rewrite !alpha67 by lia. unfold alpha_high.
  rewrite div_pow. replace (w + i - i)%nat with w by lia. reflexivity. lra. lia. Qed.

Definition beta_aux (w : nat) n :=
  map_seq (alpha_quot w) 0%nat n.

Definition beta w := Rmin_list (beta_aux w 68%nat).

Lemma beta_spec w :
  forall i, beta w <= alpha_quot w i.
Proof.
  intros. apply Rmin_list_spec.
  unfold beta_aux.
  destruct (le_dec i 67).
  - apply map_seq_In; lia.
  - replace (alpha_quot w i) with (alpha_quot w 67%nat).
    apply map_seq_In. lia.
    rewrite !alpha_quot_spec. reflexivity. lia. lia. Qed.

Lemma beta_spec2 w :
  exists i, beta w = alpha_quot w i.
Proof.
  epose proof Rmin_list_spec2 (map_seq (alpha_quot w) 0%nat 68%nat) _ as [x []].
  unfold beta, beta_aux. apply In_map_seq in H. rewrite H0.
  destruct H. exists x0. congruence.
  Unshelve. apply map_seq_nonnil; lia. Qed.

Lemma beta_pos w :
  0 <= beta w.
Proof.
  pose proof beta_spec2 w as [i]. rewrite H. unfold alpha_quot.
  pose proof alpha_pos (w + i).
  pose proof alpha_pos i. apply div_pos_pos; assumption. Qed.

Definition beta_quot w j :=
  beta (w + j) * 2 ^ j * 70 / 169.

Definition gamma_aux w e n :=
  map_seq (beta_quot w) e n.

Definition gamma w e := Rmin_list (gamma_aux w e 68%nat).

Definition gamma_spec w e :
  gamma w e <= beta (w + e) * 2 ^ e * 70 / 169.
Proof.
  apply Rmin_list_spec.
  unfold gamma_aux, beta_quot. left. reflexivity. Qed.

Definition gamma_spec2 w e :
  exists i, gamma w e = beta_quot w i.
Proof.
  epose proof Rmin_list_spec2 (map_seq (beta_quot w) e 68%nat) _ as [x []].
  unfold gamma, gamma_aux. apply In_map_seq in H. rewrite H0.
  destruct H. exists x0. congruence.
  Unshelve. apply map_seq_nonnil. lia. Qed.

Lemma gamma_pos w e :
  0 <= gamma w e.
Proof.
  pose proof gamma_spec2 w as [i]. rewrite H. unfold beta_quot.
  pose proof beta_pos (w + i).
  pose proof pow_le 2 i ltac:(lra). nra. Qed.

(************************************************)
(** The definition of the recursively defined S *)
(************************************************)

Inductive inS : nat -> mat R -> Prop :=
| IS : inS 0%nat I
| Sc (w : nat) (P : mat R) :
    forall (e : nat) (q : Z),
    inS w P ->
    (w = 0%nat) \/ (mat_norm P > beta w) ->
    mat_norm P > (gamma w e) ->
    (1 <= e)%nat ->
    Z.odd q = true ->
    (1 <= q < 2 ^+ (S e))%Z ->
    inS (e + w) (mmult (M e q) P).


Require Import BigO.Notation.
Require Import BigO.Util.DecField.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.interfaces.vectorspace.
Require Import MathClasses.orders.dec_fields.

Section Facts.
  Context `{SemiNormedSpace K V}.
  Context `{SemiNormedSpace K W1}.
  Context `{SemiNormedSpace K W2}.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Context `{forall x y : K, Decision (x = y)}.

  (**
  A general and useful result about the duality of O and Ω.
  Informal proof/overview:
    - TODO
  *)

  Lemma O_and_Omega : ∀ (f : V → W1) (g : V → W2), f ∈ O(g) ↔ g ∈ Ω(f).
    split.
    {
      (* Unfurl our hypothesis *)
      intros f_O_g.
      unfold big_O in *.
      destruct f_O_g as [k [zero_lt_k [m0 [zero_lt_m0 f_O_g]]]].

      unfold big_Omega.
      exists (/k).
      split.
      {
        now apply MathClasses.orders.dec_fields.pos_dec_recip_compat.
      }
      {
        exists m0.
        split; try assumption.
        intros m n0_le_n.
        assert (∥ f m ∥ ≤ k * (∥ g m ∥)) by (now apply f_O_g).

        assert (inv_k_gt_0 : 0 < / k) by
            (now apply MathClasses.orders.dec_fields.pos_dec_recip_compat).
        assert (mult_inv_eq_1 : (/ k) * k = 1) by
            (now apply dec_recip_inverse_ge_0).
        setoid_replace (∥g m∥) with (1 * ∥g m∥) by (now rewrite left_identity).
        (* This is awkward, but causes Coq not to automagically multiply
            (/ k_O) * k_O *)
        rewrite <- mult_inv_eq_1.
        rewrite <- associativity.
        apply order_preserving.
        - now apply (order_preserving_mult (/ k)).
        - trivial.
      }
    }
    { (* g ∈ Ω(f) -> f ∈ O(g) *)
      intros g_Ω_f.

      (* Unfurl our hypothesis *)
      unfold big_Omega in *.
      destruct g_Ω_f as [k [zero_lt_k [m0 [zero_lt_m0 g_Ω_f]]]].

      unfold big_O.
      exists (/k).
      split.
      {
        now apply MathClasses.orders.dec_fields.pos_dec_recip_compat.
      }
      {
        exists m0.
        split; try assumption.
        intros m n0_le_n.
        assert (k * (∥ f m ∥) ≤ ∥ g m ∥) by (now apply g_Ω_f).

        assert (inv_k_gt_0 : 0 < / k) by
            (now apply MathClasses.orders.dec_fields.pos_dec_recip_compat).
        assert (mult_inv_eq_1 : (/ k) * k = 1) by
            (now apply dec_recip_inverse_ge_0).
        setoid_replace (∥f m∥) with (1 * ∥f m∥) by (now rewrite left_identity).
        (* This is awkward, but causes Coq not to automagically multiply
            (/ k_O) * k_O *)
        rewrite <- mult_inv_eq_1.
        rewrite <- associativity.
        apply order_preserving.
        - now apply (order_preserving_mult (/ k)).
        - trivial.
      }
    }
  Qed.

  (**
   Little o is strictly more stringent than big O.
   *)
  Lemma o_implies_O : ∀ (f : V → W1) (g : V → W2), f ∈ o(g) → f ∈ O(g).
    intros f g f_o_g.
    unfold big_O.

    exists 1.
    split; try (apply zero_lt_one_dec).
    destruct (f_o_g 1 zero_lt_one_dec) as [m0 [zero_lt_m0 ?]].
    exists m0.
    split; assumption.
  Qed.

  (**
   Little ω is strictly more stringent than big Ω.
   *)
  Lemma omega_implies_Omega : ∀ (f : V → W1) (g : V → W2), f ∈ ω(g) → f ∈ Ω(g).
    intros f g f_ω_g.
    unfold big_Omega.

    exists 1.
    split; try (apply zero_lt_one_dec).
    destruct (f_ω_g 1 zero_lt_one_dec) as [m0 [zero_lt_m0 ?]].
    exists m0.
    split; assumption.
  Qed.

  (* Lemma big_Omega_mult_constant : ∀ (f g : (V -> V)) (c : K), f ∈ Ω(g) -> f ∈ Ω(c * g). *)
  (* Lemma big_O_mult_constant : ∀ (f g : (V -> V)) (c : K), f ∈ O(g) -> f ∈ O(c * g). *)
End Facts.


Theorem peano_3 : forall n m : nat,
  n = m -> S n = S m.
Proof.
  intros. destruct n as [|n'] eqn:En.
  - destruct m as [|m'] eqn:Em.
    + reflexivity.
    + rewrite <- H. reflexivity.
  - rewrite H. reflexivity.
Qed.


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

Require Import Arith.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

Fixpoint mem (mem_arg0 : natural) (mem_arg1 : lst) : bool
           := match mem_arg0, mem_arg1 with
              | x, Nil => false
              | x, Cons y z => orb (eqb x y) (mem x z)
              end.

Definition lst_mem := mem.

Fixpoint lst_intersection (lst_intersection_arg0 : lst) (lst_intersection_arg1 : lst) : lst
           := match lst_intersection_arg0, lst_intersection_arg1 with
              | Nil, x => Nil
              | Cons n x, y => if lst_mem n y then Cons n (lst_intersection x y) else lst_intersection x y
              end.

Lemma Nat_beq_eq : forall (x y : natural), eqb x y = true -> x = y.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. destruct y.
   + simpl in H. apply IHx in H. rewrite H. reflexivity.
   + discriminate.
   - intros. destruct y.
   + discriminate.
   + reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : lst) (z : lst), and (eq (lst_mem x y) true) (eq (lst_mem x z) true) -> eq (lst_mem x (lst_intersection y z)) true.
Proof.
   intros.
   destruct H.
   induction y.
   - simpl in H. apply Bool.orb_prop in H. destruct H.
     + simpl. destruct (lst_mem n z) eqn:?.
       * simpl. rewrite H. reflexivity.
       * lfind. Admitted.


Require Import ZArith.
Require Import Coq.Reals.Reals.
Require Import Coq.Reals.Rminmax.
Require Import micromega.RMicromega.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.

Require Import Helix.MSigmaHCOL.CType.

Instance R_Equiv: Equiv R := eq.

Instance R_Setoid: Setoid R.
Proof. split; auto. Qed.

Module MRasCT <: CType.

  Definition t := R.

  Definition CTypeEquiv := R_Equiv.
  Definition CTypeSetoid := R_Setoid.

  Instance CTypeEquivDec: forall x y: t, Decision (x = y).
  Proof.
    intros.
    unfold Decision.
    apply R.OT.eq_dec.
  Qed.

  Definition CTypeZero := R0.
  Definition CTypeOne  := R1.

  Lemma CTypeZeroOneApart: R0 ≠ R1.
  Proof.
    unfold equiv.
    eapply OrderedRing.SORneq_0_1.
    apply Rsor.
  Qed.

  Definition CTypePlus     := Rplus.
  Definition CTypeNeg      := Ropp.
  Definition CTypeMult     := Rmult.
  Definition CTypeAbs      := Rabs.

  Definition CTypeZLess (a b: R) : R :=
    match (Rlt_dec a b) with
    | left _ => CTypeOne
    | right _ => CTypeZero
    end.

  Definition CTypeMin      := Rmin.
  Definition CTypeMax      := Rmax.
  Definition CTypeSub      := Rminus.

  Instance Zless_proper: Proper ((=) ==> (=) ==> (=)) CTypeZLess.
  Proof. solve_proper. Qed.

  Instance abs_proper: Proper ((=) ==> (=)) Rabs.
  Proof. solve_proper. Qed.

  Instance plus_proper: Proper ((=) ==> (=) ==> (=)) (Rplus).
  Proof. solve_proper. Qed.

  Instance sub_proper: Proper ((=) ==> (=) ==> (=)) (Rminus).
  Proof. solve_proper. Qed.

  Instance mult_proper: Proper ((=) ==> (=) ==> (=)) (Rmult).
  Proof. solve_proper. Qed.

  Instance min_proper: Proper ((=) ==> (=) ==> (=)) (Rmin).
  Proof. solve_proper. Qed.

  Instance max_proper: Proper ((=) ==> (=) ==> (=)) (Rmax).
  Proof. solve_proper. Qed.

End MRasCT.


Require Import Ensembles.
Require Import Classical.

Variable U : Type.
Inductive Finite : Ensemble U -> Prop :=
| Empty_is_finite : Finite (Empty_set U)
| Union_is_finite : forall A : Ensemble U, Finite A -> forall x : U, ~ In U A x -> Finite (Add U A x).
Inductive cardinal : Ensemble U -> nat -> Prop :=
| card_empty : cardinal (Empty_set U) 0
| card_add : forall (A : Ensemble U) (n : nat), cardinal A n -> forall x : U, ~ In U A x -> cardinal (Add U A x) (S n).
Lemma cardinal_zero : forall X : Ensemble U, cardinal X O -> forall x : U, ~ In U X x.
Proof.
  intros.
  inversion H.
  intro.
  unfold In in H1.
  inversion H1.
Qed.
Lemma singleton_add : forall x : U, Singleton U x = Add U (Empty_set U) x.
Proof.
  intros.
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  unfold Included.
  intros.
  inversion H.
  unfold In.
  unfold Add.
  subst.
  apply Union_intror.
  apply H.
  unfold Included.
  intros.
  unfold In.
  unfold In in H.
  unfold Add in H.
  destruct H.
  destruct H.
  destruct H.
  reflexivity.
Qed.
Lemma singleton_one : forall x : U, cardinal (Singleton U x) (S O).
Proof.
  intros.
  assert (Singleton U x = Add U (Empty_set U) x).
  apply singleton_add.
  rewrite H.
  apply card_add.
  apply card_empty.
  intro.
  inversion H0.
Qed.
Lemma cardinal_invert :
  forall (X : Ensemble U) (p : nat),
    cardinal X p ->
    match p with
    | O => X = Empty_set U
    | S n => exists A : _, (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal A n)
    end.
Proof.
  intros.
  inversion H.
  reflexivity.
  exists A.
  exists x.
  intuition.
Qed.
Lemma cardinal_elim :
  forall (X : Ensemble U) (p : nat),
    cardinal X p ->
    match p with
    | O => X = Empty_set U
    | S n => Inhabited U X
    end.
Proof.
  intros.
  inversion H.
  reflexivity.
  apply (Inhabited_intro U (Add U A x) x).
  unfold In.
  unfold Add.
  apply Union_intror.
  unfold In.
  intuition.
Qed.
Lemma positive_cardinal : forall (X : Ensemble U) (n : nat), cardinal X (S n) -> exists x : U, In U X x.
Proof.
  intros.
  apply (cardinal_elim X (S n)) in H.
  destruct H.
  exists x.
  apply H.
Qed.
Lemma union_add : forall (X Y : Ensemble U) (x : U), Union U (Add U X x) Y = Add U (Union U X Y) x.
Proof.
  intros.
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  unfold Included.
  intros.
  unfold In.
  unfold Add.
  unfold In in H.
  destruct H.
  unfold In in H.
  unfold Add in H.
  destruct H.
  apply Union_introl.
  unfold In.
  apply Union_introl.
  apply H.
  apply Union_intror.
  apply H.
  apply Union_introl.
  unfold In.
  apply Union_intror.
  apply H.
  unfold Included.
  intros.
  unfold In in H.
  unfold Add in H.
  unfold In.
  destruct H.
  unfold In in H.
  destruct H.
  apply Union_introl.
  unfold In.
  unfold Add.
  apply Union_introl.
  apply H.
  apply Union_intror.
  apply H.
  apply Union_introl.
  unfold In.
  unfold Add.
  apply Union_intror.
  apply H.
Qed.
Lemma union_empty : forall X : Ensemble U, Union U (Empty_set U) X = X.
Proof.
  intros.
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  subst.
  unfold Included.
  intros.
  unfold In in H.
  case H.
  intros.
  inversion H0.
  intros.
  apply H0.
  unfold Included.
  intros.
  unfold In.
  apply Union_intror.
  apply H.
Qed.
Lemma finite_card_disjoint_union : forall (n : nat) (X Y : Ensemble U), cardinal X n -> Finite Y -> Disjoint U X Y -> Finite (Union U X Y).
Proof.
  intro n.
  induction n.
  intros.
  inversion H.
  assert (Union U (Empty_set U) Y = Y).
  apply union_empty.
  rewrite H3.
  apply H0.
  intros.
  inversion H.
  assert (~ In U Y x).
  destruct H1.
  specialize H1 with x.
  intro.
  assert (In U X x).
  unfold Add in H4.
  destruct H4.
  unfold In.
  apply Union_intror.
  unfold In.
  reflexivity.
  assert (In U (Intersection U X Y) x).
  unfold In.
  apply Intersection_intro.
  apply H7.
  apply H6.
  intuition.
  assert (Union U (Add U A x) Y = Add U (Union U A Y) x).
  apply union_add.
  rewrite H7.
  apply Union_is_finite.
  apply IHn.
  apply H3.
  apply H0.
  apply Disjoint_intro.
  intros.
  intro.
  unfold In in H8.
  destruct H8.
  destruct H1.
  specialize H1 with x0.
  unfold In in H1.
  assert (In U X x0).
  rewrite <- H4.
  unfold In.
  unfold Add.
  apply Union_introl.
  apply H8.
  assert (In U (Intersection U X Y) x0).
  unfold In.
  apply Intersection_intro.
  apply H10.
  apply H9.
  intuition.
  intro.
  unfold In in H8.
  destruct H8.
  intuition.
  intuition.
Qed.
Lemma finite_cardinal : forall X : Ensemble U, Finite X -> exists n : nat, cardinal X n.
Proof.
  intros.
  induction H.
  exists 0.
  apply card_empty.
  destruct IHFinite.
  exists (S x0).
  apply card_add.
  apply H1.
  apply H0.
Qed.

Lemma sub_disj : forall X Y : Ensemble U, Included U X Y -> Y = Union U X (Setminus U Y X) /\ Disjoint U X (Setminus U Y X).
Proof.
  intros.
  assert (forall x : U, In U X x \/ ~ In U X x).
  intros.
  apply classic.
  split.
  assert (forall x : U, In U Y x -> In U X x \/ In U (Setminus U Y X) x).
  intros.
  specialize H0 with x.
  case H0.
  intuition.
  intros.
  right.
  unfold In.
  unfold Setminus.
  intuition.
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  unfold Included.
  intros.
  specialize H1 with x.
  apply H1 in H2.
  case H2.
  intros.
  unfold In.
  apply Union_introl.
  apply H3.
  intros.
  apply Union_intror.
  apply H3.
  unfold Included.
  intros.
  unfold In in H2.
  destruct H2.
  unfold Included in H.
  apply H in H2.
  apply H2.
  unfold In in H2.
  unfold Setminus in H2.
  apply H2.
  apply Disjoint_intro.
  intros.
  intro.
  unfold In in H1.
  destruct H1.
  unfold In in H1.
  unfold In in H2.
  unfold Setminus in H2.
  intuition.
Qed.

Lemma finite_subset : forall X : Ensemble U, Finite X -> forall Y, (Included U Y X -> Finite Y).
Proof.
  intro X.
  intro.
  induction H.
  intros.
  assert (Y = Empty_set U).
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  apply H.
  unfold Included.
  intros.
  contradiction.
  rewrite H0.
  apply Empty_is_finite.
  intro.
  assert (In U Y x \/ ~In U Y x).
  apply classic.
  case H1.
  intros.
  assert (Included U (Subtract U Y x) A).
  unfold Included.
  intros.
  unfold In in H4.
  unfold Subtract in H4.
  unfold Setminus in H4.
  destruct H4.
  unfold In in H5.
  unfold Included in H3.
  specialize H3 with x0.
  apply H3 in H4.
  unfold In in H4.
  unfold Add in H4.
  destruct H4.
  apply H4.
  unfold In in H4.
  contradiction.
  specialize IHFinite with (Subtract U Y x).
  apply IHFinite in H4.
  assert (Add U (Subtract U Y x) x = Y).
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  unfold Included.
  intros.
  unfold In in H5.
  unfold Add in H5.
  destruct H5.
  unfold In in H5.
  unfold Subtract in H5.
  unfold Setminus in H5.
  apply H5.
  unfold In in H5.
  destruct H5.
  apply H2.
  unfold Included.
  intros.
  unfold In.
  unfold Add.
  assert (x = x0 \/ ~(x = x0)).
  apply classic.
  case H6.
  intros.
  apply Union_intror.
  unfold In.
  rewrite H7.
  apply In_singleton.
  intro.
  apply Union_introl.
  unfold In.
  unfold Subtract.
  unfold Setminus.
  split.
  apply H5.
  unfold In.
  intro.
  destruct H8.
  apply H7.
  reflexivity.
  rewrite <- H5.
  apply Union_is_finite.
  apply H4.
  intro.
  unfold In in H6.
  unfold Subtract in H6.
  unfold Setminus in H6.
  unfold In in H6.
  destruct H6.
  destruct H7.
  apply In_singleton.
  intros.
  assert (Included U Y A).
  unfold Included.
  intros.
  unfold Included in H3.
  specialize H3 with x0.
  assert (x <> x0).
  intro.
  subst.
  contradiction.
  apply H3 in H4.
  unfold In in H4.
  unfold Add in H4.
  destruct H4.
  apply H4.
  unfold In in H4.
  destruct H4.
  contradiction.
  apply IHFinite.
  apply H4.
Qed.
Lemma union_decompose : forall X Y : Ensemble U, Union U X Y = Union U (Union U (Setminus U X Y) (Intersection U X Y)) (Setminus U Y X).
Proof.
  intros.
  assert (forall x : U, In U X x \/ ~In U X x).
  intro.
  apply classic.
  assert (forall x : U, In U Y x \/ ~In U Y x).
  intro.
  apply classic.
  apply Extensionality_Ensembles.
  unfold Same_set.
  split.
  unfold Included.
  intros.
  unfold In in H1.
  destruct H1.
  unfold In.
  specialize H with x.
  specialize H0 with x.
  case H0.
  intros.
  apply Union_introl.
  unfold In.
  apply Union_intror.
  unfold In.
  apply Intersection_intro.
  apply H1.
  apply H2.
  intro.
  apply Union_introl.
  unfold In.
  apply Union_introl.
  unfold In.
  unfold Setminus.
  intuition.
  unfold In.
  specialize H with x.
  case H.
  intro.
  apply Union_introl.
  unfold In.
  apply Union_intror.
  unfold In.
  apply Intersection_intro.
  apply H2.
  apply H1.
  intro.
  apply Union_intror.
  unfold In.
  unfold Setminus.
  intuition.
  unfold Included.
  intros.
  unfold In.
  unfold In in H1.
  destruct H1.
  unfold In in H1.
  destruct H1.
  unfold In in H1.
  unfold Setminus in H1.
  apply Union_introl.
  apply H1.
  unfold In in H1.
  destruct H1.
  apply Union_intror.
  apply H2.
  unfold In in H1.
  unfold Setminus in H1.
  apply Union_intror.
  apply H1.
Qed.
Lemma finite_disjoint_union : forall (X Y : Ensemble U), Finite X -> Finite Y -> Disjoint U X Y -> Finite (Union U X Y).
Proof.
  intros.
  apply finite_cardinal in H.
  destruct H.
  apply (finite_card_disjoint_union x X Y).
  apply H.
  apply H0.
  apply H1.
Qed.
Lemma fin_union : forall X Y : Ensemble U, Finite X -> Finite Y -> Finite (Union U X Y).
Proof.
  intros.
  rewrite union_decompose.
  assert (Finite (Setminus U X Y)).
  assert (Included U (Setminus U X Y) X).
  unfold Included.
  intros.
  unfold In in H1.
  unfold Setminus in H1.
  apply H1.
  apply (finite_subset X).
  apply H.
  apply H1.
  assert (Finite (Intersection U X Y)).
  assert (Included U (Intersection U X Y) X).
  unfold Included.
  intros.
  unfold In in H2.
  destruct H2.
  apply H2.
  apply (finite_subset X).
  apply H.
  apply H2.
  assert (Finite (Setminus U Y X)).
  assert (Included U (Setminus U Y X) Y).
  unfold Included.
  intros.
  unfold In in H3.
  unfold Setminus in H3.
  apply H3.
  apply (finite_subset Y).
  apply H0.
  apply H3.
  assert (Disjoint U (Setminus U X Y) (Intersection U X Y)).
  apply Disjoint_intro.
  intros.
  intro.
  unfold In in H4.
  destruct H4.
  unfold In in H4.
  unfold Setminus in H4.
  unfold In in H5.
  destruct H5.
  destruct H4.
  contradiction.
  assert (Disjoint U (Union U (Setminus U X Y) (Intersection U X Y)) (Setminus U Y X)).
  apply Disjoint_intro.
  intros.
  intro.
  unfold In in H5.
  destruct H5.
  unfold In in H6.
  unfold Setminus in H6.
  destruct H6.
  unfold In in H5.
  destruct H5.
  unfold In in H5.
  unfold Setminus in H5.
  intuition.
  unfold In in H5.
  destruct H5.
  intuition.
  apply finite_disjoint_union.
  apply finite_disjoint_union.
  apply H1.
  apply H2.
  apply H4.
  apply H3.
  apply H5.
Qed.


Lemma q3 :
  forall (p:Prop) (q:Prop),
    p -> (q -> (p /\ q)).
Proof.
  intros p q pq qp.
  split.
  - assumption.
  - assumption.
Qed.


Require Import List Arith.

Variable A : Type.
Variable d : A.

Lemma nth_firstn_eq :
  forall (l:list A) (j i:nat),
    1+i <= j -> nth i (firstn j l) d = nth i l d.
Proof with simpl;trivial.
  induction l.
    induction j.
      induction i....
      induction i....
    induction j.
      induction i.
        simpl. intro H. contradict H. auto with arith.
        intro H. exfalso. contradict H. auto with arith.
      induction i....
        intro H. apply le_S_n in H. revert H. auto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import ZAxioms ZMulOrder ZSgnAbs ZGcd ZDivTrunc ZDivFloor.

(** * Least Common Multiple *)

(** Unlike other functions around, we will define lcm below instead of
  axiomatizing it. Indeed, there is no "prior art" about lcm in the
  standard library to be compliant with, and the generic definition
  of lcm via gcd is quite reasonable.

  By the way, we also state here some combined properties of div/mod
  and quot/rem and gcd.
*)

Module Type ZLcmProp
 (Import A : ZAxiomsSig')
 (Import B : ZMulOrderProp A)
 (Import C : ZSgnAbsProp A B)
 (Import D : ZDivProp A B C)
 (Import E : ZQuotProp A B C)
 (Import F : ZGcdProp A B C).

(** The two notions of division are equal on non-negative numbers *)

Lemma quot_div_nonneg : forall a b, 0<=a -> 0<b -> a÷b == a/b.
Proof.
 intros. apply div_unique_pos with (a rem b).
 now apply rem_bound_pos.
 apply quot_rem. order.
Qed.

Lemma rem_mod_nonneg : forall a b, 0<=a -> 0<b -> a rem b == a mod b.
Proof.
 intros. apply mod_unique_pos with (a÷b).
 now apply rem_bound_pos.
 apply quot_rem. order.
Qed.

(** We can use the sign rule to have an relation between divisions. *)

Lemma quot_div : forall a b, b~=0 ->
 a÷b == (sgn a)*(sgn b)*(abs a / abs b).
Proof.
 assert (AUX : forall a b, 0<b -> a÷b == (sgn a)*(sgn b)*(abs a / abs b)).
  intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order.
  destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
  rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order.
  rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order.
  rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l
    by order.
   apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order.
 (* main *)
 intros a b Hb.
 apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX].
 rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r.
 rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive.
 reflexivity.
 now apply opp_pos_neg.
 rewrite eq_opp_l, opp_0; order.
Qed.

Lemma rem_mod : forall a b, b~=0 ->
 a rem b == (sgn a) * ((abs a) mod (abs b)).
Proof.
 intros a b Hb.
 rewrite <- rem_abs_r by trivial.
 assert (Hb' := proj2 (abs_pos b) Hb).
 destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
 rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order.
 rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order.
 rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l
    by order.
  apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order.
Qed.

(** Modulo and remainder are null at the same place,
    and this correspond to the divisibility relation. *)

Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)).
Proof.
 intros a b Hb. split.
 intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 2.
  rewrite Hab; now nzsimpl.
 intros (c,Hc). rewrite <- Hc, mul_comm. now apply mod_mul.
Qed.

Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)).
Proof.
 intros a b Hb. split.
 intros Hab. exists (a÷b). rewrite (quot_rem a b Hb) at 2.
  rewrite Hab; now nzsimpl.
 intros (c,Hc). rewrite <- Hc, mul_comm. now apply rem_mul.
Qed.

Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0).
Proof.
 intros a b Hb. now rewrite mod_divide, rem_divide.
Qed.

(** When division is exact, div and quot agree *)

Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> a÷b == a/b.
Proof.
 intros a b Hb H.
 apply mul_cancel_l with b; trivial.
 assert (H':=H).
 apply rem_divide, quot_exact in H; trivial.
 apply mod_divide, div_exact in H'; trivial.
 now rewrite <-H,<-H'.
Qed.

Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) ->
 (c*a)/b == c*(a/b).
Proof.
 intros a b c Hb H.
 apply mul_cancel_l with b; trivial.
 rewrite mul_assoc, mul_shuffle0.
 assert (H':=H). apply mod_divide, div_exact in H'; trivial.
 rewrite <- H', (mul_comm a c).
 symmetry. apply div_exact; trivial.
 apply mod_divide; trivial.
 now apply divide_mul_r.
Qed.

Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) ->
 (c*a)÷b == c*(a÷b).
Proof.
 intros a b c Hb H.
 rewrite 2 quot_div_exact; trivial.
 apply divide_div_mul_exact; trivial.
 now apply divide_mul_r.
Qed.

(** Gcd of divided elements, for exact divisions *)

Lemma gcd_div_factor : forall a b c, 0<c -> (c|a) -> (c|b) ->
 gcd (a/c) (b/c) == (gcd a b)/c.
Proof.
 intros a b c Hc Ha Hb.
 apply mul_cancel_l with c; try order.
 assert (H:=gcd_greatest _ _ _ Ha Hb).
 apply mod_divide, div_exact in H; try order.
 rewrite <- H.
 rewrite <- gcd_mul_mono_l_nonneg; try order.
 f_equiv; symmetry; apply div_exact; try order;
  apply mod_divide; trivial; try order.
Qed.

Lemma gcd_quot_factor : forall a b c, 0<c -> (c|a) -> (c|b) ->
 gcd (a÷c) (b÷c) == (gcd a b)÷c.
Proof.
 intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order.
 now apply gcd_div_factor. now apply gcd_greatest.
Qed.

Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b ->
 gcd (a/g) (b/g) == 1.
Proof.
 intros a b g NZ EQ. rewrite gcd_div_factor.
 now rewrite <- EQ, div_same.
 generalize (gcd_nonneg a b); order.
 rewrite EQ; apply gcd_divide_l.
 rewrite EQ; apply gcd_divide_r.
Qed.

Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b ->
 gcd (a÷g) (b÷g) == 1.
Proof.
 intros a b g NZ EQ. rewrite !quot_div_exact; trivial.
 now apply gcd_div_gcd.
 rewrite EQ; apply gcd_divide_r.
 rewrite EQ; apply gcd_divide_l.
Qed.

(** The following equality is crucial for Euclid algorithm *)

Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a.
Proof.
 intros a b Hb. rewrite mod_eq; trivial.
 rewrite <- add_opp_r, mul_comm, <- mul_opp_l.
 rewrite (gcd_comm _ b).
 apply gcd_add_mult_diag_r.
Qed.

Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a.
Proof.
 intros a b Hb. rewrite rem_eq; trivial.
 rewrite <- add_opp_r, mul_comm, <- mul_opp_l.
 rewrite (gcd_comm _ b).
 apply gcd_add_mult_diag_r.
Qed.

(** We now define lcm thanks to gcd:

    lcm a b = a * (b / gcd a b)
            = (a / gcd a b) * b
            = (a*b) / gcd a b

   We had an abs in order to have an always-nonnegative lcm,
   in the spirit of gcd. Nota: [lcm 0 0] should be 0, which
   isn't garantee with the third equation above.
*)

Definition lcm a b := abs (a*(b/gcd a b)).

Instance lcm_wd : Proper (eq==>eq==>eq) lcm.
Proof. unfold lcm. solve_proper. Qed.

Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 ->
  a * (b / gcd a b) == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r.
Qed.

Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 ->
  (a / gcd a b) * b == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite 2 (mul_comm _ b).
 rewrite divide_div_mul_exact; try easy. apply gcd_divide_l.
Qed.

Lemma gcd_div_swap : forall a b,
 (a / gcd a b) * b == a * (b / gcd a b).
Proof.
 intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl.
 now rewrite lcm_equiv1, <-lcm_equiv2.
Qed.

Lemma divide_lcm_l : forall a b, (a | lcm a b).
Proof.
 unfold lcm. intros a b. apply divide_abs_r, divide_factor_l.
Qed.

Lemma divide_lcm_r : forall a b, (b | lcm a b).
Proof.
 unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap.
 apply divide_factor_r.
Qed.

Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a).
Proof.
 intros a b c Ha Hb (c',Hc). exists c'.
 now rewrite mul_comm, <- divide_div_mul_exact, mul_comm, Hc.
Qed.

Lemma lcm_least : forall a b c,
 (a | c) -> (b | c) -> (lcm a b | c).
Proof.
 intros a b c Ha Hb. unfold lcm. apply divide_abs_l.
 destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl.
 assert (Ga := gcd_divide_l a b).
 assert (Gb := gcd_divide_r a b).
 set (g:=gcd a b) in *.
 assert (Ha' := divide_div g a c NEQ Ga Ha).
 assert (Hb' := divide_div g b c NEQ Gb Hb).
 destruct Ha' as (a',Ha'). rewrite <- Ha' in Hb'.
 apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm].
 destruct Hb' as (b',Hb').
 exists b'.
 rewrite <- mul_assoc, Hb'.
 rewrite (proj2 (div_exact c g NEQ)).
 rewrite <- Ha', mul_assoc. f_equiv.
 apply div_exact; trivial.
 apply mod_divide; trivial.
 apply mod_divide; trivial. transitivity a; trivial.
Qed.

Lemma lcm_nonneg : forall a b, 0 <= lcm a b.
Proof.
 intros a b. unfold lcm. apply abs_nonneg.
Qed.

Lemma lcm_comm : forall a b, lcm a b == lcm b a.
Proof.
 intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b).
 now rewrite <- gcd_div_swap.
Qed.

Lemma lcm_divide_iff : forall n m p,
  (lcm n m | p) <-> (n | p) /\ (m | p).
Proof.
 intros. split. split.
 transitivity (lcm n m); trivial using divide_lcm_l.
 transitivity (lcm n m); trivial using divide_lcm_r.
 intros (H,H'). now apply lcm_least.
Qed.

Lemma lcm_unique : forall n m p,
 0<=p -> (n|p) -> (m|p) ->
 (forall q, (n|q) -> (m|q) -> (p|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp Hn Hm H.
 apply divide_antisym_nonneg; trivial. apply lcm_nonneg.
 now apply lcm_least.
 apply H. apply divide_lcm_l. apply divide_lcm_r.
Qed.

Lemma lcm_unique_alt : forall n m p, 0<=p ->
 (forall q, (p|q) <-> (n|q) /\ (m|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp H.
 apply lcm_unique; trivial.
 apply H, divide_refl.
 apply H, divide_refl.
 intros. apply H. now split.
Qed.

Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p.
Proof.
 intros. apply lcm_unique_alt; try apply lcm_nonneg.
 intros. now rewrite !lcm_divide_iff, and_assoc.
Qed.

Lemma lcm_0_l : forall n, lcm 0 n == 0.
Proof.
 intros. apply lcm_unique; trivial. order.
 apply divide_refl.
 apply divide_0_r.
Qed.

Lemma lcm_0_r : forall n, lcm n 0 == 0.
Proof.
 intros. now rewrite lcm_comm, lcm_0_l.
Qed.

Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl.
Qed.

Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n.
Proof.
 intros. now rewrite lcm_comm, lcm_1_l_nonneg.
Qed.

Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_refl.
Qed.

Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0.
Proof.
 intros. split.
 intros EQ.
 apply eq_mul_0.
 apply divide_0_l. rewrite <- EQ. apply lcm_least.
  apply divide_factor_l. apply divide_factor_r.
 destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r.
Qed.

Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m.
Proof.
 intros n m Hm H. apply lcm_unique_alt; trivial.
 intros q. split. split; trivial. now transitivity m.
 now destruct 1.
Qed.

Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m).
Proof.
 intros n m Hn. split. now apply divide_lcm_eq_r.
 intros EQ. rewrite <- EQ. apply divide_lcm_l.
Qed.

Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m.
Proof.
 intros. apply lcm_unique_alt; try apply lcm_nonneg.
 intros. rewrite divide_opp_l. apply lcm_divide_iff.
Qed.

Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m.
Proof.
 intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm.
Qed.

Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m.
Proof.
 intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H.
 easy. apply lcm_opp_l.
Qed.

Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m.
Proof.
 intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm.
Qed.

Lemma lcm_1_l : forall n, lcm 1 n == abs n.
Proof.
 intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg.
Qed.

Lemma lcm_1_r : forall n, lcm n 1 == abs n.
Proof.
 intros. now rewrite lcm_comm, lcm_1_l.
Qed.

Lemma lcm_diag : forall n, lcm n n == abs n.
Proof.
 intros. rewrite <- lcm_abs_l, <- lcm_abs_r.
 apply lcm_diag_nonneg, abs_nonneg.
Qed.

Lemma lcm_mul_mono_l :
  forall n m p, lcm (p * n) (p * m) == abs p * lcm n m.
Proof.
 intros n m p.
 destruct (eq_decidable p 0) as [Hp|Hp].
  rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl.
 destruct (eq_decidable (gcd n m) 0) as [Hg|Hg].
  apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm.
  nzsimpl. rewrite lcm_0_l. now nzsimpl.
 unfold lcm.
 rewrite gcd_mul_mono_l.
 rewrite !abs_mul, mul_assoc. f_equiv.
 rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc.
 rewrite div_mul_cancel_l; trivial.
 rewrite divide_div_mul_exact; trivial. rewrite abs_mul.
 rewrite <- (sgn_abs (sgn p)), sgn_sgn.
 destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]].
  rewrite EQ. now nzsimpl. order.
  rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl.
 apply gcd_divide_r.
 contradict Hp. now apply abs_0_iff.
Qed.

Lemma lcm_mul_mono_l_nonneg :
 forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m.
Proof.
 intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l.
Qed.

Lemma lcm_mul_mono_r :
 forall n m p, lcm (n * p) (m * p) == lcm n m * abs p.
Proof.
 intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm.
Qed.

Lemma lcm_mul_mono_r_nonneg :
 forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p.
Proof.
 intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r.
Qed.

Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 ->
 (gcd n m == 1 <-> lcm n m == abs (n*m)).
Proof.
 intros n m Hn Hm. split; intros H.
 unfold lcm. rewrite H. now rewrite div_1_r.
 unfold lcm in *.
 rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff].
 assert (H' := gcd_divide_r n m).
 assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order).
 apply mod_divide in H'; trivial. apply div_exact in H'; trivial.
 assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl).
 rewrite <- (mul_1_l (abs (_/_))) in H.
 rewrite H' in H at 3. rewrite abs_mul in H.
 apply mul_cancel_r in H; [|now rewrite abs_0_iff].
 rewrite abs_eq in H. order. apply gcd_nonneg.
Qed.

End ZLcmProp.


From mathcomp Require Import ssreflect.

Lemma injective_inl : forall (T1 T2 : Type) (t1 t2 : T1), inl T2 t1 = inl T2 t2 -> t1 = t2.
Proof.
move=> T1 T2 t1 t2 H1.
suff: (let f := fun (t : sum T1 T2) => match t with
  | inl t0 => t0
  | inr _ => t1
end in t1 = t2).
apply.
move=> f.
suff: (t1 = f (inl t1)).
move=> H2.
rewrite H2.
rewrite H1.
reflexivity.
reflexivity.
Qed.

Lemma injective_inr : forall (T1 T2 : Type) (t1 t2 : T2), inr T1 t1 = inr T1 t2 -> t1 = t2.
Proof.
move=> T1 T2 t1 t2 H1.
suff: (let f := fun (t : sum T1 T2) => match t with
  | inl _ => t1
  | inr t0 => t0
end in t1 = t2).
apply.
move=> f.
suff: (t1 = f (inr t1)).
move=> H2.
rewrite H2.
rewrite H1.
reflexivity.
reflexivity.
Qed.

Inductive sumT (T : Type) (tf : T -> Type) : Type :=
  | inT : forall (t : T), (tf t) -> sumT T tf.