(** * Tactics: More Basic Tactics *)

(** This chapter introduces several additional proof strategies
    and tactics that allow us to begin proving more interesting
    properties of functional programs.  We will see:

    - how to use auxiliary lemmas in both "forward-style" and
      "backward-style" proofs;
    - how to reason about data constructors (in particular, how to use
      the fact that they are injective and disjoint);
    - how to strengthen an induction hypothesis (and when such
      strengthening is required); and
    - more details on how to reason by case analysis. *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Export Poly.

(* ################################################################# *)
(** * The [apply] Tactic *)

(** 我们经常会遇到待证目标与上下文中的前提或已证引理刚好_相同_的情况。*)

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

(** 我们可以像之前那样用"rewrite → eq2. reflexivity."来完成。
    不过如果我们使用 [apply] 策略，只需一步就能达到同样的效果： *)

  apply eq2.  Qed.

(** [apply] 策略也可以配合条件（Conditional）假设和引理来使用：
    如果被应用的语句是一个蕴含式，那么该蕴含式的前提就会被添加到
    待证子目标列表中。*)

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

(** 通常，当我们使用 [apply H] 时，语句 [H] 会以一个绑定了某些 通用变量
    （Universal Variables） 的 [∀] 开始。在 Coq 针对 [H] 的结论匹配当前
    目标时，它会尝试为这些变量查找适当的值。例如， 当我们在以下证明中执行
    [apply eq2] 时，[eq2] 中的通用变量 [q] 会以 [n] 实例化，
    而 [r] 会以 [m] 实例化.*)

Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m)  ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** **** Exercise: 2 stars, standard, optional (silly_ex)

    Complete the following proof without using [simpl]. *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     oddb 3 = true ->
     evenb 4 = true.
Proof. intros. apply H0. Qed.
(** [] *)

(** 要使用 [apply] 策略，被应用的事实（的结论）必须精确地匹配证明目标：
    例如, 当等式的左右两边互换后，apply 就无法起效了。 *)

Theorem silly3_firsttry : forall (n : nat),
     true = (n =? 5)  ->
     (S (S n)) =? 7 = true.
Proof.
  intros n H.

(** 在这里，我们无法直接使用 [apply]，不过我们可以用 [symmetry] 策略
    它会交换证明目标中等式的左右两边。*)

  symmetry.
  simpl. (** (This [simpl] is optional, since [apply] will perform
             simplification first, if needed.) *)
  apply H.  Qed.

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

    (_Hint_: You can use [apply] with previously defined lemmas, not
    just hypotheses in the context.  Remember that [Search] is
    your friend.) *)

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

(** **** Exercise: 1 star, standard, optional (apply_rewrite)

    Briefly explain the difference between the tactics [apply] and
    [rewrite].  What are the situations where both can usefully be
    applied? *)

(* FILL IN HERE

    [] *)

(* ################################################################# *)
(** * The [apply with] Tactic *)

(** 以下愚蠢的例子在一行中使用了两次改写来将 [a;b] 变成 [e;f]。 *)

Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** 由于这种模式十分常见，因此我们希望一劳永逸地把它作为一条引理记录下来，
    即等式具有传递性。*)

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

(** 现在，按理说我们应该可以用 [trans_eq] 来证明前面的例子了。
    然而，为此我们还需要稍微改进一下 [apply] 策略 *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.

(** 如果此时我们只是告诉 Coq [apply trans_eq]，那么它会
（根据该引理的结论对证明目标的匹配）说 X 应当实例化为 [[nat]]、[n]
实例化为 [[a,b]]、以及 [o] 实例化为 [[e,f]]。然而，匹配过程并没有为[m]
确定实例：我们必须在 [apply] 的调用后面加上 [with (m:=[c,d])] 来显式地
提供一个实例 *)

  apply trans_eq with (m:=[c;d]).
  apply eq1. apply eq2.   Qed.

(** 实际上，我们通常不必在 [with] 从句中包含名字 [m]，Coq 一般足够聪明来确定
我们给出的实例。
    我们也可以写成： [apply trans_eq with [c;d]]。*)

(** **** Exercise: 3 stars, standard, optional (apply_with_exercise)  *)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros. symmetry in H0. rewrite H in H0. rewrite H0. reflexivity. Qed.
(** [] *)

(* ################################################################# *)
(** * The [injection] and [discriminate] Tactics *)

(** 回想自然数的定义：

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

    我们可从该定义中观察到，所有的数都是两种形式之一：要么是构造子 [O]， 要么就是
    将构造子 [S] 应用到另一个数上。

    不过这里还有无法直接看到的： 自然数的定义（以及我们对其它编程语言中数据类型声明
    的工作方式的非形式化理解）中还蕴含了两个事实:

    - 构造子 [S] 是单射（Injective）的。 如果 [S n = S m]，那么 [n = m] 必定成立。

    - 构造子 [O] 和 [S] 是不相交（Disjoint）的。 对于任何 [n] ，[O] 都
    不等于 [S n]。

    类似的原理同样适用于所有归纳定义的类型：所有构造子都是单射的， 而不同构造子构造出
    的值绝不可能相等。对于列表来说，[cons] 构造子是单射的， 而 [nil] 不同于任何
    非空列表。对于布尔值来说，[true] 和 [false] 是不同的。 因为 true 和 false二者
    都不接受任何参数，它们的单射性并不有趣。 其它归纳类型亦是如此 *)

(** 例如，我们可以使用定义在 [Basics.v] 中的 [pred] 函数来证明 S 的单射性。*)

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.

(** 这个技巧可以通过编写构造子的等价的 [pred] 来推广到任意的构造子上 —— 即编写一个
    "撤销" 一次构造子调用的函数。 作为一种更加简便的替代品， Coq提供了叫做[injection]
    的策略来让我们利用任意构造子的单射性。 此处是使用[injection]对上面定理的另一种证法。*)

Theorem S_injective' : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.

(** 通过在此处编写 [injection H] ， 我们命令Coq使用构造子的单射性来产生所有它能从
    [H]所推出的等式。 每一个产生的等式都作为一个前件附加在目标上。
    在这个例子中，附加了前件 [n = m] 。 *)

  injection H. intros Hnm. apply Hnm.
Qed.

(** 此处展示了一个 injection 如何直接得出多个等式的有趣例子。*)

Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  injection H. intros H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

(** injection 的 "as" 变体允许我们而非Coq来为引入的等式选择名称。 *)

Theorem injection_ex2 : forall (n m : nat),
  [n] = [m] ->
  n = m.
Proof.
  intros n m H.
  injection H as Hnm. rewrite Hnm.
  reflexivity. Qed.

(** **** Exercise: 1 star, standard (injection_ex3)  *)
Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros X x y z l j H0 H1. injection H1. intros _ H2.
  symmetry. apply H2. Qed.
(** [] *)

(** So much for injectivity of constructors.  What about disjointness?

    The principle of disjointness says that two terms beginning with
    different constructors (like [O] and [S], or [true] and [false])
    can never be equal.  This means that, any time we find ourselves
    working in a context where we've _assumed_ that two such terms are
    equal, we are justified in concluding anything we want to (because
    the assumption is nonsensical).

    The [discriminate] tactic embodies this principle: It is used on a
    hypothesis involving an equality between different
    constructors (e.g., [S n = O]), and it solves the current goal
    immediately.  For example: *)

(** discriminate : ⊥ dans hypotheses => Resoud le but actuel *)

Theorem eqb_0_l : forall n,
   0 =? n = true -> n = 0.
Proof.
  intros n.

(** We can proceed by case analysis on [n]. The first case is
    trivial. *)

  destruct n as [| n'] eqn:E.
  - (* n = 0 *)
    intros H. reflexivity.

(** However, the second one doesn't look so simple: assuming [0
    =? (S n') = true], we must show [S n' = 0]!  The way forward is to
    observe that the assumption itself is nonsensical: *)

  - (* n = S n' *)
    simpl.

(** If we use [discriminate] on this hypothesis, Coq confirms
    that the subgoal we are working on is impossible and removes it
    from further consideration. *)

    intros H. discriminate H.
Qed.

(** This is an instance of a logical principle known as the _principle
    of explosion_, which asserts that a contradictory hypothesis
    entails anything, even false things! *)

Theorem discriminate_ex1 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros n contra. discriminate contra. Qed.

Theorem discriminate_ex2 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros n m contra. discriminate contra. Qed.

(** If you find the principle of explosion confusing, remember
    that these proofs are _not_ showing that the conclusion of the
    statement holds.  Rather, they are showing that, if the
    nonsensical situation described by the premise did somehow arise,
    then the nonsensical conclusion would follow.  We'll explore the
    principle of explosion of more detail in the next chapter. *)

(** **** Exercise: 1 star, standard (discriminate_ex3)  *)
Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
  intros. discriminate H. Qed.
(** [] *)

(** The injectivity of constructors allows us to reason that
    [forall (n m : nat), S n = S m -> n = m].  The converse of this
    implication is an instance of a more general fact about both
    constructors and functions, which we will find convenient in a few
    places below: *)

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq.  reflexivity.  Qed.

(* ################################################################# *)
(** * Using Tactics on Hypotheses *)

(** 默认情况下，大部分策略会作用于目标公式并保持上下文不变。然而，
    大部分策略还有对应的变体来对上下文中的语句执行类似的操作。

    例如，策略 [simpl in H] 会对上下文中名为 [H] 的前提执行化简。
 *)

Theorem S_inj : forall (n m : nat) (b : bool),
     (S n) =? (S m) = b  ->
     n =? m = b.
Proof.
  intros n m b H. simpl in H. apply H.  Qed.

(** 类似地，[apply L in H] 会针对上下文中的前提 [H] 匹配某些
    （形如 [X → Y] 中的）条件语句 [L]。然而，与一般的 [apply] 不同
    （它将匹配 [Y] 的目标改写为子目标 [X]），[apply L in H] 会针对
    [X] 匹配 [H]，如果成功，就将其替换为 [Y]。

    换言之，[apply L in H] 给了我们一种"正向推理"的方式：
    根据 [X → Y] 和一个匹配 [X] 的前提，它会产生一个匹配 [Y] 的前提。
    作为对比，[apply L] 是一种"反向推理"：它表示如果我们知道 [X → Y]
    并且试图证明 [Y]， 那么证明 [X] 就足够了。

    下面是前面证明的一种变体，它始终使用正向推理而非反向推理 *)

Theorem silly3' : forall (n : nat),
  (n =? 5 = true -> (S (S n)) =? 7 = true) ->
  true = (n =? 5)  ->
  true = ((S (S n)) =? 7).
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.  Qed.

(** 正向推理从给定的东西开始（即前提、已证明的定理）， 根据它们迭代地
    刻画结论直到抵达目标。反向推理从目标开始， 迭代地推理蕴含目标的东西，
    直到抵达前提或已证明的定理。

    如果你之前见过非形式化的证明（例如在数学或计算机科学课上）， 它们使用的
    应该是正向推理。通常，Coq 习惯上倾向于使用反向推理， 但在某些情况下，
    正向推理更易于思考。*)

(** **** Exercise: 3 stars, standard, recommended (plus_n_n_injective)

    Practice using "in" variants in this proof.  (Hint: use
    [plus_n_Sm].) *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  (* Use [plus_n_Sm] Lemma *)
  - intros m H. simpl in H. destruct m as [| m'].
    + reflexivity.
    + simpl in H. discriminate H.
  - intros m H. simpl in H. destruct m as [| m'].
    + discriminate H.
    + simpl in H. rewrite <- !plus_n_Sm in H. (* rewrite modifiers *)
      inversion H. apply IHn' in H1. rewrite H1. reflexivity. Qed.
(** [] *)

(* ################################################################# *)
(** * Varying the Induction Hypothesis *)

(** 在 Coq 中进行归纳证明时，有时控制归纳假设的确切形式是十分重要的。 特别是在
    调用 [induction] 策略前，我们用 [intros] 将假设从目标移到上下文中时要十分小心。
    例如，假设我们要证明 [double] 函数式单射 — 即它将不同的参数映射到不同的结果：

       Theorem double_injective: forall n m,
         double n = double m -> n = m.

    其证明的开始方式有点微妙：如果我们以

       intros n. induction n.

    开始，那么一切都好。然而假如以

       intros n m. induction n.

    开始，就会卡在归纳情况中...*)

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  - (* n = O *) simpl. intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) discriminate eq.
    + (* m = S m' *) apply f_equal.

(** 此时，归纳假设 [IHn'] 不会给出 [n' = m'] — 会有个额外的 [S] 阻碍
    因此该目标无法证明。*)

      Abort.

(** What went wrong? *)

(** 问题在于，我们在调用归纳假设的地方已经将 [m] 引入了上下文中
    直观上，我们已经告诉了 Coq "我们来考虑具体的 [n] 和 [m]..."，
    而现在必须为这些具体的 n 和 m 证明 [double n = double m]，
    然后才有 [n = m]。

    下一个策略 [induction n] 告诉 Coq：我们要对 [n] 归纳来证明该目标。
    也就是说，我们要证明对于所有的 [n]，命题

      - [P n] = "if [double n = double m], then [n = m]"

    成立，需通过证明

      - [P O]

         (i.e., "if [double O = double m] then [O = m]") and

      - [P n -> P (S n)]

        (i.e., "if [double n = double m] then [n = m]" implies "if
        [double (S n) = double m] then [S n = m]").

    如果我们仔细观察第二个语句，就会发现它说了奇怪的事情：
    即，对于一个具体的 [m]，如果我们知道

      - "if [double n = double m] then [n = m]"

    那么我们就能证明

       - "if [double (S n) = double m] then [S n = m]".

    要理解为什么它很奇怪，我们来考虑一个具体的 [m] — 比如说5。
    该语句就会这样说：如果我们知道

      - [Q] = "if [double n = 10] then [n = 5]"

    那么我们就能证明

      - [R] = "if [double (S n) = 10] then [S n = 5]".

    但是知道 [Q] 对于证明 [R] 来说并没有任何帮助！（如果我们试着根据 [Q] 证明
    [R] from [Q]，就会以"假设 double (S n) = 10.."这样的句子开始， 不过之后
    我们就会卡住：知道 [double (S n)] 为 10 并不能告诉我们 [double n] 是否为 10，
    因此 [Q] 是没有用的。）*)

(** 当 [m] 已经在上下文中时，试图对 [n] 进行归纳来进行此证明是行不通的， 因为我们之后
要尝试证明涉及每一个 n 的命题，而不只是单个 m。 *)

(** 对 [double_injective] 的成功证明将 [m] 留在了目标语句中 [induction]
    作用于 [n] 的地方： *)

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  - (* n = O *) simpl. intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.

  - (* n = S n' *) simpl.

(** 注意，此时的证明目标和归纳假设是不同的：证明目标要求我们证明更一般的事情
    （即为每一个 [m] 证明该语句），而归纳假设 [IH] 相应地更加灵活， 允许我们
    在应用归纳假设时选择任何想要的 [m]。*)

    intros m eq.

(** 现在我们选择了一个具体的 [m] 并引入了假设 [double n = double m]。 由于
    我们对 [n] 做了情况分析，因此还要对 [m] 做情况分析来保持两边"同步"。*)

    destruct m as [| m'] eqn:E.
    + (* m = O *) simpl.

(** 0 的情况很显然：*)

      discriminate eq.

    + (* m = S m' *)
      apply f_equal.

(** 到这里，由于我们在 [destruct m] 的第二个分支中，因此上下文中涉及
    到的 [m'] 就是我们开始讨论的 [m] 的前趋。由于我们也在归纳的 [S] 分支中，
    这就很完美了： 如果我们在归纳假设中用当前的 [m']（此实例由下一步的 [apply]
    自动产生） 实例化一般的 [m]，那么 [IHn'] 就刚好能给出我们需要的来结束此证明。*)

      apply IHn'. injection eq as goal. apply goal. Qed.

(** What you should take away from all this is that we need to be
    careful, when using induction, that we are not trying to prove
    something too specific: To prove a property of [n] and [m] by
    induction on [n], it is sometimes important to leave [m]
    generic. *)

(** The following exercise requires the same pattern. *)

(** **** Exercise: 2 stars, standard (eqb_true)  *)
Theorem eqb_true : forall n m,
    n =? m = true -> n = m.
Proof.
  intros n. induction n as [| n' IH].
  - intros m H. destruct m as [| m'] eqn:Em.
    + reflexivity.
    + discriminate.
  - intros m H. destruct m as [| m'] eqn:Em.
    + discriminate.
    + f_equal. apply IH. apply H. Qed.
    (** Alternative for last case:
    + simpl in H. apply IH in H.
      rewrite H. reflexivity. Qed. *)

Theorem eqb_true' : forall n m,
    n =? m = true -> n = m.
Proof.
  intros m n H. generalize dependent m.
  induction n as [| n' IH].
  - intros m H. destruct m as [| m'] eqn:Em.
    + reflexivity.
    + discriminate.
  - intros m H. destruct m as [| m'] eqn:Em.
    + discriminate.
    + f_equal. apply IH. apply H. Qed.
(** [] *)

(** **** Exercise: 2 stars, advanced (eqb_true_informal)

    Give a careful informal proof of [eqb_true], being as explicit
    as possible about quantifiers. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (nat*string) := None.
(** [] *)

(** 在 [induction] 之前做一些 [intros] 来获得更一般归纳假设并不总是奏效。
    有时需要对量化的变量做一下重排。例如，假设我们想要通过对 [m] 而非 [n]
    进行归纳来证明 [double_injective]。*)

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  - (* m = O *) simpl. intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
        (* Stuck again here, just like before. *)
Abort.

(** 问题在于，要对 [m] 进行归纳，我们首先必须对 [n] 归纳。
    （如果我们不引入任何东西就执行 [induction m]，Coq
    就会自动为我们引入 [n]）*)

(** 我们可以对它做什么？一种可能就是改写该引理的陈述使得 [m] 在 [n] 之前量化。
    这样是可行的，不过它不够好：我们不想调整该引理的陈述来适应具体的证明策略！
    我们更想以最清晰自然的方式陈述它。*)

(** 我们可以先引入所有量化的变量，然后重新一般化（re-generalize） 其中的一个
    或几个，选择性地从上下文中挑出几个变量并将它们放回证明目标的开始处。
    用 generalize dependent 策略就能做到。*)

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* [n] and [m] are both in the context *)
  generalize dependent n.
  (* Now [n] is back in the goal and we can do induction on
     [m] and get a sufficiently general IH. *)
  induction m as [| m'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. injection eq as goal. apply goal. Qed.

(** 我们来看一下此定理的非形式化证明。注意我们保持 [n] 的量化状态并通过归纳证明的命题，
    对应于我们形式化证明中依赖的一般化。

    定理：对于任何自然数 n 和 m，若 [double n = double m]，则 [n = m]。

    证明：令 [m] 为一个 [nat]。我们通过对 m 进行归纳来证明，
    对于任何 n， 若 [double n = double m]，则 [n = m]。

      - 首先，设 [m = 0]，而 n 是一个数使得 [double n = double m]。我们必须证明
        [n = 0]。

        由于 [m = 0]，根据 [double] 的定义，我们有 [double n = 0]。此时对于 [n]
        需要考虑两种情况。若 [n = 0]，则得证，因为 [m = 0 = n]，正如所需。 否则，
        若对于某个 [n'] 有 [n = S n']，我们就会导出矛盾：根据 [double] 的定义，
        我们可得出 [double n = S (S (double n'))]，但它与 [double n = 0] 相矛盾。

      - 其次，设 [m = S m']，而 [n] 同样是一个数使得 [double n = double m]。
        我们必须证明 [n = S m']，根据归纳假设，对于任何数 [s]，若
        [double s = double m']，则 [s = m']。

        根据 [m = S m'] 的事实以及 [double] 的定义,,我们有
        double n = S (S (double m'))。 此时对于 n 需要考虑两种情况。

        若 n = 0，则根据 double n = 0 的定义会得出矛盾。

        因此，我们假设对于某个 n'，有 n = S n'，同样根据 double 的定义，我们有
        S (S (double n')) = S (S (double m'))，它可通过反演
        double n' = double m' 得出。
        以 n' 实例化归纳假设允许我们得出 n' = m' 的结论，显然 S n' = S m'。
        因此 S n' = n 且 S m' = m， 此即我们所欲证 [] *)

(** 在结束本节去做习题之前，我们先稍微跑个题，使用 eqb_true 来证明
    一个标识符的类似性质以备后用： *)

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

(** **** Exercise: 3 stars, standard, recommended (gen_dep_practice)

    Prove this by induction on [l]. *)

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros. generalize dependent l.
  induction n as [| n' IHn'].
  - intros. destruct l as [| a t].
    + reflexivity.
    + discriminate.
  - intros. destruct l as [| a t].
    + reflexivity.
    + simpl in H. injection H as H.
      apply IHn' in H.
      simpl.
      apply H.
      Qed.
(** [] *)

(* ################################################################# *)
(** * Unfolding Definitions *)

(** It sometimes happens that we need to manually unfold a name that
    has been introduced by a [Definition] so that we can manipulate
    its right-hand side.  For example, if we define... *)

Definition square n := n * n.

(** ... and try to prove a simple fact about [square]... *)

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl.

(** ... we appear to be stuck: [simpl] doesn't simplify anything at
    this point, and since we haven't proved any other facts about
    [square], there is nothing we can [apply] or [rewrite] with.

    To make progress, we can manually [unfold] the definition of
    [square]: *)

  unfold square.

(** Now we have plenty to work with: both sides of the equality are
    expressions involving multiplication, and we have lots of facts
    about multiplication at our disposal.  In particular, we know that
    it is commutative and associative, and from these it is not hard
    to finish the proof. *)

  rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
    { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.

(** At this point, some discussion of unfolding and simplification is
    in order.

    You may already have observed that tactics like [simpl],
    [reflexivity], and [apply] will often unfold the definitions of
    functions automatically when this allows them to make progress.
    For example, if we define [foo m] to be the constant [5]... *)

Definition foo (x: nat) := 5.

(** .... then the [simpl] in the following proof (or the
    [reflexivity], if we omit the [simpl]) will unfold [foo m] to
    [(fun x => 5) m] and then further simplify this expression to just
    [5]. *)

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.

(** However, this automatic unfolding is somewhat conservative.  For
    example, if we define a slightly more complicated function
    involving a pattern match... *)

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

(** ...then the analogous proof will get stuck: *)

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl. (* Does nothing! *)
Abort.

(** The reason that [simpl] doesn't make progress here is that it
    notices that, after tentatively unfolding [bar m], it is left with
    a match whose scrutinee, [m], is a variable, so the [match] cannot
    be simplified further.  It is not smart enough to notice that the
    two branches of the [match] are identical, so it gives up on
    unfolding [bar m] and leaves it alone.  Similarly, tentatively
    unfolding [bar (m+1)] leaves a [match] whose scrutinee is a
    function application (that cannot itself be simplified, even
    after unfolding the definition of [+]), so [simpl] leaves it
    alone. *)

(** At this point, there are two ways to make progress.  One is to use
    [destruct m] to break the proof into two cases, each focusing on a
    more concrete choice of [m] ([O] vs [S _]).  In each case, the
    [match] inside of [bar] can now make progress, and the proof is
    easy to complete. *)

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(** This approach works, but it depends on our recognizing that the
    [match] hidden inside [bar] is what was preventing us from making
    progress. *)

(** A more straightforward way to make progress is to explicitly tell
    Coq to unfold [bar]. *)

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.

(** Now it is apparent that we are stuck on the [match] expressions on
    both sides of the [=], and we can use [destruct] to finish the
    proof without thinking too hard. *)

  destruct m eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

(* ################################################################# *)
(** * Using [destruct] on Compound Expressions *)

(** 我们已经见过许多通过 destruct 进行情况分析来处理一些变量的值了。
    不过有时我们需要根据某些表达式的结果的情况来进行推理。
    我们也可以用 destruct 来做这件事。*)

Definition sillyfun (n : nat) : bool :=
  if n =? 3 then false
  else if n =? 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (n =? 3) eqn:E1.
    - (* n =? 3 = true *) reflexivity.
    - (* n =? 3 = false *) destruct (n =? 5) eqn:E2.
      + (* n =? 5 = true *) reflexivity.
      + (* n =? 5 = false *) reflexivity.  Qed.

(** 在前面的证明中展开 sillyfun 后，我们发现卡在
if (n =? 3) then ... else ... 上了。但由于
n 要么等于 3 要么不等于，因此我们可以用 destruct (eqb n 3)
来对这两种情况进行推理。

通常，destruct 策略可用于对任何计算结果进行情况分析。
如果 e 是某个表达式，其类型为归纳定义的类型 T，那么
对于 T 的每个构造子 c，destruct e 都会生成一个子目标，
其中（即目标和上下文中）所有的 e 都会被替换成 c。*)

(** **** Exercise: 3 stars, standard, optional (combine_split)

    Here is an implementation of the [split] function mentioned in
    chapter [Poly]: *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
      match split t with
      | (lx, ly) => (x :: lx, y :: ly)
      end
  end.

(** Prove that [split] and [combine] are inverses in the following
    sense: *)

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| h t IH].
  - intros l1 l2 H. injection H as H1 H2.
    rewrite <- H1. rewrite <- H2.
    reflexivity.
  - intros l1' l2' H. destruct h as [a b].
    simpl in H.
    destruct (split t) as [t1 t2].
    injection H as H1 H2.
    rewrite <- H1. rewrite <- H2.
    simpl.
    rewrite -> IH. reflexivity. reflexivity. Qed.
(** [] *)

(** The [eqn:] part of the [destruct] tactic is optional: We've chosen
    to include it most of the time, just for the sake of
    documentation, but many Coq proofs omit it.

    When [destruct]ing compound expressions, however, the information
    recorded by the [eqn:] can actually be critical: if we leave it
    out, then [destruct] can sometimes erase information we need to
    complete a proof.

    For example, suppose we define a function [sillyfun1] like
    this: *)

Definition sillyfun1 (n : nat) : bool :=
  if n =? 3 then true
  else if n =? 5 then true
  else false.

(** Now suppose that we want to convince Coq of the (rather
    obvious) fact that [sillyfun1 n] yields [true] only when [n] is
    odd.  If we start the proof like this (with no [eqn:] on the
    destruct)... *)

Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3).
  (* stuck... *)
Abort.

(** ... then we are stuck at this point because the context does
    not contain enough information to prove the goal!  The problem is
    that the substitution performed by [destruct] is quite brutal --
    in this case, it thows away every occurrence of [n =? 3], but we
    need to keep some memory of this expression and how it was
    destructed, because we need to be able to reason that, since [n =?
    3 = true] in this branch of the case analysis, it must be that [n
    = 3], from which it follows that [n] is odd.

    What we want here is to substitute away all existing occurences of
    [n =? 3], but at the same time add an equation to the context that
    records which case we are in.  This is precisely what the [eqn:]
    qualifier does. *)

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got
     stuck above, except that the context contains an extra
     equality assumption, which is exactly what we need to
     make progress. *)
    - (* e3 = true *) apply eqb_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    - (* e3 = false *)
     (* When we come to the second equality test in the body
        of the function we are reasoning about, we can use
        [eqn:] again in the same way, allowing us to finish the
        proof. *)
      destruct (n =? 5) eqn:Heqe5.
        + (* e5 = true *)
          apply eqb_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        + (* e5 = false *) discriminate eq.  Qed.

(** **** Exercise: 2 stars, standard (destruct_eqn_practice)  *)
Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b.
  destruct (f true) eqn:Et.
  - destruct (f false) eqn:Ef.
    + destruct b eqn:Eb.
      * rewrite -> Et. rewrite -> Et. rewrite -> Et. reflexivity.
      * rewrite -> Ef. rewrite -> Et. rewrite -> Et. reflexivity.
    + destruct b eqn:Eb.
      * rewrite -> Et. rewrite -> Et. rewrite -> Et. reflexivity.
      * rewrite -> Ef. rewrite -> Ef. rewrite -> Ef. reflexivity.
  - destruct (f false) eqn:Ef.
    + destruct b eqn:Eb.
      * rewrite -> Et. rewrite -> Ef. rewrite -> Et. reflexivity.
      * rewrite -> Ef. rewrite -> Et. rewrite -> Ef. reflexivity.
    + destruct b eqn:Eb.
      * rewrite -> Et. rewrite -> Ef. rewrite -> Ef. reflexivity.
      * rewrite -> Ef. rewrite -> Ef. rewrite -> Ef. reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Review *)

(** 现在我们已经见过 Coq 中最基础的策略了。未来的章节中我们还会介绍更多，
    之后我们会看到一些更加强大的自动化策略，它能让 Coq 帮我们处理底层的细节。
    不过基本上我们已经有了完成工作所需的东西。

    下面是我们已经见过的：

      - [intros]: 将前提/变量从证明目标移到上下文中

      - [reflexivity]: （当目标形如 e = e 时）结束证明

      - [apply]: 用前提、引理或构造子证明目标

      - [apply... in H]: 将前提、引理或构造子应用到上下文中的假设上（正向推理）

      - [apply... with...]: 为无法被模式匹配确定的变量显式指定值

      - [simpl]: 化简目标中的计算

      - [simpl in H]: 化简前提中的计算

      - [rewrite]: 使用相等关系假设（或引理）来改写目标

      - [rewrite ... in H]: 使用相等关系假设（或引理）来改写前提

      - [symmetry]: 将形如 t=u 的目标改为 u=t

      - [symmetry in H]: 将形如 t=u 的前提改为 u=t

      - [unfold]: 用目标中的右式替换定义的常量

      - [unfold... in H]: 用前提中的右式替换定义的常量

      - [destruct... as...]: 对归纳定义类型的值进行情况分析

      - [destruct... eqn:...]: 为添加到上下文中的等式指定名字， 记录情况分析的结果

      - [induction... as...]: 对归纳定义类型的值进行归纳

      - [injection]: reason by injectivity on equalities
        between values of inductively defined types

      - [discriminate]: reason by disjointness of constructors on
        equalities between values of inductively defined types

      - [assert (H: e)] 引入"局部引理" e 并称之为 H

      - [generalize dependent x]: 将变量 x（以及任何依赖它的东西）
        从上下文中移回目标公式内的前提中 *)

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

(** **** Exercise: 3 stars, standard (eqb_sym)  *)
Theorem eqb_sym : forall (n m : nat),
  (n =? m) = (m =? n).
Proof.
  intro n.
  induction n as [| n' IH].
  - intro m.
    destruct m as [| m'].
    + reflexivity.
    + reflexivity.
  - intro m.
    destruct m as [| m'].
    + reflexivity.
    + simpl. apply IH.
Qed.

(** [] *)

(** **** Exercise: 3 stars, advanced, optional (eqb_sym_informal)

    Give an informal proof of this lemma that corresponds to your
    formal proof above:

   Theorem: For any [nat]s [n] [m], [(n =? m) = (m =? n)].

   Proof: *)
   (* FILL IN HERE

    [] *)

(** **** Exercise: 3 stars, standard, optional (eqb_trans)  *)
Theorem eqb_trans : forall n m p,
  n =? m = true ->
  m =? p = true ->
  n =? p = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

Definition split_combine_statement : Prop :=
  forall (X Y: Type) (l: list (X * Y)) (l1: list X) (l2: list Y),
  combine l1  l2 = l ->
  length l1 = length l2 ->
  split l = (l1, l2).

Theorem split_combine : split_combine_statement.
Proof.
  intros X Y l.
  induction l as [| (a, b) t IH].
  - intros l1 l2 H1 H2.
    destruct l1.
    + destruct l2.
      * reflexivity.
      * discriminate.
    + destruct l2.
      * discriminate.
      * discriminate.
  - intros l1' l2' H1 H2.
    simpl.
    destruct (split t) as [t1 t2].
    destruct l1'.
    + discriminate.
    + destruct l2'.
      * discriminate.
      * simpl in H1.
        injection H1 as H1'1 H1'2 H1'3.
        simpl in H2.
        injection H2 as H2.
        pose (H3 := IH _ _ H1'3 H2).
        injection H3 as H3'1 H3'2.
        rewrite -> H3'1, H3'2.
        rewrite -> H1'1, H1'2.
        reflexivity.
Qed.

(* Do not modify the following line: *)
Definition manual_grade_for_split_combine : option (nat*string) := None.
(** [] *)

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

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

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros X test x l.

  induction l as [| a t IH].
  - discriminate.
  - intros lf H.
    destruct (test a) eqn:E.
    + simpl in H.
      rewrite -> E in H.
      injection H as H'1 H'2.
      rewrite <- H'1.
      apply E.
    + simpl in H.
      rewrite -> E in H.
      apply (IH lf).
      apply H.
Qed.
(** [] *)

(** **** Exercise: 4 stars, advanced, recommended (forall_exists_challenge)

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

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

      forallb negb [false;false] = true

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

      forallb (eqb 5) [] = true

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

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

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

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

      existsb evenb [] = false

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

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

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => true
  | a :: t => test a && forallb test t
  end.

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.

Example test_forallb_2 : forallb negb [false;false] = true.
Proof. reflexivity. Qed.

Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.

Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. reflexivity. Qed.

Fixpoint existsb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => false
  | a :: t => test a || existsb test t
  end.

Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.

Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.

Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.

Example test_existsb_4 : existsb evenb [] = false.
Proof. reflexivity. Qed.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool :=
  negb (forallb (fun (x: X) => negb (test x)) l).

Theorem existsb_existsb' : forall (X : Type) (test : X -> bool) (l : list X),
  existsb test l = existsb' test l.
Proof.
  intros X test l.
  induction l as [| a t IH].
  - reflexivity.
  - simpl. unfold existsb', forallb.
    destruct (test a) eqn:E.
    + reflexivity.
    + simpl. rewrite -> IH. reflexivity.
Qed.

(** [] *)

(* Thu Aug 29 23:13 EST 2019 *)


Require Import Utf8.
Require Import LibTactics LibFset.
Require Import CpdtTactics.
Local Set Implicit Arguments.

Section section_subset_facts.
Context (A : Type).
Context (E F G : fset A).

Lemma subset_trans :
E \c F → F \c G → E \c G.
Proof.
intros_all ; crush.
Qed.

Lemma subset_union_l :
E \c F → E \c (F \u G).
Proof.
intros_all.
rewrite in_union.
crush.
Qed.

Lemma subset_union_r :
E \c G → E \c (F \u G).
Proof.
intros_all.
rewrite in_union.
crush.
Qed.

Lemma notin_subset (a : A) :
a \notin F → E \c F → a \notin E.
Proof.
intros_all ; crush.
Qed.

Lemma subset_refl' :
E = F → E \c F.
Proof.
crush.
Qed.

Lemma union_subset :
E \c G → F \c G → (E \u F) \c G.
Proof.
intros_all.
rewrite in_union in *.
crush.
Qed.

Lemma union_subset_inv_l :
E \u F \c G → E \c G.
Proof.
intros H1 x H2.
apply (H1 x).
rewrite in_union ; crush.
Qed.

Lemma union_subset_inv_r :
E \u F \c G → F \c G.
Proof.
intros H1 x H2.
apply (H1 x).
rewrite in_union ; crush.
Qed.

Lemma union_subset_inv :
E \u F \c G → E \c G ∧ F \c G.
Proof.
intro ; split ; [ apply union_subset_inv_l | apply union_subset_inv_r ] ; trivial.
Qed.

End section_subset_facts.


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.

Let p (x0 x1 x2 x3 x4 x5 : R) :=
  -4/1
  * (x3 * x3 * x0 + 8/1 * (x4 - x5) * (x1 - x2)
     - x3 * (16/1 * x0 + (x4 - 8/1) * x1 + (x5 - 8/1) * x2)).

Let b1 (x0 x1 x2 x3 x4 x5 : R) :=
  (x0 - 1) * (117547965573/100000000000 - x0).

Let b2 (x0 x1 x2 x3 x4 x5 : R) :=
  (x1 - 1) * (117547965573/100000000000 - x1).

Let b3 (x0 x1 x2 x3 x4 x5 : R) :=
  (x2 - 1) * (117547965573/100000000000 - x2).

Let b4 (x0 x1 x2 x3 x4 x5 : R) :=
  (x3 - 251952632905/100000000000) * (90601/10000 - x3).

Let b5 (x0 x1 x2 x3 x4 x5 : R) :=
  (x4 - 56644/10000) * (1553/100 - x4).

Let b6 (x0 x1 x2 x3 x4 x5 : R) :=
  (x5 - 56644/10000) * (1553/100 - x5).

Theorem p_nonneg (x0 x1 x2 x3 x4 x5 : R) :
  b1 x0 x1 x2 x3 x4 x5 >= 0 ->
  b2 x0 x1 x2 x3 x4 x5 >= 0 ->
  b3 x0 x1 x2 x3 x4 x5 >= 0 ->
  b4 x0 x1 x2 x3 x4 x5 >= 0 ->
  b5 x0 x1 x2 x3 x4 x5 >= 0 ->
  b6 x0 x1 x2 x3 x4 x5 >= 0 ->
  p x0 x1 x2 x3 x4 x5 >= 0.
Proof.
unfold b1, b2, b3, b4, b5, b6, p.
validsdp.
Qed.


From Theories Require Import
  Tactics Chap_2_Framework.

(** * Specification *)

(** ** Syntax *)

Definition Id  := nat.
Definition Loc := nat.

Inductive Typ :=
  | t_arr (t1 t2 : Typ)
  | t_unit
  | t_ref (t : Typ).

Inductive Exp :=
  | e_var (x : nat)
  | e_app (e1 e2 : Exp)
  | e_abs (e : Exp)
  | e_unit
  | e_ref (e : Exp)
  | e_get (e : Exp)
  | e_set (e1 e2 : Exp).

(** ** Type System *)

Definition TypEnv := List Typ.

Inductive ExpTyp : TypEnv -> Exp -> Typ -> Prop :=
  | et_var :
      forall x te t1,
      indexr x te = some t1 ->
      ExpTyp te (e_var x) t1
  | et_app :
      forall te e1 e2 t1 t2,
      ExpTyp te e1 (t_arr t1 t2) ->
      ExpTyp te e2 t1 ->
      ExpTyp te (e_app e1 e2) t2
  | et_abs :
      forall te e t1 t2,
      ExpTyp (t1 :: te) e t2 ->
      ExpTyp te (e_abs e) (t_arr t1 t2)
  | et_unit :
      forall te,
      ExpTyp te e_unit t_unit
  | et_ref :
      forall te e t,
      ExpTyp te e t ->
      ExpTyp te (e_ref e) (t_ref t)
  | et_get :
      forall te e t,
      ExpTyp te e (t_ref t) ->
      ExpTyp te (e_get e) t
  | et_set :
      forall te e1 e2 t,
      ExpTyp te e1 (t_ref t) ->
      ExpTyp te e2 t ->
      ExpTyp te (e_set e1 e2) t_unit
  .

(** ** Semantics *)

Inductive Val :=
  | v_abs (ve : List Val) (e : Exp)
  | v_unit
  | v_loc (l : Loc).

Definition ValEnv := List Val.
Definition ValStore := List Val.

Fixpoint eval (n : nat) (ve : ValEnv) (vs : ValStore) (e : Exp) :
  CanTimeout (CanErr (Val * ValStore))
:=
  match n with
  | 0 =>
      none
  | S n =>
      match e with
      | e_var x =>
          some (omap (fun v => (v, vs)) (indexr x ve))
      | e_abs e =>
          some (some (v_abs ve e, vs))
      | e_app e1 e2 =>
          '(v_abs ve1' e1', vs) <- eval n ve vs e1;
          '(v2, vs) <- eval n ve vs e2;
          eval n (v2 :: ve1') vs e1'
      | e_unit =>
          some (some (v_unit, vs))
      | e_ref e =>
          '(v, vs) <- eval n ve vs e;
          some (some (v_loc (length vs), v :: vs))
      | e_get e =>
          '(v_loc l, vs) <- eval n ve vs e;
          some (omap (fun v => (v, vs)) (indexr l vs))
      | e_set e1 e2 =>
          '(v_loc l, vs) <- eval n ve vs e1;
          '(v2, vs) <- eval n ve vs e2;
          some (some (v_unit, update l v2 vs))
      end
  end.

Definition TypStore := List Typ.

Inductive WfEnv : ValEnv -> TypEnv -> TypStore -> Prop :=
  | wfe_nil :
      forall ts,
      WfEnv [] [] ts
  | wfe_cons :
      forall ts v t ve te,
      ValTyp ts v t ->
      WfEnv ve te ts  ->
      WfEnv (v :: ve) (t :: te) ts
with ValTyp : TypStore -> Val -> Typ -> Prop :=
  | vt_abs :
      forall ts ve te e t1 t2,
      WfEnv ve te ts ->
      ExpTyp (t1 :: te) e t2 ->
      ValTyp ts (v_abs ve e) (t_arr t1 t2)
  | vt_unit :
      forall ts,
      ValTyp ts v_unit t_unit
  | vt_loc :
      forall ts l t,
      indexr l ts = some t ->
      ValTyp ts (v_loc l) (t_ref t)
  .

Definition WfStore (vs : ValStore) (ts : TypStore) : Prop :=
  Forall2 (ValTyp ts) vs ts.

Definition SubStore (ts1 ts2 : TypStore) : Prop :=
  exists ts, ts ++ ts1 = ts2.

(** * Theorems *)

Hint Constructors Typ Exp Val ExpTyp ValTyp WfEnv Opt List.
Hint Unfold indexr length ValEnv TypEnv ValStore TypStore SubStore omap update.
Hint Resolve ex_intro.

Lemma wve_length :
  forall ve te vs,
  WfEnv ve te vs ->
  length ve = length te.
Proof.
  intros ? ? ? H. induction H.
  Case "wfe_nil". reflexivity.
  Case "wfe_cons". simpl. rewrite IHWfEnv. reflexivity.
Qed.

Hint Immediate wve_length.

Lemma index_max :
  forall X (xs : List X) (n : nat) (x : X),
  indexr n xs = some x ->
  n < length xs.
Proof.
  intros ? xs. induction xs.
  Case "nil".
    intros ? ? H. simpl in H. inversion H.
  Case "cons".
    intros ? ? H. simpl. case_eq (n =? length xs); intros E.
    Case2 "hit".
      eapply beq_nat_true in E. rewrite <- E. constructor.
    Case2 "miss".
      simpl in H. rewrite E in H. transitivity (length xs).
      - eapply IHxs. apply H.
      - constructor.
Qed.

Lemma index_extend :
  forall X xs n x' (x : X),
  indexr n xs = some x ->
  indexr n (x' :: xs) = some x.
Proof.
  intros ? ? ? ? ? H. simpl. rewrite H.
  assert (n < length xs) as H0. { eapply index_max. exact H. }
  assert (n <> length xs) as H1. { omega. }
  assert ((n =? length xs) = false) as H2. { eapply beq_nat_false_iff. exact H1. }
  rewrite H2. reflexivity.
Qed.

Lemma wve_index :
  forall ve te ts t n,
  WfEnv ve te ts ->
  indexr n te = some t ->
  exists v, indexr n ve = some v /\ ValTyp ts v t.
Proof.
  intros ? ? ? ? ? HWf Hindex. induction HWf.
  Case "wfe_nil".
    simpl in Hindex. inversion Hindex.
  Case "wfe_cons".
    simpl in Hindex. case_eq (n =? length te).
    Case2 "index hits head".
      intros Hhit. rewrite Hhit in Hindex. inversion Hindex; subst t0; clear Hindex.
      assert ((n =? length ve) = true) as Hhit'. { eauto using wve_length. }
      assert (indexr n (v :: ve) = some v). { simpl. rewrite Hhit'. reflexivity. }
      eauto.
    Case2 "index hits tail".
      intros Hmiss. rewrite Hmiss in Hindex.
      assert ((n =? length ve) = false) as Hmiss'. { eauto using wve_length. }
      specialize (IHHWf Hindex). inversion IHHWf as [v0 [H0 H1]].
      exists v0. constructor. { apply index_extend. exact H0. } { exact H1. }
Qed.

Lemma wfs_length' :
  forall vs ts ts',
  Forall2 (ValTyp ts') vs ts ->
  length vs = length ts.
Proof.
  intros until 0; intros Hwfs. induction Hwfs.
  Case "wfe_nil". reflexivity.
  Case "wfe_cons". simpl. rewrite IHHwfs. reflexivity.
Qed.

Lemma wve_index_store' :
  forall vs ts ts' t n,
  Forall2 (ValTyp ts') vs ts ->
  indexr n ts = some t ->
  exists v, indexr n vs = some v /\ ValTyp ts' v t.
Proof.
  intros until 0; intros Hwfs. induction Hwfs; intros Hindex.
  Case "wfe_nil".
    simpl in Hindex. inversion Hindex.
  Case "wfe_cons".
    simpl in Hindex. case_eq (n =? length ys).
    Case2 "index hits head".
      intros Hhit. rewrite Hhit in Hindex. inversion Hindex; subst t; clear Hindex.
      assert ((n =? length xs) = true) as Hhit'. { eauto using wfs_length'. }
      assert (indexr n (x :: xs) = some x). { simpl. rewrite Hhit'. reflexivity. }
      eauto.
    Case2 "index hits tail".
      intros Hmiss. rewrite Hmiss in Hindex.
      assert ((n =? length xs) = false) as Hmiss'. { eauto using wfs_length'. }
      specialize (IHHwfs Hindex). inversion IHHwfs as [v0 [H0 H1]].
      exists v0. constructor. { apply index_extend. exact H0. } { exact H1. }
Qed.

Lemma wfs_length :
  forall vs ts,
  WfStore vs ts ->
  length vs = length ts.
Proof.
  eauto using wfs_length'.
Qed.

Lemma wve_index_store :
  forall vs ts t n,
  WfStore vs ts ->
  indexr n ts = some t ->
  exists v, indexr n vs = some v /\ ValTyp ts v t.
Proof.
  eauto using wve_index_store'.
Qed.

Scheme wfenv_valtype_ind := Induction for WfEnv   Sort Prop
with   valtype_wfenv_ind := Induction for ValTyp Sort Prop.
Combined Scheme wfenv_valtype_mutind from wfenv_valtype_ind, valtype_wfenv_ind.
Combined Scheme valtype_wfenv_mutind from valtype_wfenv_ind, wfenv_valtype_ind.

Lemma index_substore:
  forall (l : Loc) (ts1 ts2 : TypStore) (t : Typ),
  indexr l ts1 = some t ->
  SubStore ts1 ts2 ->
  indexr l ts2 = some t.
Proof.
  intros until 0; intros Hindex Hsub.
  destruct Hsub as [ts Hsub].
  subst ts2.
  induction ts.
  - assumption.
  - simpl in *. case_eq (l =? length (ts ++ ts1)); intros.
    + eapply index_max in IHts. eapply beq_nat_true in H. omega.
    + assumption.
Qed.

Lemma valtype_wfenv_substore :
  (forall (ve : ValEnv) (te : TypEnv) (ts1 : TypStore),
   WfEnv ve te ts1 ->
   forall (ts2 : TypStore),
   SubStore ts1 ts2 ->
   WfEnv ve te ts2) /\
  (forall (ts1 : TypStore) (v : Val) (t : Typ),
   ValTyp ts1 v t ->
   forall (ts2 : TypStore),
   SubStore ts1 ts2 ->
   ValTyp ts2 v t).
Proof.
  eapply wfenv_valtype_mutind.
  - intros. econstructor.
  - intros. econstructor. eapply H.
    + exact H1.
    + eapply H0. exact H1.
  - intros. econstructor.
    + eapply H. exact H0.
    + assumption.
  - intros. econstructor.
  - intros. econstructor. eapply index_substore.
    + exact e.
    + exact H.
Qed.

Lemma valtype_substore :
  forall (v : Val) (t : Typ) (ts1 ts2 : TypStore),
  ValTyp ts1 v t ->
  SubStore ts1 ts2 ->
  ValTyp ts2 v t.
Proof.
  intros; eapply valtype_wfenv_substore; eauto.
Qed.

Lemma wfenv_substore:
  forall (te : TypEnv) (ve : ValEnv) (ts1 ts2 : TypStore),
  WfEnv ve te ts1 ->
  SubStore ts1 ts2 ->
  WfEnv ve te ts2.
Proof.
  intros; eapply valtype_wfenv_substore; eauto.
Qed.

Lemma wfstore_extend_inner:
  forall (ts ts' : TypStore) (vs : ValStore) (t : Typ),
    Forall2 (ValTyp ts') vs ts ->
    Forall2 (ValTyp (t :: ts')) vs ts.
Proof.
  induction ts; intros ts' vs t Hwfs.
  - inversion Hwfs. subst. constructor.
  - inversion Hwfs; subst.
    econstructor.
    + eapply valtype_substore.
      * eapply H2.
      * exists [t]. reflexivity.
    + eapply IHts.
      exact H3.
Qed.

Lemma wfstore_extend:
  forall (v : Val) (vs : ValStore) (t : Typ) (ts : TypStore),
  WfStore vs ts ->
  ValTyp ts v t ->
  WfStore (v :: vs) (t :: ts).
Proof.
  intros until 0; intros Hwfs Hvt.
  econstructor.
  - eapply valtype_substore.
    + exact Hvt.
    + exists [t]. reflexivity.
  - eapply wfstore_extend_inner. exact Hwfs.
Qed.

Lemma wfstore_update':
  forall (ts' ts : TypStore) (l : nat) (v : Val) (vs : ValStore) (t : Typ),
  indexr l ts = some t ->
  Forall2 (ValTyp ts') vs ts ->
  ValTyp ts' v t ->
  Forall2 (ValTyp ts') (update l v vs) ts.
Proof.
  intros until 0; intros Hindex Hwfs Hvt.
  revert Hindex Hvt.
  induction Hwfs; intros Hindex Hvt.
  - simpl. econstructor.
  -
    rename ys into ts''; rename xs into vs'; rename y into t'.
    simpl in *.
    rewrite (wfs_length' _ _ _ Hwfs).
    case_eq (l =? length ts''); intros Hlength.
    + rewrite Hlength in *.
      inversion Hindex; subst t'; clear Hindex.
      econstructor.
      * exact Hvt.
      * exact Hwfs.
    + rewrite Hlength in *.
      econstructor.
      * exact H.
      * eapply IHHwfs.
        exact Hindex.
        exact Hvt.
Qed.

Lemma wfstore_update:
  forall (l : nat) (v : Val) (vs : ValStore) (t : Typ) (ts : TypStore),
  indexr l ts = some t ->
  WfStore vs ts ->
  ValTyp ts v t ->
  WfStore (update l v vs) ts.
Proof.
  intros; eapply wfstore_update'; eauto.
Qed.

Tactic Notation "destruct_eval" constr(e) "as" "[" ident(mv) ident(Heval) "]" :=
  remember (eval _ _ _ e) as mmv eqn:Heval; symmetry in Heval;
  destruct mmv as [mv|]; [|solve by inversion].

Theorem type_soundness :
  forall n e te ve vs ts res t,
  eval n ve vs e = some res ->
  ExpTyp te e t ->
  WfStore vs ts ->
  WfEnv ve te ts ->
  exists v vs' ts',
    res = some (v, vs') /\
    WfStore vs' ts' /\
    SubStore ts ts' /\
    ValTyp ts' v t.
Proof.
  intros n. induction n.

  Case "n = 0". intros until 0. intros Heval. inversion Heval.

  Case "n = S n". intros until 0. intros Heval Htype Hwfs Hwfe. destruct e.

    Case2 "var".
      inversion Heval as [Heval']; clear Heval Heval'.
      inversion Htype; subst te0 x t1; rename H1 into Htype'.
      destruct (wve_index _ _ _ _ _ Hwfe Htype') as [v [I V]].
      rewrite I. simpl. exists v. exists vs. exists ts. intuition. apply suffix_refl.

    Case2 "app".
      inversion Htype; subst t2 e0 e3 te0;
        rename H2 into Htype1; rename H4 into Htype2; rename t into t2.

      simpl in Heval.

      destruct_eval e1 as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      (* Find out that [v1 = v_abs ve0 e]. *)
      inversion HV1; rename H3 into Hwfe3; rename H4 into Htype3; subst.

      assert (Hwfe1 : WfEnv ve te ts1). {
        eauto using wfenv_substore.
      }

      destruct_eval e2 as [mv2 Heval2].
      destruct (IHn _ _ _ _ _ _ _ Heval2 Htype2 Hwfs1 Hwfe1)
        as [v2 [vs2 [ts2 [E2 [Hwfs2 [Hss2 HV2]]]]]].
      subst mv2.

      assert (Hwfe3' : WfEnv (v2 :: ve0) (t1 :: te0) ts2). {
        eauto using wfenv_substore.
      }

      destruct (IHn _ _ _ _ _ _ _ Heval Htype3 Hwfs2 Hwfe3')
        as [v3 [vs3 [ts3 [E3 [Hwfs3 [Hss3 HV3]]]]]].

      (* whats missing for the last IHn to match the goal is [SubStore ts ts3]. *)
      assert (Hss : SubStore ts ts3). {
        eapply suffix_trans; eauto.
        eapply suffix_trans; eauto.
      }

      subst res.
      exists v3. exists vs3. exists ts3. intuition.

    Case2 "abs".
      inversion Htype; subst te0 e0. subst t.
      inversion Heval as [Heval']; clear Heval Heval'.
      exists (v_abs ve e). exists vs. exists ts.
      intuition. apply suffix_refl. eapply vt_abs; eauto.

    Case2 "unit".
      inversion Htype; subst te0. subst t.
      inversion Heval as [Heval']; clear Heval Heval'.
      do 3 eexists. intuition eauto. apply suffix_refl.

    Case2 "ref".
      inversion Htype; subst te0 e0. subst t. rename H1 into Htype1.
      simpl in Heval.

      destruct_eval e as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      inversion Heval; clear Heval; subst res.
      exists (v_loc (length vs1)). exists (v1 :: vs1). exists (t0 :: ts1).
      { intuition.
        - eauto using wfstore_extend.
        - eapply suffix_trans.
          + apply Hss1.
          + exists [t0]. reflexivity.
        - econstructor.
          simpl.
          rewrite (wfs_length _ _ Hwfs1).
          rewrite Nat.eqb_refl.
          reflexivity.
      }

    Case2 "get".
      inversion Htype; subst te0 e0. subst t. rename H1 into Htype1.
      simpl in Heval.

      destruct_eval e as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      inversion HV1; subst.
      inversion Heval; subst res.
      destruct (wve_index_store _ _ _ _ Hwfs1 H2) as [v [Hindex' HV']].
      rewrite Hindex'. simpl.
      exists v, vs1, ts1. intuition.

    Case2 "set".
      inversion Htype; subst te0 e0 e3; rename H2 into Htype1; rename H4 into Htype2.
      subst t.

      simpl in Heval.

      destruct_eval e1 as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      inversion HV1; subst ts0 t. subst v1.

      assert (Hwfe1 : WfEnv ve te ts1). {
        eauto using wfenv_substore.
      }

      destruct_eval e2 as [mv2 Heval2].
      destruct (IHn _ _ _ _ _ _ _ Heval2 Htype2 Hwfs1 Hwfe1)
        as [v2 [vs2 [ts2 [E2 [Hwfs2 [Hss2 HV2]]]]]].
      subst mv2.

      inversion Heval; subst res.
      exists v_unit, (update l v2 vs2), ts2.
      { intuition.
        - eauto using wfstore_update, index_substore.
        - eapply suffix_trans; eauto.
      }
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Import ZArith.
Require Export Znumtheory.
Require Import Tactic.
Require Import ZCAux.
Require Import Zp.
Require Import FGroup.
Require Import EGroup.
Require Import Euler.

Open Scope Z_scope.

Theorem Pocklington:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
  forall n, prime n -> (n | N) -> n mod F1 = 1.
intros N F1 R1 HF1 HR1 Neq Rec n Hn H.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite Neq; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
assert (Hn1: 1 < n); auto with zarith.
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
assert (H1: (F1 | n - 1)).
2: rewrite <- (Zmod_small 1 F1); auto with zarith.
2: case H1; intros k H1'.
2: replace n with (1 + (n - 1)); auto with zarith.
2: rewrite H1'; apply Z_mod_plus; auto with zarith.
apply Zdivide_Zpower; auto with zarith.
intros p i Hp Hi HiF1.
case (Rec p); auto.
apply Zdivide_trans with (2 := HiF1).
apply Zpower_divide; auto with zarith.
intros a (Ha1, (Ha2, Ha3)).
assert (HNn: a ^ (N - 1) mod n = 1).
apply Zdivide_mod_minus; auto with zarith.
apply Zdivide_trans with (1 := H).
apply Zmod_divide_minus; auto with zarith.
assert (~(n | a)).
intros H1; absurd (0 = 1); auto with zarith.
rewrite <- HNn; auto.
apply sym_equal; apply Zdivide_mod; auto with zarith.
apply Zdivide_trans with (1 := H1); apply Zpower_divide; auto with zarith.
assert (Hr: rel_prime a n).
apply rel_prime_sym; apply prime_rel_prime; auto.
assert (Hz: 0 < Zorder a n).
apply Zorder_power_pos; auto.
apply Zdivide_trans with (Zorder a n).
apply prime_divide_Zpower_Zdiv with (N - 1); auto with zarith.
apply Zorder_div_power; auto with zarith.
intros H1; absurd (1 < n); auto; apply Zle_not_lt; apply Zdivide_le; auto with zarith.
rewrite <- Ha3; apply Zdivide_Zgcd; auto with zarith.
apply Zmod_divide_minus; auto with zarith.
case H1; intros t Ht; rewrite Ht.
assert (Ht1: 0 <= t).
apply Zmult_le_reg_r with (Zorder a n); auto with zarith.
rewrite Zmult_0_l; rewrite <- Ht.
apply Zge_le; apply Z_div_ge0; auto with zarith.
apply Zlt_gt; apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith.
rewrite Zpower_mod; auto with zarith.
rewrite Zorder_power_is_1; auto with zarith.
rewrite Zpower_1_l; auto with zarith.
apply Zmod_small; auto with zarith.
apply Zdivide_trans with (1:= HiF1); rewrite Neq; apply Zdivide_factor_r.
apply Zorder_div; auto.
Qed.

Theorem PocklingtonCorollary1:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> N < F1 * F1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
   prime N.
intros N F1 R1 H H1 H2 H3 H4; case (prime_dec N); intros H5; auto.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite H2; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
case Zdivide_div_prime_le_square with (2:= H5); auto with zarith.
intros n (Hn, (Hn1, Hn2)).
assert (Hn3: 0 <= n).
apply Zle_trans with 2; try apply prime_ge_2; auto with zarith.
absurd (n = 1).
intros H6; contradict Hn; subst; apply not_prime_1.
rewrite <- (Zmod_small n F1); try split; auto.
apply Pocklington with (R1 := R1) (4 := H4); auto.
apply Zlt_square_mult_inv; auto with zarith.
Qed.

Theorem PocklingtonCorollary2:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 ->
   (forall p,  prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
  forall n, 0 <= n -> (n | N) -> n mod F1 = 1.
intros N F1 R1 H1 H2 H3 H4 n H5; pattern n; apply prime_induction; auto.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite H3; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
intros (u, Hu); contradict HN; subst; rewrite Zmult_0_r; auto with zarith.
intro H6; rewrite Zmod_small; auto with zarith.
intros p q Hp Hp1 Hp2; rewrite Zmult_mod; auto with zarith.
rewrite Pocklington with (n := p) (R1 := R1) (4 := H4); auto.
rewrite Hp1.
rewrite Zmult_1_r; rewrite Zmod_small; auto with zarith.
apply Zdivide_trans with (2 := Hp2); apply Zdivide_factor_l.
apply Zdivide_trans with (2 := Hp2); apply Zdivide_factor_r; auto.
Qed.

Definition isSquare x := exists y, x = y * y.

Theorem PocklingtonExtra:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> Zeven F1 -> Zodd R1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
   forall m, 1 <= m ->  (forall l, 1 <= l < m -> ~((l * F1 + 1) | N)) ->
    let s := (R1 / (2 * F1)) in
    let r := (R1 mod (2 * F1)) in
      N < (m * F1 + 1) * (2 * F1 * F1 + (r - m) * F1 + 1) ->
      (s = 0 \/ ~ isSquare (r * r - 8 * s)) -> prime N.
intros N F1 R1 H1 H2 H3 OF1 ER1 H4 m H5 H6 s r H7 H8.
case (prime_dec N); auto; intros H9.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite H3; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
case  Zdivide_div_prime_le_square with N; auto.
intros X (Hx1, (Hx2, Hx3)).
assert (Hx0: 1 < X).
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
pose (c := (X /  F1)).
assert(Hc1: 0 <= c); auto with zarith.
apply Zge_le; unfold c; apply Z_div_ge0; auto with zarith.
assert (Hc2: X = c * F1 + 1).
rewrite (Z_div_mod_eq X F1); auto with zarith.
eq_tac; auto.
rewrite (Zmult_comm F1); auto.
apply PocklingtonCorollary2 with (R1 := R1) (4 := H4); auto with zarith.
case Zle_lt_or_eq with (1 := Hc1); clear Hc1; intros Hc1.
2: contradict Hx0; rewrite Hc2; try rewrite <- Hc1; auto with zarith.
case (Zle_or_lt m c); intros Hc3.
2: case Zle_lt_or_eq with (1 := H5); clear H5; intros H5; auto with zarith.
2: case (H6 c); auto with zarith; rewrite <- Hc2; auto.
2: contradict Hc3; rewrite <- H5; auto with zarith.
pose (d := ((N / X) /  F1)).
assert(Hd0: 0 <= N / X); try apply Z_div_pos; auto with zarith.
(*
apply Zge_le; unfold d; repeat apply Z_div_ge0; auto with zarith.
*)
assert(Hd1: 0 <= d); auto with zarith.
apply Zge_le; unfold d; repeat apply Z_div_ge0; auto with zarith.
assert (Hd2: N / X =  d * F1 + 1).
rewrite (Z_div_mod_eq (N / X) F1); auto with zarith.
eq_tac; auto.
rewrite (Zmult_comm F1); auto.
apply PocklingtonCorollary2 with (R1 := R1) (4 := H4); auto with zarith.
exists X; auto with zarith.
apply Zdivide_Zdiv_eq; auto with zarith.
case Zle_lt_or_eq with (1  := Hd0); clear Hd0; intros Hd0.
2: contradict HN; rewrite (Zdivide_Zdiv_eq X N); auto with zarith.
2: rewrite <- Hd0; auto with zarith.
case (Zle_lt_or_eq 1 (N / X)); auto with zarith; clear Hd0; intros Hd0.
2: contradict H9; rewrite (Zdivide_Zdiv_eq X N); auto with zarith.
2: rewrite <- Hd0; rewrite Zmult_1_r; auto with zarith.
case Zle_lt_or_eq with (1 := Hd1); clear Hd1; intros Hd1.
2: contradict Hd0; rewrite Hd2; try rewrite <- Hd1; auto with zarith.
case (Zle_or_lt m d); intros Hd3.
2: case Zle_lt_or_eq with (1 := H5); clear H5; intros H5; auto with zarith.
2: case (H6 d); auto with zarith; rewrite <- Hd2; auto.
2: exists X; auto with zarith.
2: apply Zdivide_Zdiv_eq; auto with zarith.
2: contradict Hd3; rewrite <- H5; auto with zarith.
assert (L5: N = (c * F1 + 1) * (d * F1 + 1)).
rewrite <- Hc2; rewrite <- Hd2; apply Zdivide_Zdiv_eq; auto with zarith.
assert (L6: R1 = c * d * F1 + c + d).
apply trans_equal with ((N - 1) / F1).
rewrite H3; rewrite Zmult_comm; apply sym_equal; apply Z_div_mult; auto with zarith.
rewrite L5.
match goal with |- (?X / ?Y = ?Z) => replace X with (Z * Y) end; try ring; apply Z_div_mult; auto with zarith.
assert (L6_1: Zodd (c + d)).
case (Zeven_odd_dec (c + d)); auto; intros O1.
contradict ER1; apply Zeven_not_Zodd; rewrite L6; rewrite <- Zplus_assoc; apply Zeven_plus_Zeven; auto.
apply Zeven_mult_Zeven_r; auto.
assert (L6_2: Zeven (c * d)).
case (Zeven_odd_dec c); intros HH1.
apply Zeven_mult_Zeven_l; auto.
case (Zeven_odd_dec d); intros HH2.
apply Zeven_mult_Zeven_r; auto.
contradict L6_1; apply Zeven_not_Zodd; apply Zodd_plus_Zodd; auto.
assert ((c + d) mod (2 * F1) = r).
rewrite <- Z_mod_plus with (b := Zdiv2 (c * d)); auto with zarith.
match goal with |- ?X mod _ = _ => replace X with R1 end; auto.
rewrite L6; pattern (c * d) at 1.
rewrite Zeven_div2 with (1 := L6_2); ring.
assert (L9: c + d - r < 2 * F1).
apply Zplus_lt_reg_r with (r - m).
apply Zmult_lt_reg_r with (F1); auto with zarith.
apply Zplus_lt_reg_r with 1.
match goal with |-  ?X < ?Y =>
  replace Y with (2 * F1 * F1 + (r - m) * F1 + 1); try ring;
  replace X with ((((c + d) - m) * F1) + 1); try ring
end.
apply Zmult_lt_reg_r with (m * F1 + 1); auto with zarith.
apply Zlt_trans with (m * F1 + 0); auto with zarith.
rewrite Zplus_0_r; apply Zmult_lt_O_compat; auto with zarith.
repeat rewrite (fun x => Zmult_comm x (m * F1 + 1)).
apply Zle_lt_trans with (2 := H7).
rewrite L5.
match goal with |-  ?X <= ?Y =>
  replace X with ((m * (c + d) - m * m ) * F1 * F1 + (c + d) * F1 + 1); try ring;
  replace Y with ((c * d) * F1 * F1 + (c + d) * F1 + 1); try ring
end.
repeat apply Zplus_le_compat_r.
repeat apply Zmult_le_compat_r; auto with zarith.
assert (tmp: forall p q, 0 <= p - q  -> q <= p); auto with zarith; try apply tmp.
match goal with |-  _ <= ?X =>
  replace X with ((c - m) * (d - m)); try ring; auto with zarith
end.
assert (L10: c + d = r).
apply Zmod_closeby_eq with (2 * F1); auto with zarith.
unfold r; apply Z_mod_lt; auto with zarith.
assert (L11: 2 * s  = c * d).
apply Zmult_reg_r with F1; auto with zarith.
apply trans_equal with (R1 - (c + d)).
rewrite L10; rewrite (Z_div_mod_eq R1 (2 * F1)); auto with zarith.
unfold s, r; ring.
rewrite L6; ring.
case H8; intro H10.
absurd (0 < c * d); auto with zarith.
apply Zmult_lt_O_compat; auto with zarith.
case H10; exists (c - d); auto with zarith.
rewrite <- L10.
replace (8 * s) with (4 * (2 * s)); auto with zarith; try rewrite L11; ring.
Qed.

Theorem PocklingtonExtraCorollary:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> Zeven F1 -> Zodd R1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
    let s := (R1 / (2 * F1)) in
    let r := (R1 mod (2 * F1)) in
      N < 2 * F1 * F1 * F1 ->  (s = 0 \/ ~ isSquare (r * r - 8 * s)) -> prime N.
intros N F1 R1 H1 H2 H3 OF1 ER1 H4 s r H5 H6.
apply PocklingtonExtra with (6 := H4) (R1 := R1) (m := 1); auto with zarith.
apply Zlt_le_trans with (1 := H5).
match goal with |-  ?X <= ?K * ((?Y + ?Z) + ?T) =>
    rewrite <- (Zplus_0_l X);
   replace (K * ((Y + Z) + T)) with ((F1 * (Z + T) +  Y + Z + T) + X);[idtac | ring]
end.
apply Zplus_le_compat_r.
case (Zle_lt_or_eq 0 r); unfold r; auto with zarith.
case (Z_mod_lt R1 (2 * F1)); auto with zarith.
intros HH; repeat ((rewrite <- (Zplus_0_r 0); apply Zplus_le_compat)); auto with zarith.
intros HH; contradict ER1; apply Zeven_not_Zodd.
rewrite (Z_div_mod_eq R1 (2 * F1)); auto with zarith.
rewrite <- HH; rewrite Zplus_0_r.
rewrite <- Zmult_assoc; apply Zeven_2p.
Qed.


Require Import SF_spec.
Require Import RelDec.
Require Import List.
Require Import Sorting.
Require Import Orders.
Require Import Compare_dec.
Require Import Coq.Numbers.BinNums.
Require Import Coq.NArith.BinNat.
Import ListNotations.

Section candidate.

Local Open Scope N_scope.

Variable candidate : Set.
Variable reldec_candidate : RelDec (@eq candidate).

Definition rankSelection := rankSelection candidate.
Definition ballot := ballot candidate.

(** A record of an election will be a list of the candidates that are eliminated
in each step *)
Definition record := list (list candidate).

(** a ballot
shall be deemed "exhausted," and not counted in further stages of the
tabulation, if all of the choices have been eliminated or there are no
more choices indicated on the ballot. If a ranked-choice ballot gives
equal rank to two or more candidates, the ballot shall be declared
exhausted when such multiple rankings are reached. *)

Definition eliminated (rec : record) (cand : candidate) : bool :=
  existsb (existsb (eq_dec cand)) rec.

Definition no_viable_candidates_selection (rec : record) (sel : rankSelection) : bool :=
  forallb (eliminated rec) sel.

Definition no_viable_candidates (rec : record) (bal : ballot) : bool :=
  forallb (no_viable_candidates_selection rec) bal.

Fixpoint next_ranking (rec : record) (bal : ballot) : option (candidate * ballot) :=
match bal with
| [] :: t => next_ranking rec t
| (h :: l) :: t => if (forallb (eq_dec h) l) then
                     if (eliminated rec h) then next_ranking rec t else Some (h, bal)
                   else  None
| [] => None
end.

Fixpoint drop_none {A} (l : list (option A)) :=
match l with
| None :: t => drop_none t
| Some x :: t => x::drop_none t
| [] => [] : list A
end.

Fixpoint increment (r : list (candidate * N)) (c : candidate) :=
match r with
| (c1, n) :: t => if (eq_dec c1 c) then (c1, (n + 1)) :: t else (c1, n) :: increment t c
| nil => [(c, 1)]
end.

Fixpoint tabulate'' (rs : list (option candidate)) lc: list (candidate * N) :=
match rs with
| (Some h) :: t => tabulate'' t (increment lc h)
| None :: t => tabulate'' t lc
| nil => lc
end.

Definition tabulate' (rs : list (option candidate)) :=
tabulate'' rs nil.

Definition cnle (a b : (candidate * N)) : bool :=
match a, b with
(_, n1), (_, n2) => N.leb n1 n2
end.

Fixpoint insert {A} (cmp : A -> A -> bool) (i : A) (l : list A) :=
match l with
| h :: t => if (cmp i h) then i :: l else h :: (insert cmp i t)
| _ => [i]
end.

Fixpoint insertionsort' {A} (cmp : A -> A -> bool) (l : list A) (srtd : list A) :=
match l with
| h :: t => insertionsort' cmp t (insert cmp h srtd)
| [] => srtd
end.

Definition insertionsort {A} (cmp : A-> A -> bool) (l : list A) := insertionsort' cmp l nil.

Definition election := list ballot.

Fixpoint option_split {A B : Type} (l : list (option (A * B))) :=
match l with
| nil => (nil, nil)
| (Some (a, b)) :: t => let (l1, l2) := option_split t in ((Some a :: l1), (Some b :: l2))
| None :: t => let (l1, l2) := option_split t in ((None :: l1), ( None :: l2))
end.

(** Here we count the number of votes for each candidate, returning a sorted
    list of (candidate, number of votes). It also returns an election, where any
    exhausted ballots are removed. *)
Definition tabulate (rec : record) (elect : election) : ((list (candidate * N) * election)) :=
let get_candidates := (map (next_ranking rec) elect) in
let (next_ranks, next_election) := option_split (get_candidates) in
let counts := tabulate' next_ranks in
let sorted_ranks := insertionsort cnle counts in
(sorted_ranks, drop_none next_election).

Definition gtb_N (a b : N) : bool:=
negb (N.leb a b).

Require Import Omega.

Lemma gtb_nat_gt : forall a b,
gtb_N a b = true <-> a > b.
unfold gtb_N in *.
intros.
destruct ( a <=? b) eqn:?; intuition; try discriminate.
 - rewrite N.leb_le in Heqb0. exfalso. apply N.gt_lt in H.
   rewrite N.lt_eq_cases in Heqb0.
   destruct Heqb0. apply N.lt_asymm in H. auto. subst.
   apply N.lt_irrefl in H. auto.
 - rewrite N.leb_gt in Heqb0. clear H. apply N.gt_lt_iff. auto.
Qed.

(* assumes a list sorted by votes *)
Definition get_bottom_votes (votes : list (candidate * N)) :=
match votes with
| (c, v) :: t => map (@fst _ _) (filter (fun (x : candidate * N) => let (_, v') := x in
                                  N.eqb v v') votes)
| nil => nil
end.

Variable break_tie : list candidate -> option candidate.

(*
(* This expects a list of candidates sorted ascending in number of votes *)
Fixpoint find_eliminated' (eliminated : list candidate) (votes : list (candidate * N)) (sum : N) :=
  match votes with
  | (cand, count) :: t =>
    match t with
    |  (cand2, count2) :: _ =>
       let newsum := sum + count in
       if (N.ltb (newsum) count2) then
         find_eliminated' (cand :: eliminated)
                          t sum
       else
         match eliminated with
         | nil => match break_tie (get_bottom_votes votes) with
                  | Some l => [l]
                  | None => nil
                  end
         | _ => eliminated
         end
    | _ => eliminated
    end
  | _ => eliminated
  end.

Definition find_eliminated votes :=
  find_eliminated' [] votes 0.
*)

Definition find_eliminated_noopt votes :=
  match break_tie (get_bottom_votes votes) with
    | Some c => Some [c]
    | None => None
  end.

Fixpoint last_item votes : option (candidate * N) :=
match votes with
| h :: [] => Some h
| [] => None
| h :: t => last_item t
end.

Fixpoint run_election' (elect : election) (rec : record) (fuel : nat) :  (option candidate * record * list (list (candidate * N))) :=
match fuel with
| S n' => let (ranks, elect') := (tabulate rec elect) in
          let win_threshhold := N.of_nat (length elect')  in
          (* here we use elect' because exhausted ballots have been removed *)
          match last_item ranks with
          | Some (cand1, cand1_votes)  =>
            if (gtb_N (cand1_votes * 2) (win_threshhold)) then
              (Some cand1, rec, ranks::nil)
            else
              match (find_eliminated_noopt ranks) with
              | Some el =>
                match (run_election' elect (el :: rec) n') with
                | (c, r, t) => (c, r, ranks :: t)
                end
              | None => (None, rec, nil)
              end
          | None => (None, rec, nil)
          end
| _ => (None, rec, nil)
end.

Definition find_0s (all_candidates : list candidate) (el : election) :=
let get_candidates := (map (next_ranking nil) el) in
let (next_ranks, _) := option_split (get_candidates) in
let initial := map (fun x => (x, 0)) all_candidates in
let counts := tabulate'' next_ranks initial in
map (@fst _ _) (filter (fun (x : candidate * N) => let (_, ct) := x in N.eqb ct 0) counts).

Definition run_election elect all_candidates :=
let initial_selected := drop_none (fst (option_split (map (next_ranking nil) elect))) in
run_election' elect ([find_0s all_candidates elect]) (length elect).

End candidate.

Global Instance RelDec_eq : RelDec (@eq nat) :=
{ rel_dec := EqNat.beq_nat }.

Global Instance RelDec_lt : RelDec lt :=
{ rel_dec := NPeano.ltb }.

Global Instance RelDec_le : RelDec le :=
{ rel_dec := NPeano.leb }.

Global Instance RelDec_gt : RelDec gt :=
{ rel_dec := fun x y => NPeano.ltb y x }.

Global Instance RelDec_ge : RelDec ge :=
{ rel_dec := fun x y => NPeano.leb y x }.

Definition nat_tabulate := tabulate nat _.

Definition ballot1 : (ballot nat) :=
[[3]; [2]; [1]; [0]].

Definition ballot2 : (ballot nat) :=
[[2]; [1]; [3]; [0]].

Definition ballot3 : (ballot nat) := ballot1.

Definition ballot4 :=
[[0]; [1]].

Fixpoint repeat_append {A : Type} (l : list A) (n : nat) : list A :=
match n with
| O => nil
| S n' => l ++ (repeat_append l n')
end.

Definition election1 :=
[ballot1;
 ballot2;
 ballot3;
 ballot4].

Definition election2 := repeat_append election1 1000.

(*Compute (nat_tabulate nil (election1)).*)

Definition tiebreak (l : list nat) :=
match l with
| h :: t => Some h
| _ => None
end.

(*
Extract Inductive bool => bool [ true false ].
Extract Inductive option => option [ Some None ].
Extract Inductive unit => unit [ "()" ].
Extract Inductive list => list [ "[]" "( :: )" ].
Extract Inductive prod => "( * )" [ "" ].
Extract Inductive sumbool => bool [ true false ].
Extract Inductive sumor => option [ Some None ].

Extraction "sf_imp.ml" run_election. *)

(*
Extraction Language Haskell.

Unset Extraction KeepSingleton.
Set Extraction AutoInline.
Set Extraction Optimize.
Set Extraction AccessOpaque.

Extract Inductive unit    => "()" [ "()" ].
Extract Inductive bool    => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sumbool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sum     => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ].
Extract Inductive list    => "[]" ["[]" "(:)"].
Extract Inductive prod    => "(,)" ["(,)"].
Extract Inductive sigT    => "(,)" ["(,)"].
Extract Inductive option  => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Inductive sumor   => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].

Extraction "extracted/sf_imp.hs" run_election.
*)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Keys for environment signature.
**************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibList TLC.LibLogic TLC.LibNat TLC.LibEpsilon TLC.LibReflect TLC.LibFset.
Require Export LibKeyType.

Module VarKey <: KeyType.

Definition key := nat.

Lemma key_inhab : Inhab key.
Proof using. apply (prove_Inhab 0). Qed.

Lemma key_comp : Comparable key.
Proof using. apply nat_comparable. Qed.

Instance key_comparable : Comparable key := key_comp.

Definition keys := fset key.

Definition key_gen_list (l : list nat) :=
  1 + fold_right plus O l.

Lemma key_gen_list_spec : forall n l,
  n \in from_list l -> n < key_gen_list l.
Proof using.
  unfold key_gen_list. induction l; introv I.
  rewrite from_list_nil in I. false (in_empty_elim I).
  rewrite from_list_cons in I. rew_list.
   rewrite in_union in I. destruct I as [H|H].
     rewrite in_singleton in H. subst. nat_math.
     specializes IHl H. nat_math.
Qed.

Definition key_gen (E : keys) : key :=
  key_gen_list (epsilon (fun l => E = from_list l)).

Lemma key_gen_spec : forall E, (key_gen E) \notin E.
Proof using.
  intros. unfold key_gen. spec_epsilon as l.
  applys fset_finite. rewrite Hl. introv H.
  forwards M: key_gen_list_spec H. nat_math.
Qed.

Lemma key_fresh : forall (L : keys), { x : key | x \notin L }.
Proof using. intros L. exists (key_gen L). apply key_gen_spec. Qed.

Hint Extern 1 (fresh _ _ _ _) => simpl.
Lemma key_freshes : forall L n,
  { xs : list key | fresh key L n xs }.
Proof using.
 intros. gen L. induction n; intros L.
  exists* (nil : list key).
  destruct (key_fresh L) as [x Fr].
   destruct (IHn (L \u \{x})) as [xs Frs].
   exists* (x::xs).
Qed.

End VarKey.


Require Export Sets_Existence.

(* ORDERED PAIRS: RELATIONS *)

Module OrderedP.

(* 48 Definition  [x,y] = [[x]|[x|y]] *)

Definition Ordered x y : Class := [ [x] | [x|y]].

Notation "[ x , y ]" := (Ordered x y) (at level 0).

Hint Unfold Ordered : set.

(* 49 Theorem  [x,y] is a set if and only if x is a set and y is a set;
   if [x,y] is not a set, then [x,y] = μ. *)

Theorem ord_set : forall (x y: Class),
  Ensemble [x,y] <-> Ensemble x /\ Ensemble y.
Proof.
  intros; split; intro.
  - unfold Ordered in H; unfold Unordered in H.
    apply Axiom_Union' in H; destruct H; apply sing_set_inv in H.
    apply sing_set_inv in H; apply sing_set_inv in H0; split; auto.
    unfold Unordered in H0; apply Axiom_Union' in H0.
    destruct H0; apply sing_set_inv in H1; auto.
  - destruct H; unfold Ordered, Unordered; apply Axiom_Union; split.
    + apply sing_set; auto; apply sing_set; auto.
    + apply sing_set; auto; apply unord_set; auto.
Qed.

Theorem ord_set' : forall (x y: Class),
  ~ Ensemble [x,y] -> [x,y] = μ.
Proof.
  intros; generalize (ord_set x y); intros.
  apply definition_not with (B:= Ensemble x /\ Ensemble y) in H; try tauto.
  apply not_and_or in H; apply unord_notset in H; auto.
  generalize universe_notset; intros; rewrite <-H in H1.
  unfold Ordered; apply unord_notset; auto.
Qed.

Hint Resolve ord_set ord_set' : set.

(* 50 Theorem  If x and y are sets, then ∪[x,y]=[x|y], ∩[x,y]=[x], ∪∩[x,y]=x,
   ∩∩[x,y]=x, ∪∪[x,y]=x∪y, ∩∪[x,y]=x∩y. If either x or y is not a set,
   then ∪∩[x,y]=Φ, ∩∩[x,y]=Φ, ∪∪[x,y]=Φ, ∩∪[x,y]=Φ. *)

Lemma lem_set_ele_orde : forall (x y: Class),
  Ensemble x /\ Ensemble y -> Ensemble [x] /\ Ensemble [x | y].
Proof.
  intros; apply ord_set in H; auto.
  unfold Ordered in H; unfold Unordered in H.
  apply Axiom_Union' in H; destruct H.
  apply sing_set_inv in H; auto.
  apply sing_set_inv in H0; auto.
Qed.

Theorem set_ele_orde : forall (x y: Class),
  Ensemble x /\ Ensemble y -> (∪[x,y] = [x|y]) /\ (∩[x,y] = [x]) /\
  (∪(∩[x,y]) = x) /\ (∩(∩[x,y]) = x) /\ (∪(∪[x,y]) = x∪y) /\ (∩(∪[x,y]) = x∩y).
Proof.
  intros; elim H; intros.
  repeat unfold Ordered; apply lem_set_ele_orde in H.
  apply unord_ele in H; auto; elim H; intros; repeat split.
  - rewrite H3; apply Axiom_Extent; split; intros; try (apply bel_union; tauto).
    apply bel_union in H4; destruct H4; auto; apply bel_union; tauto.
  - rewrite H2; apply Axiom_Extent; split; intros.
    + apply bel_inter in H4; apply H4.
    + apply bel_inter; split; auto; apply bel_union; tauto.
  - rewrite H2; apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H4; destruct H4, H5, H5.
      apply bel_inter in H6; destruct H6; apply Axiom_Scheme in H6.
      destruct H6; rewrite <- H8; auto.
      apply bel_universe_set; auto.
    + apply Axiom_Scheme; split; Ens; exists x.
      split; auto; apply bel_inter; split.
      * apply Axiom_Scheme; split; auto.
      * apply bel_union; left; apply Axiom_Scheme.
        split; try apply H0; trivial.
  - rewrite H2; apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H4; destruct H4.
      apply H5; apply bel_inter; split.
      * apply Axiom_Scheme; split; auto.
      * apply bel_union; left; apply Axiom_Scheme; split; auto.
    + apply Axiom_Scheme; split; Ens.
      intros; apply bel_inter in H5. destruct H5.
      apply Axiom_Scheme in H5. destruct H5. rewrite H7; auto.
      apply bel_universe_set; auto.
  - rewrite H3; apply Axiom_Extent; split; intros.
    + apply bel_union; apply Axiom_Scheme in H4; destruct H4, H5, H5.
      apply bel_union in H6; destruct H6.
      * apply Axiom_Scheme in H6; destruct H6; left; rewrite <- H7; auto.
        apply bel_universe_set; auto.
      * apply bel_union in H6; destruct H6.
        -- apply Axiom_Scheme in H6; destruct H6.
           left; rewrite <- H7; auto; apply bel_universe_set; auto.
        -- apply Axiom_Scheme in H6; destruct H6.
           right; rewrite <- H7; auto; apply bel_universe_set; auto.
    + apply Axiom_Scheme; apply bel_union in H4; split.
      * unfold Ensemble; destruct H4; Ens.
      * destruct H4.
        -- exists x; split; auto; apply bel_union; left.
           apply Axiom_Scheme; split; auto.
        -- exists y; split; auto; apply bel_union; right.
           apply bel_union; right; apply Axiom_Scheme; split; auto.
  - rewrite H3; apply Axiom_Extent; split; intros.
    + apply Lemma_x in H4; elim H4; intros.
      apply Axiom_Scheme in H5; apply Axiom_Scheme in H6.
      destruct H4; apply bel_inter; split; auto.
      * apply H5; apply bel_union; left.
        apply Axiom_Scheme; split; auto.
      * apply H6; apply bel_union; right.
        apply bel_union; right.
        apply Axiom_Scheme; split; auto.
    + apply bel_inter in H4; destruct H4.
      apply Axiom_Scheme; split; Ens.
      intros; apply bel_union in H6; destruct H6.
      * apply Axiom_Scheme in H6; destruct H6; rewrite H7; auto.
        apply bel_universe_set; auto.
      * apply Axiom_Scheme in H6; destruct H6, H7.
        -- apply Axiom_Scheme in H7; destruct H7.
           rewrite H8; auto; apply bel_universe_set; auto.
        -- apply Axiom_Scheme in H7; destruct H7.
           rewrite H8; auto; apply bel_universe_set; auto.
Qed.

Lemma lem_set_ele_orde' : forall (x y: Class),
  ~Ensemble x \/ ~Ensemble y -> ~Ensemble [x] \/ ~Ensemble [x | y].
Proof.
  intros; elim H; intros.
  - left; apply sing_eq_universe_iff_not_set in H0; auto.
    rewrite H0; apply universe_notset; auto.
  - right; apply unord_notset in H; auto.
    rewrite H; apply universe_notset; auto.
Qed.

Theorem set_ele_orde' : forall (x y: Class),
  ~Ensemble x \/ ~Ensemble y -> (∪(∩[x,y]) = Φ) /\ (∩(∩[x,y]) = μ)
  /\ (∪(∪[x,y]) = μ) /\ (∩(∪[x,y]) = Φ).
Proof.
  intros; apply lem_set_ele_orde' in H; auto.
  apply unord_ele_not in H; destruct H.
  repeat unfold Ordered; repeat split.
  - rewrite H; apply zero_eleU_zero; auto.
  - rewrite H; apply zero_eleI_universe; auto.
  - rewrite H0; rewrite <- universe_eleU; auto.
  - rewrite H0; rewrite <- universe_eleI; auto.
Qed.

Hint Resolve set_ele_orde set_ele_orde' : set.

(* 51 Definition  1st coord z = ∩∩z. *)

Definition First z := ∩∩z.

Hint Unfold First : set.

(* 52 Definition  2nd coord z = (∩∪z)∪(∪∪z)~(∪∩z). *)

Definition Second z := (∩∪z)∪(∪∪z)~(∪∩z).

Hint Unfold Second : set.

(* 53 Theorem  2nd coord μ = μ. *)

Lemma universe_diff_zero : μ ~ Φ = μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply bel_inter in H; destruct H; auto.
  - apply bel_inter; split; auto.
    apply Axiom_Scheme; split.
    * apply bel_universe_set in H; auto.
    * apply not_bel_zero; auto.
Qed.

Theorem snd_U : Second μ = μ.
Proof.
  intros; unfold Second.
  repeat rewrite <-universe_eleU; auto.
  repeat rewrite <-universe_eleI ; auto.
  rewrite zero_eleU_zero; auto.
  rewrite universe_diff_zero; auto.
  apply universe_union; auto.
Qed.

Hint Rewrite snd_U : set.

(* 54 Theorem  If x and y are sets, 1st coord [x,y] = x and 2nd coord [x,y] = y.
   If either of x and y is not a set, then 1st coord [x,y] = μ and
   2nd coord [x,y] = μ. *)

Lemma union_diff : forall (x y: Class),
  (x ∪ y) ~ x = y ~ x.
Proof.
  intros.
  apply Axiom_Extent; split; intros.
  - apply bel_inter in H; apply bel_inter.
    destruct H; apply bel_union in H; split; auto.
    destruct H; auto; apply Axiom_Scheme in H0.
    destruct H0; elim H1; auto.
  - apply bel_inter in H; apply bel_inter.
    destruct H; split; auto.
    apply bel_union; tauto.
Qed.

Theorem ordere_fst_snd : forall (x y: Class),
  Ensemble x /\ Ensemble y -> First [x,y] = x /\ Second [x,y] = y.
Proof.
  intros; apply set_ele_orde in H; auto; split.
  - unfold First; apply H.
  - destruct H, H0, H1, H2, H3; unfold Second.
    rewrite H4; rewrite H3; rewrite H1.
    rewrite union_diff; auto; unfold Difference.
    rewrite inter_com; auto; rewrite <- union_dist; auto.
    rewrite Property_μ; auto; rewrite universe_inter; auto.
Qed.

Theorem not_ordere_fst_snd : forall (x y: Class),
  ~Ensemble x \/ ~Ensemble y -> First [x,y] = μ /\ Second [x,y] = μ.
Proof.
  intros; apply set_ele_orde' in H; auto; split.
  - unfold First; apply H.
  - destruct H, H0, H1; unfold Second.
    rewrite H2; rewrite H1; rewrite H.
    rewrite universe_diff_zero; auto.
    apply universe_union; auto.
Qed.

Hint Resolve ordere_fst_snd not_ordere_fst_snd : set.

(* 55 Theorem  If x and y are sets and [x,y] = [u,v], then x=u and y=v. *)

Theorem ord_eq : forall (x y u v: Class),
  Ensemble x /\ Ensemble y -> ([x,y] = [u,v] <-> x = u /\ y = v).
Proof.
  intros; split; intros.
  - double H; apply ord_set in H; apply ordere_fst_snd in H1; destruct H1.
    rewrite H0 in H, H1, H2; apply ord_set in H; apply ordere_fst_snd in H.
    destruct H; rewrite H1 in H; rewrite H2 in H3; split; auto.
  - destruct H0; rewrite H0, H1; auto.
Qed.

Hint Resolve ord_eq : set.

(* 56 Definition  r is a relation if and only if for each member z of r there
   is x and y such that z = [x,y]. *)

Definition Relation r : Prop :=
  forall z, z∈r -> exists x y, z = [x,y].

Hint Unfold Relation: set.

(* II Classification axiom-scheme  For each b, b ∈ { a : A } if and only if
   b is a set and B. *)

(* { [x,y] : ... }  If the member is a ordered pair, then { [x,y] : ... } is
   used. The definition of { [x,y] : ... } is to avoid excessive notation. We
   agree that { [x,y] : ... } is to be identical with { u : for some x, some y,
   u = (x,y) and ... }. *)

Parameter Classifier_P : (Class -> Class -> Prop) -> Class.

Notation "\{\ P \}\" := (Classifier_P P) (at level 0).

Axiom Axiom_SchemeP : forall (a b: Class) (P: Class -> Class -> Prop),
  [a,b] ∈ \{\ P \}\ <-> Ensemble [a,b] /\ (P a b).

Axiom Property_P : forall (z: Class) (P: Class -> Class -> Prop),
  z ∈ \{\ P \}\ -> (exists a b, z = [a,b]) /\ z ∈ \{\ P \}\.

Ltac PP H a b := apply Property_P in H; destruct H as [[a [b H]]];
  rewrite H in *.

Hint Resolve Axiom_SchemeP Property_P : set.

(* 57 Definition  r ∘ s = { [x,z] : for some y, [x,y]∈s and [y,z]∈r }. *)

Definition Composition r s : Class :=
 \{\ λ x z, exists y, [x,y]∈s /\ [y,z]∈r \}\.

Notation "r ∘ s" := (Composition r s) (at level 50, no associativity).

(* r∘s = {u : for some x, some y and some z, u=[x,z], [x,y]∈s and [y,z]∈r}. *)

Definition Composition' r s : Class :=
  \{ λ u, exists x y z, u = [x,z] /\ [x,y] ∈ s /\ [y,z] ∈ r \}.

Hint Unfold Composition Composition' : set.

(* 58 Theorem  (r∘s)∘t = r∘(s∘t). *)

Theorem compo_ass : forall (r s t: Class),
  (r ∘ s) ∘ t = r ∘ (s ∘ t).
Proof.
  intros; apply Axiom_Extent; split; intros.
  - PP H a b. apply Axiom_SchemeP in H0; destruct H0, H1 as [y H1], H1.
    apply Axiom_SchemeP in H2; destruct H2, H3, H3.
    apply Axiom_SchemeP; split; auto.
    exists x; split; try tauto; apply Axiom_SchemeP; split; Ens.
    AssE [a,y]; AssE [y,x]; apply ord_set in H5; apply ord_set in H6.
    destruct H5, H6; apply ord_set; auto.
  - PP H a b; apply Axiom_SchemeP in H0; destruct H0, H1 as [y H1], H1.
    apply Axiom_SchemeP in H1; destruct H1, H3, H3.
    apply Axiom_SchemeP; split; auto.
    exists x; split; auto; apply Axiom_SchemeP; split; Ens.
    AssE [a,x]; AssE [y,b]; apply ord_set in H5; apply ord_set in H6.
    destruct H5, H6; apply ord_set; Ens.
Qed.

Hint Rewrite compo_ass : set.

(* 59 Theorem  r∘(s∪t) = r∘s ∪ r∘t and r∘(s∩t) ⊂ r∘s ∩ r∘t. *)

Theorem rel_compo : forall (r s t: Class),
  Relation r /\ Relation s -> r ∘ (s ∪ t) = (r ∘ s) ∪ (r ∘ t) /\
  r ∘ (s ∩ t) ⊂ (r ∘ s) ∩ (r ∘ t).
Proof.
  intros; split.
  - apply Axiom_Extent; split; intros.
    + PP H0 a b; apply Axiom_SchemeP in H1; destruct H1.
      apply bel_union.
      destruct H2 as [y H2]; destruct H2.
      apply bel_union in H2; destruct H2.
      * left; apply Axiom_SchemeP; split; auto.
        exists y; split; auto.
      * right; apply Axiom_SchemeP; split; auto.
        exists y; split; auto.
    + apply bel_union in H0; destruct H0; PP H0 a b; apply Axiom_SchemeP.
      * apply Axiom_SchemeP in H1; destruct H1.
        destruct H2 as [y H2]; destruct H2; split; auto.
        exists y; split; auto; apply bel_union; try tauto.
      * apply Axiom_SchemeP in H1; destruct H1.
        destruct H2 as [y H2]; destruct H2; split; auto.
        exists y; split; auto; apply bel_union; try tauto.
  - unfold Subclass; intros; PP H0 a b.
    apply Axiom_SchemeP in H1; destruct H1.
    destruct H2 as [y H2]; destruct H2.
    apply bel_inter in H2; apply bel_inter; split.
    + apply Axiom_SchemeP; split; auto.
      exists y; split; try apply H2; auto.
    + apply Axiom_SchemeP; split; auto.
      exists y; split; try apply H2; auto.
Qed.

Hint Resolve rel_compo : set.

(* 60 Definition  r⁻¹ = { [x,y] : [y,x] ∈ r }. *)

Definition Inverse r : Class := \{\ λ x y, [y,x]∈r \}\.

Notation "r ⁻¹" := (Inverse r)(at level 5).

Hint Unfold Inverse : set.

(* 61 Theorem  If r is a relation, then (r⁻¹)⁻¹ = r. *)

Lemma orde_set_iff : forall (x y: Class),
  Ensemble [x,y] <-> Ensemble [y,x].
Proof.
  intros; split; intros.
  - apply ord_set in H; auto.
    destruct H; apply ord_set; auto.
  - apply ord_set in H; auto.
    destruct H; apply ord_set; auto.
Qed.

Theorem rel_inv_fix : forall (r: Class),
  Relation r -> (r ⁻¹)⁻¹ = r.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - PP H0 a b; apply Axiom_SchemeP in H1; destruct H1.
    apply Axiom_SchemeP in H2; apply H2.
  - unfold Relation in H; double H0; apply H in H1.
    destruct H1 as [a [b H1]]; rewrite H1 in *; clear H1.
    apply Axiom_SchemeP; split; Ens; apply Axiom_SchemeP; split; auto.
    apply orde_set_iff; auto; Ens.
Qed.

Hint Rewrite rel_inv_fix : set.

(* 62 Theorem  (r∘s)⁻¹ = (s⁻¹) ∘ (r⁻¹). *)

Theorem comp_inv_dist : forall (r s: Class),
  (r ∘ s)⁻¹ = (s⁻¹) ∘ (r⁻¹).
Proof.
  intros; apply Axiom_Extent; split; intros.
  - PP H a b; apply Axiom_SchemeP in H0; destruct H0 as [H0 H1].
    apply Axiom_SchemeP; split; auto.
    apply Axiom_SchemeP in H1; destruct H1, H2, H2.
    exists x; split.
    + apply Axiom_SchemeP; split; auto.
      apply orde_set_iff; Ens; exists r; auto.
    + apply Axiom_SchemeP; split; auto.
      apply orde_set_iff; Ens.
  - PP H a b; apply Axiom_SchemeP in H0; destruct H0, H1, H1.
    apply Axiom_SchemeP; split; auto.
    apply Axiom_SchemeP in H1; apply Axiom_SchemeP in H2.
    apply Axiom_SchemeP; split.
    + apply orde_set_iff; auto.
    + exists x; split; try apply H0; try apply H2.
      destruct H1; auto.
Qed.

Hint Rewrite comp_inv_dist : set.

End OrderedP.

Export OrderedP.


Require Import Ashley.Axioms.
Require Import Ashley.Category.
Require Import Ashley.SetFunction.

Instance Category_Category: Category (set_type Category) :=
{
  hom cat1 cat2 := Functor (struct cat1) (struct cat2);
  id cat := identity_functor (struct cat);
  compose c1 c2 c3 := compose_functor
}.
intros.

unfold compose_functor.
f_equal.

Definition mapHomOff `(f: Functor) := @mapHom _ _ _ _ f.

Check @mapHom.
Definition mapHomOf1 `(A: Category) `(B: Category) (f: Functor A B) (o1 o2: objOf A) (m: homOf A o1 o2) : homOf B (mapObjOf f o1) (mapObjOf f o2) := @mapHom (objOf A) A (objOf B) B f o1 o2 m.

Check mapHomOf1.

Record R: Type := MkR {rT: Type; rV: rT}.

Lemma test: forall (a b: R), a = b.
intros.
apply R_ind.
intros.
symmetry.
apply R_ind.
intros.
f_equal.

Lemma functor_equal: forall `(A: Category) `(B: Category) (f1: Functor A B) (f2: Functor A B),
    (mapObjOf f1 = mapObjOf f2) -> (forall (o1: objOf A) (o2: objOf A) (m : homOf A o1 o2), mapHomOf1 A B f1 o1 o2 m = mapHomOf1 A B f2 o1 o2 m) -> f1 = f2.


(* Proof StoreT forms a comonad -- Russell O'Connor *)

Set Implict Arguments.
Unset Strict Implicit.

Require Import FunctionalExtensionality.

Record Comonad (w : Type -> Type) : Type :=
 { extract : forall a, w a -> a
 ; extend : forall a b, (w a -> b) -> w a -> w b
 ; law1 : forall a x, extend _ _ (extract a) x = x
 ; law2 : forall a b f x, extract b (extend a _ f x) = f x
 ; law3 : forall a b c f g x, extend b c f (extend a b g x) = extend a c (fun y => f (extend a b g y)) x
 }.

Section StoreT.

Variables (s : Type) (w:Type -> Type).
Hypothesis wH : Comonad w.

Definition map a b f x := extend _ wH a b (fun y => f (extract _ wH _ y)) x.

Lemma map_extend : forall a b c f g x, map b c f (extend _ wH a b g x) = extend _ wH _ _ (fun y => f (g y)) x.
Proof.
intros a b c f g x.
unfold map.
rewrite law3.
apply equal_f.
apply f_equal.
extensionality y.
rewrite law2.
reflexivity.
Qed.

Record StoreT (a:Type): Type := mkStoreT
  {store : w (s -> a)
  ;loc   : s}.

Definition extractST a (x:StoreT a) : a :=
 extract _ wH _ (store _ x) (loc _ x).

Definition mapST a b (f:a -> b) (x:StoreT a) : StoreT b :=
 mkStoreT _ (map _ _ (fun g x => f (g x)) (store _ x)) (loc _ x).

Definition duplicateST a (x:StoreT a) : StoreT (StoreT a) :=
 mkStoreT _ (extend _ wH _ _ (mkStoreT _) (store _ x)) (loc _ x).

Let extendST := fun a b f x => mapST _ b f (duplicateST a x).

Lemma law1ST : forall a x, extendST _ _ (extractST a) x = x.
Proof.
intros a [v b].
unfold extractST, extendST, duplicateST, mapST.
simpl.
rewrite map_extend.
simpl.
replace (fun (y : w (s -> a)) (x : s) => extract w wH (s -> a) y x)
 with (extract w wH (s -> a)).
 rewrite law1.
 reflexivity.
extensionality y.
extensionality x.
reflexivity.
Qed.

Lemma law2ST : forall a b f x, extractST b (extendST a _ f x) = f x.
Proof.
intros a b f [v c].
unfold extendST, mapST, extractST.
simpl.
rewrite map_extend.
rewrite law2.
reflexivity.
Qed.

Lemma law3ST : forall a b c f g x, extendST b c f (extendST a b g x) = extendST a c (fun y => f (extendST a b g y)) x.
Proof.
intros a b c f g [v d].
unfold extendST, mapST, extractST.
simpl.
repeat rewrite map_extend.
rewrite law3.
repeat (apply equal_f||apply f_equal).
extensionality y.
extensionality x.
rewrite map_extend.
reflexivity.
Qed.

Definition StoreTComonad : Comonad StoreT :=
 Build_Comonad _ _ _ law1ST law2ST law3ST.

End StoreT.

Check StoreTComonad.


From Coq Require Import Relations.
From AlmostFull.Default Require Import AlmostFull.
From AlmostFull.Default Require Import AFConstructions.

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

(* DisjunctiveWF *)
Lemma disjunctive_wf :
  forall (A:Type) (T : A -> A -> Prop)
  (R1 R2 : A -> A -> Prop)
  (decR1 : dec_rel R1) (decR2 : dec_rel R2),
  well_founded R1 -> well_founded R2 ->
  (forall x y, clos_trans_1n A T x y ->  R1 x y \/ R2 x y) ->
  well_founded T.
Proof.
intros A T R1 R2 decR1 decR2 wfR1 wfR2 Hincl.
pose (R x y := ~ R1 y x /\ ~ R2 y x).
assert (almost_full R) as Raf.
  apply af_intersection.
  apply (af_from_wf wfR1 decR1).
  apply (af_from_wf wfR2 decR2).
destruct Raf as (p,Hsec).
apply wf_from_af with (R:=R) (p:=p).
intros x y CT. destruct CT; firstorder. assumption.
Defined.

(* TerminatorInduction *)
Lemma disj_wf_induction:
 forall (A:Type) (T : A -> A -> Prop)
 (R1 R2 : A -> A -> Prop)
 (decR1 : dec_rel R1) (decR2 : dec_rel R2),
 well_founded R1 -> well_founded R2 ->
 (forall x y, clos_trans_1n A T x y ->  R1 x y \/ R2 x y) ->
 forall P : A -> Type,
 (forall x, (forall y, T y x -> P y) -> P x) ->
 forall a, P a.
Proof.
intros A T R1 R2 decR1 decR2 wfR1 wfR2 Hincl P.
apply well_founded_induction_type with (R := T).
apply disjunctive_wf with (R1 := R1) (R2 := R2); auto.
Defined.