Require Export Iron.Language.SystemF2Data.Exp.Base.
Require Export Iron.Language.SystemF2Data.Exp.Alt.

(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)  (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t)  (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1) (liftTX d x2)

  |  XCon dc ts xs
  => XCon dc (map (liftTT 1 d) ts) (map (liftTX d) xs)

  |  XCase xx alts
  => XCase (liftTX d xx) (map (liftTA d) alts)

  |  XPrim p xs
  => XPrim p (map (liftTX d) xs)

  |  XLit l
  => XLit l
 end

 with liftTA (d: nat) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (liftTX d xx)
  end.

(* Data constructor of alternative is unchanged by lifting. *)
Lemma dcOfAlt_liftTA
 : forall d a
 , dcOfAlt (liftTA d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftTA : global.

(* Data constructor of alternatives are unchaged by lifting. *)
Lemma dcOfAlt_liftTA_map
 :  forall ix aa
 ,  map dcOfAlt (map (liftTA ix) aa)
 =  map dcOfAlt aa.
Proof.
 intros. induction aa; snorm; rewritess; eauto.
Qed.
Hint Rewrite dcOfAlt_liftTA_map : global.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Export CatSem.ORDER.tlc_order_rep.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** we define two morphisms of representations to be equal
    if they agree on each set of variables *)

Lemma eq_Rep_equiv (P R: TLCPO_rep) :
     Equivalence (A:=TLCPO_rep_Hom P R)
         (fun a c => forall r, a r == c r).
Proof.
  intros;
  constructor;
  unfold Reflexive,
         Symmetric,
         Transitive;
  simpl; intros; auto;
  etransitivity; eauto.
Qed.

Definition eq_Rep_oid (P R : TLCPO_rep) := Build_Setoid (eq_Rep_equiv P R).

(** Identity Representation *)

Program Instance Rep_id_struct (P : TLCPO_rep) :
         TLCPO_rep_Hom_struct (RMonad_id P).
Next Obligation.
  match goal with [H:prod _ _ |- _] =>
     destruct H end;
  auto.
Qed.

Definition Rep_id (P: TLCPO_rep) := Build_TLCPO_rep_Hom (Rep_id_struct P).

(** Composition of Representations *)
Section Rep_comp.

Variables P Q R: TLCPO_rep.
Variable M: TLCPO_rep_Hom P Q.
Variable N: TLCPO_rep_Hom Q R.

Obligation Tactic := cat;
    repeat rew (App_Hom (S:=M));
    repeat rew (App_Hom (S:=N));
    repeat rew (Abs_Hom (S:=M));
    repeat rew (Abs_Hom (S:=N));
    cat.

Program Instance Rep_comp_struct :
      TLCPO_rep_Hom_struct (RMonad_comp M N).

Definition Rep_comp := Build_TLCPO_rep_Hom Rep_comp_struct.

End Rep_comp.

(** category of representations *)

Ltac t := match goal with [H : forall _ _ _ , _ = _ |- _ ] =>
              rewrite H end.

Obligation Tactic := cat; try unf_Proper;
      cat; repeat t; cat.

Program Instance TLCPO_REP_struct : Cat_struct (TLCPO_rep_Hom) := {
  mor_oid a c := eq_Rep_oid a c;
  id a := Rep_id a;
  comp P Q R f g := Rep_comp f g
}.

Definition TLCPO_REP := Build_Cat TLCPO_REP_struct.

Existing Instance tlcpo_rep_struct.


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

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

Print Assumptions sub.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


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

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

Print Assumptions sub.


(** * Induction: Proof by Induction *)

(** The next line imports all of our definitions from the
    previous chapter. *)

Require Export Basics.

(** For it to work, you need to use [coqc] to compile [Basics.v]
    into [Basics.vo].  (This is like making a .class file from a .java
    file, or a .o file from a .c file.)

    Here are two ways to compile your code:

     - CoqIDE:

         Open [Basics.v].
         In the "Compile" menu, click on "Compile Buffer".

     - Command line:

         Run [coqc Basics.v]

    *)

(* ###################################################################### *)
(** * Proof by Induction *)

(** We proved in the last chapter that [0] is a neutral element
    for [+] on the left using a simple argument.  The fact that it is
    also a neutral element on the _right_... *)

Theorem plus_0_r_firsttry : forall n:nat,
  n + 0 = n.

(** ... cannot be proved in the same simple way.  Just applying
  [reflexivity] doesn't work: the [n] in [n + 0] is an arbitrary
  unknown number, so the [match] in the definition of [+] can't be
  simplified.  *)

Proof.
  intros n.
  simpl. (* Does nothing! *)
Abort.

(** *** *)

(** And reasoning by cases using [destruct n] doesn't get us much
   further: the branch of the case analysis where we assume [n = 0]
   goes through, but in the branch where [n = S n'] for some [n'] we
   get stuck in exactly the same way.  We could use [destruct n'] to
   get one step further, but since [n] can be arbitrarily large, if we
   try to keep on like this we'll never be done. *)

Theorem plus_0_r_secondtry : forall n:nat,
  n + 0 = n.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    reflexivity. (* so far so good... *)
  - (* n = S n' *)
    simpl.       (* ...but here we are stuck again *)
Abort.

(** *** *)

(** To prove such facts -- indeed, to prove most interesting
    facts about numbers, lists, and other inductively defined sets --
    we need a more powerful reasoning principle: _induction_.

    Recall (from high school) the principle of induction over natural
    numbers: If [P(n)] is some proposition involving a natural number
    [n] and we want to show that [P] holds for _all_ numbers [n], we can
    reason like this:
         - show that [P(O)] holds;
         - show that, for any [n'], if [P(n')] holds, then so does
           [P(S n')];
         - conclude that [P(n)] holds for all [n].

    In Coq, the steps are the same but the order is backwards: we
    begin with the goal of proving [P(n)] for all [n] and break it
    down (by applying the [induction] tactic) into two separate
    subgoals: first showing [P(O)] and then showing [P(n') -> P(S
    n')].  Here's how this works for the theorem we are trying to
    prove at the moment: *)

(** *** *)

Theorem plus_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite -> IHn'. reflexivity.  Qed.

(** Like [destruct], the [induction] tactic takes an [as...]
    clause that specifies the names of the variables to be introduced
    in the subgoals.  In the first branch, [n] is replaced by [0] and
    the goal becomes [0 + 0 = 0], which follows by simplification.  In
    the second, [n] is replaced by [S n'] and the assumption [n' + 0 =
    n'] is added to the context (with the name [IHn'], i.e., the
    Induction Hypothesis for [n']). Notice that the name for the
    induction hypothesis was explicitly given in the [as...] clause of
    the call to [induction]. The goal in this case becomes [(S n') + 0
    = S n'], which simplifies to [S (n' + 0) = S n'], which in turn
    follows from the induction hypothesis. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** **** Exercise: 2 stars (basic_induction)  *)

(** Prove the following lemmas using induction. You might need
    previously proven results. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros n. induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m. induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n.
  - simpl. rewrite plus_0_r. reflexivity.
  - simpl. rewrite IHn. rewrite plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p.
  induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars (double_plus)  *)

(** Consider the following function, which doubles its argument: *)

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

(** Use induction to prove this simple fact about [double]: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros n. induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. rewrite plus_n_Sm. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star (destruct_induction)  *)
(** Briefly explain the difference between the tactics
    [destruct] and [induction].

(* FILL IN HERE *)

*)
(** [] *)

(* ###################################################################### *)
(** * Proofs Within Proofs *)

(** In Coq, as in informal mathematics, large proofs are very
    often broken into a sequence of theorems, with later proofs
    referring to earlier theorems.  Occasionally, however, a proof
    will need some miscellaneous fact that is too trivial (and of too
    little general interest) to bother giving it its own top-level
    name.  In such cases, it is convenient to be able to simply state
    and prove the needed "sub-theorem" right at the point where it is
    used.  The [assert] tactic allows us to do this.  For example, our
    earlier proof of the [mult_0_plus] theorem referred to a previous
    theorem named [plus_O_n].  We can also use [assert] to state and
    prove [plus_O_n] in-line: *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n). { reflexivity. }
  rewrite -> H.
  reflexivity.  Qed.

(** The [assert] tactic introduces two sub-goals.  The first is
    the assertion itself; by prefixing it with [H:] we name the
    assertion [H].  (Note that we could also name the assertion with
    [as] just as we did above with [destruct] and [induction], i.e.,
    [assert (0 + n = n) as H].  Also note that we mark the proof of
    this assertion with curly braces [{ ... }], both for readability
    and so that, when using Coq interactively, we can see more easily
    when we have finished proving the assertion.)  The second goal is
    the same as the one at the point where we invoke [assert], except
    that, in the context, we have the assumption [H] that [0 + n = n].
    That is, [assert] generates one subgoal where we must prove the
    asserted fact and a second subgoal where we can use the asserted
    fact to make progress on whatever we were trying to prove in the
    first place. *)

(** Actually, [assert] will turn out to be handy in many sorts of
    situations.  For example, suppose we want to prove that [(n + m)
    + (p + q) = (m + n) + (p + q)]. The only difference between the
    two sides of the [=] is that the arguments [m] and [n] to the
    first inner [+] are swapped, so it seems we should be able to
    use the commutativity of addition ([plus_comm]) to rewrite one
    into the other.  However, the [rewrite] tactic is a little stupid
    about _where_ it applies the rewrite.  There are three uses of
    [+] here, and it turns out that doing [rewrite -> plus_comm]
    will affect only the _outer_ one. *)

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* We just need to swap (n + m) for (m + n)...
     it seems like plus_comm should do the trick! *)
  rewrite -> plus_comm.
  (* Doesn't work...Coq rewrote the wrong plus! *)
Abort.

(** To get [plus_comm] to apply at the point where we want it, we can
    introduce a local lemma stating that [n + m = m + n] (for
    the particular [m] and [n] that we are talking about here), prove
    this lemma using [plus_comm], and then use this lemma to do the
    desired rewrite. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.  Qed.

(** **** Exercise: 4 stars (mult_comm)  *)
(** Use [assert] to help prove this theorem.  You shouldn't need to
    use induction. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p. rewrite plus_assoc.
  assert (H: n + m = m + n).
  { rewrite plus_comm. reflexivity. }
  rewrite H. rewrite plus_assoc.
  reflexivity.
Qed.

(** Now prove commutativity of multiplication.  (You will probably
    need to define and prove a separate subsidiary theorem to be used
    in the proof of this one.)  You may find that [plus_swap] comes in
    handy. *)

Lemma mult_n_O : forall n : nat, n * 0 = 0.
Proof.
  induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.
(* Introduce mult_plus_dist  *)
Lemma mult_plus_dist :
  forall m n p : nat, n * (m + p) = n * m + n * p.
Proof.
  intros m n p.
  induction n.
  + simpl. reflexivity.
  + simpl. rewrite IHn.
    repeat (rewrite plus_assoc).
    assert (m + p + n * m = m + n * m + p).
    {  rewrite <- plus_assoc.
       replace (p + n * m) with (n * m + p).
       * rewrite plus_assoc. reflexivity.
       * rewrite plus_comm. reflexivity.
    }
    rewrite H. reflexivity.
Qed.

Lemma mult_n_1 : forall n, n * 1 = n.
Proof.
  induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros m n.
  induction m.
  - rewrite mult_0_r.
    simpl.  reflexivity.
  - simpl.
    replace (S m) with (m + 1).
    +  rewrite mult_plus_dist.
       rewrite mult_n_1. rewrite plus_comm. rewrite IHm.
       reflexivity.
    +  rewrite plus_comm. simpl. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (evenb_n__oddb_Sn)  *)

(** Prove the following simple fact: *)

Theorem evenb_n__oddb_Sn : forall n : nat,
  evenb n = negb (evenb (S n)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * More Exercises *)

(** **** Exercise: 3 stars, optional (more_exercises)  *)
(** Take a piece of paper.  For each of the following theorems, first
    _think_ about whether (a) it can be proved using only
    simplification and rewriting, (b) it also requires case
    analysis ([destruct]), or (c) it also requires induction.  Write
    down your prediction.  Then fill in the proof.  (There is no need
    to turn in your piece of paper; this is just to encourage you to
    reflect before hacking!) *)

Theorem ble_nat_refl : forall n:nat,
  true = ble_nat n n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem plus_ble_compat_l : forall n m p : nat,
  ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem S_nbeq_0 : forall n:nat,
  beq_nat (S n) 0 = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_1_l : forall n:nat, 1 * n = n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem all3_spec : forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
               (negb c))
  = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (beq_nat_refl)  *)
(** Prove the following theorem.  Putting [true] on the left-hand side
of the equality may seem odd, but this is how the theorem is stated in
the standard library, so we follow suit.  Since rewriting
works equally well in either direction, we will have no
problem using the theorem no matter which way we state it. *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (plus_swap')  *)
(** The [replace] tactic allows you to specify a particular subterm to
   rewrite and what you want it rewritten to.  More precisely,
   [replace (t) with (u)] replaces (all copies of) expression [t] in
   the goal by expression [u], and generates [t = u] as an additional
   subgoal. This is often useful when a plain [rewrite] acts on the wrong
   part of the goal.

   Use the [replace] tactic to do a proof of [plus_swap'], just like
   [plus_swap] but without needing [assert (n + m = m + n)].
*)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (binary_commute)  *)
(** Recall the [increment] and [binary-to-unary] functions that you
    wrote for the [binary] exercise in the [Basics] chapter.  Prove
    that these functions commute -- that is, incrementing a binary
    number and then converting it to unary yields the same result as
    first converting it to unary and then incrementing.
    Name your theorem [bin_to_nat_pres_incr].

    (Before you start working on this exercise, please copy the
    definitions from your solution to the [binary] exercise here so
    that this file can be graded on its own.  If you find yourself
    wanting to change your original definitions to make the property
    easier to prove, feel free to do so.) *)

Inductive bin : Type :=
  | zero : bin
  | twice : bin -> bin
  | twice_plus_one : bin -> bin.

Fixpoint incr (b : bin) : bin :=
  match b with
    | zero => twice_plus_one zero
    | twice b => twice_plus_one b
    | twice_plus_one b => twice (incr b)
  end.

Fixpoint bin_to_nat (b : bin) : nat :=
  match b with
  | zero => O
  | twice b' => mult (S (S O)) (bin_to_nat b')
  | twice_plus_one b' => plus (mult (S (S O)) (bin_to_nat b')) (S O)
  end.

Theorem bin_to_nat_pres_incr :
  forall b : bin, bin_to_nat (incr b) = bin_to_nat b + 1.
Proof.
  induction b.
  - simpl. reflexivity.
  - simpl.  rewrite <- plus_n_O. reflexivity.
  - simpl. rewrite IHb. rewrite <- plus_n_O. rewrite <- plus_n_O.
    rewrite plus_assoc.
    replace (bin_to_nat b + 1 + bin_to_nat b) with (bin_to_nat b + bin_to_nat b + 1).
    + reflexivity.
    + repeat (rewrite <- plus_assoc).
      replace (bin_to_nat b + 1) with (1 + bin_to_nat b).
      * reflexivity.
      * rewrite plus_comm.  reflexivity.
Qed.

(** [] *)

(** **** Exercise: 5 stars, advanced (binary_inverse)  *)
(** This exercise is a continuation of the previous exercise about
    binary numbers.  You will need your definitions and theorems from
    the previous exercise to complete this one.

    (a) First, write a function to convert natural numbers to binary
        numbers.  Then prove that starting with any natural number,
        converting to binary, then converting back yields the same
        natural number you started with.

    (b) You might naturally think that we should also prove the
        opposite direction: that starting with a binary number,
        converting to a natural, and then back to binary yields the
        same number we started with.  However, it is not true!
        Explain what the problem is.

    (c) Define a "direct" normalization function -- i.e., a function
        [normalize] from binary numbers to binary numbers such that,
        for any binary number b, converting to a natural and then back
        to binary yields [(normalize b)].  Prove it.  (Warning: This
        part is tricky!)

    Again, feel free to change your earlier definitions if this helps
    here.
*)

Fixpoint nat_to_bin (n : nat) :=
  match n with
  | O   => zero
  | S m => incr (nat_to_bin m)
end.

Lemma bin_incr
  : forall b, bin_to_nat (incr b) = S (bin_to_nat b).
Proof.
  induction b.
  - simpl. reflexivity.
  - simpl. rewrite <- plus_n_O.
    rewrite plus_comm. simpl. reflexivity.
  - simpl. repeat (rewrite <- plus_n_O).
    rewrite IHb. simpl.
    replace (bin_to_nat b + bin_to_nat b + 1) with (bin_to_nat b + (1 + bin_to_nat b)).
    + simpl. reflexivity.
    + rewrite plus_assoc. rewrite plus_comm. rewrite plus_assoc. reflexivity.
Qed.

Theorem bin_to_nat_conversion :
  forall n : nat, bin_to_nat (nat_to_bin n) = n.
Proof.
 induction n.
 + simpl. reflexivity.
 + simpl. rewrite bin_incr. rewrite IHn. reflexivity.
Qed.

(* Answer to b:
  Inductive definition of binary gives natural numbers many representations.
  Yet bin_to_nat doesn't preserve the information about the specific representation.
  For example

   bin_to_nat zero = 0
   bin_to_nat (Twice zero) = 0

  Because of that we cannot prove
    forall b : binary, nat_to_bin (bin_to_nat b) = b.
*)

Fixpoint normalize(b : bin) :=
  match b with
  | zero       => zero
  | twice zero => zero
  | twice b'  => match normalize b' with
                 | zero => zero
                 | b'' => twice b''
                 end
  | twice_plus_one b'   => twice_plus_one (normalize b')
end.

Example normalize_1 : normalize (twice (twice zero)) = zero.
Proof.
  simpl. reflexivity.
Qed.

Example normalize_2 : normalize (twice_plus_one (twice (twice zero))) = twice_plus_one zero.
Proof.
  simpl. reflexivity.
Qed.
(*
Lemma twice_nat_to_bin :
 forall b : bin, nat_to_bin (bin_to_nat b + bin_to_nat b) = twice b.
Proof.
  induction b.
  - simpl. reflexivity.
  -
Qed.
*)

Lemma b1 :
  forall b : bin, nat_to_bin (bin_to_nat b + bin_to_nat b) = normalize (twice (nat_to_bin (bin_to_nat b))).
Proof.
 admit.
Qed.

Lemma b4 :
  forall b : bin, nat_to_bin (bin_to_nat b + bin_to_nat b + 1) = normalize (twice_plus_one (nat_to_bin (bin_to_nat b))).
Proof.
 admit.
Qed.

Lemma b2 :
  forall b : bin, normalize (normalize b) = normalize b.
Proof.
 admit.
Qed.

Lemma b3 :
  forall b : bin, normalize (twice (normalize b)) = normalize (twice b).
Proof.
 admit.
Qed.

Lemma b5 :
  forall b : bin, normalize (twice_plus_one (normalize b)) = normalize (twice_plus_one b).
Proof.
 admit.
Qed.

Theorem nat_to_bin_conversion :
  forall b : bin, nat_to_bin (bin_to_nat b) = normalize b.
Proof.
  induction b.
  - simpl. reflexivity.
  - simpl bin_to_nat. rewrite <- plus_n_O.
    rewrite b1. rewrite IHb. rewrite b3. reflexivity.
  - simpl bin_to_nat. rewrite <- plus_n_O.
    rewrite b4. rewrite IHb. rewrite b5. reflexivity.
Qed.
(** [] *)

(* ###################################################################### *)
(** * Formal vs. Informal Proof (Advanced) *)

(** "Informal proofs are algorithms; formal proofs are code." *)

(** The question of what, exactly, constitutes a "proof" of a
    mathematical claim has challenged philosophers for millennia.  A
    rough and ready definition, though, could be this: a proof of a
    mathematical proposition [P] is a written (or spoken) text that
    instills in the reader or hearer the certainty that [P] is true.
    That is, a proof is an act of communication.

    Now, acts of communication may involve different sorts of readers.
    On one hand, the "reader" can be a program like Coq, in which case
    the "belief" that is instilled is a simple mechanical check that
    [P] can be derived from a certain set of formal logical rules, and
    the proof is a recipe that guides the program in performing this
    check.  Such recipes are _formal_ proofs.

    Alternatively, the reader can be a human being, in which case the
    proof will be written in English or some other natural language,
    thus necessarily _informal_.  Here, the criteria for success are
    less clearly specified.  A "good" proof is one that makes the
    reader believe [P].  But the same proof may be read by many
    different readers, some of whom may be convinced by a particular
    way of phrasing the argument, while others may not be.  One reader
    may be particularly pedantic, inexperienced, or just plain
    thick-headed; the only way to convince them will be to make the
    argument in painstaking detail.  But another reader, more familiar
    in the area, may find all this detail so overwhelming that they
    lose the overall thread.  All they want is to be told the main
    ideas, because it is easier to fill in the details for themselves.
    Ultimately, there is no universal standard, because there is no
    single way of writing an informal proof that is guaranteed to
    convince every conceivable reader.  In practice, however,
    mathematicians have developed a rich set of conventions and idioms
    for writing about complex mathematical objects that, within a
    certain community, make communication fairly reliable.  The
    conventions of this stylized form of communication give a fairly
    clear standard for judging proofs good or bad.

    Because we are using Coq in this course, we will be working
    heavily with formal proofs.  But this doesn't mean we can ignore
    the informal ones!  Formal proofs are useful in many ways, but
    they are _not_ very efficient ways of communicating ideas between
    human beings. *)

(** For example, here is a proof that addition is associative: *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof. intros n m p. induction n as [| n' IHn']. reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

(** Coq is perfectly happy with this as a proof.  For a human,
    however, it is difficult to make much sense of it.  If you're used
    to Coq you can probably step through the tactics one after the
    other in your mind and imagine the state of the context and goal
    stack at each point, but if the proof were even a little bit more
    complicated this would be next to impossible.  Instead, a
    mathematician might write it something like this: *)
(** - _Theorem_: For any [n], [m] and [p],
      n + (m + p) = (n + m) + p.
    _Proof_: By induction on [n].

    - First, suppose [n = 0].  We must show
        0 + (m + p) = (0 + m) + p.
      This follows directly from the definition of [+].

    - Next, suppose [n = S n'], where
        n' + (m + p) = (n' + m) + p.
      We must show
        (S n') + (m + p) = ((S n') + m) + p.
      By the definition of [+], this follows from
        S (n' + (m + p)) = S ((n' + m) + p),
      which is immediate from the induction hypothesis. *)
(** _Qed_ *)

(** The overall form of the proof is basically similar.  This is
    no accident: Coq has been designed so that its [induction] tactic
    generates the same sub-goals, in the same order, as the bullet
    points that a mathematician would write.  But there are
    significant differences of detail: the formal proof is much more
    explicit in some ways (e.g., the use of [reflexivity]) but much
    less explicit in others (in particular, the "proof state" at any
    given point in the Coq proof is completely implicit, whereas the
    informal proof reminds the reader several times where things
    stand). *)

(** Here is a formal proof that shows the structure more
    clearly: *)

Theorem plus_assoc'' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - (* n = 0 *)
    reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.   Qed.

(** **** Exercise: 2 stars, advanced (plus_comm_informal)  *)
(** Translate your solution for [plus_comm] into an informal proof. *)

(** Theorem: Addition is commutative.

    Proof: (* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, optional (beq_nat_refl_informal)  *)
(** Write an informal proof of the following theorem, using the
    informal proof of [plus_assoc] as a model.  Don't just
    paraphrase the Coq tactics into English!

    Theorem: [true = beq_nat n n] for any [n].

    Proof: (* FILL IN HERE *)
[] *)

(** $Date: 2015-08-10 19:55:52 +0200 (Mon, 10 Aug 2015) $ *)


From FOL Require Import FullSyntax Arithmetics.
From FOL.Proofmode Require Import Theories ProofMode.
From FOL.Incompleteness Require Import utils fol_utils qdec.

Require Import Lia.
Require Import String.

Open Scope string_scope.

Require Import Setoid.

Require Import Undecidability.Shared.Libs.DLW.Vec.vec.

Require Import String.
Open Scope string_scope.

Section bin_qdec.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.

  Section lemmas.
    Context `{pei : peirce}.

    Lemma Q_add_assoc1 x y z t : Qeq ⊢ num t == (x ⊕ y) ⊕ z → num t == x ⊕ (y ⊕ z).
    Proof.
      induction t as [|t IH] in x |-*; fstart; fintros "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero (y ⊕ z)).
          fapply ax_refl.
        + fexfalso. fapply (ax_zero_succ ((x' ⊕ y) ⊕ z)).
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero (y ⊕ z)).
          fapply ax_refl.
        + frewrite "Hx'". frewrite (ax_add_rec (y ⊕ z) x').
          specialize (IH x').
          fapply ax_succ_congr. fapply IH.
          fapply ax_succ_inj.
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
    Qed.
    Lemma Q_add_assoc2 x y z t : Qeq ⊢ num t == (x ⊕ y) ⊕ z → num t == y ⊕ (x ⊕ z).
    Proof.
      induction t as [|t IH] in x |-*; fstart; fintros "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero z).
          fapply ax_refl.
        + fexfalso. fapply (ax_zero_succ ((x' ⊕ y) ⊕ z)).
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero z).
          fapply ax_refl.
        + frewrite "Hx'". frewrite (ax_add_rec z x').
          pose proof (add_rec_swap2 t y (x' ⊕ z)). cbn in H.
          fapply ax_sym. fapply H. fapply ax_sym.
          fapply IH.
          fapply ax_succ_inj.
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
    Qed.

    Lemma bin_bounded_forall_iff t φ : bounded_t 0 t ->
      Qeq ⊢ (∀∀ ($1 ⊕ $0 ⧀= t) → φ) ↔
            (∀ ($0 ⧀= t) → ∀ ($0 ⧀= t) → ($1 ⊕ $0 ⧀= t) → φ).
    Proof.
      intros Hb. destruct (closed_term_is_num Hb) as [t' Ht'].
      cbn. unfold "↑".
      fstart.
      fassert (t == num t') as "Ht" by fapply Ht'.
      fsplit.
      - fintros "H" x "Hx".
        fintros y "Hy" "Hxy".
        fapply "H". repeat rewrite (bounded_t_0_subst _ Hb). ctx.
      - fintros "H" x y. fintros "[z Hz]".
        fapply "H".
        + fexists (y ⊕ z).
          rewrite !(bounded_t_0_subst _ Hb).
          frewrite "Ht". fapply Q_add_assoc1.
          feapply ax_trans.
          * feapply ax_sym. fapply "Ht".
          * fapply "Hz".
        + fexists (x ⊕ z).
          rewrite !(bounded_t_0_subst _ Hb).
          frewrite Ht'. fapply Q_add_assoc2.
          feapply ax_trans.
          * feapply ax_sym. fapply "Ht".
          * fapply "Hz".
        + fexists z. ctx.
    Qed.
  End lemmas.

  Lemma Qdec_bin_bounded_forall t φ :
    Qdec φ -> Qdec (∀∀ $1 ⊕ $0 ⧀= t`[↑]`[↑] → φ).
  Proof.
    intros Hφ.
    eapply (@Qdec_iff' (∀ ($0 ⧀= t`[↑]) → ∀ ($0 ⧀= t`[↑]`[↑]) → ($1 ⊕ $0 ⧀= t`[↑]`[↑]) → φ)).
    - intros ρ Hb.
      cbn. rewrite !up_term.
      unfold "↑".
      assert (bounded_t 0 t`[ρ]) as Ht.
      { destruct (find_bounded_t t) as [k Hk].
        eapply subst_bounded_max_t; last eassumption. auto. }
      pose proof (@bin_bounded_forall_iff intu t`[ρ] φ Ht).
      pose proof (subst_Weak ρ H) as H'. change (List.map _ _) with Qeq in H'.
      apply frewrite_equiv_switch.
      cbn in H'.
      rewrite !(bounded_t_0_subst _ Ht). rewrite !(bounded_t_0_subst _ Ht) in H'.
      apply H'.
    - do 2 apply Qdec_bounded_forall.
      apply Qdec_impl.
      + apply Qdec_le.
      + assumption.
  Qed.

End bin_qdec.


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

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

Print Assumptions sub.


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

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

Print Assumptions opp.


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

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

Print Assumptions opp.


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

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

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e266m3_9limbs.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.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* ************************************************************************

          Buchberger : final reduction algorithm

          Laurent Thery April 1998 (revised May 1998)

   ************************************************************************ *)

From Coq Require Import List Relation_Definitions.
From Buchberger Require Import LetP.

Section Reduce.
Variable poly : Type.
Variable cb : list poly -> poly -> Prop.
Variable divp : poly -> poly -> Prop.
Variable reduce : list poly -> poly -> poly -> Prop.
Variable nf : list poly -> poly -> poly.
Variable stable : list poly -> list poly -> Prop.
Variable grobner : list poly -> Prop.
Variable zero : poly.
Variable zerop : poly -> Prop.
Variable zerop_dec : forall p : poly, {zerop p} + {~ zerop p}.
Hypothesis cb_id : forall (L : list poly) (p : poly), In p L -> cb L p.
Hypothesis cb_zerop : forall (L : list poly) (p : poly), zerop p -> cb L p.
Hypothesis
  cb_incl :
    forall (L1 L2 : list poly) (p : poly), incl L1 L2 -> cb L1 p -> cb L2 p.
Hypothesis nf_cb : forall (p : poly) (L : list poly), cb (p :: L) (nf L p).
Hypothesis
  cb_trans :
    forall (L : list poly) (p q : poly), cb (p :: L) q -> cb L p -> cb L q.
Hypothesis
  cb_comp :
    forall L1 L2 : list poly,
    (forall p : poly, In p L1 -> cb L2 p) ->
    forall q : poly, cb L1 q -> cb L2 q.
Hypothesis cb_nf : forall (p : poly) (L : list poly), cb (nf L p :: L) p.
Hypothesis
  cb_compo :
    forall (p : poly) (L1 : list poly),
    cb L1 p ->
    forall L2 : list poly, (forall q : poly, In q L1 -> cb L2 q) -> cb L2 p.
Hypothesis
  zerop_elim_cb :
    forall (L : list poly) (p q : poly), zerop p -> cb (p :: L) q -> cb L q.
Hypothesis
  grobner_def :
    forall L : list poly,
    grobner L ->
    forall p : poly, cb L p -> zerop p \/ (exists q : poly, reduce L p q).
Hypothesis
  def_grobner :
    forall L : list poly,
    (forall p : poly, cb L p -> zerop p \/ (exists q : poly, reduce L p q)) ->
    grobner L.
Hypothesis
  nf_div :
    forall (p : poly) (L : list poly),
    ~ zerop p ->
    ~ zerop (nf L p) ->
    exists q : poly, In q (nf L p :: L) /\ divp p q /\ ~ zerop q.
Hypothesis
  div_reduce :
    forall (p : poly) (L1 L2 : list poly),
    (forall r1 : poly,
     In r1 L1 -> ~ zerop r1 -> exists r2 : poly, In r2 L2 /\ divp r1 r2) ->
    forall q : poly, reduce L1 p q -> exists r : poly, reduce L2 p r.
Hypothesis divp_id : forall p : poly, divp p p.
Hypothesis divp_trans : transitive poly divp.
Hypothesis
  nf_div_zero :
    forall (p : poly) (L : list poly),
    ~ zerop p ->
    zerop (nf L p) -> exists q : poly, In q L /\ divp p q /\ ~ zerop q.

Theorem zerop_nf_cb :
 forall (L : list poly) (p : poly), zerop (nf L p) -> cb L p.
Proof.
intros L p H'.
apply zerop_elim_cb with (p := nf L p); auto.
Qed.
Local Hint Resolve zerop_nf_cb : core.

Definition redacc : list poly -> list poly -> list poly.
Proof.
intros H'; elim H'.
intros L; exact (nil (A:=poly)).
intros a p Rec Acc.
apply LetP with (A := poly) (h := nf (p ++ Acc) a).
intros u H'0; case (zerop_dec u); intros Z.
exact (Rec Acc).
exact (u :: Rec (u :: Acc)).
Defined.

Definition red (L : list poly) : list poly := redacc L nil.
Local Hint Resolve incl_refl incl_tl incl_appr incl_appl incl_cons incl_app
  in_or_app : core.

Theorem redacc_cb :
 forall (L1 L2 : list poly) (p : poly),
 In p (redacc L1 L2) -> cb (L1 ++ L2) p.
Proof.
intros L1; elim L1; auto.
simpl in |- *; auto.
simpl in |- *; unfold LetP in |- *; intros a l H' L2 p.
case (zerop_dec (nf (l ++ L2) a)).
intros H'0 H'1.
apply cb_incl with (L1 := l ++ L2); auto.
simpl in |- *.
intros H'0 H'1; case H'1;
 [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ];
 auto.
apply cb_trans with (p := nf (l ++ L2) a); auto.
apply cb_incl with (L1 := l ++ nf (l ++ L2) a :: L2); auto.
apply incl_app; auto with datatypes.
Qed.

Theorem red_cb : forall (L : list poly) (p : poly), In p (red L) -> cb L p.
Proof.
unfold red in |- *.
intros L p H'.
generalize (redacc_cb L nil); simpl in |- *; auto.
rewrite <- app_nil_end; auto.
Qed.

Theorem cb_redacc :
 forall (L1 L2 : list poly) (p : poly), In p L1 -> cb (redacc L1 L2 ++ L2) p.
Proof.
intros L1; elim L1; simpl in |- *; auto.
intros L2 p H'; elim H'; auto.
unfold LetP in |- *.
intros a l H' L2 p H'0; case H'0;
 [ intros H'1; rewrite H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
case (zerop_dec (nf (l ++ L2) p)); auto.
intros H'0.
apply cb_comp with (L1 := l ++ L2); auto.
intros p0 H'2.
lapply (in_app_or l L2 p0); auto.
intros H'3; case H'3; auto.
intros H'0.
2: case (zerop_dec (nf (l ++ L2) a)); auto.
2: intros H'0.
2: apply
    cb_incl
     with (L1 := redacc l (nf (l ++ L2) a :: L2) ++ nf (l ++ L2) a :: L2);
    auto with datatypes.
apply cb_compo with (L1 := nf (l ++ L2) p :: l ++ L2); simpl in |- *; auto.
intros q H'2; case H'2;
 [ intros H'3; rewrite <- H'3; clear H'2 | intros H'3; clear H'2 ];
 auto with datatypes.
case (in_app_or l L2 q H'3); auto with datatypes.
intros H'2.
apply
 cb_incl with (L1 := redacc l (nf (l ++ L2) p :: L2) ++ nf (l ++ L2) p :: L2);
 auto with datatypes.
Qed.

Theorem cb_red : forall (L : list poly) (p : poly), In p L -> cb (red L) p.
Proof.
intros L p H'.
lapply (cb_redacc L nil p); [ intros H'3; generalize H'3 | idtac ];
 simpl in |- *; auto.
rewrite <- app_nil_end; auto.
Qed.

Theorem cb_red_cb1 :
 forall (p : poly) (L : list poly), cb L p -> cb (red L) p.
Proof.
intros p L H'.
apply cb_compo with (L1 := L); auto.
intros q H'0.
apply cb_red; auto.
Qed.

Theorem cb_red_cb2 :
 forall (p : poly) (L : list poly), cb (red L) p -> cb L p.
Proof.
intros p L H'.
apply cb_compo with (L1 := red L); auto.
intros q H'0.
apply red_cb; auto.
Qed.

Hypothesis
  nf_div_zero1 :
    forall (p : poly) (L : list poly),
    ~ zerop p ->
    zerop (nf L p) -> ex (fun q : poly => In q L /\ divp p q /\ ~ zerop q).

Theorem redacc_divp :
 forall (L1 L2 : list poly) (p : poly),
 ~ zerop p ->
 In p (L1 ++ L2) ->
 exists q : poly, In q (redacc L1 L2 ++ L2) /\ divp p q /\ ~ zerop q.
Proof.
intros L1; elim L1; simpl in |- *; auto.
intros L2 p H' H'0; exists p; split; auto.
unfold LetP in |- *.
intros a l H' L2 p H'0 H'1; case H'1;
 [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ];
 auto.
case (zerop_dec (nf (l ++ L2) a)); simpl in |- *; auto.
intros Z1.
lapply (nf_div_zero1 a (l ++ L2));
 [ intros H'5; lapply H'5; [ intros H'6; clear H'5 | clear H'5 ] | idtac ];
 auto.
case H'6; intros q E; case E; intros H'3 H'4; case H'4; intros H'5 H'7;
 clear H'4 E H'6.
lapply (H' L2 q);
 [ intros H'8; lapply H'8; [ intros H'9; clear H'8 | clear H'8 ] | idtac ];
 auto.
case H'9; intros q0 E; case E; intros H'4 H'6; case H'6; intros H'8 H'10;
 clear H'6 E H'9.
exists q0; split; [ idtac | split ]; auto.
apply divp_trans with (y := q); auto.
rewrite H'2; auto.
intros Z1.
lapply (nf_div a (l ++ L2));
 [ intros H'5; lapply H'5; [ intros H'6; clear H'5 | clear H'5 ] | idtac ];
 auto.
case H'6; intros q E; case E; intros H'3 H'4; case H'4; intros H'5 H'7;
 clear H'4 E H'6.
simpl in H'3.
case H'3; [ intros H'4; clear H'3 | intros H'4; clear H'3 ].
exists q; split; [ idtac | split ]; auto.
lapply (H' (nf (l ++ L2) a :: L2) q);
 [ intros H'8; lapply H'8; [ intros H'9; clear H'8 | clear H'8 ] | idtac ];
 auto.
case H'9; intros q0 E; case E; intros H'3 H'6; case H'6; intros H'8 H'10;
 clear H'6 E H'9.
exists q0; split; [ idtac | split ]; auto.
case
 (in_app_or (redacc l (nf (l ++ L2) a :: L2)) (nf (l ++ L2) a :: L2) q0 H'3);
 auto.
simpl in |- *; auto.
intros H'6; case H'6; [ intros H'9; clear H'6 | intros H'9; clear H'6 ]; auto.
apply divp_trans with (y := q); auto.
case (in_app_or l L2 q H'4); auto with datatypes.
rewrite H'2; auto.
case (zerop_dec (nf (l ++ L2) a)); simpl in |- *; auto.
intros Z1.
case (in_app_or l L2 p H'2); auto.
intros H'3.
lapply (H' (nf (l ++ L2) a :: L2) p);
 [ intros H'6; lapply H'6; [ intros H'7; clear H'6 | clear H'6 ] | idtac ];
 auto.
case H'7; intros q E; case E; intros H'4 H'5; case H'5; intros H'6 H'8;
 clear H'5 E H'7.
exists q; split; auto.
case
 (in_app_or (redacc l (nf (l ++ L2) a :: L2)) (nf (l ++ L2) a :: L2) q H'4);
 auto.
simpl in |- *; auto.
intros H; case H; intros H1; auto.
intros H; exists p; split; [ right | idtac ]; auto.
Qed.

Theorem red_divp :
 forall (L : list poly) (p : poly),
 In p L ->
 ~ zerop p -> exists q : poly, In q (red L) /\ divp p q /\ ~ zerop q.
Proof.
intros L p H' H'0.
lapply (redacc_divp L nil p); auto.
simpl in |- *; auto.
rewrite <- app_nil_end; auto.
rewrite <- app_nil_end; auto.
Qed.

Theorem red_grobner : forall L : list poly, grobner L -> grobner (red L).
Proof.
intros L H'.
apply def_grobner; auto.
intros p H'0.
lapply (grobner_def L);
 [ intros H'2; lapply (H'2 p); [ intros H'4 | idtac ] | idtac ];
 auto.
case H'4; auto.
intros H'1; case H'1; intros q E; clear H'1.
right.
apply div_reduce with (L1 := L) (q := q); auto.
intros r1 H'1 H'3.
lapply (red_divp L r1);
 [ intros H'7; lapply H'7; [ intros H'8; clear H'7 | clear H'7 ] | idtac ];
 auto.
case H'8; intros q0 E0; case E0; intros H'5 H'6; case H'6; intros H'7 H'9;
 clear H'6 E0 H'8.
exists q0; split; auto.
apply cb_red_cb2; auto.
Qed.
End Reduce.


Require Import Iron.Language.SystemF.KiJudge.

(* Substitution of types in types preserves kinding. *)
Theorem subst_type_type_ix
 :  forall ix ke t1 k1 t2 k2
 ,  get ix ke = Some k2
 -> KIND ke t1 k1
 -> KIND (delete ix ke) t2 k2
 -> KIND (delete ix ke) (substTT ix t2 t1) k1.
Proof.
 intros. gen ix ke t2 k1 k2.
 induction t1; intros; simpl; inverts H0; eauto.

 Case "TVar".
  destruct k1. destruct k2.
  fbreak_nat_compare.
  SCase "n = ix".
   auto.

  SCase "n < ix".
   apply KIVar. rewrite <- H4.
   apply get_delete_above; auto.

  SCase "n > ix".
   apply KIVar. rewrite <- H4.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below. omega.

 Case "TForall".
  apply KIForall.
  rewrite delete_rewind.
  eapply IHt1; eauto.
   apply liftTT_weaken. auto.
Qed.

Theorem subst_type_type
 :  forall ke t1 k1 t2 k2
 ,  KIND (ke :> k2) t1 k1
 -> KIND ke         t2 k2
 -> KIND ke (substTT 0 t2 t1) k1.
Proof.
 intros.
 unfold substTT.
 assert (ke = delete 0 (ke :> k2)). auto. rewrite H1.
 eapply subst_type_type_ix; simpl; eauto.
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra Coq.Logic.ChoiceFacts MathClasses.interfaces.functors
  MathClasses.theory.categories MathClasses.categories.categories.

(* Axiom dependent_functional_choice: DependentFunctionalChoice. *)

Section object.
  Context {I: Type} (O: I → Type)
    `{∀ i, Arrows (O i)}
    `{∀ i (x y: O i), Equiv (x ⟶ y)}
    `{∀ i, CatId (O i)} `{∀ i, CatComp (O i)}
    `{∀ i, Category (O i)}.

  Definition Object := ∀ i, O i.
  Global Instance pa: Arrows Object := λ x y, ∀ i, x i ⟶ y i. (* todo: make nameless *)
  Global Instance: CatId Object := λ _ _, cat_id.
  Global Instance: CatComp Object := λ _ _ _ d e i, d i ◎ e i.
  Definition e (x y: Object): Equiv (x ⟶ y) := λ f g, ∀ i, f i = g i.
End object.

(* Avoid Coq trying to apply e to find arbitrary Equiv instances *)
Hint Extern 0 (Equiv (_ ⟶ _)) => eapply @e : typeclass_instances.

Section contents.
  Context {I: Type} (O: I → Type)
    `{∀ i, Arrows (O i)}
    `{∀ i (x y: O i), Equiv (x ⟶ y)}
    `{∀ i, CatId (O i)} `{∀ i, CatComp (O i)}
    `{∀ i, Category (O i)}.

  Global Instance: ∀ x y: Object O, Setoid (x ⟶ y) := _.

  Global Instance: Category (Object O).
  Proof with try reflexivity.
   constructor. apply _.
      intros ? ? ? x y E x' y' F i.
      change (x i ◎ x' i = y i ◎ y' i).
      rewrite (E i), (F i)...
     repeat intro. apply comp_assoc.
    repeat intro. apply id_l. (* todo: Use left_identity *)
   repeat intro. apply id_r.
  Qed.

  Let product_object := categories.object (Object O).

  Notation ith_obj i := (categories.object (O i)).

  Program Definition project i: categories.object (Object O) ⟶ ith_obj i :=
    @categories.arrow _ _ (λ d, d i) (λ _ _ a, a i) _.
  Next Obligation. Proof. (* functorial *)
   constructor; intros; try reflexivity; try apply _.
   constructor; try apply _.
   intros ? ? E. apply E.
  Qed.

  Section factors.

    Variables (C: categories.Object) (X: ∀ i, C ⟶ ith_obj i).

    Let ith_functor i := categories.Functor_inst _ _ (X i).
      (* todo: really necessary? *)

    Program Definition factor: C ⟶ product_object
      := @categories.arrow _ _ (λ (c: C) i, X i c) (λ (x y: C) (c: x ⟶ y) i, fmap (X i) c) _.
    Next Obligation. Proof with try reflexivity; intuition. (* functorial *)
     constructor; intros; try apply _.
       constructor; try apply _.
       intros ? ? E ?.
       change (fmap (X i) x = fmap (X i) y).
       rewrite E...
      intro. unfold fmap at 1. rewrite preserves_id... destruct X...
     intro. unfold fmap at 1. rewrite preserves_comp... destruct X...
    Qed. (* todo: those [destruct X]'s shouldn't be necessary *)
(*
    Lemma s: is_sole (λ h', ∀ i, X i = project i ◎ h') factor.
    Proof with try reflexivity; intuition.
     split.
      intro.
      exists (λ v, refl_arrows (X i v)).
      simpl. unfold compose. intros ? ? ?.
      rewrite right_identity, left_identity...
     intros alt alt_factors.
     generalize (dependent_functional_choice I _ _ alt_factors). clear alt_factors.
     unfold isoT in *.
     simpl.
     intros [x H4].
     unfold equiv.
     unfold categories.e.
     unfold compose in H4.
     set (P := λ v, prod (alt v ⟶ (λ i, (X i) v)) ((λ i, (X i) v) ⟶ alt v)).
     set (d := λ v, (λ i, snd (` (x i v)), λ i, fst (` (x i v))): P v).
     assert (∀ v, uncurry iso_arrows (d v)) as Q.
      split; simpl; intro.
       change (snd (` (x i v)) ◎ fst (` (x i v)) = cat_id).
       destruct (x i v) as [? []]...
      change (fst (` (x i v)) ◎ snd (` (x i v)) = cat_id).
      destruct (x i v) as [? []]...
     exists (λ v, exist (uncurry iso_arrows) _ (Q v)).
     intros p q r i.
     simpl.
     unfold comp.
     unfold CatComp_instance_0. (* todo: no! *)
     pose proof (H4 i p q r). clear H4.
     destruct (x i p) as [aa0 i0].
     destruct (x i q) as [a1a2 i1].
     simpl in *.
     unfold uncurry in *.
     unfold iso_arrows in *.
     destruct (categories.Functor_inst _ _ alt).
     unfold compose in x, aa0, a1a2.
     simpl in *.
     unfold fmap.
     match goal with
       |- appcontext [ categories.Fmap_inst _ ?cat ?alt ] => set (f:=categories.Fmap_inst _ cat alt) in |- *
     end.
     setoid_rewrite <- (left_identity (f p q r i ◎ fst aa0)).
     transitivity ((fst a1a2 ◎ snd a1a2) ◎ (f p q r i ◎ fst aa0)).
      apply comp_proper...
     apply transitivity with ((fst a1a2) ◎ (((snd a1a2) ◎ (categories.Fmap_inst _ _ alt p q r i)) ◎ (fst aa0))).
      repeat rewrite associativity...
     simpl.
     rewrite <- H5.
     repeat rewrite <- (associativity _ _).
     rewrite (proj2 i0), right_identity...
    Qed. (* WARNING: Uses DependentFunctionalChoice. (Todo: reflect.) *)
      (* todo: awful proof. clean up! *)
*)
  End factors.

  (* At the time of this writing (Coq trunk 12801), attempting to state the above in terms
  of the nice product-relates interfaces from theory/categories results in universe
  inconsistency errors that I have isolated and reported as Coq bug #2252. *)

  Global Instance mono (X Y: Object O): ∀ (a: X ⟶ Y), (∀ i, @Mono _ _ (H0 _) (H2 i) _ _ (a i)) → Mono a.
  Proof. firstorder. Qed. (* todo: why so ugly all of a sudden? *)

End contents.


(* Coq Implementations of the Kernel Perceptron, Budget Kernel Perceptron, and Description Kernel Perceptron*)
Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.

Require Import NArith.
Require Import List. Import ListNotations.
Require Import Extraction.

Require Import MLCert.axioms MLCert.float32 MLCert.learners MLCert.extraction_hs MLCert.monads.

Section KernelClassifier.
  Variable n : nat. (*the dimensionality*)
  Variable m : nat. (*#examples*)

  Definition Ak := ('I_m * float32_arr n)%type. (*examples*)
  Definition Bk := bool. (*labels*)
  Context {support_vectors} `{Foldable support_vectors ('I_m * float32_arr n * bool)}.
  Definition KernelParams := (support_vectors * float32_arr m)%type.

  Section predict.
    Open Scope f32_scope.
    Definition linear_kernel {n} (x y : float32_arr n) : float32 :=
      f32_dot x y.
    Definition quadratic_kernel (x y : float32_arr n) : float32 :=
      (f32_dot x y) ** 2.

    Definition kernel_predict (K : float32_arr n -> float32_arr n -> float32)
        (w : KernelParams) (x : Ak) : Bk :=
      let T := w.1 in
      foldable_foldM
        (fun xi_yi r =>
           let: ((i, xi), yi) := xi_yi in
           let: (j, xj) := x in
           let: wi := f32_get i w.2 in
           r + (float32_of_bool yi) * wi * (K xi xj))
        0 T > 0.
  End predict.
End KernelClassifier.

Section KernelClassifierBudget.
  Variable n : nat. (*the dimensionality*)
  Variable m : nat. (*#examples*)

  Variable sv : nat. (*#support vectors*)
  Variable K: float32_arr n -> float32_arr n -> float32.

  Definition Akb: Type := float32_arr n. (*examples*)
  Definition Bkb := bool. (*labels*)

  Definition bsupport_vector: Type := Akb * Bkb.
  Definition bsupport_vectors: Type := AxVec sv (float32 * (bsupport_vector)).
  Context `{Foldable bsupport_vectors (float32 * bsupport_vector)}.

  Section predict.
    Open Scope f32_scope.

    Definition kernel_predict_budget
               (w: bsupport_vectors)
               (x: Akb) : Bkb :=
      foldable_foldM
        (fun wi_xi r =>
           let: (wi, (xi, yi)) := wi_xi in
           r + (float32_of_bool yi) * wi * (K xi x))
        0 w > 0.
  End predict.
End KernelClassifierBudget.

Section KernelClassifierDes.
  Variable n : nat. (*the dimensionality*)
  Variable m : nat. (*#examples*)

  Variable des : nat. (*#support vectors*)
  Variable K: float32_arr n -> float32_arr n -> float32.

  Definition Akd: Type := float32_arr n. (*examples*)
  Definition Bkd := bool. (*labels*)

  Definition dsupport_vector: Type := Akd * Bkd.
  Definition dsupport_vectors: Type := AxVec des dsupport_vector.
  Definition dparams: Type := float32 * dsupport_vectors.
  Context `{F:Foldable dparams dsupport_vector}.
  Context `{F':Foldable dsupport_vectors dsupport_vector}.

  Section predict.
    Open Scope f32_scope.

    Definition kernel_predict_des
               (aw: dparams)
               (x: Akd) : Bkd :=
      let (a, w) := aw in
      foldable_foldM
        (fun wi_xi r =>
           let: (xi, yi) := wi_xi in
           r + (float32_of_bool yi) * (K xi x))
        0 w > 0.
  End predict.
End KernelClassifierDes.

Module KernelPerceptron.
  Section Learner.
    Variable n : nat. (*the dimensionality*)
    Variable m : nat. (*#examples*)
    Variable sv : nat. (*#support vectors*)
    Notation A := (Ak n m).
    Notation B := Bk.
    Context {support_vectors} `{F:Foldable support_vectors (A * B)}.
    Definition Params := @KernelParams m support_vectors.
    Variable K : float32_arr n -> float32_arr n -> float32.

    Record Hypers : Type := mkHypers { }.

    Open Scope f32_scope.

    Definition kernel_update
      (K : float32_arr n -> float32_arr n -> float32)
          (h:Hypers) (example_label:A*B) (p:Params) : Params :=
      let: ((i, example), label) := example_label in
      let: predicted_label := kernel_predict K p (i, example) in
      if Bool.eqb predicted_label label then p
      else (p.1, f32_upd i (f32_get i p.2 + 1) p.2).

    Definition Learner : Learner.t A B Hypers Params :=
      Learner.mk
        (fun _ => @kernel_predict n m support_vectors F K)
        (kernel_update K).
  End Learner.
End KernelPerceptron.

Module KernelPerceptronBudget.
  Section Learner.
    Variable n : nat. (*the dimensionality*)
    Variable m : nat. (*#examples*)
    Variable sv : nat. (*#support vectors - 1*)
    Notation A := (Akb n).
    Notation B := Bkb.
    Definition Params := bsupport_vectors n (S sv).
    Context `{F: Foldable Params (float32 * (A * B))}.
    Variable K : float32_arr n -> float32_arr n -> float32.
    Variable U : Params -> A*B -> Params.

    Record Hypers : Type := mkHypers { }.

    Open Scope f32_scope.
    Definition f32_arr_eq (x y : float32_arr n) : bool :=
      f32_fold2 true
        (fun a b z => if (f32_eq a b) then z else false)
        x y.

    Fixpoint nat_to_f32 (x : nat) : float32 :=
      match x with
      | O => f32_0
      | S x' => (nat_to_f32 x') + f32_1
      end.

    (*Is x in s?*)
    Definition existing (s : Params) (yj : A*B) : bool :=
      let: (j, y) := yj in
      foldable_foldM
        (fun wi_xi r =>
          let: (_, (x, l)) := wi_xi in
            (f32_arr_eq x j) || r)
        false s.

    Definition upd_weights (p: Params) (yj: A): Params :=
      AxVec_map
        (fun xi =>
          let: (wi, (x, li)) := xi in
          if f32_arr_eq x yj then (wi+1, (x, li))
          else xi)
        p.

    (*This function requires that the Params be initialized with (S sv) support vectors*)
    Definition add_new (p: Params) (yj: A*B): Params :=
      AxVec_cons (1, yj) (AxVec_init p).

    Definition budget_update (p: Params) (yj: A*B): Params :=
      if existing p yj then upd_weights p yj.1
      else add_new p yj.

    Definition kernel_update
      (K : float32_arr n -> float32_arr n -> float32)
          (h:Hypers) (example_label:A*B) (p:Params) : Params :=
      let: (example, label) := example_label in
      let: predicted_label := kernel_predict_budget K p example in
      if Bool.eqb predicted_label label then p
      else (U p example_label).

    Definition Learner : Learner.t A B Hypers Params :=
      Learner.mk
        (fun _ => @kernel_predict_budget n (S sv) K F)
        (kernel_update K).
  End Learner.
End KernelPerceptronBudget.

Module KernelPerceptronDes.
  Section Learner.
    Variable n : nat. (*the dimensionality*)
    Variable m : nat. (*#examples*)
    Variable des : nat. (*#support vectors - 1*)
    Notation A := (Akd n).
    Notation B := Bkd.
    Definition DSup := dsupport_vectors n (S des).

    Definition Params := (float32 * DSup)%type.
    Context `{F: Foldable Params (A * B)}.
    Context `{F': Foldable DSup (A * B)}.
    Variable K : float32_arr n -> float32_arr n -> float32.

    Record Hypers : Type := mkHypers { alpha : float32; }.

    Open Scope f32_scope.

    Definition des_update (ap: Params) (yj: A*B): Params :=
      let (a, p) := ap in
      ((f32_add f32_1 a), (AxVec_cons yj) (AxVec_init p)).

    Definition kernel_update
      (K : float32_arr n -> float32_arr n -> float32)
          (h:Hypers) (example_label:A*B) (ap:Params) : Params :=
      let: (example, label) := example_label in
      let: (a, p) := ap in
      let: predicted_label := kernel_predict_des K ap example in
      if Bool.eqb predicted_label label then ap
      else if f32_eq a (alpha h) then ap
           else des_update ap example_label.

    Definition Learner : Learner.t A B Hypers Params :=
      Learner.mk
        (fun _ => @kernel_predict_des n (S des) K F')
        (@kernel_update K).
  End Learner.
End KernelPerceptronDes.

Require Import Reals Fourier.
Require Import OUVerT.bigops OUVerT.dist OUVerT.chernoff OUVerT.learning.

Section KernelPerceptronGeneralization.
  Variable n : nat. (*The dimensionality*)
  Variable m : nat. (*#examples*)
  Variable sv : nat.
  Notation A := [finType of 'I_m * float32_arr_finType n].
  Notation B := bool_finType.
  Variable d : A * B -> R.
  Variable d_dist : big_sum (enum [finType of A * B]) d = 1.
  Variable d_nonneg : forall x, 0 <= d x.

  Variable m_gt0 : (0 < m)%nat.

  Variable epochs : nat.

  Variable hypers : KernelPerceptron.Hypers.
  Variable K : float32_arr n -> float32_arr n -> float32.

  (*Represent the training set as a one-dimensional (flattened) float array.*)
  Definition KPsupport_vectors := float32_arr_finType (m*n).
  Context {H: Foldable KPsupport_vectors (A * B)}.

  Notation Params := [finType of {:KPsupport_vectors * float32_arr_finType m}].
  Definition Kaccuracy :=
    @accuracy01 A _ m Params (Learner.predict
      (@KernelPerceptron.Learner n m KPsupport_vectors H K) hypers).

  Lemma Kcard_Params : INR #|Params| = 2 ^ (m*n*32 + m*32).
  Proof.
    rewrite /training_set card_prod !float32_arr_card.
    rewrite mult_INR !pow_INR /= pow_add //.
  Qed.

  Variables
    (not_perfectly_learnable :
       forall p : Params, 0 < expVal d m_gt0 Kaccuracy p < 1)
    (mut_ind : forall p : Params, mutual_independence d (Kaccuracy p)).

  Lemma Kperceptron_bound eps (eps_gt0 : 0 < eps) init :
    @main A B Params KernelPerceptron.Hypers
      (@KernelPerceptron.Learner n m KPsupport_vectors H K)
      hypers m m_gt0 epochs d eps init (fun _ => 1) <=
    2^(m*n*32 + m*32) * exp (-2%R * eps^2 * mR m).
  Proof.
    rewrite -Kcard_Params.
    apply: Rle_trans; first by apply: main_bound.
    apply: Rle_refl.
  Qed.
End KernelPerceptronGeneralization.

Section KernelPerceptronGeneralizationBudget.
  Variable n : nat. (*The dimensionality*)
  Variable m : nat. (*#examples*)
  Variable sv : nat.
  Notation A := (float32_arr_finType n).
  Notation B := bool_finType.
  Variable d : A * B -> R.
  Variable d_dist : big_sum (enum [finType of A * B]) d = 1.
  Variable d_nonneg : forall x, 0 <= d x.

  Variable m_gt0 : (0 < m)%nat.

  Variable epochs : nat.

  Variable hypers : KernelPerceptronBudget.Hypers.
  Variable K : float32_arr n -> float32_arr n -> float32.

  Notation bsupport_vector := [finType of A * B].
  Notation Params := (AxVec_finType (S sv) [finType of (float32_finType * bsupport_vector)]).

  Context `{F : Foldable (bsupport_vectors n (S sv)) (float32 * bsupport_vector)}.
  Variable U : bsupport_vectors n (S sv) -> A * B -> bsupport_vectors n (S sv).
  Definition KaccuracyBudget :=
    @accuracy01 A _ m Params (Learner.predict
      (@KernelPerceptronBudget.Learner n sv F K U) hypers).

  Lemma Kcard_Params_Budget_size : INR #|Params| =
    INR (((2 ^ 32) * ((2 ^ (n * 32)) * 2)) ^ (S (sv))).

  Proof.
    unfold Params. unfold bsupport_vector. unfold Akb.
    rewrite (@AxVec_card_gen (2 ^ 32 * (2 ^ (n * 32) * 2)) (S sv)).
    - rewrite pow_INR. auto.
    - rewrite card_prod. rewrite float32_card.
    rewrite card_prod.
    rewrite float32_arr_card. rewrite card_bool. auto.
    Qed.

  Require Import Omega.
  Lemma Kcard_Params_Budget_helper : INR (((2 ^ 32) * ((2 ^ (n * 32)) * 2)) ^ (S (sv)))
  = INR 2^((32*(S sv) + ((1 + n * 32)*(S sv)))).
  Proof.
  assert (H: muln (Nat.pow 2 (muln n 32)) 2 = muln 2 (Nat.pow 2 (muln n 32))%coq_nat).
    { rewrite <- multE. omega. }
  rewrite ->  H.
  assert (J: muln 2 (Nat.pow 2 (muln n 32)) = Nat.pow 2 (1 + (muln n 32))).
    { rewrite Nat.pow_succ_r'. auto. }
  rewrite -> J.
  rewrite <- Nat.pow_add_r. rewrite <- Nat.pow_mul_r.
  rewrite pow_INR. rewrite Nat.mul_add_distr_r. auto.
  Qed.

  Lemma Kcard_Params_Budget : INR #| Params | =
      INR 2^((32*(S sv) + ((1 + n * 32)*(S sv)))).
  Proof.
  rewrite Kcard_Params_Budget_size.
  rewrite Kcard_Params_Budget_helper.
  auto.
  Qed.

  Variables
    (not_perfectly_learnable :
       forall p : Params, 0 < expVal d m_gt0 KaccuracyBudget p < 1)
    (mut_ind : forall p : Params, mutual_independence d (KaccuracyBudget p)).

  Lemma Kperceptron_bound_budget eps (eps_gt0 : 0 < eps) init :
    @main A B Params KernelPerceptronBudget.Hypers
      (@KernelPerceptronBudget.Learner n sv F K U)
      hypers m m_gt0 epochs d eps init (fun _ => 1) <=
    INR 2^((32*(S sv) + ((1 + n * 32)*(S sv)))) * exp (-2%R * eps^2 * mR m).
  Proof.
    rewrite -Kcard_Params_Budget.
    apply: Rle_trans; first by apply: main_bound.
    apply: Rle_refl.
  Qed.
End KernelPerceptronGeneralizationBudget.

Section KernelPerceptronGeneralizationDes.
  Variable n : nat. (*The dimensionality*)
  Variable m : nat. (*#examples*)
  Variable des : nat.
  Notation A := (float32_arr_finType n).
  Notation B := bool_finType.
  Variable d : A * B -> R.
  Variable d_dist : big_sum (enum [finType of A * B]) d = 1.
  Variable d_nonneg : forall x, 0 <= d x.

  Variable m_gt0 : (0 < m)%nat.

  Variable epochs : nat.

  Variable hypers : KernelPerceptronDes.Hypers.
  Variable K : float32_arr n -> float32_arr n -> float32.

  Notation dsupport_vector := [finType of A * B].
  Notation Params := [finType of float32_finType *
    (AxVec_finType (S des) dsupport_vector)].

  Context `{F : Foldable (dsupport_vectors n (S des)) dsupport_vector}.
  Definition KaccuracyDes :=
    @accuracy01 A _ m Params (Learner.predict
      (@KernelPerceptronDes.Learner n des F K) hypers).

  Lemma Kcard_Params_Des_size : INR #|Params| =
    INR (2 ^ 32 * ((2 ^ (n * 32)) * 2) ^ (S (des))).

  Proof.
    unfold Params. rewrite card_prod. rewrite float32_card. unfold dsupport_vector. unfold Akb.
    rewrite (@AxVec_card_gen (2 ^ (n * 32) * 2) (S des)).
    -  auto.
    - rewrite card_prod.
    rewrite float32_arr_card. rewrite card_bool. auto.
    Qed.

  Require Import Omega.
  Lemma Kcard_Params_Des_helper : INR (2 ^ 32 * ((2 ^ (n * 32)) * 2) ^ (S (des)))
  = INR 2 ^ (32 + (1 + n * 32) * (S des)).
  Proof.
  assert (H: muln (Nat.pow 2 (muln n 32)) 2 = muln 2 (Nat.pow 2 (muln n 32))%coq_nat).
    { rewrite <- multE. omega. }
  rewrite ->  H.
  assert (J: muln 2 (Nat.pow 2 (muln n 32)) = Nat.pow 2 (1 + (muln n 32))).
    { rewrite Nat.pow_succ_r'. auto. }
  rewrite -> J.
  rewrite <- Nat.pow_mul_r. rewrite <- Nat.pow_add_r.
  rewrite pow_INR. auto.
  Qed.

  Lemma Kcard_Params_Des : INR #| Params | =
      INR 2 ^ (32 + (1 + n * 32) * (S des)).
  Proof.
  rewrite Kcard_Params_Des_size.
  rewrite Kcard_Params_Des_helper.
  auto.
  Qed.

  Variables
    (not_perfectly_learnable :
       forall p : Params, 0 < expVal d m_gt0 KaccuracyDes p < 1)
    (mut_ind : forall p : Params, mutual_independence d (KaccuracyDes p)).

  Lemma Kperceptron_bound_Des eps (eps_gt0 : 0 < eps) init :
    @main A B Params KernelPerceptronDes.Hypers
      (@KernelPerceptronDes.Learner n des F K)
      hypers m m_gt0 epochs d eps init (fun _ => 1) <=
    INR 2 ^ (32 + (1 + n * 32) * (S des)) * exp (-2%R * eps^2 * mR m).
  Proof.
    rewrite -Kcard_Params_Des.
    apply: Rle_trans; first by apply: main_bound.
    apply: Rle_refl.
  Qed.
End KernelPerceptronGeneralizationDes.

Section KPerceptronExtraction.
  Variable n : nat. (*The dimensionality*)
  Variable m : nat. (*#examples*)
  Notation A := (Ak n m).
  Notation B := Bk.
  Variable d : A * B -> R.

  (*Variable m : nat. (*The number of training samples*)*)
  Variable epochs : nat.

  Notation Params := (KernelParams m)%type.

  Variable hypers : KernelPerceptron.Hypers.
  Variable K : float32_arr n -> float32_arr n -> float32.

  Notation Q := (A * B)%type.
  Definition kperceptron (r:Type) :=
    @extractible_main
      A B Params KernelPerceptron.Hypers
      (@KernelPerceptron.Learner n m (seq.seq Q) (list_Foldable Q) K)
      hypers
      epochs
      (seq.seq Q)
      (list_Foldable Q)
      r
      (fun T => ret T).
End KPerceptronExtraction.

Extraction Language Haskell.
Extraction "hs/KernelPerceptron/KPerceptron.hs" kperceptron linear_kernel quadratic_kernel.
Extraction "hs/KernelPerceptron/timing_drivers/KPerceptron.hs" kperceptron linear_kernel quadratic_kernel.

Section KPerceptronExtractionBudget.
  Variable n : nat. (*The dimensionality*)
  Variable m : nat. (*#examples*)
  Variable sv : nat.
  Notation A := (Akb n).
  Notation B := Bkb.
  Variable d : A * B -> R.

  (*Variable m : nat. (*The number of training samples*)*)
  Variable epochs : nat.

  Notation Params := (KernelPerceptronBudget.Params n sv)%type.

  Variable hypers : KernelPerceptronBudget.Hypers.
  Variable K : float32_arr n -> float32_arr n -> float32.

  Notation Q := (A * B)%type.
  Variable U : (@KernelPerceptronBudget.Params n sv) ->
     Q -> (@KernelPerceptronBudget.Params n sv).

  Context `{F : Foldable Params (float32 * bsupport_vector n)}.
  Definition kperceptronbudget (r:Type) :=
    @extractible_main
      A B Params KernelPerceptronBudget.Hypers
      (@KernelPerceptronBudget.Learner n sv F K U)
      hypers
      epochs
      (seq.seq Q)
      (list_Foldable Q)
      r
      (fun T => ret T).
End KPerceptronExtractionBudget.

Extraction Language Haskell.
Extraction "hs/KernelPerceptron/KPerceptronBudget.hs" kperceptronbudget linear_kernel quadratic_kernel KernelPerceptronBudget.budget_update.
Extraction "hs/KernelPerceptron/timing_drivers/KPerceptronBudget.hs" kperceptronbudget linear_kernel quadratic_kernel KernelPerceptronBudget.budget_update.

Section KPerceptronExtractionDes.
  Variable n : nat. (*The dimensionality*)
  Variable m : nat. (*#examples*)
  Variable des : nat.
  Notation A := (Akd n).
  Notation B := Bkd.
  Variable d : A * B -> R.

  (*Variable m : nat. (*The number of training samples*)*)
  Variable epochs : nat.

  Notation Params := (KernelPerceptronDes.Params n des)%type.

  Variable hypers : KernelPerceptronDes.Hypers.
  Variable K : float32_arr n -> float32_arr n -> float32.

  Notation Q := (A * B)%type.

  Context `{F : Foldable (KernelPerceptronDes.DSup n des) (dsupport_vector n)}.
  Definition kperceptrondes (r:Type) :=
    @extractible_main
      A B Params KernelPerceptronDes.Hypers
      (@KernelPerceptronDes.Learner n des F K)
      hypers
      epochs
      (seq.seq Q)
      (list_Foldable Q)
      r
      (fun T => ret T).
End KPerceptronExtractionDes.

Extraction Language Haskell.
Extraction "hs/KernelPerceptron/KPerceptronDes.hs" kperceptrondes linear_kernel quadratic_kernel.
Extraction "hs/KernelPerceptron/timing_drivers/KPerceptronDes.hs" kperceptrondes linear_kernel quadratic_kernel.


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism Terminal Dual Initial.
Require Import ProofIrrelevance.
Require Import FunctionalExtensionality.

Set Universe Polymorphism.

(** Binary Products *)

Class Product (C: Category) (A B prod: @obj C): Type :=
{
  pi1       : @arrow C A prod;
  pi2       : @arrow C B prod;
  prod_f    : forall (Z: @obj C) (f: @arrow C A Z) (g: @arrow C B Z), @arrow C prod Z;
  prod_f_c1 : forall (Z: @obj C) (f: @arrow C A Z) (g: @arrow C B Z), f = pi1 o prod_f Z f g;
  prod_f_c2 : forall (Z: @obj C) (f: @arrow C A Z) (g: @arrow C B Z), g = pi2 o prod_f Z f g;
  prod_f_uni: forall (Z: @obj C) (f: @arrow C A Z) (g: @arrow C B Z) (p: @arrow C prod Z),
              f = pi1 o p -> g = pi2 o p-> (prod_f Z f g) = p
}.

Lemma prod_f_id: forall (C: Category) (A B AxB: @obj C) (p: Product C A B AxB) ,
  @prod_f C A B AxB p AxB (@pi1 C A B AxB p) (@pi2 C A B AxB p) = identity (AxB).
Proof. intros C A B AxB (pi1, pi2, prod, ob1, ob2, ob3).
       simpl in *.
       specialize (ob3 AxB pi1 pi2 (identity AxB)).
       apply ob3.
       - rewrite f_identity. reflexivity.
       - rewrite f_identity. reflexivity.
Qed.

Class hasProducts (C: Category): Type :=
{
  pobj: forall (A B: @obj C), @obj C;
  hasp: forall (A B: @obj C), Product C A B (pobj A B)
}.

Lemma prod_assoc_iso: forall (C: Category) (hp: hasProducts C) (X Y Z: @obj C),
  Isomorphic (@pobj C hp X (@pobj C hp Y Z)) (@pobj C hp (@pobj C hp X Y) Z).
Proof. intros C (pobj, hasp) X Y Z.
       simpl in *.
       destruct (hasp (pobj X Y) Z) as (pi1, pi2, p, f, g, uniqp).
       destruct (hasp X (pobj Y Z)) as (pi3, pi4, q, h, i, uniqq).
       unshelve econstructor.
       - apply p.
         + destruct (hasp X Y) as (pi5, pi6, r, l, m, uniqr).
           destruct (hasp Y Z) as (pi7, pi8, k, u, v, uniqk).
           apply r.
           ++ exact (pi3).
           ++ exact (pi7 o pi4).
         + destruct (hasp Y Z) as (pi7, pi8, k, u, v, uniqk).
           exact (pi8 o pi4).
       - unshelve econstructor.
         + apply q.
           ++ destruct (hasp X Y) as (pi5, pi6, r, l, m, uniqr).
              exact (pi5 o pi1).
           ++ destruct (hasp X Y) as (pi5, pi6, r, l, m, uniqr).
              destruct (hasp Y Z) as (pi7, pi8, k, u, v, uniqk).
              apply k.
              * exact (pi6 o pi1).
              * exact pi2.
         + simpl.
           destruct (hasp X Y) as (pi5, pi6, r, l, m, uniqr).
           destruct (hasp Y Z) as (pi7, pi8, k, u, v, uniqk).
           simpl in *.
           pose proof uniqp as uuniqp.
           specialize (uniqp (pobj (pobj X Y) Z) pi1 pi2
                             (p (pobj X (pobj Y Z)) (r (pobj X (pobj Y Z)) pi3 (pi7 o pi4)) (pi8 o pi4)
                              o q (pobj (pobj X Y) Z) (pi5 o pi1) (k (pobj (pobj X Y) Z) (pi6 o pi1) pi2))).
           specialize (uuniqp (pobj (pobj X Y) Z) pi1 pi2 (identity (pobj (pobj X Y) Z))).
           rewrite <- uniqp, uuniqp.
           reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite assoc.
             rewrite <- f.
             pose proof uniqr as uuniqr.
             specialize (uniqr (pobj (pobj X Y) Z) (pi5 o pi1) (pi6 o pi1)
               (r (pobj X (pobj Y Z)) pi3 (pi7 o pi4) o q (pobj (pobj X Y) Z)
               (pi5 o pi1) (k (pobj (pobj X Y) Z) (pi6 o pi1) pi2)) ).
             specialize (uuniqr (pobj (pobj X Y) Z)  (pi5 o pi1) (pi6 o pi1) pi1 ).
             rewrite <- uniqr, uuniqr.
             reflexivity.
             ** reflexivity.
             ** reflexivity.
             ** rewrite assoc.
                rewrite <- l.
                rewrite <- h.
                reflexivity.
             ** rewrite assoc.
                rewrite <- m.
                rewrite <- assoc.
                rewrite <- i.
                rewrite <- u.
                reflexivity.
           * rewrite assoc.
             rewrite <- g.
             rewrite <- assoc.
             rewrite <- i.
             rewrite <- v.
             reflexivity.
         + destruct (hasp X Y) as (pi5, pi6, r, l, m, uniqr).
           destruct (hasp Y Z) as (pi7, pi8, k, u, v, uniqk).
           simpl in *.
           pose proof uniqq as uuniqq.
           specialize (uniqq (pobj X (pobj Y Z)) pi3 pi4
              (q (pobj (pobj X Y) Z) (pi5 o pi1) (k (pobj (pobj X Y) Z) (pi6 o pi1) pi2)
               o p (pobj X (pobj Y Z)) (r (pobj X (pobj Y Z)) pi3 (pi7 o pi4)) (pi8 o pi4))).
           specialize (uuniqq (pobj X (pobj Y Z)) pi3 pi4 (identity (pobj X (pobj Y Z)))).
           rewrite <- uniqq, uuniqq.
           reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite assoc.
             rewrite <- h.
             rewrite <- assoc.
             rewrite <- f.
             rewrite <- l.
             reflexivity.
           * rewrite assoc.
             rewrite <- i.
             pose proof uniqk as uuniqk.
             specialize (uniqk (pobj X (pobj Y Z)) (pi7 o pi4) (pi8 o pi4)
               (k (pobj (pobj X Y) Z) (pi6 o pi1) pi2 o p (pobj X (pobj Y Z))
               (r (pobj X (pobj Y Z)) pi3 (pi7 o pi4)) (pi8 o pi4))).
             specialize (uuniqk (pobj X (pobj Y Z)) (pi7 o pi4) (pi8 o pi4) pi4).
             rewrite <- uniqk, uuniqk.
             reflexivity.
             ** reflexivity.
             ** reflexivity.
             ** rewrite assoc.
                rewrite <- u.
                rewrite <- assoc.
                rewrite <- f.
                rewrite <- m.
                reflexivity.
             ** rewrite assoc.
                rewrite <- v.
                rewrite <- g.
                reflexivity.
Qed.

Lemma prod_comm_iso: forall (C: Category) (hp: hasProducts C) (X Y: @obj C),
  Isomorphic (@pobj C hp X Y) (@pobj C hp Y X).
Proof. intros C (pobj, hasp) X Y .
       simpl in *.
       destruct (hasp X Y) as (pi1, pi2, p, pax1, pax2, uniqp).
       destruct (hasp Y X) as (pi3, pi4, q, qax1, qax2, uniqq).
       unshelve econstructor.
       - exact (q (pobj X Y) pi2 pi1).
       - unshelve econstructor.
         + exact (p (pobj Y X) pi4 pi3).
         + pose proof uniqq as uuniqq.
           specialize (uniqq (pobj Y X) pi3 pi4 (q (pobj X Y) pi2 pi1 o p (pobj Y X) pi4 pi3)).
           specialize (uuniqq (pobj Y X) pi3 pi4 (identity (pobj Y X))).
           rewrite <- uniqq, uuniqq.
           reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite assoc.
             rewrite <- (qax1 _ pi2 pi1).
             rewrite <- (pax2 _ pi4 pi3).
             reflexivity.
           * rewrite assoc.
             rewrite <- (qax2 _ pi2 pi1).
             rewrite <- (pax1 _ pi4 pi3).
             reflexivity.
         + pose proof uniqp as uuniqp.
           specialize (uniqp (pobj X Y) pi1 pi2 (p (pobj Y X) pi4 pi3 o q (pobj X Y) pi2 pi1)).
           specialize (uuniqp (pobj X Y) pi1 pi2 (identity (pobj X Y))).
           rewrite <- uniqp, uuniqp.
           reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite assoc.
             rewrite <- (pax1 _ pi4 pi3).
             rewrite <- (qax2 _ pi2 pi1).
             reflexivity.
           * rewrite assoc.
             rewrite <- (pax2 _ pi4 pi3).
             rewrite <- (qax1 _ pi2 pi1).
             reflexivity.
Qed.

Lemma prod_term_iso_l: forall (C: Category) (hp: hasProducts C) (ht: hasTerminal C) (X: @obj C),
  Isomorphic (@pobj C hp X (@tobj C ht)) X.
Proof. intros C (pobj, hasp) (tobj, (f, funiq)) X.
       simpl in *.
       destruct (hasp X tobj) as (pi1, pi2, p, pax1, pax2, uniqp).
       unshelve econstructor.
       - exact pi1.
       - unshelve econstructor.
         + exact (p X (identity X) (f X)).
         + rewrite <- (pax1 _ (identity X) (f X)).
           reflexivity.
         + pose proof uniqp as uuniqp.
           specialize (uniqp (pobj X tobj) pi1 pi2 (p X (identity X) (f X) o pi1)).
           specialize (uuniqp (pobj X tobj) pi1 pi2 (identity (pobj X tobj))).
           rewrite <- uniqp, uuniqp.
           reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite assoc.
             rewrite <- (pax1 _ (identity X) (f X)).
             rewrite identity_f.
             reflexivity.
           * rewrite assoc.
             rewrite <- (pax2 _ (identity X) (f X)).
             apply funiq.
Qed.

Lemma prod_term_iso_r: forall (C: Category) (hp: hasProducts C) (ht: hasTerminal C) (X: @obj C),
  Isomorphic (@pobj C hp (@tobj C ht) X) X.
Proof. intros C (pobj, hasp) (tobj, (f, funiq)) X.
       simpl in *.
       specialize (prod_comm_iso C); intro I.

       destruct (hasp tobj X) as (pi1, pi2, p, pax1, pax2, uniqp).
       unshelve econstructor.
       - exact pi2.
       - unshelve econstructor.
         + exact (p X (f X) (identity X)).
         + rewrite <- (pax2 _ (f X) (identity X)).
           reflexivity.
         + pose proof uniqp as uuniqp.
           specialize (uniqp (pobj tobj X) pi1 pi2 (p X (f X) (identity X) o pi2 )).
           specialize (uuniqp (pobj tobj X) pi1 pi2 (identity (pobj tobj X))).
           rewrite <- uniqp, uuniqp.
           reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite f_identity.
             reflexivity.
           * rewrite assoc.
             rewrite <- (pax1 _ (f X) (identity X)).
             apply funiq.
           * rewrite assoc.
             rewrite <- (pax2 _ (f X) (identity X)).
             rewrite identity_f.
             reflexivity.
Qed.

Class PCatObj (C: Category) (A B: @obj C) : Type :=
{
   Zob: @obj C;
   Zob_ax: (@arrow C A Zob * @arrow C B Zob)%type
}.

Require Import JMeq.

Lemma PCatObjEq (C: Category) (A B: @obj C) (x y: PCatObj C A B):
  @Zob C A B x = @Zob C A B  y ->
  JMeq (fst (@Zob_ax C A B x)) (fst (@Zob_ax C A B y)) ->
  JMeq (snd (@Zob_ax C A B x)) (snd (@Zob_ax C A B y)) -> x = y.
Proof. destruct x as (Z1, (f1, g1)).
       destruct y as (Z2, (f2, g2)).
       simpl.
       intros H1 H2 H3.
       subst. easy.
Qed.

Class PCatArrow (C: Category) (A B: @obj C) (x y: PCatObj C A B) : Type :=
{
   fgarr    : @arrow C (@Zob C A B y) (@Zob C A B x);
   fgarr_ax1: fst (@Zob_ax C A B x) = fst (@Zob_ax C A B y) o fgarr;
   fgarr_ax2: snd (@Zob_ax C A B x) = snd (@Zob_ax C A B y) o fgarr;
}.

Lemma PCatArrowEq (C: Category) (A B: @obj C) (x y: PCatObj C A B) (f g: PCatArrow C A B x y):
 @fgarr C A B x y f = @fgarr C A B x y g -> f = g.
Proof. destruct x as (Z1, (f1, g1)).
       destruct y as (Z2, (f2, g2)).
       destruct f as (f, fax1, fax2).
       destruct g as (g, gax1, gax2).
       simpl in *. intro H.
       subst.
       f_equal.
       specialize (UIP_refl _ _ gax1); intros. rewrite H. reflexivity.
       specialize (UIP_refl _ _ gax2); intros. rewrite H. reflexivity.
Qed.

Definition PCat (C: Category) (A B: @obj C): Category.
Proof. unshelve econstructor.
       - exact (PCatObj C A B).
       - intros f g. exact (PCatArrow C A B g f).
       - intros (Z, (f1, g1)). simpl in *.
         unshelve econstructor.
         + simpl. exact (@identity C Z).
         + simpl. rewrite !f_identity. reflexivity.
         + simpl. rewrite !f_identity. reflexivity.
       - intros (Z1, (f1, g1)) (Z2, (f2, g2)) (Z3, (f3, g3))
         (h1, h1eq1, h1eq2) (h2, h2eq1, h2eq2).
         unshelve econstructor.
         + exact (h1 o h2).
         + simpl in *. rewrite assoc.
           rewrite <- h1eq1, <- h2eq1. reflexivity.
         + simpl in *. rewrite assoc. rewrite <- h1eq2, <- h2eq2. reflexivity.
       - repeat intro. now subst.
       - intros a b c d F G H. apply PCatArrowEq.
         destruct a as (Z1, (f1, g1)).
         destruct b as (Z2, (f2, g2)).
         destruct c as (Z3, (f3, g3)).
         destruct d as (Z4, (f4, g4)).
         destruct F as (h1, h1eq1, h1eq2).
         destruct G as (h2, h2eq1, h2eq2).
         destruct H as (h3, h3eq1, h3eq2).
         simpl. rewrite assoc. reflexivity.
       - intros a b F. apply PCatArrowEq.
         destruct a as (Z1, (f1, g1)).
         destruct b as (Z2, (f2, g2)).
         destruct F as (h1, h1eq1, h1eq2).
         simpl. rewrite identity_f. reflexivity.
       - intros a b F. apply PCatArrowEq.
         destruct a as (Z1, (f1, g1)).
         destruct b as (Z2, (f2, g2)).
         destruct F as (h1, h1eq1, h1eq2).
         simpl. rewrite f_identity. reflexivity.
Defined.

Definition terminalPCatObj (C: Category) (A B AxB: @obj C) (p: Product C A B AxB): PCatObj C A B.
Proof. destruct p as (pi1, pi2, h, hax1, hax2, huni).
       unshelve econstructor.
       - exact AxB.
       - exact (pi1, pi2).
Defined.

Definition tPCatObj (C: Category) (A B AxB: @obj C) (p: Product C A B AxB): Terminal (PCat C A B) (terminalPCatObj C A B AxB p).
Proof. destruct p as (pi1, pi2, h, hax1, hax2, huni).
       unshelve econstructor.
       - simpl.
         intros (Z, (f, g)).
         unshelve econstructor.
         + simpl. exact (h Z f g).
         + simpl. apply hax1.
         + simpl. apply hax2.
       - simpl.
         intros (Z1, (f1, g1)) (f3, f3ax1, f3ax2) (f4, fax1, f4ax2).
         simpl in *. apply PCatArrowEq. simpl.
         pose proof huni as hhuni.
         specialize (@huni Z1 f1 g1 f4).
         specialize (@hhuni Z1 f1 g1 f3).
         rewrite <- huni, <- hhuni; easy.
Defined.

Lemma productIso0: forall (C: Category) (A B P P': @obj C) (p: Product C A B P), @Isomorphic C P P' -> Product C A B P'.
Proof. intros C A B P P' (pi1, pi2, p, pax1, pax2, puniq) (h, (hinv, hax1, hax2)).
       unshelve econstructor.
       - exact (pi1 o hinv).
       - exact (pi2 o hinv).
       - intros X f g.
         exact (h o (p X f g)).
       - intros X f g. simpl. rewrite assoc. setoid_rewrite <- assoc at 2.
         rewrite hax2, f_identity. apply pax1.
       - intros X f g. simpl. rewrite assoc. setoid_rewrite <- assoc at 2.
         rewrite hax2, f_identity. apply pax2.
       - intros X f g p1 Ha Hb.
         rewrite <- assoc in Ha.
         rewrite <- assoc in Hb.
         simpl.
         specialize (puniq X f g (hinv o p1) Ha Hb).
         assert (HH: h o p X f g = h o hinv o p1).
         rewrite <- !assoc, puniq. reflexivity.
         rewrite hax1, !identity_f in HH.
         exact HH.
Qed.

Lemma ProductIso: forall (C: Category) (A B P P': @obj C) (p: Product C A B P) (p': Product C A B P'), @Isomorphic C P P'.
Proof. intros C A B P P' (pi11, pi12, h1, h1ax1, h1ax2, h1uniq) (pi21, pi22, h2, h2ax1, h2ax2, h2uniq).
       unshelve econstructor.
       - exact (h2 P pi11 pi12).
       - unshelve econstructor.
         + exact (h1 P' pi21 pi22).
         + pose proof h2uniq as hh2uniq.
           specialize (h2uniq P' pi21 pi22 (h2 P pi11 pi12 o h1 P' pi21 pi22)).
           specialize (hh2uniq P' pi21 pi22 (identity P')).
           rewrite <- h2uniq, <- hh2uniq.
           reflexivity.
           ++ rewrite f_identity. easy.
           ++ rewrite f_identity. easy.
           ++ rewrite assoc.
              rewrite <- h2ax1, <- h1ax1.
              reflexivity.
           ++ rewrite assoc.
              rewrite <- h2ax2, <- h1ax2.
              reflexivity.
         + pose proof h1uniq as hh1uniq.
           specialize (h1uniq P pi11 pi12 (h1 P' pi21 pi22 o h2 P pi11 pi12)).
           specialize (hh1uniq P pi11 pi12 (identity P)).
           rewrite <- h1uniq, <- hh1uniq.
           reflexivity.
           ++ rewrite f_identity. easy.
           ++ rewrite f_identity. easy.
           ++ rewrite assoc.
              rewrite <- h1ax1, <- h2ax1.
              reflexivity.
           ++ rewrite assoc.
              rewrite <- h1ax2, <- h2ax2.
              reflexivity.
Qed.

Lemma ProductIsoUnique: forall (C: Category) (A B P P': @obj C) (p: Product C A B P) (p': Product C A B P'),
  { f: @arrow C P P' & Isomorphism C f ->
    forall g: @arrow C P P', (@pi1 C A B P p) o g = (@pi1 C A B P' p') ->
                             (@pi2 C A B P p) o g = (@pi2 C A B P' p') -> Isomorphism C g -> f = g }.
Proof. intros C A B P P' (pi11, pi12, h1, h1ax1, h1ax2, h1uniq) (pi21, pi22, h2, h2ax1, h2ax2, h2uniq).
       simpl in *.
       exists (h1 P' pi21 pi22).
       intros (finv, fax1, fax2) g Hg1 Hg2 (ginv, gax1, gax2).
       symmetry.
       specialize (h1uniq P' pi21 pi22 g).
       rewrite h1uniq; easy.
Qed.

(* Require Import Coq.Init.Datatypes. *)

Lemma setProd: forall A B: @obj SetCat, Product SetCat A B (prod A B).
Proof. intros.
       unshelve econstructor.
       - simpl. intros (a, b). exact a.
       - simpl. intros (a, b). exact b.
       - simpl. intros Z f g z. exact (f z, g z).
       - simpl. intros Z f g. easy.
       - simpl. intros Z f g. easy.
       - simpl. intros Z f g p1 H1 H2.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H1) as Hax1';
         cbv beta in Hax1'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H2) as Hax2';
         cbv beta in Hax2'.
(*          pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H3) as Hax3';
         cbv beta in Hax3'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H4) as Hax4';
         cbv beta in Hax4'. *)
         apply functional_extensionality.
         intro z.
         specialize (Hax1' z).
         specialize (Hax2' z).
         destruct (p1 z).
         rewrite <- Hax1', <- Hax2'.
         reflexivity.
Defined.

Definition preorderProdObj (P1 P2: PreOrder): @obj PreOrderCat.
Proof. destruct P1 as (P1, le1, r1, t1).
       destruct P2 as (P2, le2, r2, t2).
       simpl in *.
       unshelve econstructor.
       - exact (prod P1 P2).
       - intros (a, c) (b, d).
         exact ((le1 a b) && (le2 c d)).
       - intros (a, b).
         rewrite r1, r2. reflexivity.
       - intros (a, d) (b, e) (c, f) (H1, H2).
         apply andb_prop in H1, H2.
         destruct H1 as (Ha, Hb).
         destruct H2 as (Hc, Hd).
         assert (le1 a b = true /\ le1 b c = true) by easy.
         specialize (t1 _ _ _ H).
         assert (le2 d e = true /\ le2 e f = true) by easy.
         specialize (t2 _ _ _ H0).
         rewrite t1, t2. reflexivity.
Defined.

Lemma preorderProd: forall A B: @obj PreOrderCat, Product PreOrderCat A B (preorderProdObj A B).
Proof. intros (A, le1, r1, t1) (B, le2, r2, t2).
       unshelve econstructor.
       - simpl. unshelve econstructor.
         + simpl. intros (a, b). exact a.
         + simpl. intros (a, c) (b, d) H.
           apply andb_prop in H. easy.
       - simpl. unshelve econstructor.
         + simpl. intros (a, b). exact b.
         + simpl. intros (a, c) (b, d) H.
           apply andb_prop in H. easy.
       - simpl. intros (Z, le3, r3, t3) (f, fax) (g, gax).
         unshelve econstructor.
         + simpl in *. intro z. exact (f z, g z).
         + simpl in *. intros x y Hx. rewrite fax, gax.
           easy. easy. easy.
       - simpl. intros (Z, le3, r3, t3) (f, fax) (g, gax).
         apply PreOrderMapEq. simpl. easy.
       - simpl. intros (Z, le3, r3, t3) (f, fax) (g, gax).
         apply PreOrderMapEq. simpl. easy.
       - simpl. intros (Z, le3, r3, t3) (f, fax) (g, gax) (h, hax) H1 H2.
         apply PreOrderMapEq. simpl.
         inversion H1.
         inversion H2.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H0) as Hax1';
         cbv beta in Hax1'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H3) as Hax2';
         cbv beta in Hax2'.
         apply functional_extensionality.
         intro z.
         simpl in *.
         destruct (h z).
         reflexivity.
Defined.

Definition monoidProdObj (M1 M2: Monoid): @obj Mon.
Proof. destruct M1 as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
       destruct M2 as (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
       simpl in *.
       unshelve econstructor.
       - exact (prod M1 M2).
       - exact (e1, e2).
       - intros (a, c) (b, d).
         exact ((M1f a b), (M2f c d)).
       - intros (a, d) (b, e) (c, f).
         rewrite M1ob1, M2ob1. reflexivity.
       - simpl. intros (a, b).
         rewrite M1ob2, M2ob2. reflexivity.
       - simpl. intros (a, b).
         rewrite M1ob3, M2ob3. reflexivity.
Defined.

Lemma monoidProd: forall A B: @obj Mon, Product Mon A B (monoidProdObj A B).
Proof. destruct A as (A, e1, M1f, M1ob1, M1ob2, M1ob3).
       destruct B as (B, e2, M2f, M2ob1, M2ob2, M2ob3).
       simpl in *.
       unshelve econstructor.
       - simpl. unshelve econstructor.
         + simpl. intros (a, b). exact a.
         + simpl. reflexivity.
         + simpl. intros (a, c) (b, d). reflexivity.
       - simpl. unshelve econstructor.
         + simpl. intros (a, b). exact b.
         + simpl. reflexivity.
         + simpl. intros (a, c) (b, d). reflexivity.
       - simpl. intros (M3, e3, M3f, M3ob1, M3ob2, M3ob3) (f, fax1, fax2) (g, gax1, gax2).
         unshelve econstructor.
         + simpl in *. intro z. exact (f z, g z).
         + simpl in *. rewrite fax1, gax1. reflexivity.
         + simpl in *. intros x y. rewrite fax2, gax2. reflexivity.
       - simpl. intros (M3, e3, M3f, M3ob1, M3ob2, M3ob3) (f, fax1, fax2) (g, gax1, gax2).
         apply MonoidMapEq. simpl. easy.
       - simpl. intros (M3, e3, M3f, M3ob1, M3ob2, M3ob3) (f, fax1, fax2) (g, gax1, gax2).
         apply MonoidMapEq. simpl. easy.
       - simpl. intros (M3, e3, M3f, M3ob1, M3ob2, M3ob3) (f, fax1, fax2)
                       (g, gax1, gax2) (h, hax1, hax2) H1 H2.
         apply MonoidMapEq. simpl.
         inversion H1.
         inversion H2.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H0) as Hax1';
         cbv beta in Hax1'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H3) as Hax2';
         cbv beta in Hax2'.
         apply functional_extensionality.
         intro z.
         specialize (Hax1' z).
         specialize (Hax2' z).
         destruct (h z).
         rewrite <- Hax1', <- Hax2'.
         reflexivity.
Defined.

Lemma lb: forall (P: PreOrder) (A B AxB: @obj (PreOrderDetCat P)), Product (PreOrderDetCat P) A B AxB ->
  @pohrel P AxB A = true /\ @pohrel P AxB B = true.
Proof. intros (P, le, r, t) A B AxB (pi1, pi2, h, hax1, hax2, huniq).
       split.
       - simpl in pi1.
         simpl. case_eq (le AxB A); intro H.
         + easy.
         + clear hax1 huniq.
           unfold PreOrderICMap in *.
           simpl in pi1.
           rewrite H in pi1. easy.
       - simpl in pi2.
         simpl. case_eq (le AxB B); intro H.
         + easy.
         + clear hax2 huniq.
           unfold PreOrderICMap in *.
           simpl in pi2.
           rewrite H in pi2. easy.
Qed.

Class POBM (P: PreOrder) (p q: @pos P): Type :=
{
   pobm   : @pos P;
   pobmpi1: @pohrel P pobm p = true;
   pobmpi2: @pohrel P pobm q = true;
   pobmuni: forall r, @pohrel P r pobm = true <-> @pohrel P r p = true /\ @pohrel P r q = true
}.

Class hasPOBM (P: PreOrder): Type :=
{
  hpobm: forall p q, POBM P p q
}.

Lemma binarymeet: forall (P: PreOrder) (p q: @obj (PreOrderDetCat P)) (h: POBM P p q),
  Product (PreOrderDetCat P) p q (@pobm P p q h).
Proof.
   simpl in *.
   unshelve econstructor.
   - simpl in *.
     unfold PreOrderICMap.
     destruct P as (P, le, r, t).
     destruct h as (l, pi1, pi2, uni). simpl in *. rewrite pi1. exact tt.
   - simpl in *.
     unfold PreOrderICMap.
     destruct P as (P, le, r, t).
     destruct h as (l, pi1, pi2, uni). simpl in *. rewrite pi2. exact tt.
   - simpl in *. intros.
     unfold PreOrderICMap in *.
     destruct P as (P, le, r, t).
     destruct h as (l, pi1, pi2, uni). simpl in *.
     specialize (uni Z).
     destruct (le Z p).
     + destruct (le Z q).
       ++ assert (le Z l = true ). apply uni. easy.
          rewrite H. exact tt.
       ++ easy.
     + easy.
   - cbn in *. intros z f g.
     apply PreOrderICMapEq.
   - cbn in *. intros z f g.
     apply PreOrderICMapEq.
   - cbn in *. intros z f g p1 Ha Hb.
     apply PreOrderICMapEq.
Defined.

Lemma hasProductsPreOrderDetCat (P: PreOrder) (h: hasPOBM P): hasProducts (PreOrderDetCat P).
Proof. unshelve econstructor.
       - simpl in *. intros p q.
         exact (@pobm P p q (@hpobm P h p q)).
       - simpl. intros p q. apply binarymeet.
Defined.

(* here (slide 58).... *)

(* Lemma glb: forall (P: PreOrder) (A B AxB: @obj (PreOrderDetCat P)), Product (PreOrderDetCat P) A B AxB ->
  forall R, @pohrel P R A = true /\ @pohrel P R B = true -> @pohrel P R AxB = true.
Proof. intros (P, le, refl, trans) p q pxq (pi1, pi2, h, hax1, hax2, huniq) r (Ha, Hb).
       simpl. simpl in Ha, Hb, pi1, pi2, r, h.
       clear hax1 hax2 huniq.
       specialize (h r).
       assert ((if le r pxq then unit else Empty_set) -> le r pxq = true).
       intro H. case_eq (le r pxq); intro H0. easy. rewrite H0 in H. easy.
       apply H.
       simpl in *.
       rewrite Ha, Hb in h. specialize (h tt tt).
       destruct (le r pxq); exact h.
Qed. *)