Require Export FSets.

Definition dist_3 (S:Type) (A B C  : S) : Prop := A <> B /\ A <> C /\ B <> C.

Definition dist_4 (S:Type) (A B C D :S) : Prop :=
  A <> B /\ A <> C /\ A <> D /\ B <> C /\ B <> D /\ C <> D.

Module Type ProjectiveSpace (DecPoints: FSetInterface.WS).

Notation "s [==] t" := (DecPoints.eq s t) (at level 70, no associativity).

Definition dist4 A B C D  :=
 ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\
 ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D.

Definition dist3 A B C  :=
 ~ A [==] B /\ ~ A [==] C /\ ~ B [==] C.

(*** Projective geometry ****)
Definition Point := DecPoints.t.
Parameter Line: Type.
Parameter Incid : Point -> Line -> Prop.

Axiom incid_dec : forall (A:Point)(l:Line), {Incid A l} + {~Incid A l}.

(* A1 : any two points lie on a unique Line *)

Axiom a1_exists : forall A B : Point, {l : Line | Incid A l /\ Incid B l}.

Axiom uniqueness : forall (A B :Point)(l1 l2:Line),
   Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> A [==] B \/ l1 = l2.

(* A2 : Pasch's axiom *)

Axiom a2 : forall A B C D:Point, forall lAB lCD lAC lBD :Line,
dist4 A B C D ->
Incid A lAB/\Incid B lAB ->
Incid C lCD/\Incid D lCD ->
Incid A lAC/\Incid C lAC ->
Incid B lBD/\Incid D lBD ->
(exists I:Point, (Incid I lAB /\ Incid I lCD)) -> exists J:Point, (Incid J lAC /\Incid J lBD).

(** A3 : dimension-related axioms *)

Axiom a3_1 :
  forall l:Line,exists A:Point, exists B:Point, exists C:Point,
 dist3 A B C/\Incid A l /\Incid B l /\ Incid C l.

Definition Intersect (l1 l2:Line) := exists P:Point, Incid P l1 /\ (Incid P l2).

(** there exists 2 lines which do not intersect *)
Axiom a3_2 (* dim >= 3 *) : exists l1:Line, exists l2:Line, forall p:Point, ~(Incid p l1/\Incid p l2).

Definition Intersect_In (l1 l2 :Line) (P:Point) := Incid P l1 /\ Incid P l2.

Axiom a3_3 :  forall l1 l2 l3:Line, dist_3 Line l1 l2 l3 ->
exists l4 :Line,  exists J1:Point, exists J2:Point, exists J3:Point, (dist3 J1 J2 J3) /\
     (Intersect_In l1 l4 J1) /\ (Intersect_In l2 l4 J2) /\ (Intersect_In l3 l4 J3).

End ProjectiveSpace.

Module Type ProjectiveSpaceOrHigher (DecPoints: FSetInterface.WS).

Notation "s [==] t" := (DecPoints.eq s t) (at level 70, no associativity).

Definition dist4 A B C D  :=
 ~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\
 ~ B [==] C /\ ~ B [==] D /\ ~ C [==] D.

Definition dist3 A B C  :=
 ~ A [==] B /\ ~ A [==] C /\ ~ B [==] C.

(*** Projective geometry ****)
Definition Point := DecPoints.t.
Parameter Line : Type.

(** We do force to use Coq equality for line equality in order to be able to prove that the rank axiom system
implies this one *)

(* Of course one can implement this using Coq's equality without problem. *)

Parameter line_eq : Line -> Line -> Prop.
Axiom line_eq_sym : forall l m, line_eq l m -> line_eq m l.
Axiom line_eq_trans : forall l m n, line_eq l m -> line_eq m n ->  line_eq l n.
Axiom line_eq_refl : forall l, line_eq l l.

Parameter Incid : Point -> Line -> Prop.

Axiom incid_dec : forall (A:Point)(l:Line), {Incid A l} + {~Incid A l}.

(* A1 : any two points lie on a unique Line *)

Axiom a1_exists : forall A B : Point, {l : Line | Incid A l /\ Incid B l}.

Axiom uniqueness : forall (A B :Point)(l1 l2:Line),
   Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> A [==] B \/ line_eq l1 l2.

(* A2 : Pasch's axiom *)

Axiom a2 : forall A B C D:Point, forall lAB lCD lAC lBD :Line,
dist4 A B C D ->
Incid A lAB/\Incid B lAB ->
Incid C lCD/\Incid D lCD ->
Incid A lAC/\Incid C lAC ->
Incid B lBD/\Incid D lBD ->
(exists I:Point, (Incid I lAB /\ Incid I lCD)) -> exists J:Point, (Incid J lAC /\Incid J lBD).

(** A3 : dimension-related axioms *)

Axiom a3_1 :
  forall l:Line,exists A:Point, exists B:Point, exists C:Point,
 dist3 A B C/\Incid A l /\Incid B l /\ Incid C l.

(** there exists 2 lines which do not intersect *)
Axiom a3_2 (* dim >= 3 *) : exists l1:Line, exists l2:Line, forall p:Point, ~(Incid p l1/\Incid p l2).

End ProjectiveSpaceOrHigher.

Module Type VeblenYoungProjectiveSpace.

Parameter Point: Set.
Parameter Line: Set.
Parameter Incid : Point -> Line -> Prop.

(* A1 line existence *)
Axiom A1 : forall A B, A <> B -> {l:Line | Incid A l /\ Incid B l}.

(* A2 line unicity *)
Axiom A2 : forall (A B :Point)(l1 l2:Line), A<>B ->
   Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> l1=l2.

Definition collinear A B C := exists l, Incid A l /\ Incid B l /\ Incid C l.

Axiom A3: forall A B C D E, ~ collinear A B C -> D<>E -> collinear B C D -> collinear C A E ->
 {F:Point | collinear A B F /\ collinear D E F}.

Axiom E0: forall l, {A:Point & {B:Point & {C:Point | (dist_3 Point A B C/\Incid A l /\Incid B l /\ Incid C l)}}}.

(* E1 *)
Axiom l0 : Line.

Axiom E2: ~ exists l, forall A, Incid A l.

(* E3 all points are not on the same plane *)

(* E3' if S3 is a three space, every point is on S3 *)

(* E3' is equivalent to any two distinct planes have a line in common *)
(* E3' is equivalent to every set of five points lie on the same three-space *)

End VeblenYoungProjectiveSpace.


(** * SfLib: Software Foundations Library *)

(* $Date: 2011-03-14 20:08:53 -0400 (Mon, 14 Mar 2011) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

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

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(* From Poly.v *)

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem not_eq_beq_false : forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

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

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Definition relation (X:Type) := X -> X -> Prop.

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

Inductive refl_step_closure (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | rsc_refl  : forall (x : X),
                 refl_step_closure X R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure X R y z ->
                    refl_step_closure X R x z.
Implicit Arguments refl_step_closure [[X]].

Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rsc_refl" | Case_aux c "rsc_step" ].

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y r.
  apply rsc_step with y. apply r. apply rsc_refl.   Qed.

Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.

Definition beq_id id1 id2 :=
  match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Theorem not_eq_beq_id_false : forall i1 i2,
  i1 <> i2 -> beq_id i1 i2 = false.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  assert (n <> n0).
    intros C. subst. apply H. reflexivity.
  apply not_eq_beq_false. assumption.  Qed.

Theorem beq_id_sym: forall i1 i2,
  beq_id i1 i2 = beq_id i2 i1.
Proof.
  intros i1 i2. destruct i1. destruct i2. apply beq_nat_sym. Qed.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (beq_id x2 x1)...
Qed.

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e291m19_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From S5 Require Export canonical.

Theorem completeness (G : form_set) (f : form) :
  (forall (m: model) (w : m), (forall g, G g -> interpret g m w) ->
  interpret f m w) -> ax_s5 G f.
Proof.
  intros H1. destruct (excluded_middle (ax_s5 G f)) as [H2 | H2].
  { assumption. }
  exfalso. assert (consistent (add_singleton G (Neg f))) as con.
  { intros H3. apply deduction_theorem, ax_s5_dne_infer in H3. contradiction. }
  pose (w := world_from_set (add_singleton G (Neg f)) con).
  assert (interpret (Neg f) can_model w) as H3.
  { apply truth_lemma. simpl. apply max_consistent_subset.
    unfold add_singleton. left. reflexivity. }
  simpl in H3. apply H3, H1. intros g Gg. apply truth_lemma.
  apply (subset_lemma (add_singleton G (Neg f))).
  { apply max_consistent_subset. }
  apply subset_add_singleton, Gg.
Qed.