Require Import ZArith.
Require Import NPeano.

Load "Bijection".

Definition nat_lt N := e_lift {n : nat | n < N}.

Definition finite (A : eqset) : Type :=
  { n : nat | eq_cardinal A (nat_lt n) }.

Lemma finite_nat_lt : forall N, finite (nat_lt N).
Proof.
  intro N.
  unfold finite.
  exists N.
  apply eq_cardinal_reflexive.
Qed.

Definition finite_cardinal A (A_finite : finite A) : nat.
  elim A_finite.
  intro n.
  intros.
  apply n.
Defined.

Lemma _nat_lt_ge_dec : forall n m : nat, {n < m} + {n >= m}.
Proof.
  intros n m.
  assert ({n < m} + {n = m} + {n > m}) as nm_opts.
  apply lt_eq_lt_dec.
  destruct nm_opts as [[n_lt_m | n_eq_m] | n_gt_m].
  left; assumption.
  right; apply Nat.eq_le_incl; symmetry; assumption.
  right; apply lt_le_weak; assumption.
Qed.

Lemma eq_in_lift : forall A (x y : e_set (e_lift A)), x == y -> x = y.
Proof.
  intros A x y H.
  compute in H.
  assumption.
Qed.

(*
 * 0 1 2 ... x-1 x x+1     N-1
 *
 * 0 1 2 ... x-1 x x+1 ... N-1 N
 * 0 1 2 ... x-1   x+1 ... N-1 N
 *)
Definition bijection_n_Sn_removal_function N (x : e_set (nat_lt (S N))) :
               e_set (nat_lt N) -> e_set (eqset_remove (nat_lt (S N)) x).
  intro y.
  assert ({proj1_sig y < proj1_sig x} + {proj1_sig y >= proj1_sig x})
      as xy_opts.
    apply _nat_lt_ge_dec.
  destruct xy_opts as [y_lt_x | y_ge_x].
  (* y < x *)
  assert (proj1_sig y < S N) as hyp_LT.
    apply lt_trans with (proj1_sig x).
    assumption.
    apply (proj2_sig x).
  exists (exist (fun z => z < S N) (proj1_sig y) hyp_LT).
  simpl.
  compute.
  intro x_eq_fy.
  assert (proj1_sig x = proj1_sig (exist (fun z : nat => z < S N) (proj1_sig y) hyp_LT))
      as H. apply f_equal. assumption.
  simpl in H.
  assert (proj1_sig x <> proj1_sig y).
    apply not_eq_sym.
    apply Nat.lt_neq.
    assumption.
  contradiction.
  (* y >= x *)
  assert (proj1_sig y + 1 < S N) as hyp_LT.
    rewrite plus_comm.
    simpl.
    apply lt_n_S.
    apply (proj2_sig y).
  exists (exist (fun z => z < S N) (proj1_sig y + 1) hyp_LT).
  simpl.
  compute.
  intro x_eq_fy.
  assert (proj1_sig x = proj1_sig (exist (fun z : nat => z < S N) (proj1_sig y + 1) hyp_LT))
      as H. apply f_equal. assumption.
  simpl in H.
  assert (proj1_sig x <> proj1_sig y + 1).
    apply le_gt_S in y_ge_x.
    rewrite plus_comm.
    simpl.
    apply Nat.lt_neq.
    assumption.
  contradiction.
Defined.

Definition bijection_n_Sn_removal_functional N (x : e_set (nat_lt (S N))) :
               e_set (nat_lt N ==> eqset_remove (nat_lt (S N)) x).
  simpl.
  unfold e_function_set.
  exists (bijection_n_Sn_removal_function N x).
  intros y1 y2 y1_eq_y2.
  compute in y1_eq_y2.
  replace y2 with y1.
  apply e_reflexive.
Defined.

Lemma bijection_n_Sn_removal :
  forall N (x : e_set (nat_lt (S N))),
    eq_cardinal (nat_lt N) (eqset_remove (nat_lt (S N)) x).
Proof.
  intros N x.
  unfold eq_cardinal.
  exists (bijection_n_Sn_removal_functional N x).
  apply inhabits.
  unfold bijection.
  intro fy.
  assert ({proj1_sig (proj1_sig fy) < proj1_sig x} +
          {proj1_sig (proj1_sig fy) = proj1_sig x} +
          {proj1_sig (proj1_sig fy) > proj1_sig x})
      as fy_opts.
    apply lt_eq_lt_dec.
  case fy_opts as [[fy_lt_x | fy_eq_x ] | fy_gt_x].
    (* fy < x *)
    admit.
    (* fy = x *)
    assert (~(x == proj1_sig fy)) as H.
      apply (proj2_sig fy).
      (** TODO **)
    (* fy > x *)
    admit.
Qed.

Lemma eq_cardinal_imp_eq_nat :
        forall N M, eq_cardinal (nat_lt N) (nat_lt M) -> N = M.
Proof.
  intro N.
  induction N.

  (* 0 *)
  intros M eq_card_N_M.
  unfold eq_cardinal in eq_card_N_M.
  elim eq_card_N_M.
  intros f inh_f_bij; case inh_f_bij; intro f_bij.
  assert ({0 = M} + {0 <> M}) as M_cases.
    apply eq_nat_dec.
  case M_cases.
  tauto.
  intro neq_0_M.
  assert (M > 0) as gt_0_M.
  apply neq_0_lt.
  assumption.
  unfold bijection in f_bij.
  elim f_bij with (exist (fun n => n < M) 0 gt_0_M).
  intro impossible_element.
  simpl in impossible_element.
  assert (proj1_sig impossible_element < 0).
  apply (proj2_sig impossible_element).
  assert (~proj1_sig impossible_element < 0).
  apply lt_n_0.
  contradiction.

  (* S N *)
  intros M eq_card_N_M.
  unfold eq_cardinal in eq_card_N_M.
  elim eq_card_N_M.
  intros f inh_f_bij; case inh_f_bij; intro f_bij.

Qed.

Lemma finite_cardinal_well_defined :
  forall A (A_fin1 A_fin2 : finite A),
    finite_cardinal A A_fin1 = finite_cardinal A A_fin2.
Proof.
  intros A A_fin1 A_fin2.
  unfold finite in A_fin1.
  elim A_fin1; intros n bijection_A_n.
  elim A_fin2; intros m bijection_A_m.
  induction n.
    (* 0 *)
    simpl.

    (* S n *)

(*** TODO :

     Demostrar que si tengo dos demostraciones de que un conjunto
     es finito, la primera componente (su cardinal), siempre coincide.
     Por induccion.

 ***)

(**** Groups ****)

Structure group :=
  mk_group {
      g_eqset : eqset ;
      g_unit : e_set g_eqset ;
      g_op : e_set g_eqset -> e_set g_eqset -> e_set g_eqset ;
      g_inv : e_set g_eqset -> e_set g_eqset ;
      g_unit_l : forall x, g_op g_unit x == x ;
      g_unit_r : forall x, g_op x g_unit == x ;
      g_assoc : forall x y z, g_op x (g_op y z) == g_op (g_op x y) z ;
      g_inv_r : forall x, g_op x (g_inv x) == g_unit
  }.

Notation "[ G ]" := (e_set (g_eqset G)).
Notation "a ** b" := (g_op _ a b) (at level 35).
Notation "a !" := (g_inv _ a) (at level 25).

Definition g_finite (G : group) := finite (e_set (g_eqset G)).

Definition g_order G (G_finite : g_finite G) : nat.
  unfold g_finite in G_finite.
  unfold finite in G_finite.
  elim G_finite.
  intros n _.
  apply n.
Defined.

Definition subgroup (H G : group) : Prop :=
  e_subset (g_eqset H) (g_eqset G).

(****)

Inductive Z2_set := Z2_0 | Z2_1.

Definition Z2_op (a b : Z2_set) :=
  match a with
  | Z2_0 => b
  | Z2_1 => (match b with
             | Z2_0 => Z2_1
             | Z2_1 => Z2_0
             end)
  end.

Definition Z2_inv (a : Z2_set) := a.

Lemma Z2_unit_l : forall x, Z2_op Z2_0 x = x.
Proof.
  intro x.
  case x.
  compute; reflexivity.
  compute; reflexivity.
Qed.

Lemma Z2_unit_r : forall x, Z2_op x Z2_0 = x.
Proof.
  intro x.
  case x.
  compute; reflexivity.
  compute; reflexivity.
Qed.

Lemma Z2_assoc : forall x y z, Z2_op x (Z2_op y z) = Z2_op (Z2_op x y) z.
Proof.
  intros x y z.
  case x.
  case y.
  compute; reflexivity.
  compute; reflexivity.
  case y.
  compute; reflexivity.
  case z.
  compute; reflexivity.
  compute; reflexivity.
Qed.

Lemma Z2_inv_r : forall x, Z2_op x (Z2_inv x) = Z2_0.
Proof.
  intro x.
  case x.
  compute; reflexivity.
  compute; reflexivity.
Qed.

Definition Z2 : group := mk_group
      Z2_set
      Z2_0
      Z2_op
      Z2_inv
      Z2_unit_l
      Z2_unit_r
      Z2_assoc
      Z2_inv_r.

Lemma nat_lt_2_cases : forall x : nat_lt 2, {proj1_sig x = 0} + {proj1_sig x = 1}.
Proof.
  intro x.
  assert (proj1_sig x <= 1) as x_shape.
    unfold nat_lt in x.
    elim x.
    intros x_value x_prop.
    simpl.
    apply lt_n_Sm_le.
    assumption.
  SearchAbout lt.
  rewrite <- NPeano.Nat.lt_1_r.
  replace (proj1_sig x = 0) with (proj1_sig x < 1).
  apply le_lt_eq_dec.
  assumption.
Qed.

Definition Z2_enum (x : nat_lt 2) : Z2_set.
  assert (proj1_sig x = 0 \/ proj1_sig x = 1) as x_cases.
  apply nat_lt_2_cases.
  case x_cases.

Lemma Z2_set_finite : finite Z2_set.
Proof.
  unfold finite.
  exists 2.
  exists (fun x => nat_lt_2 x).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (x : natural) : natural := mult z (Succ x).


Inductive bin: Type := | O : bin | B: bin -> bin | S: bin -> bin.

Fixpoint incr (b : bin) : bin :=
match b with
|O => S O
|B n' => S n'
|S n' => B (incr n')
end.

Example test_incr_1:
incr(O) = S O.

Proof. simpl. reflexivity. Qed.

Example test_incr_2:
incr(S O) = B (S O).

Proof. simpl. reflexivity. Qed.


Require Import Coq.Arith.EqNat Coq.Arith.Compare_dec.
Require Import Coq.Lists.List.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.
Set Implicit Arguments.

Local Arguments leb !_ !_.

Section fixedpoints.
  Context {A : Type}
          (sizeof : A -> nat)
          (step : A -> A)
          (step_monotonic : forall a, sizeof (step a) <= sizeof a)
          (step_eq : forall a, sizeof (step a) = sizeof a -> step a = a)
          (upperbound : A).

  Definition greatest_fixpoint_step
             (greatest_fixpoint : nat -> A -> A)
             (sz : nat)
             (a : A)
    : A
    := match sz with
       | 0 => a
       | S sz'
         => let a' := step a in
            let sza := sizeof a in
            let sza' := sizeof a' in
            if leb (S sza') sza
            then greatest_fixpoint sz' a'
            else a
       end.

  Fixpoint greatest_fixpoint' (sz : nat)
    : A -> A
    := greatest_fixpoint_step greatest_fixpoint' sz.

  Definition greatest_fixpoint (a : A) := greatest_fixpoint' (sizeof a) a.

  Lemma greatest_fixpoint_fixpoint a : step (greatest_fixpoint a) = greatest_fixpoint a.
  Proof.
    unfold greatest_fixpoint.
    set (sz := sizeof a).
    assert (H : sizeof a <= sz) by reflexivity.
    clearbody sz.
    revert dependent a.
    induction sz as [|sz IHsz].
    { simpl.
      intros a Hle.
      assert (sizeof (step a) <= 0) by (etransitivity; [ apply step_monotonic | apply Hle ]).
      apply step_eq; omega. }
    { simpl.
      intros.
      repeat match goal with
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
             | [ H : leb _ _ = true |- _ ]
               => apply leb_iff in H
             | [ H : leb _ _ = false |- _ ]
               => apply leb_iff_conv in H
             | _ => solve [ eauto with nocore ]
             | [ |- step _ = _ ] => apply step_eq
             | _ => omega
             | [ H : forall a, _ -> _ = _ |- _ ] => rewrite H by omega
             | [ H : _ < _ |- _ ] => hnf in H
             | [ H : S _ <= S _ |- _ ] => apply Le.le_S_n in H
             | [ H : sizeof ?x <= ?y, H' : ?y <= sizeof (step ?x) |- _ ]
               => let H'' := fresh in
                  assert (H'' : sizeof (step x) <= sizeof x) by apply step_monotonic;
                    assert (sizeof x = y) by omega;
                    assert (y = sizeof (step x)) by omega;
                    clear H H' H''
             | [ H : sizeof ?x <= sizeof (step ?x) |- _ ]
               => let H'' := fresh in
                  assert (H'' : sizeof (step x) <= sizeof x) by apply step_monotonic;
                    assert (sizeof x = sizeof (step x)) by omega;
                    clear H H''
             end. }
  Qed.
End fixedpoints.

Section listpair.
  Context {A B : Type}
          (fA : list A -> list B -> A -> bool)
          (fB : list A -> list B -> B -> bool)
          (upperA : list A)
          (upperB : list B).

  Definition sizeof_pair (lss : list A * list B) : nat
    := length (fst lss) + length (snd lss).

  Let step (lss : list A * list B) : list A * list B
    := (filter (fA (fst lss) (snd lss)) (fst lss),
        filter (fB (fst lss) (snd lss)) (snd lss)).

  Lemma step_monotonic lss : sizeof_pair (step lss) <= sizeof_pair lss.
  Proof.
    unfold step, sizeof_pair; simpl;
      apply Plus.plus_le_compat;
      apply length_filter.
  Qed.

  Lemma step_eq lss
    : sizeof_pair (step lss) = sizeof_pair lss -> step lss = lss.
  Proof.
    unfold sizeof_pair, step; simpl.
    destruct lss as [lsA lsB]; simpl.
    intro H.
    repeat match goal with
           | [ H : context[filter ?f ?ls] |- _ ]
             => unique pose proof (length_filter f ls)
           end.
    match goal with
    | [ H : ?x + ?y = ?x' + ?y' |- _ = _ :> list _ * list _ ]
      => assert (x = x') by omega;
           assert (y = y') by omega;
           clear H
    end.
    rewrite !length_filter_eq by omega.
    reflexivity.
  Qed.

  Definition greatest_fixpoint_of_lists : list A * list B
    := greatest_fixpoint sizeof_pair step (upperA, upperB).

  Definition greatest_fixpoint_of_lists_fixpoint
    : step greatest_fixpoint_of_lists = greatest_fixpoint_of_lists.
  Proof.
    apply greatest_fixpoint_fixpoint.
    { intros; apply step_monotonic. }
    { intros; apply step_eq; assumption. }
  Qed.

  Lemma greatest_fixpoint_of_lists_correct_1
        (lsA := fst greatest_fixpoint_of_lists)
        (lsB := snd greatest_fixpoint_of_lists)
    : fold_right andb true (map (fA lsA lsB) lsA) = true.
  Proof.
    unfold lsA at 2.
    rewrite <- greatest_fixpoint_of_lists_fixpoint.
    unfold step; simpl.
    apply fold_right_andb_true_map_filter.
  Qed.

  Lemma greatest_fixpoint_of_lists_correct_2
        (lsA := fst greatest_fixpoint_of_lists)
        (lsB := snd greatest_fixpoint_of_lists)
    : fold_right andb true (map (fB lsA lsB) lsB) = true.
  Proof.
    unfold lsB at 2.
    rewrite <- greatest_fixpoint_of_lists_fixpoint.
    unfold step; simpl.
    apply fold_right_andb_true_map_filter.
  Qed.
End listpair.


Require Import Quote.

Parameters A B C : Prop.

Inductive Formula : Type :=
| fAnd : Formula -> Formula -> Formula
| fOr  : Formula -> Formula -> Formula
| fNot : Formula -> Formula
| fTrue: Formula
| fCon : Prop -> Formula    (* Constructor for constants *)
.

Fixpoint eval (p:Formula) : Prop :=
    match p with
    | fAnd p1 p2    => eval p1 /\ eval p2
    | fOr  p1 p2    => eval p1 \/ eval p2
    | fNot p1       => ~ eval p1
    | fTrue         => True
    | fCon c        => c
    end.

Lemma L1 : A /\ (A /\ True) /\ ~B /\ (A <-> A).
Proof.
    quote eval.

Show.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.apartness.

Generalizable Variables A.

Lemma irrefl_neq `{R : Relation A} `{!Irreflexive R}
  : forall x y, R x y -> x <> y.
Proof.
intros ?? E e;rewrite e in E. apply (irreflexivity _ _ E).
Qed.

Lemma le_flip `{Le A} `{!TotalRelation (≤)} x y : ~(y ≤ x) -> x ≤ y.
Proof.
intros nle.
destruct (total _ x y) as [?|le];auto.
destruct (nle le).
Qed.

Section partial_order.
  Context `{PartialOrder A}.

  Lemma eq_le x y : x = y -> x ≤ y.
  Proof.
  intros E.
  rewrite E.
  apply reflexivity.
  Qed.

  Lemma eq_le_flip x y : x = y -> y ≤ x.
  Proof.
  intros E.
  rewrite E.
  apply reflexivity.
  Qed.

  Lemma not_le_ne x y : ~(x ≤ y) -> x <> y.
  Proof.
  intros E1 E2.
  apply E1.
  rewrite E2.
  apply reflexivity.
  Qed.

  Lemma eq_iff_le x y : x = y <-> x ≤ y /\ y ≤ x.
  Proof.
  split; intros E.
  - rewrite E. split;apply reflexivity.
  - apply (antisymmetry (≤) x y);apply E.
  Qed.
End partial_order.

Section strict_order.
  Context `{StrictOrder A}.

  Lemma lt_flip x y : x < y -> ~(y < x).
  Proof.
  intros E1 E2.
  apply (irreflexivity (<) x).
  transitivity y;assumption.
  Qed.

  Lemma lt_antisym x y : ~(x < y < x).
  Proof.
  intros [E1 E2].
  destruct (lt_flip x y);assumption.
  Qed.

  Lemma lt_ne x y : x < y -> x <> y.
  Proof.
  intros E1 E2.
  rewrite E2 in E1.
  apply (irreflexivity (<) y). assumption.
  Qed.

  Lemma lt_ne_flip x y : x < y -> y <> x.
  Proof.
  intro.
  apply symmetric_neq, lt_ne.
  assumption.
  Qed.

  Lemma eq_not_lt x y : x = y -> ~(x < y).
  Proof.
  intros E.
  rewrite E.
  apply (irreflexivity (<)).
  Qed.
End strict_order.

Section pseudo_order.
  Context `{PseudoOrder A}.

  Local Existing Instance pseudo_order_apart.

  Lemma apart_total_lt x y : x ≶ y -> x < y |_| y < x.
  Proof.
  intros.
  apply apart_iff_total_lt.
  assumption.
  Qed.

  Lemma pseudo_order_lt_apart x y : x < y -> x ≶ y.
  Proof.
  intros.
  apply apart_iff_total_lt.
  auto.
  Qed.

  Lemma pseudo_order_lt_apart_flip x y : x < y -> y ≶ x.
  Proof.
  intros.
  apply apart_iff_total_lt.
  auto.
  Qed.

  Lemma not_lt_apart_lt_flip x y : ~(x < y) -> x ≶ y -> y < x.
  Proof.
  intros nlt neq. apply apart_iff_total_lt in neq.
  destruct neq.
  - destruct nlt;auto.
  - auto.
  Qed.

  Lemma pseudo_order_cotrans_twice x₁ y₁ x₂ y₂
    : x₁ < y₁ -> merely (x₂ < y₂ |_| x₁ < x₂ |_| y₂ < y₁).
  Proof.
  intros E1.
  apply (merely_destruct (cotransitive E1 x₂));intros [?|E2];
  try solve [apply tr;auto].
  apply (merely_destruct (cotransitive E2 y₂));intros [?|?];apply tr;auto.
  Qed.

  Lemma pseudo_order_lt_ext x₁ y₁ x₂ y₂ : x₁ < y₁ ->
    merely (x₂ < y₂ |_| x₁ ≶ x₂ |_| y₂ ≶ y₁).
  Proof.
  intros E.
  apply (merely_destruct (pseudo_order_cotrans_twice x₁ y₁ x₂ y₂ E));
  intros [?|[?|?]];apply tr;
  auto using pseudo_order_lt_apart.
  Qed.

  Global Instance pseudoorder_strictorder : StrictOrder (_ : Lt A).
  Proof.
  split.
  - apply _.
  - intros x E.
    destruct (pseudo_order_antisym x x); auto.
  - intros x y z E1 E2.
    apply (merely_destruct (cotransitive E1 z));intros [?|?]; trivial.
    destruct (pseudo_order_antisym y z); auto.
  Qed.

  Global Instance nlt_trans : Transitive (complement (<)).
  Proof.
  intros x y z.
  intros E1 E2 E3.
  apply (merely_destruct (cotransitive E3 y));
  intros [?|?]; contradiction.
  Qed.

  Global Instance nlt_antisymm : AntiSymmetric (complement (<)).
  Proof.
  intros x y H1 H2.
  apply tight_apart. intros nap. apply apart_iff_total_lt in nap.
  destruct nap;auto.
  Qed.

  Lemma ne_total_lt `{!TrivialApart A} x y : x <> y -> x < y |_| y < x.
  Proof.
  intros neq;apply trivial_apart in neq.
  apply apart_total_lt. assumption.
  Qed.

  Global Instance lt_trichotomy `{!TrivialApart A} `{DecidablePaths A}
    : Trichotomy (<).
  Proof.
  intros x y.
  destruct (dec (x = y)) as [?|?]; try auto.
  destruct (ne_total_lt x y); auto.
  Qed.
End pseudo_order.

Section full_partial_order.
  Context `{FullPartialOrder A}.

  Local Existing Instance strict_po_apart.

  (* Duplicate of strong_setoids.apart_ne. This is useful because a
    StrongSetoid is not defined as a substructure of a FullPartialOrder *)
  Instance strict_po_apart_ne x y : PropHolds (x ≶ y) -> PropHolds (x <> y).
  Proof.
  intros; apply _.
  Qed.

  Global Instance fullpartialorder_strictorder : StrictOrder (<).
  Proof.
  split; try apply _.
  - apply strict_po_mere_lt.
  - intros x. red. intros E;apply lt_iff_le_apart in E.
    destruct E as [_ ?].
    apply (irreflexivity (≶) x).
    assumption.
  Qed.

  Lemma lt_le x y : PropHolds (x < y) -> PropHolds (x ≤ y).
  Proof.
  intro.
  apply lt_iff_le_apart.
  assumption.
  Qed.

  Lemma not_le_not_lt x y : ~(x ≤ y) -> ~(x < y).
  Proof.
  intros E1 E2.
  apply E1. apply lt_le. assumption.
  Qed.

  Lemma lt_apart x y : x < y -> x ≶ y.
  Proof.
  intro.
  apply lt_iff_le_apart.
  assumption.
  Qed.

  Lemma lt_apart_flip x y : x < y -> y ≶ x.
  Proof.
  intro.
  apply symmetry, lt_iff_le_apart.
  assumption.
  Qed.

  Lemma le_not_lt_flip x y : y ≤ x -> ~(x < y).
  Proof.
  intros E1 E2;apply lt_iff_le_apart in E2.
  destruct E2 as [E2a E2b].
  revert E2b. apply tight_apart.
  apply (antisymmetry (≤));assumption.
  Qed.

  Lemma lt_not_le_flip x y : y < x -> ~(x ≤ y).
  Proof.
  intros E1 E2.
  apply (le_not_lt_flip y x);assumption.
  Qed.

  Lemma lt_le_trans x y z : x < y -> y ≤ z -> x < z.
  Proof.
  intros E1 E2.
  apply lt_iff_le_apart. apply lt_iff_le_apart in E1.
  destruct E1 as [E1a E1b].
  split.
  - transitivity y;assumption.
  - apply (merely_destruct (cotransitive E1b z));intros [E3 | E3]; trivial.
    apply lt_apart. apply symmetry in E3.
    transitivity y;apply lt_iff_le_apart; auto.
  Qed.

  Lemma le_lt_trans x y z : x ≤ y -> y < z -> x < z.
  Proof.
  intros E2 E1.
  apply lt_iff_le_apart. apply lt_iff_le_apart in E1.
  destruct E1 as [E1a E1b].
  split.
  - transitivity y;auto.
  - apply (merely_destruct (cotransitive E1b x));intros [E3 | E3]; trivial.
    apply lt_apart. apply symmetry in E3.
    transitivity y; apply lt_iff_le_apart; auto.
  Qed.

  Lemma lt_iff_le_ne `{!TrivialApart A} x y : x < y <-> x ≤ y /\ x <> y.
  Proof.
   transitivity (x <= y /\ apart x y).
   - apply lt_iff_le_apart.
   - split;intros [E1 E2];split;trivial;apply trivial_apart;trivial.
  Qed.

  Lemma le_equiv_lt `{!TrivialApart A} `{forall x y : A, Decidable (x = y)} x y
    : x ≤ y -> x = y |_| x < y.
  Proof.
  intros.
  destruct (dec (x = y)); try auto.
  right.
  apply lt_iff_le_ne; auto.
  Qed.

  Instance dec_from_lt_dec `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)}
    : DecidablePaths A.
  Proof.
  intros x y.
  destruct (decide_rel (<=) x y) as [E1|E1];
  [destruct (decide_rel (<=) y x) as [E2|E2]|].
  - left. apply (antisymmetry (<=));assumption.
  - right. intros E3;apply E2.
    pattern y. apply (transport _ E3).
    apply reflexivity.
  - right. intros E3;apply E1.
    pattern y; apply (transport _ E3).
    apply reflexivity.
  Defined.

  Definition lt_dec_slow `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)} :
    forall x y, Decidable (x < y).
  Proof.
  intros x y.
  destruct (dec (x ≤ y));
  [destruct (dec (x = y))|].
  - right. apply eq_not_lt. assumption.
  - left. apply lt_iff_le_ne. auto.
  - right. apply not_le_not_lt. assumption.
  Defined.
End full_partial_order.

(* Due to bug #2528 *)
#[export]
Hint Extern 5 (PropHolds (_ <> _)) =>
  eapply @strict_po_apart_ne :  typeclass_instances.
#[export]
Hint Extern 10 (PropHolds (_ ≤ _)) =>
  eapply @lt_le : typeclass_instances.
#[export]
Hint Extern 20 (Decidable (_ < _)) =>
  eapply @lt_dec_slow : typeclass_instances.

Section full_pseudo_order.
  Context `{FullPseudoOrder A}.

  Local Existing Instance pseudo_order_apart.

  Lemma not_lt_le_flip x y : ~(y < x) -> x ≤ y.
  Proof.
  intros.
  apply le_iff_not_lt_flip.
  assumption.
  Qed.

  Instance fullpseudo_partial : PartialOrder (≤) | 10.
  Proof.
  repeat split.
  - apply _.
  - apply _.
  - intros x. apply not_lt_le_flip, (irreflexivity (<)).
  - intros x y z E1 E2.
    apply le_iff_not_lt_flip;
    apply le_iff_not_lt_flip in E1;
    apply le_iff_not_lt_flip in E2.
    change (complement (<) z x).
    transitivity y;assumption.
  - intros x y E1 E2.
    apply le_iff_not_lt_flip in E1;
    apply le_iff_not_lt_flip in E2.
    apply (antisymmetry (complement (<)));assumption.
  Qed.

  Lemma fullpseudo_fullpartial' : FullPartialOrder Ale Alt.
  Proof.
  split; try apply _.
  intros x y.
  split.
  - intros E. split.
    + apply not_lt_le_flip. apply lt_flip;assumption.
    + apply pseudo_order_lt_apart. assumption.
  - intros [? E]. apply not_lt_apart_lt_flip;[|symmetry;trivial].
    apply le_iff_not_lt_flip. trivial.
  Qed.

  Global Instance fullpseudo_fullpartial@{i} : FullPartialOrder Ale Alt
    := ltac:(first [exact fullpseudo_fullpartial'@{i i Set Set Set}|
                    exact fullpseudo_fullpartial'@{i i}]).

  Global Instance le_stable : forall x y, Stable (x ≤ y).
  Proof.
  intros x y. unfold Stable.
  intros dn. apply le_iff_not_lt_flip.
  intros E. apply dn.
  intros E';apply le_iff_not_lt_flip in E';auto.
  Qed.

  Lemma le_or_lt `{!TrivialApart A} `{DecidablePaths A} x y : x ≤ y |_| y < x.
  Proof.
  destruct (trichotomy (<) x y) as [|[|]]; try auto.
  - left. apply lt_le;trivial.
  - left. apply eq_le;trivial.
  Qed.

  Global Instance le_total `{!TrivialApart A} `{DecidablePaths A}
    : TotalOrder (≤).
  Proof.
  split; try apply _.
  intros x y.
  destruct (le_or_lt x y); auto.
  right. apply lt_le.
  trivial.
  Qed.

  Lemma not_le_lt_flip `{!TrivialApart A} `{DecidablePaths A} x y
    : ~(y ≤ x) -> x < y.
  Proof.
  intros.
  destruct (le_or_lt y x); auto.
  contradiction.
  Qed.

  Existing Instance dec_from_lt_dec.

  Definition lt_dec `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)}
    : forall x y, Decidable (x < y).
  Proof.
  intros.
  destruct (decide_rel (<=) y x).
  - right;apply le_not_lt_flip;assumption.
  - left; apply not_le_lt_flip;assumption.
  Defined.
End full_pseudo_order.

#[export]
Hint Extern 8 (Decidable (_ < _)) => eapply @lt_dec : typeclass_instances.
(*
The following instances would be tempting, but turn out to be a bad idea.

#[export]
Hint Extern 10 (PropHolds (_ <> _)) => eapply @le_ne : typeclass_instances.
#[export]
Hint Extern 10 (PropHolds (_ <> _)) => eapply @le_ne_flip : typeclass_instances.

It will then loop like:

semirings.lt_0_1 -> lt_ne_flip -> ...
*)

Section dec_strict_setoid_order.
  Context `{StrictOrder A} `{Apart A} `{!TrivialApart A} `{DecidablePaths A}.

  Instance: IsApart A := dec_strong_setoid.

  Context `{!Trichotomy (<)}.

  Instance dec_strict_pseudo_order: PseudoOrder (<).
  Proof.
  split; try apply _.
  - intros x y [??].
    destruct (lt_antisym x y); auto.
  - intros x y Exy z.
    destruct (trichotomy (<) x z) as [? | [Exz | Exz]];apply tr; try auto.
    right. rewrite <-Exz. assumption.
  - intros x y. transitivity (x <> y);[split;apply trivial_apart|].
    split.
    + destruct (trichotomy (<) x y) as [?|[?|?]]; auto.
      intros E;contradiction E.
    + intros [?|?];[apply lt_ne|apply lt_ne_flip];trivial.
  Qed.
End dec_strict_setoid_order.

Section dec_partial_order.
  Context `{PartialOrder A} `{DecidablePaths A}.

  Definition dec_lt: Lt A := fun x y => x ≤ y /\ x <> y.

  Context `{Alt : Lt A} `{is_mere_relation A lt}
    (lt_correct : forall x y, x < y <-> x ≤ y /\ x <> y).

  Instance dec_order: StrictOrder (<).
  Proof.
  split.
  - apply _.
  - intros x E. apply lt_correct in E. destruct E as [_ []];trivial.
  - intros x y z E1 E2.
    apply lt_correct;
    apply lt_correct in E1;
    apply lt_correct in E2.
    destruct E1 as [E1a E1b],E2 as [E2a E2b].
    split.
    + transitivity y;trivial.
    + intros E3. destruct E2b.
      apply (antisymmetry (≤)); trivial.
      rewrite <-E3. assumption.
  Qed.

  Context `{Apart A} `{!TrivialApart A}.

  Instance: IsApart A := dec_strong_setoid.

  Instance dec_full_partial_order: FullPartialOrder (≤) (<).
  Proof.
  split;try apply _.
  intros. transitivity (x <= y /\ x <> y);[|
  split;intros [? ?];split;trivial;apply trivial_apart;trivial].
  apply lt_correct.
  Qed.

  Context `{!TotalRelation (≤)}.

  Instance: Trichotomy (<).
  Proof.
  intros x y.
  destruct (dec (x = y)); try auto.
  destruct (total (≤) x y);[left|right;right];
  apply lt_correct;auto.
  split;auto.
  intro E;apply symmetry in E;auto.
  Qed.

  Instance dec_pseudo_order: PseudoOrder (<) := dec_strict_pseudo_order.

  Instance dec_full_pseudo_order: FullPseudoOrder (≤) (<).
  Proof.
  split; try apply _.
  intros x y.
  split.
  - intros ? E. apply lt_correct in E;destruct E as [? []].
    apply (antisymmetry (≤));assumption.
  - intros E1.
    destruct (total (≤) x y); trivial.
    destruct (dec (x = y)) as [E2|E2].
    + rewrite E2. apply reflexivity.
    + destruct E1. apply lt_correct;split;auto.
      apply symmetric_neq;assumption.
  Qed.
End dec_partial_order.

Lemma lt_eq_trans `{Lt A} : forall x y z, x < y -> y = z -> x < z.
Proof.
intros ???? [];trivial.
Qed.

Section pseudo.
  Context {A : Type}.
  Context `{PseudoOrder A}.

  Lemma nlt_lt_trans {x y z : A} : ~ (y < x) -> y < z -> x < z.
  Proof.
    intros nltyx ltyz.
    assert (disj := cotransitive ltyz x).
    strip_truncations.
    destruct disj as [ltyx|ltxz].
    - destruct (nltyx ltyx).
    - exact ltxz.
  Qed.

  Lemma lt_nlt_trans {x y z : A} : x < y -> ~ (z < y) -> x < z.
  Proof.
    intros ltxy nltzy.
    assert (disj := cotransitive ltxy z).
    strip_truncations.
    destruct disj as [ltxz|ltzy].
    - exact ltxz.
    - destruct (nltzy ltzy).
  Qed.

  Lemma lt_transitive : Transitive (_ : Lt A).
  Proof.
    intros x y z ltxy ltyz.
    assert (ltxyz := cotransitive ltxy z).
    strip_truncations.
    destruct ltxyz as [ltxz|ltzy].
    - assumption.
    - destruct (pseudo_order_antisym y z (ltyz , ltzy)).
  Qed.

  Global Existing Instance lt_transitive.

End pseudo.


Require Export BaseLists Removal.

(** *** Cardinality *)

Section Cardinality.
  Variable X : eqType.
  Implicit Types A B : list X.

  Fixpoint card A :=
    match A with
      | nil => 0
      | x::A => if Dec (x el A) then card A else 1 + card A
    end.

  Lemma card_cons x A :
    x el A -> card (x::A) = card A.
  Proof.
    intros H. cbn. decide (x el A) as [H1|H1]; tauto.
  Qed.

  Lemma card_cons' x A :
    ~ x el A -> card (x::A) = 1 + card A.
  Proof.
    intros H. cbn. decide (x el A) as [H1|H1]; tauto.
  Qed.

  Lemma card_in_rem x A :
    x el A -> card A = 1 + card (rem A x).
  Proof.
    intros D.
    induction A as [|y A].
    - contradiction D.
    - decide (y = x) as [->|H].
      + clear D. rewrite rem_fst.
        cbn. decide (x el A) as [H1|H1].
        * auto.
        * now rewrite (rem_id H1).
      + assert (x el A) as H1 by (destruct D; tauto). clear D.
        rewrite (rem_fst' _ H). specialize (IHA H1).
        simpl card at 2.
        decide (y el rem A x) as [H2|H2].
        * rewrite card_cons. exact IHA.
          apply in_rem_iff in H2. intuition.
        * rewrite card_cons'. now rewrite IHA.
          contradict H2.  now apply in_rem_iff.
  Qed.

  Lemma card_not_in_rem A x :
    ~ x el A -> card A = card (rem A x).
  Proof.
    intros D; rewrite rem_id; auto.
  Qed.

  Lemma card_le A B :
    A <<= B -> card A <= card B.
  Proof.
  revert B.
  induction A as [|x A]; intros B D; cbn.
  - omega.
  - apply incl_lcons in D as [D D1].
    decide (x el A) as [E|E].
    + auto.
    + rewrite (card_in_rem D).
      enough (card A <= card (rem B x)) by omega.
      apply IHA. auto.
  Qed.

  Lemma card_eq A B :
    A === B -> card A = card B.
  Proof.
    intros [E F]. apply card_le in E. apply card_le in F. omega.
  Qed.

  Lemma card_cons_rem x A :
    card (x::A) = 1 + card (rem A x).
  Proof.
    rewrite (card_eq (rem_equi x A)). cbn.
    decide (x el rem A x) as [D|D].
    - exfalso. apply in_rem_iff in D; tauto.
    - reflexivity.
  Qed.

  Lemma card_0 A :
    card A = 0 -> A = nil.
  Proof.
    destruct A as [|x A]; intros D.
    - reflexivity.
    - exfalso. rewrite card_cons_rem in D. omega.
  Qed.

  Lemma card_ex A B :
    card A < card B -> exists x, x el B /\ ~ x el A.
  Proof.
    intros D.
    decide (B <<= A) as [E|E].
    - exfalso. apply card_le in E. omega.
    - apply list_exists_not_incl; auto.
  Qed.

  Lemma card_equi A B :
    A <<= B -> card A = card B -> A === B.
  Proof.
    revert B.
    induction A as [|x A]; cbn; intros B D E.
    - symmetry in E. apply card_0 in E. now rewrite E.
    - apply incl_lcons in D as [D D1].
      decide (x el A) as [F|F].
      + rewrite (IHA B); auto.
      + rewrite (IHA (rem B x)).
        * symmetry. apply rem_reorder, D.
        * auto.
        * apply card_in_rem in D. omega.
  Qed.

  Lemma card_lt A B x :
    A <<= B -> x el B -> ~ x el A -> card A < card B.
  Proof.
    intros D E F.
    decide (card A = card B) as [G|G].
    + exfalso. apply F. apply (card_equi D); auto.
    + apply card_le in D. omega.
  Qed.

  Lemma card_or A B :
    A <<= B -> A === B \/ card A < card B.
  Proof.
    intros D.
    decide (card A = card B) as [F|F].
    - left. apply card_equi; auto.
    - right. apply card_le in D. omega.
  Qed.

End Cardinality.

Instance card_equi_proper (X: eqType) :
  Proper (@equi X ==> eq) (@card X).
Proof.
  hnf. apply card_eq.
Qed.


(*定义类型 day*)
Inductive day : Type :=
    |monday
    |tuesday
    |thursday
    |wednesday
    |friday
    |saturday
    |sunday.

Definition next_weekday (d:day) : day :=
    match d with
    |monday => tuesday
    |tuesday => wednesday
    |wednesday => thursday
    |thursday => friday
    |friday => monday
    |saturday => monday
    |sunday => monday
    end.

(*通过Compute命令计算next_weekday表达式的值*)
Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

(*期望的结果*)
(*先定义一个断言assertion，名字叫做test_next_weekday，方便以后引用*)
Example test_next_weekday:
    (next_weekday (next_weekday saturday)) = tuesday.
(*通过Proof来证明断言的正确性*)
Proof.
    simpl.
    reflexivity.
Qed.

(*定义布尔类型*)
Inductive bool : Type :=
    |true
    |false.

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

Definition andb (b1:bool)(b2:bool) : bool :=
    match b1 with
    |true => b2
    |false => false
    end.

Definition orb (b1:bool)(b2:bool) : bool :=
    match b1 with
    |true => true
    |false => b2
    end.

(*对上述布尔函数进行测试*)
Example test_orb1:
    (orb true false) = true.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_orb2:
    (orb false false) = false.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_orb3:
    (orb false true) = true.
Proof.
    simpl.
    reflexivity.
Qed.

Example test_orb4:
    (orb true true) = true.
Proof.
    simpl.
    reflexivity.
Qed.

(*使用Notation简化Definition*)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5:
    false || false || true = true.
Proof.
    simpl.
    reflexivity.
Qed.

(*条件表达式*)
Definition negb' (b:bool) : bool:=
    if b
        then false
    else
        true.

Definition andb' (b1:bool)(b2:bool) : bool:=
    if b1
        then b2
    else
        false.

Definition orb' (b1:bool)(b2:bool) : bool:=
    if b1
        then true
    else
        b2.

(*练习1，nandb*)
Definition nandb (b1:bool)(b2:bool) : bool:=
    match b1 with
    |true => negb b2
    |false => true
    end.
Example test_nandb1:
    (nandb true false) = true.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_nandb2:
    (nandb false false) = true.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_nandb3:
    (nandb false true) = true.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_nandb4:
    (nandb true true) = false.
Proof.
    simpl.
    reflexivity.
Qed.

(*练习2，andb3*)
Definition andb3 (b1:bool)(b2:bool)(b3:bool) : bool :=
    match b1 with
    |true => andb b2 b3
    |false => false
    end.
Example test_andb31:
    (andb3 true true true) = true.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_andb32:
    (andb3 false true true) = false.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_andb33:
    (andb3 true false true) = false.
Proof.
    simpl.
    reflexivity.
Qed.
Example test_andb34:
    (andb3 true true false) = false.
Proof.
    simpl.
    reflexivity.
Qed.

(*类型Type，包括表达式和函数*)
Check true.
Check true : bool.
Check (negb true) : bool.
Check negb : bool -> bool.

(*由旧类型构造新类型，类似于复合定义*)
Inductive rgb : Type :=
    |red
    |green
    |blue.

Inductive color : Type :=
    |black
    |white
    |primary (p:rgb).

Definition monochrome (c:color) : bool :=
    match c with
    |black => true
    |white => true
    |primary p => false
    end.

Definition isred (c:color) : bool :=
    match c with
    |black => false
    |white => false
    |primary red => true
    |primary _ => false
    end.

(*模块Modules*)
Module Playground.
    Definition b : rgb := blue.
End Playground.

Definition b : bool := true.
Check b : bool.

(*元组Tuples*)
Module TuplePlayground.
Inductive bit : Type :=
    |B0
    |B1.

Inductive nybble : Type :=
    |bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B1 B0) : nybble.

Definition all_zero (nb : nybble) : bool :=
    match nb with
    |(bits B0 B0 B0 B0) => true
    |(bits _ _ _ _) => false
    end.

Compute (all_zero (bits B1 B0 B1 B0)).
Compute (all_zero (bits B0 B0 B0 B0)).
End TuplePlayground.

(*自然数Numbers*)
Module NatPlayground.
Inductive nat : Type :=
    |O
    |S (n : nat).

Inductive nat' : Type :=
    |stop
    |tick (foo : nat').

Check tick stop.


Module NatList.
Inductive natprod : Type :=
  | pair (n1 n2 : nat).

Notation "( x , y )" := (pair x y).

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) => y
  end.

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.

From Coq Require Export String.

Inductive bool : Type :=
  | true
  | false.

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

Definition andb (b_1 : bool) (b_2 : bool) : bool :=
  match b_1 with
  | true  => b_2
  | false => false
  end.

Definition orb (b_1 : bool) (b_2 : bool) : bool :=
  match b_1 with
  | true  => true
  | false => b_2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b_1 : bool) (b_2 : bool) : bool :=
  negb (andb b_1 b_2).

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

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

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

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

Definition andb3 (b_1 : bool) (b_2 : bool) (b_3 : bool) : bool :=
  andb (andb b_1 b_2) b_3.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.

Check true : bool.

Check (negb true) : bool.

Check negb : bool -> bool.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black     => true
  | white     => true
  | primary p => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | black       => false
  | white       => false
  | primary red => true
  | primary _   => false
  end.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

Module TuplePlayground.

Inductive bit : Type :=
  | B_0
  | B_1.

Inductive nybble : Type :=
  | bits (b_0 b_1 b_2 b_3 : bit).

Check (bits B_1 B_0 B_1 B_0) : nybble.

Module NatPlayground.

Inductive nat : Type :=
  | O
  | S (n : nat).

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.

End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
  | O   => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minustwo 4).

Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1: odd 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_odd2: odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
  | O  => m
  | S n' => S (plus n' m)
  end.

Compute (plus 3 5).

Fixpoint mult (n : nat) (m : nat) : nat :=
  match n with
  | O    => O
  | S n' => plus m (mult n' m )
  end.

Compute (mult 3 5).

Example test_mult1 : mult 3 3 = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m : nat) : nat :=
  match n, m with
  | O   , _    => O
  | S _ , O    => n
  | S n', S m' => minus n' m'
  end.

Compute (minus 5 3).

End NatPlayground2.

Fixpoint exp (n m : nat) : nat :=
  match m with
  | O    => S O
  | S m' => mult n (exp n m')
  end.

Compute (exp 2 3).

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

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

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

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.
Check ((0 + 1) + 1) : nat.

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

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

Example test_leb1: leb 2 2 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 2 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 2 = false.
Proof. simpl. reflexivity. Qed.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Example test_leb3': (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
  andb (leb n m) (negb (eqb n m)).

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Theorem plus_O_n : forall n : nat, O + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof. intros n. reflexivity. Qed.

Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof. intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m : nat,
  n = m -> n + n = m + m.
Proof. intros n m. intros H. rewrite -> H. 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 H2.
  rewrite -> H1.
  rewrite <- H2.
  reflexivity.
Qed.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity.
Qed.

Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intro p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity.
Qed.

Theorem plus_1_neg_0 : forall n : nat, (n+1) =? 0 = false.
Proof.
  intro n.
  destruct n as [|n'] eqn: E.
  - reflexivity.
  - reflexivity.
Qed.

Theorem negb_involutive : forall b : bool, negb (negb b) = b.
Proof.
  intro b.
  destruct b eqn: E.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commmutative : forall b c, andb b c = andb c b.
Proof.
  intros b c.
  destruct c eqn:Ec.
  - destruct b eqn:Eb.
    + reflexivity.
    + reflexivity.
  - destruct b eqn:Eb.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange : forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn:Eb.
  - destruct c eqn:Ec.
  -- destruct d eqn:Ed.
  --- reflexivity.
  --- reflexivity.
  -- destruct d eqn:Ed.
  --- reflexivity.
  --- reflexivity.
  - destruct c eqn:Ec.
  -- destruct d eqn:Ed.
  --- reflexivity.
  --- reflexivity.
  -- destruct d eqn:Ed.
  --- reflexivity.
  --- reflexivity.
Qed.

Theorem abdb_true_elim2 : forall b c : bool, andb b c = true -> c = true.
Proof.
  intros b c. destruct c eqn:Ec.
  - destruct b eqn:Eb.
  -- reflexivity.
  -- reflexivity.
  - destruct b eqn:Eb.
  -- intro H. rewrite <- H. reflexivity.
  -- intro H. rewrite <- H. reflexivity.
Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq div.
From mathcomp
Require Import fintype bigop finset prime fingroup ssralg finalg.

(******************************************************************************)
(*  Definition of the additive group and ring Zp, represented as 'I_p         *)
(******************************************************************************)
(* Definitions:                                                               *)
(* From fintype.v:                                                            *)
(*     'I_p == the subtype of integers less than p, taken here as the type of *)
(*             the integers mod p.                                            *)
(* This file:                                                                 *)
(*     inZp == the natural projection from nat into the integers mod p,       *)
(*             represented as 'I_p. Here p is implicit, but MUST be of the    *)
(*             form n.+1.                                                     *)
(* The operations:                                                            *)
(*      Zp0 == the identity element for addition                              *)
(*      Zp1 == the identity element for multiplication, and a generator of    *)
(*             additive group                                                 *)
(*   Zp_opp == inverse function for addition                                  *)
(*   Zp_add == addition                                                       *)
(*   Zp_mul == multiplication                                                 *)
(*   Zp_inv == inverse function for multiplication                            *)
(* Note that while 'I_n.+1 has canonical finZmodType and finGroupType         *)
(* structures, only 'I_n.+2 has a canonical ring structure (it has, in fact,  *)
(* a canonical finComUnitRing structure), and hence an associated             *)
(* multiplicative unit finGroupType. To mitigate the issues caused by the     *)
(* trivial "ring" (which is, indeed is NOT a ring in the ssralg/finalg        *)
(* formalization), we define additional notation:                             *)
(*       'Z_p == the type of integers mod (max p 2); this is always a proper  *)
(*               ring, by constructions. Note that 'Z_p is provably equal to  *)
(*               'I_p if p > 1, and convertible to 'I_p if p is of the form   *)
(*               n.+2.                                                        *)
(*       Zp p == the subgroup of integers mod (max p 1) in 'Z_p; this is thus *)
(*               is thus all of 'Z_p if p > 1, and else the trivial group.    *)
(* units_Zp p == the group of all units of 'Z_p -- i.e., the group of         *)
(*               (multiplicative) automorphisms of Zp p.                      *)
(* We show that Zp and units_Zp are abelian, and compute their orders.        *)
(* We use a similar technique to represent the prime fields:                  *)
(*        'F_p == the finite field of integers mod the first prime divisor of *)
(*                maxn p 2. This is provably equal to 'Z_p and 'I_p if p is   *)
(*                provably prime, and indeed convertible to the above if p is *)
(*                a concrete prime such as 2, 5 or 23.                        *)
(* Note finally that due to the canonical structures it is possible to use    *)
(* 0%R instead of Zp0, and 1%R instead of Zp1 (for the latter, p must be of   *)
(* the form n.+2, and 1%R : nat will simplify to 1%N).                        *)
(******************************************************************************)

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

Local Open Scope ring_scope.

Section ZpDef.

(***********************************************************************)
(*                                                                     *)
(*  Mod p arithmetic on the finite set {0, 1, 2, ..., p - 1}           *)
(*                                                                     *)
(***********************************************************************)

Variable p' : nat.
Local Notation p := p'.+1.

Implicit Types x y z : 'I_p.

(* Standard injection; val (inZp i) = i %% p *)
Definition inZp i := Ordinal (ltn_pmod i (ltn0Sn p')).
Lemma modZp x : x %% p = x.
Proof. by rewrite modn_small ?ltn_ord. Qed.
Lemma valZpK x : inZp x = x.
Proof. by apply: val_inj; rewrite /= modZp. Qed.

(* Operations *)
Definition Zp0 : 'I_p := ord0.
Definition Zp1 := inZp 1.
Definition Zp_opp x := inZp (p - x).
Definition Zp_add x y := inZp (x + y).
Definition Zp_mul x y := inZp (x * y).
Definition Zp_inv x := if coprime p x then inZp (egcdn x p).1 else x.

(* Additive group structure. *)

Lemma Zp_add0z : left_id Zp0 Zp_add.
Proof. exact: valZpK. Qed.

Lemma Zp_addNz : left_inverse Zp0 Zp_opp Zp_add.
Proof.
by move=> x; apply: val_inj; rewrite /= modnDml subnK ?modnn // ltnW.
Qed.

Lemma Zp_addA : associative Zp_add.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modnDml modnDmr addnA.
Qed.

Lemma Zp_addC : commutative Zp_add.
Proof. by move=> x y; apply: val_inj; rewrite /= addnC. Qed.

Definition Zp_zmodMixin := ZmodMixin Zp_addA Zp_addC Zp_add0z Zp_addNz.
Canonical Zp_zmodType := Eval hnf in ZmodType 'I_p Zp_zmodMixin.
Canonical Zp_finZmodType := Eval hnf in [finZmodType of 'I_p].
Canonical Zp_baseFinGroupType := Eval hnf in [baseFinGroupType of 'I_p for +%R].
Canonical Zp_finGroupType := Eval hnf in [finGroupType of 'I_p for +%R].

(* Ring operations *)

Lemma Zp_mul1z : left_id Zp1 Zp_mul.
Proof. by move=> x; apply: val_inj; rewrite /= modnMml mul1n modZp. Qed.

Lemma Zp_mulC : commutative Zp_mul.
Proof. by move=> x y; apply: val_inj; rewrite /= mulnC. Qed.

Lemma Zp_mulz1 : right_id Zp1 Zp_mul.
Proof. by move=> x; rewrite Zp_mulC Zp_mul1z. Qed.

Lemma Zp_mulA : associative Zp_mul.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modnMml modnMmr mulnA.
Qed.

Lemma Zp_mul_addr : right_distributive Zp_mul Zp_add.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modnMmr modnDm mulnDr.
Qed.

Lemma Zp_mul_addl : left_distributive Zp_mul Zp_add.
Proof. by move=> x y z; rewrite -!(Zp_mulC z) Zp_mul_addr. Qed.

Lemma Zp_mulVz x : coprime p x -> Zp_mul (Zp_inv x) x = Zp1.
Proof.
move=> co_p_x; apply: val_inj; rewrite /Zp_inv co_p_x /= modnMml.
by rewrite -(chinese_modl co_p_x 1 0) /chinese addn0 mul1n mulnC.
Qed.

Lemma Zp_mulzV x : coprime p x -> Zp_mul x (Zp_inv x) = Zp1.
Proof. by move=> Ux; rewrite /= Zp_mulC Zp_mulVz. Qed.

Lemma Zp_intro_unit x y : Zp_mul y x = Zp1 -> coprime p x.
Proof.
case=> yx1; have:= coprimen1 p.
by rewrite -coprime_modr -yx1 coprime_modr coprime_mulr; case/andP.
Qed.

Lemma Zp_inv_out x : ~~ coprime p x -> Zp_inv x = x.
Proof. by rewrite /Zp_inv => /negPf->. Qed.

Lemma Zp_mulrn x n : x *+ n = inZp (x * n).
Proof.
apply: val_inj => /=; elim: n => [|n IHn]; first by rewrite muln0 modn_small.
by rewrite !GRing.mulrS /= IHn modnDmr mulnS.
Qed.

Import GroupScope.

Lemma Zp_mulgC : @commutative 'I_p _ mulg.
Proof. exact: Zp_addC. Qed.

Lemma Zp_abelian : abelian [set: 'I_p].
Proof. exact: FinRing.zmod_abelian. Qed.

Lemma Zp_expg x n : x ^+ n = inZp (x * n).
Proof. exact: Zp_mulrn. Qed.

Lemma Zp1_expgz x : Zp1 ^+ x = x.
Proof. by rewrite Zp_expg; apply: Zp_mul1z. Qed.

Lemma Zp_cycle : setT = <[Zp1]>.
Proof. by apply/setP=> x; rewrite -[x]Zp1_expgz inE groupX ?mem_gen ?set11. Qed.

Lemma order_Zp1 : #[Zp1] = p.
Proof. by rewrite orderE -Zp_cycle cardsT card_ord. Qed.

End ZpDef.

Arguments Zp0 {p'}.
Arguments Zp1 {p'}.
Arguments inZp {p'}.

Lemma ord1 : all_equal_to (0 : 'I_1).
Proof. by case=> [[] // ?]; apply: val_inj. Qed.

Lemma lshift0 m n : lshift m (0 : 'I_n.+1) = (0 : 'I_(n + m).+1).
Proof. exact: val_inj. Qed.

Lemma rshift1 n : @rshift 1 n =1 lift (0 : 'I_n.+1).
Proof. by move=> i; apply: val_inj. Qed.

Lemma split1 n i :
  split (i : 'I_(1 + n)) = oapp (@inr _ _) (inl _ 0) (unlift 0 i).
Proof.
case: unliftP => [i'|] -> /=.
  by rewrite -rshift1 (unsplitK (inr _ _)).
by rewrite -(lshift0 n 0) (unsplitK (inl _ _)).
Qed.

Lemma big_ord1 R idx (op : @Monoid.law R idx) F :
  \big[op/idx]_(i < 1) F i = F 0.
Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed.

Lemma big_ord1_cond R idx (op : @Monoid.law R idx) P F :
  \big[op/idx]_(i < 1 | P i) F i = if P 0 then F 0 else idx.
Proof. by rewrite big_mkcond big_ord1. Qed.

Section ZpRing.

Variable p' : nat.
Local Notation p := p'.+2.

Lemma Zp_nontrivial : Zp1 != 0 :> 'I_p. Proof. by []. Qed.

Definition Zp_ringMixin :=
  ComRingMixin (@Zp_mulA _) (@Zp_mulC _) (@Zp_mul1z _) (@Zp_mul_addl _)
               Zp_nontrivial.
Canonical Zp_ringType := Eval hnf in RingType 'I_p Zp_ringMixin.
Canonical Zp_finRingType := Eval hnf in [finRingType of 'I_p].
Canonical Zp_comRingType := Eval hnf in ComRingType 'I_p (@Zp_mulC _).
Canonical Zp_finComRingType := Eval hnf in [finComRingType of 'I_p].

Definition Zp_unitRingMixin :=
  ComUnitRingMixin (@Zp_mulVz _) (@Zp_intro_unit _) (@Zp_inv_out _).
Canonical Zp_unitRingType := Eval hnf in UnitRingType 'I_p Zp_unitRingMixin.
Canonical Zp_finUnitRingType := Eval hnf in [finUnitRingType of 'I_p].
Canonical Zp_comUnitRingType := Eval hnf in [comUnitRingType of 'I_p].
Canonical Zp_finComUnitRingType := Eval hnf in [finComUnitRingType of 'I_p].

Lemma Zp_nat n : n%:R = inZp n :> 'I_p.
Proof. by apply: val_inj; rewrite [n%:R]Zp_mulrn /= modnMml mul1n. Qed.

Lemma natr_Zp (x : 'I_p) : x%:R = x.
Proof. by rewrite Zp_nat valZpK. Qed.

Lemma natr_negZp (x : 'I_p) : (- x)%:R = - x.
Proof. by apply: val_inj; rewrite /= Zp_nat /= modn_mod. Qed.

Import GroupScope.

Lemma unit_Zp_mulgC : @commutative {unit 'I_p} _ mulg.
Proof. by move=> u v; apply: val_inj; rewrite /= GRing.mulrC. Qed.

Lemma unit_Zp_expg (u : {unit 'I_p}) n :
  val (u ^+ n) = inZp (val u ^ n) :> 'I_p.
Proof.
apply: val_inj => /=; elim: n => [|n IHn] //.
by rewrite expgS /= IHn expnS modnMmr.
Qed.

End ZpRing.

Definition Zp_trunc p := p.-2.

Notation "''Z_' p" := 'I_(Zp_trunc p).+2
  (at level 8, p at level 2, format "''Z_' p") : type_scope.
Notation "''F_' p" := 'Z_(pdiv p)
  (at level 8, p at level 2, format "''F_' p") : type_scope.

Section Groups.

Variable p : nat.

Definition Zp := if p > 1 then [set: 'Z_p] else 1%g.
Definition units_Zp := [set: {unit 'Z_p}].

Lemma Zp_cast : p > 1 -> (Zp_trunc p).+2 = p.
Proof. by case: p => [|[]]. Qed.

Lemma val_Zp_nat (p_gt1 : p > 1) n : (n%:R : 'Z_p) = (n %% p)%N :> nat.
Proof. by rewrite Zp_nat /= Zp_cast. Qed.

Lemma Zp_nat_mod (p_gt1 : p > 1)m : (m %% p)%:R = m%:R :> 'Z_p.
Proof. by apply: ord_inj; rewrite !val_Zp_nat // modn_mod. Qed.

Lemma char_Zp : p > 1 -> p%:R = 0 :> 'Z_p.
Proof. by move=> p_gt1; rewrite -Zp_nat_mod ?modnn. Qed.

Lemma unitZpE x : p > 1 -> ((x%:R : 'Z_p) \is a GRing.unit) = coprime p x.
Proof.
by move=> p_gt1; rewrite qualifE /= val_Zp_nat ?Zp_cast ?coprime_modr.
Qed.

Lemma Zp_group_set : group_set Zp.
Proof. by rewrite /Zp; case: (p > 1); apply: groupP. Qed.
Canonical Zp_group := Group Zp_group_set.

Lemma card_Zp : p > 0 -> #|Zp| = p.
Proof.
rewrite /Zp; case: p => [|[|p']] //= _; first by rewrite cards1.
by rewrite cardsT card_ord.
Qed.

Lemma mem_Zp x : p > 1 -> x \in Zp. Proof. by rewrite /Zp => ->. Qed.

Canonical units_Zp_group := [group of units_Zp].

Lemma card_units_Zp : p > 0 -> #|units_Zp| = totient p.
Proof.
move=> p_gt0; transitivity (totient p.-2.+2); last by case: p p_gt0 => [|[|p']].
rewrite cardsT card_sub -sum1_card big_mkcond /=.
by rewrite totient_count_coprime big_mkord.
Qed.

Lemma units_Zp_abelian : abelian units_Zp.
Proof. by apply/centsP=> u _ v _; apply: unit_Zp_mulgC. Qed.

End Groups.

(* Field structure for primes. *)

Section PrimeField.

Open Scope ring_scope.

Variable p : nat.

Section F_prime.

Hypothesis p_pr : prime p.

Lemma Fp_Zcast : (Zp_trunc (pdiv p)).+2 = (Zp_trunc p).+2.
Proof. by rewrite /pdiv primes_prime. Qed.

Lemma Fp_cast : (Zp_trunc (pdiv p)).+2 = p.
Proof. by rewrite Fp_Zcast ?Zp_cast ?prime_gt1. Qed.

Lemma card_Fp : #|'F_p| = p.
Proof. by rewrite card_ord Fp_cast. Qed.

Lemma val_Fp_nat n : (n%:R : 'F_p) = (n %% p)%N :> nat.
Proof. by rewrite Zp_nat /= Fp_cast. Qed.

Lemma Fp_nat_mod m : (m %% p)%:R = m%:R :> 'F_p.
Proof. by apply: ord_inj; rewrite !val_Fp_nat // modn_mod. Qed.

Lemma char_Fp : p \in [char 'F_p].
Proof. by rewrite !inE -Fp_nat_mod p_pr ?modnn. Qed.

Lemma char_Fp_0 : p%:R = 0 :> 'F_p.
Proof. exact: GRing.charf0 char_Fp. Qed.

Lemma unitFpE x : ((x%:R : 'F_p) \is a GRing.unit) = coprime p x.
Proof. by rewrite pdiv_id // unitZpE // prime_gt1. Qed.

End F_prime.

Lemma Fp_fieldMixin : GRing.Field.mixin_of [the unitRingType of 'F_p].
Proof.
move=> x nzx; rewrite qualifE /= prime_coprime ?gtnNdvd ?lt0n //.
case: (ltnP 1 p) => [lt1p | ]; last by case: p => [|[|p']].
by rewrite Zp_cast ?prime_gt1 ?pdiv_prime.
Qed.

Definition Fp_idomainMixin := FieldIdomainMixin Fp_fieldMixin.

Canonical Fp_idomainType := Eval hnf in IdomainType 'F_p  Fp_idomainMixin.
Canonical Fp_finIdomainType := Eval hnf in [finIdomainType of 'F_p].
Canonical Fp_fieldType := Eval hnf in FieldType 'F_p Fp_fieldMixin.
Canonical Fp_finFieldType := Eval hnf in [finFieldType of 'F_p].
Canonical Fp_decFieldType :=
  Eval hnf in [decFieldType of 'F_p for Fp_finFieldType].

End PrimeField.


Require Import Crypto.Algebra.Hierarchy.
Require Import ZArith Znumtheory.
Require Import Lia.
Require Import Logic.
From Coqprime Require Import Pmod.
Section RepSquare.
Context {T op id} {monoid: @monoid T (@eq T) op id}.

Local Open Scope nat_scope.

Local Infix "*" := op.
Local Infix "=" := eq.

Fixpoint pow_pos (x : T) (n : positive) : T :=
match n with
    | xH => x
    | xO m => (pow_pos (x * x) m)
    | xI m => (pow_pos (x * x) m) * x
end.

Notation "x ^ n" := (pow_pos x n).

Fixpoint pow_nat (x : T) (n : nat) : T :=
match n with
    | O => id
    | S m => (pow_nat x m) * x
end.

Notation "x ^' n" := (pow_nat x n) (at level 80).

Ltac move_operand_left y H :=
  repeat (rewrite <- (associative y _ _); try (rewrite H; repeat rewrite associative)); repeat rewrite associative; try rewrite H.

Ltac apply_comm x y H := repeat rewrite associative; move_operand_left y H; repeat rewrite <- associative;
match goal with
  | |- (x * ?n1) = (x * ?n2) => assert (n1 = n2) as Haux by (apply_comm x y H); rewrite Haux; auto
  | _ => auto
end.

Lemma pow_nat_plus: forall x (n m : nat), (x ^' (n + m)) = (x ^' n) * (x ^' m).
Proof.
    intros x n m. induction m as [| m' IHm'].
        - rewrite right_identity; auto with zarith.
        - simpl; rewrite associative; rewrite <- IHm'; rewrite Nat.add_succ_r; auto.
Qed.

Lemma pow_pos_odd: forall x n, x ^ (n~1) = x^(n~0) * x.
Proof. auto. Qed.

Lemma pow_pos_ev: forall x n, (x^ (n ~0) = x ^ n * x ^ n) /\ x ^ n * x = x * x ^ n.
Proof.
    intros x n; generalize dependent x; simpl; induction n as [n' IHn'|n' IHn'|]; intros x; split; simpl; auto;
    repeat rewrite (proj1 (IHn' (_))); apply_comm x (x ^ n') (proj2 (IHn' x)).
Qed.

Lemma pow_pos_com: forall x n, x * x ^ n = x ^ n * x.
Proof. intros x n; symmetry; apply (proj2 (pow_pos_ev x n)). Qed.

Lemma pow_pos_distr: forall x n, (x * x) ^ n = x ^ n * x ^ n.
Proof.
    intros x n; pose proof pow_pos_ev as H; induction n as [n' IHn' |n' IHn' |]; try destruct (H (x * x) n') as [H0 _]; auto.
        - repeat rewrite pow_pos_odd; destruct (H x n') as [H1 _]; repeat rewrite H0; rewrite H1;
          repeat rewrite IHn'; apply_comm x (x ^ n') (pow_pos_com x n').
Qed.

Lemma repeated_square_correct: forall x n, pow_pos x n = pow_nat x (Pos.to_nat n).
Proof.
    intros x n; induction n as [n' IHn| |].
        - rewrite Pos2Nat.inj_xI; simpl; rewrite pow_nat_plus;
          rewrite Nat.add_0_r; rewrite <- IHn; rewrite pow_pos_distr; auto.
        - rewrite Pos2Nat.inj_xO; simpl; rewrite Nat.add_0_r; rewrite pow_nat_plus;
          rewrite <- IHn; apply pow_pos_distr.
        - simpl; rewrite left_identity; auto.
Qed.

End RepSquare.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (lf2 : natural) (lf3 : natural) : natural :=
  mult (Succ Zero) lf1.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (lf1 : natural) (z : natural) (x : natural)
  : natural := mult z (Succ x).


Require Import Tutorial.

(* A specification of what it means to choose a number that is not in a particular list *)
Definition notInList (ls : list nat) :=
  {n : nat | ~In n ls}%comp.

(* We can use a simple property to justify a decomposition of the original spec. *)
Theorem notInList_decompose : forall ls,
  refine (notInList ls) (upper <- {upper | forall n, In n ls -> upper >= n};
                         {beyond | beyond > upper}).
Proof.
  refines.
  firstorder.
Qed.

(* A simple traversal will find the maximum list element, which is a good upper bound. *)
Definition listMax := fold_right max 0.

(* ...and we can prove it! *)
Theorem listMax_upperBound : forall init ls,
  forall n, In n ls -> fold_right max init ls >= n.
Proof.
  induction ls; simpl; intuition.
  arithmetic.
  apply IHls in H0.
  arithmetic.
Qed.

(* Now we restate that result as a computation refinement. *)
Theorem listMax_refines : forall ls,
  refine {upper | forall n, In n ls -> upper >= n} (ret (listMax ls)).
Proof.
  refines.
  apply listMax_upperBound.
Qed.

(* An easy way to find a number higher than another: add 1! *)
Theorem increment_refines : forall n,
  refine {higher | higher > n} (ret (n + 1)).
Proof.
  refines.
  arithmetic.
Qed.

(* Let's derive an efficient implementation. *)
Theorem implementation : { f : list nat -> Comp nat | forall ls, refine (notInList ls) (f ls) }.
Proof.
  begin.
  rewrite notInList_decompose.
  rewrite listMax_refines.
  setoid_rewrite increment_refines. (* Different tactic here to let us rewrite under a binder! *)
  monad_simpl.
  finish honing.
Defined.

(* We can extract the program that we found as a standlone, executable Gallina term. *)
Definition impl := Eval simpl in projT1 implementation.
Print impl.

Eval compute in impl (1 :: 7 :: 8 :: 2 :: 13 :: 6 :: nil).


Require Export GeoCoq.Elements.OriginalProofs.lemma_congruenceflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_extensionunique.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_rightreverse :
   forall A B C D,
   Per A B C -> BetS A B D -> Cong A B B D ->
   Cong A C D C.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists E, (BetS A B E /\ Cong A B E B /\ Cong A C E C /\ neq B C)) by (conclude_def Per );destruct Tf as [E];spliter.
assert (Cong B D A B) by (conclude lemma_congruencesymmetric).
assert (Cong B D E B) by (conclude lemma_congruencetransitive).
assert (Cong B D B E) by (forward_using lemma_congruenceflip).
assert (eq D E) by (conclude lemma_extensionunique).
assert (Cong A C D C) by (conclude cn_equalitysub).
close.
Qed.

End Euclid.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  mult (Succ Zero) lf1.


Class Category : Type := {
  obj : Type;
  hom : obj -> obj -> Type;

  id : forall {a : obj}, hom a a;
  compose : forall {a b c : obj}, hom b c -> hom a b -> hom a c;

  compose_assoc :
    forall {a b c d : obj} (f : hom c d) (g : hom b c) (h : hom a b),
    compose f (compose g h) = compose (compose f g) h;

  id_unit_left :
    forall {a b : obj} (f : hom a b),
    compose id f = f;

  id_unit_right :
    forall {a b : obj} (f : hom a b),
    compose f id = f;
}.

#[refine] Instance TypeCategory : Category := {
  obj := Type;
  hom := fun a b => a -> b;
  id := fun a => fun x : a => x;
  compose := fun a b c => fun (f : b -> c) (g : a -> b) (x : a) => f (g x);
}.
Proof. trivial. trivial. trivial. Qed.

Require Import Coq.Classes.RelationClasses.

Program Instance EqualityCategory : Category := {
  obj := Type;
  hom := fun a b => a = b;
  id := @eq_refl Type;
  compose := fun (a b c : Type) (f : b = c) (g : a = b) => eq_trans g f;
}.


(** * BagPerm:  Insertion Sort With Bags *)

(** We have seen how to specify algorithms on "collections", such as
    sorting algorithms, using [Permutation]s.  Instead of using
    permutations, another way to specify these algorithms is to use
    _bags_ (also called _multisets_), which we introduced in [Lists].
    A _set_ of values is like a list with no repeats where
    the order does not matter.  A _multiset_ is like a list, possibly
    with repeats, where the order does not matter.  Whereas the principal
    query on a set is whether a given element appears in it, the
    principal query on a bag is _how many_ times a given element appears
    in it. *)

From Coq Require Import Strings.String. (* for manual grading *)
From Coq Require Import Setoid Morphisms.
From VFA Require Import Perm.
From VFA Require Import Sort.

(** To keep this chapter more self-contained,
we restate the critical definitions from [Lists].  *)
Definition bag := list nat.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t =>
      (if h =? v then 1 else 0) + count v t
  end.

(** We will say two bags are _equivalent_ if they have the same number
    of copies of every possible element. *)

Definition bag_eqv (b1 b2: bag) : Prop :=
  forall n, count n b1 = count n b2.

(** **** Exercise: 2 stars, standard (bag_eqv_properties) *)

(* It is easy to prove [bag_eqv] is an equivalence relation. *)

Lemma bag_eqv_refl : forall b, bag_eqv b b.
Proof.
  unfold bag_eqv. intros. reflexivity.
Qed.

Lemma bag_eqv_sym: forall b1 b2, bag_eqv b1 b2 -> bag_eqv b2 b1.
Proof.
  unfold bag_eqv. intros.
  specialize H with n.
  symmetry.
  assumption.
Qed.

Lemma bag_eqv_trans: forall b1 b2 b3,
  bag_eqv b1 b2 -> bag_eqv b2 b3 -> bag_eqv b1 b3.
Proof.
  unfold bag_eqv. intros.
  specialize H with n.
  specialize H0 with n.
  transitivity (count n b2);
  assumption.
Qed.

(** The following little lemma is handy in a couple of places. *)

Lemma bag_eqv_cons : forall x b1 b2,
  bag_eqv b1 b2 -> bag_eqv (x::b1) (x::b2).
Proof.
  unfold bag_eqv. intros.
  specialize H with n.
  simpl. rewrite H.
  reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Correctness *)

(** A sorting algorithm must rearrange the elements into a list that
    is totally ordered.  But let's say that a different way: the
    algorithm must produce a list _with the same multiset of values_,
    and this list must be totally ordered. *)

Definition is_a_sorting_algorithm' (f: list nat -> list nat) :=
  forall al, bag_eqv al (f al) /\ sorted (f al).

(** **** Exercise: 3 stars, standard (insert_bag)

    First, prove the auxiliary lemma [insert_bag], which will be
    useful for proving [sort_bag] below.  Your proof will be by
    induction.  *)

Lemma insert_bag: forall x l, bag_eqv (x::l) (insert x l).
Proof.
  intros. induction l.
  (* nil *) simpl. apply bag_eqv_refl.
  (* l = a :: l *)
  simpl.
  bdestruct (a >=? x).
  (* a >= x *) apply bag_eqv_refl.
  (* a < x *)
  assert (H0: bag_eqv (a :: x :: l) (a :: insert x l))
    by (apply bag_eqv_cons; assumption).
  apply bag_eqv_trans with (b2 := a :: x :: l).
  unfold bag_eqv. intro. simpl. lia.
  assumption.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (sort_bag)

    Now prove that sort preserves bag contents. *)
Theorem sort_bag: forall l, bag_eqv l (sort l).
Proof.
  intro. induction l. unfold bag_eqv. reflexivity.
  simpl.
  assert (H1: bag_eqv (a :: (sort l)) (insert a (sort l)))
    by apply insert_bag.
  apply bag_eqv_trans with (b2 := a :: (sort l));
  try apply bag_eqv_cons; assumption.
Qed.

(** [] *)

(** Now we wrap it all up.  *)

Theorem insertion_sort_correct:
  is_a_sorting_algorithm' sort.
Proof.
  split. apply sort_bag. apply sort_sorted.
Qed.

(** **** Exercise: 1 star, standard (permutations_vs_multiset)

    Compare your proofs of [insert_perm, sort_perm] with your proofs
    of [insert_bag, sort_bag].  Which proofs are simpler?

      - [ ] easier with permutations,
      - [ ] easier with multisets
      - [ ] about the same.

   Regardless of "difficulty", which do you prefer / find easier to
   think about?
      - [ ] permutations or
      - [ ] multisets

   Put an X in one box in each list. *)
(* Do not modify the following line: *)
Definition manual_grade_for_permutations_vs_multiset : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Permutations and Multisets *)

(** The two specifications of insertion sort are equivalent.  One
    reason is that permutations and multisets are closely related.
    We're going to prove:

       [Permutation al bl <-> bag_eqv al bl.] *)

(** **** Exercise: 3 stars, standard (perm_bag)

    The forward direction is straighforward, by induction on the evidence for
    [Permutation]: *)
Lemma perm_bag:
  forall al bl : list nat,
   Permutation al bl -> bag_eqv al bl.
Proof.
  intros. induction H.
  - (* nil *) apply bag_eqv_refl.
  - (* skip *) apply bag_eqv_cons. assumption.
  - (* swap *)
    unfold bag_eqv. intro. simpl.
    destruct (y =? n); destruct (x =? n); reflexivity.
  - (* trans *) apply bag_eqv_trans with (b2 := l'); assumption.
Qed.
(** [] *)

(** The other direction,
    [bag_eqv al bl -> Permutation al bl],
    is surprisingly difficult.
    This proof approach is due to Zhong Sheng Hu.
    The first three lemmas are used to prove the fourth one. *)

(** **** Exercise: 2 stars, advanced (bag_nil_inv) *)
Lemma bag_nil_inv : forall b, bag_eqv [] b -> b = [].
Proof.
  unfold bag_eqv. intros. induction b.
  reflexivity.
  specialize H with a.
  simpl in H.
  rewrite Nat.eqb_refl in H.
  inversion H.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (bag_cons_inv) *)
Lemma bag_cons_inv : forall l x n,
    S n = count x l ->
    exists l1 l2,
      l = l1 ++ x :: l2
      /\ count x (l1 ++ l2) = n.
Proof.
  intros. induction l.
  - (* nil - contradiction *) inv H.
  - (* a :: l *)
    destruct (a =? x) eqn:E; simpl in H.
    + (* a = x *)
      rewrite E in H.
      inv H.
      exists [], l.
      apply beq_nat_true in E.
      subst.
      auto.
    + (* a <> x *)
      rewrite E in H.
      simpl in H.
      apply IHl in H as [l1 [l2 [Hl Hc]]].
      subst.
      exists (a :: l1), l2.
      simpl. rewrite E.
      auto.
Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (count_insert_other) *)
Lemma count_insert_other : forall l1 l2 x y,
  y <> x -> count y (l1 ++ x :: l2) = count y (l1 ++ l2).
Proof.
  intro. induction l1; intros.
  - (* l1 = nil *)
    apply Nat.neq_sym in H.
    apply Nat.eqb_neq in H.
    simpl.
    rewrite H.
    auto.
  - (* l1 = a :: l1 *)
    bdestruct (a =? y).
    + subst.
      apply (IHl1 l2 x y) in H.
      simpl.
      rewrite Nat.eqb_refl.
      auto.
    + apply Nat.eqb_neq in H0.
      simpl.
      rewrite H0.
      simpl.
      apply (IHl1 l2 x y) in H.
      assumption.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (bag_perm) *)
Lemma bag_perm:
  forall al bl, bag_eqv al bl -> Permutation al bl.
Proof.
  intro.
  induction al.
  - intros.
    apply bag_nil_inv in H.
    subst.
    constructor.
  - intros. induction bl as [| b bl].
    + apply bag_eqv_sym in H.
      apply bag_nil_inv in H.
      discriminate.
    + bdestruct (a =? b).
      * subst.
        assert (H0: bag_eqv al bl). {
          unfold bag_eqv. intro.
          unfold bag_eqv in H.
          specialize H with n.
          simpl in H.
          bdestruct (b =? n);
          subst; inv H;
          reflexivity.
        }
        apply IHal in H0.
        constructor.
        assumption.
      * assert (exists l1 l2, al = l1 ++ b :: l2 /\ count b (l1 ++ l2) = count b bl)
         as [al1 [al2 [Ha Hcb]]].
       {
        assert (S (count b bl) = count b al) as Ha. {
          unfold bag_eqv in H.
          specialize H with b.
          simpl in H.
          rewrite Nat.eqb_refl in H.
          apply Nat.eqb_neq in H0 as H1.
          rewrite H1 in H.
          simpl in H.
          auto.
                 }
        apply bag_cons_inv in Ha.
        assumption.
          }

       assert (exists l1 l2, bl = l1 ++ a :: l2 /\ count a (l1 ++ l2) = count a al)
         as [bl1 [bl2 [Hb Hca]]].
       {
        assert (S (count a al) = count a bl) as Hb. {
          unfold bag_eqv in H.
          specialize H with a.
          simpl in H.
          rewrite Nat.eqb_refl in H.
          apply Nat.neq_sym in H0.
          apply Nat.eqb_neq in H0 as H2.
          rewrite H2 in H.
          simpl in H.
          auto.
        }
        apply bag_cons_inv in Hb.
        assumption.
                    }

       assert (forall n, n <> b -> n <> a -> count n al = count n bl) as Hcab.
       {
         unfold bag_eqv in H.
         intros.
         specialize H with n.
         simpl in H.
         bdestruct (b =? n);
         bdestruct (a =? n);
         subst;
         try contradiction.
         (* b <> a <> n *)
         simpl in H.
         assumption.
       }

       subst.

       assert (count a (al1 ++ al2) = count a (bl1 ++ bl2)). {
         apply (count_insert_other al1 al2) in H0.
         rewrite H0 in Hca.
         symmetry. assumption.
       }

       assert (count b (al1 ++ al2) = count b (bl1 ++ bl2)). {
         apply not_eq_sym in H0.
         apply (count_insert_other bl1 bl2) in H0.
         rewrite H0 in Hcb.
         assumption.
       }

       (*
       do 2 rewrite app_comm_cons.
       apply Permutation_app.
       *)

Admitted.
(** [] *)

(* ################################################################# *)
(** * The Main Theorem: Equivalence of Multisets and Permutations *)
Theorem bag_eqv_iff_perm:
  forall al bl, bag_eqv al bl <-> Permutation al bl.
Proof.
  intros. split. apply bag_perm. apply perm_bag.
Qed.

(** Therefore, it doesn't matter whether you prove your sorting
    algorithm using the Permutations method or the multiset method. *)

Corollary sort_specifications_equivalent:
    forall sort, is_a_sorting_algorithm sort <->  is_a_sorting_algorithm' sort.
Proof.
  unfold is_a_sorting_algorithm, is_a_sorting_algorithm'.
  split; intros;
  destruct (H al); split; auto;
  apply bag_eqv_iff_perm; auto.
Qed.

(** $Date$ *)

(* 2021-08-11 15:15 *)


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section weak_tarski_s_parallel_postulate_weak_inverse_projection_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Formalization of a proof from Bachmann's article "Zur Parallelenfrage" *)

Lemma  weak_tarski_s_parallel_postulate__weak_inverse_projection_postulate_aux :
  weak_tarski_s_parallel_postulate ->
  forall A B C P T,
    Per A B C -> InAngle T A B C ->
    P <> T -> CongA P B A P B C -> Per B P T -> Coplanar A B C P ->
    (exists X, Out B A X /\ Col T P X) \/ (exists Y, Out B C Y /\ Col T P Y).
Proof.
  intros tora A B C P T HPer HInAngle HPT HCongA HPerP HCop.

  assert (HIn : InAngle P A B C)
    by (apply conga_cop_inangle_per2__inangle with T; assumption).
  assert (HAcute : Acute P B A)
    by (apply acute_sym, conga_inangle_per__acute with C; assumption).
  assert (HAcute' : Acute P B C) by (apply (acute_conga__acute P B A); assumption).
  assert_diffs.
  assert (HPerp : Perp B P P T) by (apply per_perp; auto).
  assert (HNCol : ~ Col A B C) by (apply per_not_col; auto).
  assert (HNCol1 : ~ Col B P T) by (apply per_not_col; auto).
  destruct (col_dec A B T).
    left; exists T; split; Col.
    apply l6_6, acute_col_perp__out_1 with P; Col.
  destruct (tora A B C T) as [U [V [HU [HV HUTV]]]]; trivial.
  destruct (col_dec P T U) as [HCol|HNCol2].
    left; exists U; split; Col.
  destruct (col_dec P T V) as [HCol|HNCol3].
    right; exists V; split; Col.
  destruct (cop__one_or_two_sides P T B U) as [HTS|HOS]; Col.

    {
    assert (Coplanar A B C P) by Cop.
    assert (Coplanar A B C T) by Cop.
    assert (Coplanar A B U C) by (apply col__coplanar; assert_cols; Col).
    CopR.
    }
    destruct HTS as [_ [_ [X [HX1 HX2]]]].
    left; exists X; split; Col.
    apply l6_7 with U; auto.
    assert_diffs; apply l6_6, bet_out; auto.
    intro; subst; apply HNCol1, HX1.
  assert (HTS : TS P T B V).
    apply l9_8_2 with U; Side.
    repeat split; Col.
    exists T; repeat split; Col.
  destruct HTS as [_ [_ [Y [HY1 HY2]]]].
  right; exists Y; split; Col.
  apply l6_7 with V; auto.
  assert_diffs; apply l6_6, bet_out; auto.
  intro; subst; apply HNCol1, HY1.
Qed.

Lemma weak_tarski_s_parallel_postulate__weak_inverse_projection_postulate :
  weak_tarski_s_parallel_postulate -> weak_inverse_projection_postulate.
Proof.
intro wtpp.
cut (forall A B C P T,
       Per A B C -> InAngle T A B C ->
       P <> T -> CongA P B A P B C -> Coplanar A B C P -> Per B P T ->
       exists X Y, Out B A X /\ Col T P X /\ Out B C Y /\ Col T P Y).

  {
  intros rabp A B C D E F P Q HAcute HPerE HSuma HOut HPQ HPerP HCop.
  assert (HNCol1 : ~ Col A B C).
    intro; suma.assert_diffs; apply (per_not_col D E F); auto.
    apply (col2_suma__col A B C A B C); assumption.
  assert (HNCol2 : ~ Col B P Q) by (assert_diffs; apply per_not_col; auto).
  assert (HCongA : CongA A B C P B C).
    assert_diffs; apply out_conga with A C A C; try (apply out_trivial); CongA.
  assert (HNCol3 : ~ Col P B C) by (apply (ncol_conga_ncol A B C); assumption).
  assert (HPerp : Perp B P P Q) by (apply per_perp; assert_diffs; auto).
  apply suma_left_comm in HSuma.
  destruct HSuma as [J [HJ1 [HJ2 [HJ3 HJ4]]]].
  assert (HQ' : exists Q', P <> Q' /\ Col P Q Q' /\ InAngle Q' C B P).
  { destruct (cop_not_par_same_side B P Q P P C) as [Q0 [HCol HOS]]; Col.

      {
      assert (Coplanar A B P C) by Cop.
      CopR.
      }

    destruct (one_side_dec B C P Q0).
      exists Q0; assert_diffs; split; auto; split; Col.
      apply os2__inangle; assumption.
    assert (HQ' : exists Q', Col P Q Q' /\ Col B C Q').
    { destruct (col_dec B C Q0).
        exists Q0; Col.
      assert_diffs.
      destruct (cop__not_one_side_two_sides B C P Q0) as [_ [_ [Q' [HCol' HBet]]]]; Col; Cop.
      exists Q'; split; ColR.
    }
    destruct HQ' as [Q' [HCol1 HCol2]].
    exists Q'.
    assert (P <> Q') by (intro; subst; apply HNCol3; Col).
    split; auto; split; Col.
    apply out321__inangle; auto.
      assert_diffs; auto.
    apply l6_6, (acute_col_perp__out_1 P); Col.
      apply (acute_conga__acute A B C); assumption.
    apply perp_col1 with Q; auto.
  }
  destruct HQ' as [Q' [HPQ' [HCol HInangle]]].
  assert (HInangle' : InAngle Q' C B J).
  { apply in_angle_trans with P; trivial.
    apply l11_25 with A C J; try (apply out_trivial; assert_diffs; auto); [|apply l6_6; assumption].
    apply os_ts__inangle.
      assert (~ Col A B J) by (apply (ncol_conga_ncol A B C); CongA).
      assert_diffs; apply cop__not_one_side_two_sides; Col; Cop.
    assert (~ Col C B J).
      apply (ncol_conga_ncol D E F); CongA; assert_diffs; apply per_not_col; auto.
    apply invert_one_side, one_side_symmetry, cop__not_two_sides_one_side; Col.
      assert_diffs; auto.
    apply conga_sams_nos__nts with A B C; SumA.
  }
  destruct (rabp C B J P Q') as [Y [_ [HY1 [HY2 _]]]]; trivial.
    apply (l11_17 D E F); CongA.
    assert_diffs; apply out_conga with A C A J; try (apply out_trivial); CongA.
    assert (Coplanar A B P C) by Cop.
    CopR.
    apply per_col with Q; auto.
  exists Y; split; ColR.
  }

  {
  intros A B C P T HPer HInAngle HPT HCongA HCop HPerP.
  assert (HNOut : ~ Out B A C) by (intro; assert_diffs; apply (per_not_col A B C); Col).
  assert (HPerp : Perp B P P T) by (assert_diffs; apply per_perp; auto).
  destruct (weak_tarski_s_parallel_postulate__weak_inverse_projection_postulate_aux wtpp A B C P T) as [[X [HX1 HX2]]|[Y [HY1 HY2]]]; trivial.
  - destruct (symmetric_point_construction X P) as [Y HY].
    assert (X <> Y).
    { intro; treat_equalities.
      apply HNOut, l6_7 with P; trivial.
      apply (l11_21_a P B A); trivial.
      apply l6_6, HX1.
    }
    assert (Out B C Y).
    { apply conga_cop_out_reflectl__out with A P X; trivial.
      apply l10_4_spec; split.
        exists P; Col.
      left; apply perp_col2_bis with P T; ColR.
    }
    exists X, Y; repeat (split; try ColR).
  - destruct (symmetric_point_construction Y P) as [X HX].
    assert (X <> Y).
    { intro; treat_equalities.
      apply HNOut, l6_7 with P; apply l6_6; trivial.
      apply (l11_21_a P B C); CongA.
      apply l6_6, HY1.
    }
    assert (Out B A X).
    { apply conga_cop_out_reflectl__out with C P Y; CongA; Cop.
        intro HOut; apply HNOut, l6_6, HOut.
      apply l10_4_spec; split.
        exists P; Col.
      left; apply perp_col2_bis with P T; try ColR.
    }
    exists X, Y; repeat (split; try ColR).
  }
Qed.

End weak_tarski_s_parallel_postulate_weak_inverse_projection_postulate.


From Coq Require Import Arith.
From Coq Require Import List.
From StructTact Require Import StructTactics.
Import ListNotations.

Set Implicit Arguments.

Lemma leb_false_lt : forall m n, leb m n = false -> n < m.
Proof.
  induction m; intros.
  - discriminate.
  - simpl in *. break_match; subst; auto with arith.
Qed.

Lemma leb_true_le : forall m n, leb m n = true -> m <= n.
Proof.
  induction m; intros.
  - auto with arith.
  - simpl in *. break_match; subst; auto with arith.
    discriminate.
Qed.

Lemma ltb_false_le : forall m n, m <? n = false -> n <= m.
Proof.
  induction m; intros; destruct n; try discriminate; auto with arith.
Qed.

Lemma ltb_true_lt : forall m n, m <? n = true -> m < n.
  induction m; intros; destruct n; try discriminate; auto with arith.
Qed.

Ltac do_bool :=
  repeat match goal with
    | [ H : Nat.eqb _ _ = true |- _ ] => apply Nat.eqb_eq in H
    | [ H : Nat.eqb _ _ = false |- _ ] => apply Nat.eqb_neq in H
    | [ H : andb _ _ = true |- _ ] => apply Bool.andb_true_iff in H
    | [ H : andb _ _ = false |- _ ] => apply Bool.andb_false_iff in H
    | [ H : orb _ _ = true |- _ ] => apply Bool.orb_prop in H
    | [ H : negb _ = true |- _ ] => apply Bool.negb_true_iff in H
    | [ H : negb _ = false |- _ ] => apply Bool.negb_false_iff in H
    | [ H : PeanoNat.Nat.ltb _ _ = true |- _ ] => apply ltb_true_lt in H
    | [ H : PeanoNat.Nat.ltb _ _ = false |- _ ] => apply ltb_false_le in H
    | [ H : leb _ _ = true |- _ ] => apply leb_true_le in H
    | [ H : leb _ _ = false |- _ ] => apply leb_false_lt in H
    | [ |- andb _ _ = true ]=> apply Bool.andb_true_iff
    | [ |- andb _ _ = false ] => apply Bool.andb_false_iff
    | [ |- leb _ _ = true ] => apply leb_correct
    | [ |-  _ <> false ] => apply Bool.not_false_iff_true
    | [ |- Nat.eqb _ _ = false ] => apply Nat.eqb_neq
    | [ |- Nat.eqb _ _ = true ] => apply Nat.eqb_eq
  end.

Definition null {A : Type} (xs : list A) : bool :=
  match xs with
    | [] => true
    | _ => false
  end.

Lemma null_sound :
  forall A (l : list A),
    null l = true -> l = [].
Proof.
  destruct l; simpl in *; auto; discriminate.
Qed.

Lemma null_false_neq_nil :
  forall A (l : list A),
    null l = false -> l <> [].
Proof.
  destruct l; simpl in *; auto; discriminate.
Qed.


(**
<<
  [1] Pottier, Francois. loop (Dec 11, 2014), fpottier.
         https://github.com/fpottier/loop

>>
*)

  Require Import homo.MyLib.
  Require Import homo.FoldLib.
  Require Import Recdef.

  Definition g (s: nat * nat) : option (nat * nat) :=
    let (n, m) := s in
    match m with
      | O => None
      | S m' => Some (n-1, m')
    end.

  Definition snd_lt (s' s: nat * nat) := (snd s') < (snd s).

  Lemma g_lt:
    forall s s',
      g s = Some s' -> snd_lt s' s.
  Proof.
    intros.
    unfold g in H.
    destruct s as [n m].
    destruct m as [| m].
    - inversion H.
    - inversion H.
      unfold snd_lt.
      auto.
  Defined.

  Require Import Coq.Arith.Wf_nat.
  Require Import Coq.Wellfounded.Inverse_Image.

  Lemma snd_lt_wf: well_founded snd_lt.
  Proof.
    unfold snd_lt.
    eapply wf_inverse_image.
    eapply lt_wf.
  Defined.

  Definition cr (s: nat * nat) (seed: nat) :=
    let (n, m) := s in (S n) * seed.

  Infix "(+)" := cr (at level 80, right associativity).

  Function fact_sep
             (seed: nat)
             (s: nat * nat) {wf snd_lt s} : nat:=
      match (g s) with
        | None     => seed
        | Some s' => s' (+) (fact_sep seed s')
      end.
  Proof.
    intros.
    apply g_lt.
    exact teq.
    exact snd_lt_wf.
  Defined.

  Fixpoint fact (n:nat) :=
    match n with
    | O => 1
    | S n' => n * fact n'
    end.

  Theorem fact_sep__fact: forall n,
      fact_sep 1 (n,n) = fact n.
  Proof.
    intro n.
    induction n as [| n]; rewrite fact_sep_equation; auto.
    simpl.
    rewrite Nat.sub_0_r.
    rewrite IHn.
    reflexivity.
  Qed.

  (** *** [fact_sep_prog]

      To run a test for [fact_sep].
   *)
  Fixpoint fact_sep_prog (seed n m: nat) :=
    match m with
    | O => seed
    | S m' => n * (fact_sep_prog seed (n-1) m')
    end.

  Eval compute in (fact_sep_prog 1 5 5).
  Eval compute in (fact 5).

  Theorem fact_sep__fact_sep_prog:
    forall m n seed,
      n >= m ->
      fact_sep seed (n,m) = fact_sep_prog seed n m.
  Proof.
    intro.
    induction m; intros;
      rewrite fact_sep_equation;
      unfold g; unfold cr.

    unfold fact_sep_prog. reflexivity.
    destruct n as [| n]. inversion H.
    assert(A1: n >= m) by auto with arith. clear H.
    rewrite IHm.
    2: omega.
    simpl.
    rewrite <- minus_n_O.
    reflexivity.
  Qed.

  (** ** Splitting

   *)

  Definition split_nm (n m: nat) :=
    let m1 := div2 m in
    let m2 := m - m1 in
    let n1 := n  in
    let n2 := n1 - m1 in
    (n1, m1, n2, m2).

  Definition SplitPred (t1 t2: nat * nat) :=
    let (n1,m1) := t1 in
    let (n2,m2) := t2 in
    n2 = n1 - m1.

  Lemma Associative:
    forall a b c,
      cr a (b * c) = cr a b * c.
  Proof.
    intros [n m] b c.
    unfold cr.
    auto with arith.
  Qed.

  Lemma Unit:
    forall (seed : nat),
      seed = 1 * seed.
  Proof.
    auto with arith.
  Qed.

  Definition scat (s1 s2: nat * nat) := (fst s1, (snd s1) + (snd s2)).

  Lemma Base_Omitted:
    forall s1 s2,
      SplitPred s1 s2 ->
      g s1 = None ->
      scat s1 s2 = s2.
  Proof.
    unfold SplitPred.
    intros [n1 m1] [n2 m2] Sp * Gs1.
    unfold scat in *.
    simpl in *.
    destruct m1.
    - rewrite <- minus_n_O in Sp.
      rewrite plus_0_l.
      subst n2.
      reflexivity.
    - inversion Gs1.
  Qed.

  Lemma Recursive_Retention_R:
    forall s1 s2 s : nat * nat,
      SplitPred s1 s2 ->
      g s1 = Some s ->
      g (scat s1 s2) = Some (scat s s2).
  Proof.
    intros * H Sp.
    clear H.
    unfold SplitPred in Sp.
    destruct s1 as [n1 m1].
    destruct s2 as [n2 m2].
    destruct s as [n1' m1'].
    unfold scat.
    simpl.
    unfold g in Sp.
    induction m1 as [| m1].
    inversion Sp.
    inversion Sp.
    subst n1' m1'.
    simpl.
    reflexivity.
  Qed.

  Lemma Recursive_Retension_L:
    forall s1 s2: nat * nat,
      SplitPred s1 s2 ->
    forall s : nat * nat,
      g s1 = Some s -> SplitPred s s2.
  Proof.
    intros [n1 m1] [n2 m2] Sp [n3 m3] Gs1.
    unfold SplitPred; unfold scat in *.
    simpl in *.
    destruct m1; inversion Gs1.
    injection Gs1. intros M1 N3.
    subst m3.
    omega.
  Qed.

  Lemma Head_Access:
   forall (s1 s2 : nat * nat),
     SplitPred s1 s2 ->
     forall (b : nat),
     cr (scat s1 s2) b = cr s1 b.
  Proof.
    intros [n1 m1] [n2 m2] * Sp.
    clear Sp.
    unfold scat in *.
    simpl in *.
    reflexivity.
  Qed.

  Lemma fact_sep_homomorphism:
    forall t1 t2,
      SplitPred t1 t2 ->
      fact_sep 1 (scat t1 t2) =
      (fact_sep 1 t1) * (fact_sep 1 t2).
  Proof.
    Unset Ltac Debug.
    linU_homomorphism_tac
      fact_sep_equation
      Base_Omitted
      Recursive_Retention_R
      Head_Access
      Recursive_Retension_L
      Unit
      Associative
    .
  Qed.

  Lemma Head_Access':
   forall (s1 s2 : nat * nat),
     SplitPred s1 s2 ->
     forall (b : nat),
       cr (scat s1 s2) b = cr s1 b.
  Proof.
    intros [n1 m1] [n2 m2] * Sp.
    unfold scat in *.
    simpl in *.
    reflexivity.
  Qed.

  Function fact_homo (t: nat * nat) {wf snd_lt t} :=
    match t with
      | (n, m) =>
    match m with
    | O => 1
    | S O => n
    | S m' => match split_nm n m with
              | (n1,m1,n2,m2) =>
                let v1 := (fact_homo (n1, m1)) in
                let v2 := (fact_homo (n2, m2)) in
                v1 * v2
              end
    end
    end.

  Proof.
    - intros.
      unfold split_nm in teq2.
      injection teq2; intros.
      unfold snd_lt. simpl. subst.
      case (Nat.div2 n0) eqn: H; auto.
      omega.
    - intros.
      unfold split_nm in teq2.
      injection teq2; intros.
      unfold snd_lt. simpl.
      subst.
      destruct n0; auto with arith.
    - apply snd_lt_wf.
  Defined.

  Definition split_nat (n:nat) :=
    let n1 := div2 n in
    let n2 := n - n1 in
    (n1, n2).

  Eval compute in (split_nat 10).
  Eval compute in (split_nat 0).

  Function fact_homo_prog (n m: nat) {measure (fun n: nat => n) m } :=
    match m with
      | O => 1
      | S O => n
      | S m' =>
          let (m1, m2) := split_nat m in
          let v1 := (fact_homo_prog n m1) in
          let v2 := (fact_homo_prog (n-m1) m2) in
          v1 * v2
    end.
  Proof.
    - intros.
      unfold split_nat in teq1.
      inversion teq1.
      case (Nat.div2 n0) eqn: DivN0; omega.
    - intros.
      unfold split_nat in teq1.
      inversion teq1.
      destruct n0; auto with arith.
  Defined.

  Eval compute in (split_nm 3 3).
  Eval compute in (fact_homo_prog 4 2).

  Theorem fact_sep__fact_homo:
    forall n m,
      n >= m ->
      fact_sep 1 (n, m) = fact_homo (n,m).
  Proof.

    intros n m.
    name_term t (n, m) T. rewrite <- T.
    generalize dependent T.
    generalize dependent m.
    generalize dependent n.

    functional induction (fact_homo t); intros * T VT;
      injection T; clear T; intros; subst m n0.
    - rewrite fact_sep_equation; auto.
    - destruct n as [| n]. inversion VT.
      rewrite fact_sep_equation; simpl.
      rewrite fact_sep_equation; simpl.
      rewrite Nat.sub_0_r.
      auto with arith.
    - destruct n as [| n]. inversion VT.
      assert(VT': n >= m') by auto with arith; clear VT; rename VT' into VT.
      unfold split_nm in e1;
        apply invertTupleRewriteRev_test4 in e1 as [N1 [M1 [N2 M2]]].
      assert (A1: n2 >= m2) by omega.
      assert (A2: n1 >= m1).
      {
        subst.
        apply le_trans with (m:=S m').
        apply le_div2.
        auto with arith.
      }
      erewrite <- IHn; auto; clear IHn.
      erewrite <- IHn0; auto; clear IHn0.

      assert (Sp: SplitPred (n1,m1) (n2,m2)) by (unfold SplitPred; omega).
      apply fact_sep_homomorphism in Sp.

      rewrite <- Sp.
      unfold scat. simpl.
      subst n1.
      assert (A46: S m' = m1 + m2). {
        assert (m1 <= m').
        {
          subst; simpl.
          destruct m'; trivial.
          apply le_n_S.
          apply le_div2.
        }
        omega.
      }
    rewrite A46.
    reflexivity.

  Restart.
    intros n m.
    name_term t (n, m) T. rewrite <- T.
    generalize dependent T.
    generalize dependent m.
    generalize dependent n.

    functional induction (fact_homo t); intros * T VT;
      injection T; clear T; intros; subst m n0.
    - rewrite fact_sep_equation; auto.
    - destruct n as [| n]. inversion VT.
      rewrite fact_sep_equation; simpl.
      rewrite fact_sep_equation; simpl.
      rewrite Nat.sub_0_r.
      auto with arith.
    - destruct n as [| n]. inversion VT.
      assert(VT': n >= m') by auto with arith; clear VT; rename VT' into VT.
      unfold split_nm in e1;
        apply invertTupleRewriteRev_test4 in e1 as [N1 [M1 [N2 M2]]].
      assert (A1: n2 >= m2) by omega.
      assert (A2: n1 >= m1).
      {
        subst.
        apply le_trans with (m:=S m').
        apply le_div2.
        auto with arith.
      }
      erewrite <- IHn; auto; clear IHn.
      erewrite <- IHn0; auto; clear IHn0.

      assert (Sp: SplitPred (n1,m1) (n2,m2)) by (unfold SplitPred; omega).
      apply fact_sep_homomorphism in Sp.

      rewrite <- Sp.
      unfold scat. simpl.
      subst n1.
      assert (A46: S m' = m1 + m2). {
        assert (m1 <= m').
        {
          subst; simpl.
          destruct m'; trivial.
          apply le_n_S.
          apply le_div2.
        }
        omega.
      }
    rewrite A46.
    reflexivity.

  Qed.